view release on metacpan or  search on metacpan

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

         i => 'integer',
         o => 'perl-extended-integer',
         f => 'float',
      }->{$type};
      my $line = "$mode $type option";
      $line .= ", at least $min times" if defined($min) && $min > 1;
      $line .= ", no more than $max times"
        if defined($max) && length($max);
      $line .= ", list valued" if defined($desttype) && $desttype eq '@';
      push @retval, $line;
   } ## end elsif ($getopt =~ s<(          )? \z><>mxs)
   elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs) {
      $mode     = 'optional';
      $type     = 'i';
      $default  = $1;
      $desttype = $2;
      my $line = "optional integer, defaults to $default";
      $line .= ", list valued" if defined($desttype) && $desttype eq '@';
      push @retval, $line;
   } ## end elsif ($getopt =~ s<: (\d+) ([@%])? \z><>mxs)
   elsif ($getopt =~ s<:+ ([@%])? \z><>mxs) {
      $mode     = 'optional';
      $type     = 'i';
      $default  = 'increment';
      $desttype = $1;
      my $line = "optional integer, current value incremented if omitted";
      $line .= ", list valued" if defined($desttype) && $desttype eq '@';
      push @retval, $line;
   } ## end elsif ($getopt =~ s<:+ ([@%])? \z><>mxs)

   my @alternatives = split /\|/, $getopt;
   if ($type eq 'bool') {
      push @retval, map {
         if   (length($_) == 1) { "-$_" }
         else                   { "--$_ | --no-$_" }
      } @alternatives;
   } ## end if ($type eq 'bool')
   elsif ($mode eq 'optional') {
      push @retval, map {
         if   (length($_) == 1) { "-$_ [<value>]" }
         else                   { "--$_ [<value>]" }
      } @alternatives;
   } ## end elsif ($mode eq 'optional')
   else {
      push @retval, map {
         if   (length($_) == 1) { "-$_ <value>" }
         else                   { "--$_ <value>" }
      } @alternatives;
   } ## end else [ if ($type eq 'bool') ]

   return @retval;
} ## end sub commandline_help ($getopt)

sub commit_configuration ($self, $spec, $args) {
   my $commit = $spec->{commit} // return;
   $self->{factory}->($commit, 'commit')->($self, $spec, $args);
}

sub d (@stuff) {
   no warnings;
   require Data::Dumper;
   local $Data::Dumper::Indent = 1;
   warn Data::Dumper::Dumper(@stuff % 2 ? \@stuff : {@stuff});
} ## end sub d (@stuff)

sub default_getopt_config ($self, $spec) {
   my @r = qw< gnu_getopt >;
   push @r, qw< require_order pass_through >
      if has_children($self, $spec);
   push @r, qw< pass_through > if  $spec->{'allow-residual-options'};
   return \@r;
}

sub execute ($self, $args) {
   my $command    = $self->{trail}[-1][0];
   my $executable = fetch_spec_for($self, $command)->{execute}
     or die "no executable for '$command'\n";
   $executable = $self->{factory}->($executable, 'execute');    # "resolve"
   my $config = $self->{configs}[-1] // {};
   return $executable->($self, $config, $args);
} ## end sub execute

sub fetch_subcommand_default ($self, $spec) {
   my $acfg = $self->{application}{configuration};
   my $child = exists($spec->{'default-child'}) ? $spec->{'default-child'}
      : exists($acfg->{'default-child'}) ? $acfg->{'default-child'}
      : get_child($self, $spec, 'help'); # help is last resort
   return ($child, $child) if defined $child && length $child;
   return;
}

sub fetch_subcommand ($self, $spec, $args) {
   my ($subc, $alias) = fetch_subcommand_wh($self, $spec, $args)
      or return;
   my $r = ref $subc;
   if ($r eq 'HASH') {
      $subc = $spec->{children}[$subc->{index}]
         if scalar(keys $subc->%*) == 1 && defined $subc->{index};
      $r = ref $subc;
      return ($subc, $subc->{supports}[0]) if $r eq 'HASH';
      $alias = $subc;
   }
   die "invalid sub-command (ref to $r)" if $r;
   return ($subc, $alias);
}

sub fetch_subcommand_wh ($self, $spec, $args) {
   # if there's a dispatch, use that to figure out where to go next
   # **this** might even overcome having children at all!
   for my $cfg ($spec, $self->{application}{configuration}) {
      next unless exists $cfg->{dispatch};
      my $sub = $self->{factory}->($cfg->{dispatch}, 'dispatch');
      defined(my $child = $sub->($self, $spec, $args)) or return;
      return ($child, $child);
   }

   # 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