view release on metacpan or  search on metacpan

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

   $self->execution_reason($child_args[0]);
   $self->final_collect;  # no @args passed in this collection
   $self->final_commit;
   $self->pre_execute_run;
   return $self->execute;
} ## end sub run

package App::Easer::V2::Command::Commands;
push our @ISA, 'App::Easer::V2::Command';
sub aliases                { 'commands' }
sub allow_residual_options { 0 }
sub description            { 'Print list of supported sub-commands' }
sub help                   { 'list sub-commands' }
sub name                   { 'commands' }

sub target ($self) {
   my ($subc, @rest) = $self->residual_args;
   die "this command does not support many arguments\n" if @rest;
   my $target = $self->parent;
   $target = $target->find_matching_child($subc) if defined $subc;
   die "cannot find sub-command '$subc'\n" unless defined $target;
   return $target;
} ## end sub target ($self)

sub list_commands_for ($self, $target = undef) {
   $target //= $self->target;
   my @lines;
   for my $command ($target->inflate_children($target->list_children)) {
      my $help    = $command->help // '(**missing help**)';
      my @aliases = $command->aliases;
      next unless @aliases;
      push @lines, sprintf '%15s: %s', shift(@aliases), $help;
      push @lines, sprintf '%15s  (also as: %s)', '', join ', ', @aliases
        if @aliases;
   } ## end for my $command ($target...)
   return unless @lines;
   return join "\n", @lines;
} ## end sub list_commands_for

sub _build_printout_facility ($self) {
   my $channel = $self->target->help_channel;
   my $refch = ref $channel;

   return $channel if $refch eq 'CODE';

   my $fh;
   if ($refch eq 'GLOB') {
      $fh = $channel;
   }
   elsif ($refch eq 'SCALAR') {
      open $fh, '>', $channel or die "open(): $!\n";
   }
   elsif ($refch) {
      die 'invalid channel';
   }
   else {
      ($channel, my $binmode) = split m{:}mxs, $channel, 2;
      if ($channel eq '-' || lc($channel) eq '-stdout') {
         $fh = \*STDOUT;
      }
      elsif (lc($channel) eq '-stderr') {
         $fh = \*STDERR;
      }
      else {
         open $fh, '>', $channel or die "open('$channel'): $!\n";
      }
      binmode $fh, $binmode if length($binmode // '');
   }

   return sub ($cmd, @stuff) {
      print {$fh} @stuff;
      return $cmd;
   }
}

sub printout ($self, @stuff) {
   my $pof = $self->_rw;
   $self->_rw($pof = $self->_build_printout_facility) unless $pof;
   $pof->($self, @stuff);
}

sub execute ($self) {
   my $target = $self->target;
   my $name   = $target->call_name // $target->name;
   if (defined(my $commands = $self->list_commands_for($target))) {
      $self->printout("sub-commands for $name\n", $commands, "\n");
   }
   else {
      $self->printout("no sub-commands for $name\n");
   }
} ## end sub execute ($self)

package App::Easer::V2::Command::Help;
push our @ISA, 'App::Easer::V2::Command::Commands';
our @aliases = qw< help usage >;
sub aliases                { @aliases }
sub allow_residual_options { 0 }
sub description            { 'Print help for (sub)command' }
sub help                   { 'print a help command' }
sub name                   { 'help' }

sub __commandline_help ($getopt) {
   my @retval;

   my ($mode, $type, $desttype, $min, $max, $default);
   if (substr($getopt, -1, 1) eq '!') {
      $type = 'bool-negatable';
      substr $getopt, -1, 1, '';
      push @retval, 'boolean (can be negated)';
   }
   elsif ($getopt =~ s<:\+ ([@%])? \z><>mxs) {
      $mode     = 'optional';
      $type     = 'i';
      $default  = 'increment';
      $desttype = $1;
      my $line = "integer, value is optional, defaults to incrementing current value";
      $line .= ", list valued" if defined($desttype) && $desttype eq '@';
      push @retval, $line;
   } ## end elsif ($getopt =~ s<:+ ([@%])? \z><>mxs)
   elsif (substr($getopt, -1, 1) eq '+') {
      $mode = 'increment';