view release on metacpan or  search on metacpan

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

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   => [ ],
      };
      state $default_hash_v2_008 = {
         current => [ qw< +CmdLine +Environment +Default +ParentSlices > ],
         final   => [ ],
      };
      $r = $slot->{sources};
      $r = $slot->{sources} =
         ! defined($r)            ? Carp::confess()
         : $r eq 'default-array'  ? $default_array
         : $r eq 'default-hash'   ? $default_hash
         : $r eq 'v2.008'         ? $default_hash_v2_008
         :                         Carp::confess()
         unless ref($r); # string-based, get either default
   }
   Carp::confess() unless defined($r);

   return $r->@* if ref($r) eq 'ARRAY'; # backwards-compatible behaviour
   return \$r if ref($r) eq 'HASH';     # new behaviour
   Carp::confess(); # unsupported condition
}

# getter only
sub _sources_for_phase ($self, $phase) {
   my @sources = $self->sources; # might call an overridden thing

   return ${$sources[0]}->{$phase}
      if @sources == 1
         && ref($sources[0]) eq 'REF'
         && ref(${$sources[0]}) eq 'HASH';

   # backwards compatibility means that we only support the "current"
   # phase and do nothing for other ones.
   return $phase eq 'current' ? \@sources : ();
}

sub supports ($self, $what) {
   any { $_ eq $what } $self->aliases;
}

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

sub resolve_options ($self, $spec) {
   return $spec if ref($spec) eq 'HASH';

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

      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
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;
   eval { require $file } or Carp::confess("module<$module>: $EVAL_ERROR");
   return $module;
}

# Gets a specification like "Foo::Bar::baz" and returns a reference to
# sub "baz" in "Foo::Bar". If no package name is set, returns a
# reference to a sub in the package of $self. FIXME document properly
sub ref_to_sub ($self, $spec) {
   Carp::confess("undefined specification in ref_to_sub")
     unless defined $spec;
   return $spec if ref($spec) eq 'CODE';
   my ($class, $function) =
     ref($spec) eq 'ARRAY'
     ? $spec->@*
     : $spec =~ m{\A (?: (.*) :: )? (.*) \z}mxs;
   return $self->can($function) unless length($class // '');
   $self->load_module($class)   unless $class->can($function);
   return $class->can($function);