view release on metacpan or  search on metacpan

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

      : (ref($stuff[0]) || @stuff % 2) ? \@stuff
      :                                  {@stuff}
   );
} ## end sub dd (@stuff)

sub run ($app, @args) {
   my $class = 'App::Easer::V2::Command';
   my $instance =
       ref($app) eq 'HASH'  ? $class->new($app)
     : ref($app) eq 'ARRAY' ? $class->instantiate($app->@*)
     :                        $class->instantiate($app);
   return $instance->run(@args);
} ## end sub run

sub import ($package, @args) {
   my $target = caller;
   my @args_for_exporter;
   our %registered;

   my $parent_class = 'App::Easer::V2::Command';
   while (@args) {
      my $request = shift @args;
      if ($request eq '-command') {
         $registered{$target} = 1;
         no strict 'refs';
         push @{$target . '::ISA'}, $parent_class;
      }
      elsif ($request eq '-inherit') {
         no strict 'refs';
         push @{$target . '::ISA'}, $parent_class;
      }
      elsif ($request eq '-register') {
         $registered{$target} = 1;
      }
      elsif ($request eq '-spec') {
         Carp::croak "no specification provided"
           unless @args;
         Carp::croak "invalid specification provided"
           unless ref($args[0]) eq 'HASH';
         no strict 'refs';
         no warnings 'once';
         ${$target . '::app_easer_spec'} = shift @args;
      } ## end elsif ($request eq '-spec')
      elsif ($request eq '-parent') { # 2024-08-28 EXPERIMENTAL
         Carp::croak "no parent class provided"
           unless @args;
         $parent_class = shift @args;

         # make sure it's required
         App::Easer::V2::Command->load_module($parent_class);
      }
      else { push @args_for_exporter, $request }
   } ## end while (@args)
   $package->export_to_level(1, $package, @args_for_exporter);
} ## end sub import

package App::Easer::V2::Command;
use Scalar::Util 'blessed';
use List::Util 'any';
use English '-no_match_vars';
use Scalar::Util qw< weaken >;

# some stuff can be managed via a hash reference kept in a "slot",
# allowing for overriding should be easy either with re-defining the
# "slot" method, or overriding the sub-method relying on it. The name of
# the slot is the same as the name of the actual package that $self is
# blessed into.
sub slot ($self) { return $self->{blessed($self)} //= {} }

# This is a poor man's way to easily define attributes in a single line
# 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   => [ ],
      };
      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;
}