view release on metacpan or  search on metacpan

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

   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) {