File Coverage

blib/lib/App/Cmd/Setup.pm

Criterion	Covered	Total	%
statement	86	87	98.8
branch	11	18	61.1
condition	5	6	83.3
subroutine	23	23	100.0
pod			n/a
total	125	134	93.2

# The "experimental" below is not actually scary.  The feature went on to be
# de-experimental-ized with no changes and is now on by default in perl v5.24
# and later. -- rjbs, 2021-03-14
use 5.020;
use warnings;
use experimental qw(postderef postderef_qq);

package App::Cmd::Setup 0.340;

# ABSTRACT: helper for setting up App::Cmd classes

#pod =head1 OVERVIEW
#pod
#pod App::Cmd::Setup is a helper library, used to set up base classes that will be
#pod used as part of an App::Cmd program.  For the most part you should refer to
#pod L for how you should use this library.
#pod
#pod This class is useful in three scenarios:
#pod
#pod =begin :list
#pod
#pod = when writing your App::Cmd subclass
#pod
#pod Instead of writing:
#pod
#pod   package MyApp;
#pod   use parent 'App::Cmd';
#pod
#pod ...you can write:
#pod
#pod   package MyApp;
#pod   use App::Cmd::Setup -app;
#pod
#pod The benefits of doing this are mostly minor, and relate to sanity-checking your
#pod class.  The significant benefit is that this form allows you to specify
#pod plugins, as in:
#pod
#pod   package MyApp;
#pod   use App::Cmd::Setup -app => { plugins => [ 'Prompt' ] };
#pod
#pod Plugins are described in L.
#pod
#pod Doing this also allows you to override the default configuration passed to
#pod L. By default, this configuration includes C,
#pod which allows subdispatch to work correctly. If you are not using subdispatch,
#pod and want your command to exit on unknown options, you can say:
#pod
#pod   package MyApp;
#pod   use App::Cmd::Setup -app => { getopt_conf => [] };
#pod
#pod = when writing abstract base classes for commands
#pod
#pod That is: when you write a subclass of L that is intended for
#pod other commands to use as their base class, you should use App::Cmd::Setup.  For
#pod example, if you want all the commands in MyApp to inherit from MyApp::Command,
#pod you may want to write that package like this:
#pod
#pod   package MyApp::Command;
#pod   use App::Cmd::Setup -command;
#pod
#pod Do not confuse this with the way you will write specific commands:
#pod
#pod   package MyApp::Command::mycmd;
#pod   use MyApp -command;
#pod
#pod Again, this form mostly performs some validation and setup behind the scenes
#pod for you.  You can use C> if you prefer.
#pod
#pod = when writing App::Cmd plugins
#pod
#pod L is a mechanism that allows an App::Cmd class to inject code
#pod into all its command classes, providing them with utility routines.
#pod
#pod To write a plugin, you must use App::Cmd::Setup.  As seen above, you must also
#pod use App::Cmd::Setup to set up your App::Cmd subclass if you wish to consume
#pod plugins.
#pod
#pod For more information on writing plugins, see L and
#pod L.
#pod
#pod =end :list
#pod
#pod =cut

use App::Cmd ();
use App::Cmd::Command ();
use App::Cmd::Plugin ();
use Carp ();
use Data::OptList ();
use String::RewritePrefix ();

# 0.06 is needed for load_optional_class
use Class::Load 0.06 qw();

use Sub::Exporter -setup => {
  -as     => '_import',
  exports => [ qw(foo) ],
  collectors => [
    -app     => \'_make_app_class',
    -command => \'_make_command_class',
    -plugin  => \'_make_plugin_class',
  ],
};

sub import {
  goto &_import;
}

sub _app_base_class { 'App::Cmd' }

my %valid_keys = map {; $_ => 1 } qw(plugins getopt_conf);

sub _make_app_class {
  my ($self, $val, $data) = @_;
  my $into = $data->{into};

  $val ||= {};
  Carp::confess "invalid argument to -app setup"
    if grep { ! $valid_keys{$_} } keys %$val;

  Carp::confess "app setup requested on App::Cmd subclass $into"
    if $into->isa('App::Cmd');

  $self->_make_x_isa_y($into, $self->_app_base_class);

  if ( ! Class::Load::load_optional_class( $into->_default_command_base ) ) {
    my $base = $self->_command_base_class;
    Sub::Install::install_sub({
      code => sub { $base },
      into => $into,
      as   => '_default_command_base',
    });
  }

  # TODO Check this is right. -- kentnl, 2010-12
  #
  #  my $want_plugin_base = $self->_plugin_base_class;
  my $want_plugin_base = 'App::Cmd::Plugin';

  my @plugins;
  for my $plugin (@{ $val->{plugins} // [] }) {
    $plugin = String::RewritePrefix->rewrite(
      {
        ''  => 'App::Cmd::Plugin::',
        '=' => ''
      },
      $plugin,
    );
    Class::Load::load_class( $plugin );
    unless( $plugin->isa( $want_plugin_base ) ){
        die "$plugin is not a " . $want_plugin_base;
    }
    push @plugins, $plugin;
  }

  Sub::Install::install_sub({
    code => sub { @plugins },
    into => $into,
    as   => '_plugin_plugins',
  });

  if ($val->{getopt_conf}) {
    my @getopt_conf = @{ $val->{getopt_conf} };

    Sub::Install::install_sub({
      code => sub { return [ @getopt_conf ] },
      into => $into,
      as   => '_getopt_conf',
    });
  }

  return 1;
}

sub _command_base_class { 'App::Cmd::Command' }

sub _make_command_class {
  my ($self, $val, $data) = @_;
  my $into = $data->{into};

  Carp::confess "command setup requested on App::Cmd::Command subclass $into"
    if $into->isa('App::Cmd::Command');

  $self->_make_x_isa_y($into, $self->_command_base_class);

  return 1;
}

sub _make_x_isa_y {
  my ($self, $x, $y) = @_;

  no strict 'refs';
  push @{"$x\::ISA"}, $y;
}

sub _plugin_base_class { 'App::Cmd::Plugin' }
sub _make_plugin_class {
  my ($self, $val, $data) = @_;
  my $into = $data->{into};

  Carp::confess "plugin setup requested on App::Cmd::Plugin subclass $into"
    if $into->isa('App::Cmd::Plugin');

  Carp::confess "plugin setup requires plugin configuration" unless $val;

  $self->_make_x_isa_y($into, $self->_plugin_base_class);

  # In this special case, exporting everything by default is the sensible thing
  # to do. -- rjbs, 2008-03-31
  $val->{groups} = [ default => [ -all ] ] unless $val->{groups};

  my @exports;
  for my $pair (Data::OptList::mkopt($val->{exports})->@*) {
    push @exports, $pair->[0], ($pair->[1] || \'_faux_curried_method');
  }

  $val->{exports} = \@exports;

  Sub::Exporter::setup_exporter({
    %$val,
    into => $into,
    as   => 'import_from_plugin',
  });

  return 1;
}

1;

__END__