App-Easer

 view release on metacpan or  search on metacpan

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

# Corinna will be a blessing eventually
sub _rwn ($self, $name, @newval) {
   my $vref = \$self->slot->{$name};
   $$vref = $newval[0] if @newval;
   return $$vref;
}

sub _rw ($s, @n) { $s->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) }

sub _rwa ($self, @n) {
   my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n);
   Carp::confess() unless defined $aref;
   return $aref->@*;
}

sub _rwad ($self, @n) {
   my $aref = $self->_rwn((caller(1))[3] =~ s{.*::}{}rmxs, @n) // [];
   return wantarray ? $aref->@* : [$aref->@*];
}

sub _rw_prd ($self, @n) {
   my $slot = $self->slot;
   my $name = (caller(1))[3] =~ s{.*::}{}rmxs;
   if (@n) {
      $slot->{$name} = $n[0];
   }
   elsif (ref(my $ref_to_default = $slot->{$name})) {
      my $parent = $self->parent;
      $slot->{$name} = $parent ? $parent->$name : $$ref_to_default;
   }
   return $slot->{$name};
}

# these "attributes" would point to stuff that is normally "scalar" and
# used as specification overall. It can be overridden but probably it's
# just easier to stick in a hash inside the slot. We don't want to put
# executables here, though - overriding should be the guiding principle
# in this case.
sub aliases ($self, @r) {
   if (my @aliases = $self->_rwad(@r)) { return @aliases }
   if (defined(my $name = $self->_rwn('name'))) { return $name }
   return;
}
sub allow_residual_options ($self, @r) { $self->_rw(@r) }
sub auto_environment ($self, @r) { $self->_rw(@r) }
sub call_name ($self, @r) { $self->_rw(@r) }
sub children ($self, @r) { $self->_rwa(@r) }
sub children_prefixes ($self, @r) { $self->_rwa(@r) }
sub default_child ($self, @r) { $self->_rw(@r) }
sub description ($self, @r) { $self->_rw(@r) }
sub environment_prefix ($self, @r) { $self->_rw(@r) }
sub execution_reason ($self, @r) { $self->_rw(@r) }
sub fallback_to ($self, @r) { $self->_rw(@r) }
sub final_commit_stack ($self, @r) { $self->_rwa(@r) }
sub force_auto_children ($self, @r) { $self->_rw(@r) }
sub hashy_class ($self, @r) { $self->_rw(@r) }
sub help ($self, @r) { $self->_rw(@r) }
sub help_channel ($slf, @r) { $slf->_rw(@r) }
sub name ($s, @r) { $s->_rw(@r) // ($s->aliases)[0] // '**no name**' }
sub options_help ($s, @r) { $s->_rw(@r) }
sub params_validate ($self, @r) { $self->_rw(@r) }
sub parent ($self, @r) { $self->_rw(@r) }
sub pre_execute ($self, @r) { $self->_rwa(@r) }
sub residual_args ($self, @r) { $self->_rwa(@r) }
sub _last_cmdline ($self, @r) { $self->_rw(@r) }
sub _sources ($self, @r) { $self->_rwn(sources => @r) }
sub usage ($self, @r) { $self->_rw(@r) }

sub config_hash_key ($self, @r) { $self->_rw_prd(@r) }

sub is_root ($self) { ! defined($self->parent) }
sub root ($self) {
   my $slot = $self->slot;
   return $slot->{root} //= do {
      my $retval = $self;
      while (defined(my $parent = $retval->parent)) {
         $retval = $parent;
      }
      $retval;
   };
}

sub child ($self, @newval) {
   my $slot = $self->slot;
   if (@newval) {
      $slot->{child} = $newval[0];
      weaken($slot->{child});
   }
   return $slot->{child};
}
sub is_leaf ($self) { ! defined($self->child) }
sub leaf ($self) {
   my $slot = $self->slot;
   if (! exists($slot->{leaf})) {
      my $retval = $self;
      while (defined(my $parent = $retval->child)) {
         $retval = $parent;
      }
      $slot->{leaf} = $retval;
      weaken($slot->{leaf});
   }
   return $slot->{leaf};
}


# 2024-08-27 expand to allow hashref in addition to arrayref
# backwards-compatibility contract is that overriding this function allows
# returning the list of sources to use, which might be composed of a single
# hashref...
sub sources ($self, @new) {
   my $r;
   my $slot = $self->slot;
   if (@new) { # setter + getter
      $r = $slot->{sources} = $new[0];
   }
   else {   # getter only, set default if *nothing* has been set yet
      state $default_array =
         [ qw< +CmdLine +Environment +Parent=70 +Default=100 > ];
      state $default_hash  = {
         current => [ qw< +CmdLine +Environment +Default +ParentSlices > ],
         final   => [ ],

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

sub options ($self, @r) {
   return map { $self->resolve_options($_) } $self->_rwa(@r);
}

sub resolve_options ($self, $spec) {
   return $spec if ref($spec) eq 'HASH';
   $spec = [inherit_options => $spec] unless ref $spec;
   Carp::confess("invalid spec $spec") unless ref($spec) eq 'ARRAY';
   my ($method_name, @names) = $spec->@*;
   my $method = $self->can($method_name)
     or Carp::confess("cannot find method $method_name in $self");
   return $self->$method(@names);
} ## end sub resolve_options

sub inherit_options ($self, @names) {
   my %got;
   map {
      my @options;
      if ($_ eq '+parent') {
         @options = grep { $_->{transmit} // 0 } $self->parent->options;
      }
      else {
         my $name_exact = ref($_) ? undef : $_;
         my $name_rx    = qr{\A(?:$_)\z};
         my $ancestor = $self->parent;
         while ($ancestor) {
            push @options, my @pass =  # FIXME something's strange here
              grep {
               my $name = $self->name_for_option($_);
               ($_->{transmit} // 0)
               && (! $got{$name}++)     # inherit once only
               && (
                  (defined($name_exact) && $name eq $name_exact)
                  || (! $_->{transmit_exact} && $name =~ m{$name_rx})
               );
              } $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

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

   $self->_collect(
      [
         sub ($self, $opts, $args) {
            my $latest = $self->_rwn('config');
            $self->_rwn(config => ($latest = {})) unless $latest;
            my $queue = $latest->{all_eslices_at}{$priority} //= [];
            push $queue->@*, [ $priority, injection => [], '', $data ];
            return;
         },
      ]
   );
}

# (intermediate) commit collected options values, called after collect ends
sub commit ($self, @n) {
   my $commit = $self->_rw(@n);
   return $commit if @n;  # setter, don't call the commit callback
   return unless $commit;
   return $self->ref_to_sub($commit)->($self);
} ## end sub commit

# final commit of collected options values, called after final_collect ends
# this method tries to "propagate" the call up to the parent (and the root
# eventually) unless told not to do so. This should allow concentrating
# some housekeeping operations in the root command while still waiting for
# all options to have been collected
sub final_commit ($self, @n) {
   return $self->_rw(@n) if @n;  # setter, don't call the callback

   # we operate down at the slot level because we want to separate the case
   # where key 'final_commit' is absent (defaulting to propagation up to
   # the parent) and where it's set but otherwise false (in which case
   # there is no propagation).
   my $slot = $self->slot;

   # put "myself" onto the call stack for final_commit
   my $stack = $slot->{final_commit_stack} //= [];
   push $stack->@*, $self;

   if (exists($slot->{final_commit})) {
      my $commit = $slot->{final_commit};

      # if $commit is false (but present, because it exists) then we
      # stop and do not propagate to the parent
      return unless $commit;

      # otherwise, we call it and its return value will tell us whether to
      # propagate to the parent too or stop here
      my $propagate_to_parent = $self->ref_to_sub($commit)->($self);
      return unless $propagate_to_parent;
   }

   # here we try to propagate to the parent... if it exists
   my $parent = $self->parent;
   return unless $parent;  # we're root, no parent, no propagation up

   $parent->final_commit_stack([$stack->@*]);
   return $parent->final_commit;
} ## end sub commit

# validate collected options values, called after commit ends.
sub validate ($self, @n) {

   # Support the "accessor" interface for using a validation sub
   my $validator = $self->_rw(@n);
   return $validator if @n;

   # If set, it MUST be a validation sub reference. Otherwise, try the
   # params_validate/Params::Validate path.
   if ($validator) {
      die "validator can only be a CODE reference\n"
         unless ref $validator eq 'CODE';
      $validator->($self);
   }
   elsif (my $params_validate = $self->params_validate) {
      require Params::Validate;
      if (my $config_validator = $params_validate->{config} // undef) {
         my @array = $self->config_hash;
         &Params::Validate::validate(\@array, $config_validator);
      }
      if (my $args_validator = $params_validate->{args} // undef) {
         my @array = $self->residual_args;
         &Params::Validate::validate_pos(\@array, $args_validator->@*);
      }
   }
   else {} # no validation needed

   return $self;
} ## end sub validate ($self)

sub find_matching_child ($self, $command) {
   return unless defined $command;
   for my $candidate ($self->list_children) {
      my ($child) = $self->inflate_children($candidate);
      return $child if $child->supports($command);
   }
   return;
} ## end sub find_matching_child

sub _inflate_default_child ($self) {
   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

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

# transform one or more children "hints" into instances.
sub inflate_children ($self, @hints) {
   my $hashy = $self->hashy_class;
   map {
      my $child = $_;
      if (!blessed($child)) {    # actually inflate it
         $child =
             ref($child) eq 'ARRAY' ? $self->instantiate($child->@*)
           : ref($child) eq 'HASH'  ? $self->instantiate($hashy, $child)
           :                          $self->instantiate($child);
      } ## end if (!blessed($child))
      $self->_reparent($child);  # returns $child
   } grep { defined $_ } @hints;
} ## end sub inflate_children

# fallback mechanism when finding a child, relies on fallback_to.
sub fallback ($self) {
   my $fto = $self->fallback_to;
   return $fto if !defined($fto) || $fto !~ m{\A(?: 0 | [1-9]\d* )\z};
   my @children = $self->list_children;
   return $children[$fto] if $fto <= $#children;
   return undef;
} ## end sub fallback ($self)

# execute what's set as the execute sub in the slot
sub execute ($self) {
   my $spec = $self->_rw or die "nothing to search for execution\n";
   my $sub = $self->ref_to_sub($spec) or die "nothing to execute\n";
   return $sub->($self);
}

sub pre_execute_schedule ($self, @specs) {
   if (my $spec = $self->_rw) {
      my $sub = $self->ref_to_sub($spec) or die "nothing for pre_execute_schedule\n";
      return $sub->($self, @specs);
   }

   # default approach is to append to the current ones
   $self->pre_execute([$self->pre_execute, @specs]);
   return $self;
}

sub pre_execute_run ($self) {
   if (my $spec = $self->_rw) {
      my $sub = $self->ref_to_sub($spec) or die "nothing to pre-execute\n";
      return $sub->($self);
   }

   # default is to run 'em all
   for my $spec ($self->pre_execute) {
      my $sub = $self->ref_to_sub($spec) or die "nothing to pre-execute\n";
      $sub->($self);
   }
   return $self;
}

sub run ($self, $name, @args) {
   $self->call_name($name);
   $self->collect(@args);
   $self->commit;
   $self->validate;
   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 {