view release on metacpan or  search on metacpan

lib/App/Easer/V1.pm  view on Meta::CPAN

   # regular course here, no point in going forth without children
   return unless has_children($self, $spec);

   # use defaults if there's no argument to investigate
   return fetch_subcommand_default($self, $spec) unless $args->@*;

   # try to get a child from the first argument
   if (my $child = get_child($self, $spec, $args->[0])) {
      return ($child, shift $args->@*); # consumed arg name
   }

   # the first argument didn't help, but we might want to fallback
   for my $cfg ($spec, $self->{application}{configuration}) {
      if (exists $cfg->{fallback}) { # executable
         defined(my $fb = $cfg->{fallback}) or return;
         my $sub = $self->{factory}->($fb, 'fallback'); # "resolve"
         defined(my $child = $sub->($self, $spec, $args)) or return;
         return ($child, $child);
      }
      if (exists $spec->{'fallback-to'}) {
         defined(my $fbto = $spec->{'fallback-to'}) or return;
         return ($fbto, $fbto);
      }
      return fetch_subcommand_default($self, $spec)
         if $cfg->{'fallback-to-default'};
   }

   # no fallback at this point... it's an error, build a message and die!
   my @names = map { $_->[1] } $self->{trail}->@*;
   shift @names;    # remove first one
   my $path = join '/', @names, $args->[0]; # $args->[0] was the candidate
   die "cannot find sub-command '$path'\n";
} ## end sub fetch_subcommand_wh

sub generate_factory ($c) {
   my $w = \&stock_factory;    # default factory
   $w = stock_factory($c->{create}, 'factory', $c) if defined $c->{create};
   return sub ($e, $d = '') { $w->($e, $d, $c) };
}

sub get_child ($self, $spec, $name) {
   for my $child (get_children($self, $spec)) {
      my $command = fetch_spec_for($self, $child);
      next
        unless grep { $_ eq $name }
        ($command->{supports} //= [$child])->@*;
      return $child;
   } ## end for my $child (get_children...)
   return;
} ## end sub get_child

sub stock_ChildrenByPrefix ($self, $spec, @prefixes) {
   require File::Spec;
   my @expanded_inc = map {
      my ($v, $dirs) = File::Spec->splitpath($_, 'no-file');
      [$v, File::Spec->splitdir($dirs)];
   } @INC;
   my %seen;
   return map {
      my @parts = split m{::}mxs, $_ . 'x';
      substr(my $bprefix = pop @parts, -1, 1, '');
      map {
         my ($v, @dirs) = $_->@*;
         my $dirs = File::Spec->catdir(@dirs, @parts);
         if (opendir my $dh, File::Spec->catpath($v, $dirs, '')) {
            grep { ! $seen{$_}++ }
            map {
               substr(my $lastpart = $_, -3, 3, '');
               join '::', @parts, $lastpart;
            } grep {
               my $path = File::Spec->catpath($v, $dirs, $_);
               (-e $path && ! -d $path)
               && substr($_, 0, length($bprefix)) eq $bprefix
               && substr($_, -3, 3) eq '.pm'
            } readdir $dh;
         }
         else { () }
      } @expanded_inc;
   } @prefixes;
}

sub expand_children ($self, $spec, $child_spec) {
   return $child_spec unless ref($child_spec) eq 'ARRAY';
   my ($exe, @args) = $child_spec->@*;
   return $self->{factory}->($exe, 'children')->($self, $spec, @args);
}

sub get_children ($self, $spec, $expand = 1) {
   return if $spec->{leaf};
   return if exists($spec->{children}) && !$spec->{children};
   my @children = ($spec->{children} // [])->@*;

   # set auto-leaves as 1 by default, new in 0.007002
   $self->{application}{configuration}{'auto-leaves'} = 1
      unless exists $self->{application}{configuration}{'auto-leaves'};

   return
     if $self->{application}{configuration}{'auto-leaves'}
     && @children == 0;    # no auto-children for leaves under auto-leaves

   # skip expansion if $expand is false (default is expand)
   @children = map { expand_children($self, $spec, $_) } @children
      if $expand;

   my @auto =
     exists $self->{application}{configuration}{'auto-children'}
     ? (($self->{application}{configuration}{'auto-children'} // [])->@*)
     : (qw< help commands >);
   if (exists $spec->{'no-auto'}) {
      if (ref $spec->{'no-auto'}) {
         my %no = map { $_ => 1 } $spec->{'no-auto'}->@*;
         @auto = grep { !$no{$_} } @auto;
      }
      elsif ($spec->{'no-auto'} eq '*') {
         @auto = ();
      }
      else {
         die "invalid no-auto, array or '*' are allowed\n";
      }
   } ## end if (exists $spec->{'no-auto'...})

lib/App/Easer/V1.pm  view on Meta::CPAN

} ## end sub stock_JsonFiles

sub stock_Default ($self, $spec, @ignore) {
   return {
      map { '//=' . name_for_option($_) => $_->{default} }
      grep { exists $_->{default} } ($spec->{options} // [])->@*
   };
} ## end sub stock_Default

sub stock_Environment ($self, $spec, @ignore) {
   my $enamr = env_namer($self, $spec);
   return {
      map {
         my $en = $enamr->($_); # name of environment variable
         defined($en) && exists($ENV{$en})
            ? (name_for_option($_) => $ENV{$en}) : ();
        } ($spec->{options} // [])->@*
   };
} ## end sub stock_Environment

sub stock_NamEnv ($self, $cspec, $ospec) {
   my $aek = 'auto-environment';
   my $autoenv = exists $cspec->{$aek} ? $cspec->{$aek}
      : $self->{application}{configuration}{$aek} // undef;
   my $env = exists $ospec->{environment} ? $ospec->{environment}
      : $autoenv ? 1 : undef;
   return $env unless ($env // '') eq '1';
   my $appname = $self->{application}{configuration}{name} // '';
   my $optname = name_for_option($ospec);
   return uc(join '_', $appname, $optname);
}

sub stock_Parent ($self, $spec, @ignore) { $self->{configs}[-1] // {} }

sub stock_commands ($self, $config, $args) {
   die "this command does not support arguments\n" if $args->@*;
   my $target = get_descendant($self, $self->{trail}[-2][0], $args);
   print_commands($self, $target);
   return 0;
} ## end sub stock_commands

sub stock_factory ($executable, $default_subname = '', $opts = {}) {
   state $factory = sub ($executable, $default_subname) {
      my @prefixes =
          !defined $opts->{prefixes}       ? ()
        : 'ARRAY' eq ref $opts->{prefixes} ? ($opts->{prefixes}->@*)
        :                                    ($opts->{prefixes});
      push @prefixes, {'+' => 'App::Easer::V1#stock_'};
    SEARCH:
      for my $expansion_for (@prefixes) {
         for my $p (keys $expansion_for->%*) {
            next if $p ne substr $executable, 0, length $p;
            substr $executable, 0, length $p, $expansion_for->{$p};
            last SEARCH;
         }
      } ## end SEARCH: for my $expansion_for (...)

      # if it *still* "starts" with '=', it's "inline" Perl code
      return eval $executable if $executable =~ s{\A \s* = \s* }{}mxs;

      my ($package, $sname) = split m{\#}mxs, $executable;
      $sname = $default_subname unless defined $sname && length $sname;

      # first try to see if the sub is already available in $package
      if (my $s = $package->can($sname)) { return $s }

      # otherwise force loading of $package and retry
      (my $path = "$package.pm") =~ s{::}{/}gmxs;
      require $path;
      if (my $s = $package->can($sname)) { return $s }

      die "no '$sname' in '$package'\n";
   };
   state $cache = {};

   my $args;
   ($executable, $args) = ($executable->{executable}, $executable)
     if 'HASH' eq ref $executable;
   $executable = $cache->{$executable . ' ' . $default_subname} //=
     $factory->($executable, $default_subname)
     if 'CODE' ne ref $executable;
   return $executable unless $args;
   return sub { $executable->($args, @_) };
} ## end sub stock_factory

sub stock_help ($self, $config, $args) {
   print_help($self, get_descendant($self, $self->{trail}[-2][0], $args));
   return 0;
} ## end sub stock_help

sub stock_DefaultSources { [qw< +Default +CmdLine +Environment +Parent >] }

sub stock_SourcesWithFiles {
   [
      qw< +Default +CmdLine +Environment +Parent
         +JsonFileFromConfig +JsonFiles
        >
   ]
} ## end sub stock_SourcesWithFiles

sub validate_configuration ($self, $spec, $args) {
   my $from_spec = $spec->{validate};
   my $from_self = $self->{application}{configuration}{validate};
   my $validator;
   if (defined $from_spec && 'HASH' ne ref $from_spec) {
      $validator = $self->{factory}->($from_spec, 'validate');
   }
   elsif (defined $from_self && 'HASH' ne ref $from_self) {
      $validator = $self->{factory}->($from_self, 'validate');
   }
   else {    # use stock one
      $validator = \&params_validate;
   }
   $validator->($self, $spec, $args);
} ## end sub validate_configuration

exit run(
   $ENV{APPEASER} // {
      commands => {
         MAIN => {
            name        => 'main app',