App-Easer

 view release on metacpan or  search on metacpan

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

              } $ancestor->options;
            $ancestor = $ancestor->parent;
         } ## end while ($ancestor)
      } ## end else [ if ($_ eq '+parent') ]
      map { +{transmit => 1, $_->%*, inherited => 1} } @options;
   } @names;
} ## end sub inherit_options

sub new ($pkg, @args) {
   my $pkg_spec = do { no strict 'refs'; ${$pkg . '::app_easer_spec'} };
   my $slot = {
      aliases                => [],
      allow_residual_options => 0,
      auto_environment       => 0,
      children               => [],
      children_prefixes      => [$pkg . '::Cmd'],
      config_hash_key        => \'merged',
      default_child          => 'help',
      environment_prefix     => '',
      fallback_to            => undef,
      final_commit_stack     => [],
      force_auto_children    => undef,
      hashy_class            => __PACKAGE__,
      help_channel           => '-STDOUT:encoding(UTF-8)',
      options                => [],
      params_validate        => undef,
      pre_execute            => [],
      residual_args          => [],
      sources                => 'default-array',   # 2024-08-24 defer
      ($pkg_spec // {})->%*,
      (@args && ref $args[0] ? $args[0]->%* : @args),
   };
   my $self = bless {$pkg => $slot}, $pkg;
   return $self;
} ## end sub new

sub merge_hashes ($self, @hrefs) { # FIXME this seems way more complicated than needed
   my (%retval, %is_overridable);
   for my $href (@hrefs) {
      for my $src_key (keys $href->%*) {
         my $dst_key          = $src_key;
         my $this_overridable = 0;
         $retval{$dst_key} = $href->{$src_key}
           if $is_overridable{$dst_key} || !exists($retval{$dst_key});
         $is_overridable{$dst_key} = 0 unless $this_overridable;
      } ## end for my $src_key (keys $href...)
   } ## end for my $href (@hrefs)
   return \%retval;
} ## end sub merge_hashes

sub _collect ($self, $sources, @args) {
   my @residual_args;    # what is left from the @args at the end

   my $slot = $self->slot;
   my $last_priority = 0;
   for my $source ($sources->@*) {
      my ($src, @opts) = ref($source) eq 'ARRAY' ? $source->@* : $source;
      my $meta = (@opts && ref $opts[0]) ? shift @opts : {};
      my $locator = $src;
      if (! ref($src)) {
         ($src, my $priority) = split m{=}mxs, $src;
         $meta->{priority} = $priority if defined $priority;
         $locator = $src =~ s{\A \+}{source_}rmxs;
      }
      my $sub = $self->ref_to_sub($locator)
        or die "unhandled source for $locator\n";

      my ($slice, $residuals) = $sub->($self, \@opts, \@args);
      push @residual_args, $residuals->@* if defined $residuals;

      # whatever happened in the source, it might have changed the
      # internals and we need to re-load them from the current config
      my $latest = $self->_rwn('config') // {};
      my @sequence = ($latest->{sequence} //= [])->@*;    # legacy
      my %all_eslices_at = ($latest->{all_eslices_at} // {})->%*; # v2.8
      my %command_eslices_at = ($latest->{command_eslices_at} // {})->%*;

      # only operate if the source returned something to track
      if ($slice) {
         $last_priority = my $priority
            = $meta->{priority} //= $last_priority + 10;

         my $eslice = [$priority, $src, \@opts, $locator, $slice];

         # new way of collecting the aggregated configuration
         # the merge takes into account priorities across all command
         # layers, this function encapsulates getting all of them
         push(($all_eslices_at{$priority} //= [])->@*, $eslice);
         push(($command_eslices_at{$priority} //= [])->@*, $eslice);

         # older way of collecting the aggregated configuration
         push @sequence, $eslice;
         for (my $i = $#sequence; $i > 0; --$i) {
            last if $sequence[$i - 1][0] <= $sequence[$i][0];
            @sequence[$i - 1, $i] = @sequence[$i, $i - 1];
         }
      }

      # whatever happened, re-compute the aggregated configuration in the
      # new "matrix" way and in the legacy way
      my $matrix_config = $self->merge_hashes(
         map { $_->[-1] }                 # take slice out of eslice
         map { $all_eslices_at{$_}->@* }  # unroll all eslices
         sort { $a <=> $b }               # sort by priority
         keys(%all_eslices_at)            # keys is the priority
      );
      my $legacy_config = $self->merge_hashes(map {$_->[-1]} @sequence);

      # save configuration at each step, so that each following source
      # can take advantage of configurations collected so far. This is
      # important for e.g. sources that load options from files whose
      # path is provided as an option itself.
      $self->_rwn(
         config => {
            merged             => $legacy_config,
            merged_legacy      => $legacy_config,
            'v2.008'           => $matrix_config,
            sequence           => \@sequence,
            all_eslices_at     => \%all_eslices_at,
            command_eslices_at => \%command_eslices_at,
         }

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

   defined(my $default = $self->default_child)
     or die "undefined default child\n";
   return undef if $default eq '-self';
   my $child = $self->find_matching_child($default)
     or die "no child matching the default $default\n";
   return $child;
} ## end sub inflate_default_child ($self)

# look for a child to hand execution over. Returns an child instance or
# undef (which means that the $self is in charge of executing
# something). This implements the most sensible default, deviations will
# have to be coded explicitly.
# Return values:
# - (undef, '-leaf') if no child exists
# - ($instance, @args) if a child is found with $args[0]
# - ($instance, '-default') if the default child is returned
# - (undef, '-fallback') in case $self is the fallback
# - ($instance, '-fallback', @args) in case the fallback is returned
sub find_child ($self) {
   my @candidates = $self->list_children or return (undef, '-leaf');
   my @residuals = $self->residual_args;
   if (@residuals) {
      if (my $child = $self->find_matching_child($residuals[0])) {
         return ($child, @residuals);
      }    # otherwise... see what the fallback is about
   }
   elsif (defined(my $default = $self->default_child)) {
      return ($self->_inflate_default_child, '-default');
   }

   # try the fallback...
   my $fallback = $self->fallback;
   if (defined $fallback) {
      return (undef, '-fallback') if $fallback eq '-self';
      return ($self->_inflate_default_child, '-default')
        if $fallback eq '-default';
      if (my $child = $self->find_matching_child($fallback)) {
         return ($child, -fallback => @residuals);
      }
   } ## end if (defined $fallback)

   # no fallback at this point... it's an error, build a message and die!
   # FIXME this can be improved
   die "cannot find sub-command '$residuals[0]'\n";
} ## end sub find_child ($self)

# get the list of children. This only gives back a list of "hints" that
# can be turned into instances via inflate_children. In this case, it's
# module names
sub list_children ($self) {
   my @children = $self->children;

   # handle auto-loading of children from modules in @INC via prefixes
   require File::Spec;
   my @expanded_inc = map {
      my ($v, $dirs) = File::Spec->splitpath($_, 'no-file');
      [$v, File::Spec->splitdir($dirs)];
   } @INC;
   my %seen;
   my @autoloaded_children = 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'
              } sort { $a cmp $b } readdir $dh;
         } ## end if (opendir my $dh, File::Spec...)
         else { () }
      } @expanded_inc;
   } $self->children_prefixes;
   push @autoloaded_children, map {
      my $prefix = $_;
      my $prefix_length = length($prefix);
      grep { !$seen{$_}++ }
        grep {
         (substr($_, 0, length $prefix) eq $prefix)
            && (index($_, ':', $prefix_length) < 0);
        } keys %App::Easer::V2::registered;
   } $self->children_prefixes;

   # auto-loaded children are appended with consistent sorting
   push @children, sort { $a cmp $b } @autoloaded_children;

   push @children, $self->auto_children
     if $self->force_auto_children // @children;
   return @children;
} ## end sub list_children ($self)

sub _auto_child ($self, $name, $inflate = 0) {
   my $child = __PACKAGE__ . '::' . ucfirst(lc($name));
   ($child) = $self->inflate_children($child) if $inflate;
   return $child;
}

# returns either class names or inflated objects
sub auto_children ($self, $inflate = 0) {
   map { $self->_auto_child($_, $inflate) } qw< help commands tree >;
}

sub auto_commands ($self) { return $self->_auto_child('commands', 1) }

sub auto_help ($self) { return $self->_auto_child('help', 1) }

sub auto_tree ($self) { return $self->_auto_child('tree', 1) }

sub run_help ($self, $mode = 'help') { $self->auto_help->run($mode) }

sub full_help_text ($s, @as) { $s->auto_help->collect_help_for($s, @as) }

sub load_module ($sop, $module) {
   my $file = "$module.pm" =~ s{::}{/}grmxs;

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

   my ($child, @child_args) = $self->find_child;
   return $child->run(@child_args) if defined $child;

   # we're the executors
   $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 '@';