File Coverage

blib/lib/MooX/Cmd/Role.pm

Criterion	Covered	Total	%
statement	106	107	99.0
branch	36	42	85.7
condition			n/a
subroutine	25	26	96.1
pod	2	2	100.0
total	169	177	95.4

package MooX::Cmd::Role;
# ABSTRACT: MooX cli app commands do this
our $VERSION = '1.000';
use strict;
use warnings;

use Moo::Role;

use Carp;
use Module::Runtime qw/ use_module /;
use Regexp::Common;
use Text::ParseWords 'shellwords';
use Module::Pluggable::Object;

use List::MoreUtils qw/first_index first_result/;
use Scalar::Util    qw/blessed/;
use Params::Util    qw/_ARRAY/;


has 'command_args' => (is => "ro");


has 'command_chain' => (is => "ro");


has 'command_chain_end' => (is => "lazy");

sub _build_command_chain_end { $_[0]->command_chain->[-1] }


has 'command_name' => (is => "ro");


has 'command_commands' => (is => "lazy");

sub _build_command_commands
{
    my ($class, $params) = @_;
    defined $params->{command_base} or $params->{command_base} = $class->_build_command_base($params);
    my $base = $params->{command_base};

    # I have no clue why 'only' and 'except' seems to not fulfill what I need or are bugged in M::P - Getty
    my @cmd_plugins = grep {
        my $plug_class = _mkcommand($_, $base);
        index($plug_class, ":") == -1;
    } Module::Pluggable::Object->new(
        search_path => $base,
        require     => 0,
    )->plugins;

    my %cmds = map { _mkcommand($_, $base) => $_ } @cmd_plugins;
    scalar keys %cmds == scalar @cmd_plugins
      or croak "Can't compute unambiguous list of commands from '" . join("', '", @cmd_plugins) . "'";

    \%cmds;
}


has command_base => (is => "lazy");

sub _build_command_base { $_[0] . '::Cmd'; }


has command_execute_method_name => (is => "lazy");

sub _build_command_execute_method_name { "execute" }


has command_execute_return_method_name => (is => "lazy");

sub _build_command_execute_return_method_name { "execute_return" }


has command_creation_method_name => (is => "lazy");

sub _build_command_creation_method_name { "new_with_cmd" }


has command_creation_chain_methods => (is => "lazy");

sub _build_command_creation_chain_methods { ['new_with_options', 'new'] }


has command_execute_from_new => (is => "lazy");

sub _build_command_execute_from_new { 0 }


sub new_with_cmd { goto &_initialize_from_cmd; }

sub _mkcommand
{
    my ($package, $base) = @_;
    my $bwc     = "${base}::";
    my $len_bwc = length($bwc);
    index($package, $bwc) == 0 and substr($package, 0, $len_bwc, "");
    lc($package);
}

my @private_init_params =
  qw(command_base command_execute_method_name command_execute_return_method_name command_creation_chain_methods command_execute_method_name);

my $required_method = sub {
    my ($tgt, $method) = @_;
    $tgt->can($method) or croak("You need an '$method' in " . (blessed $tgt || $tgt));
};

my $call_required_method = sub {
    my ($tgt, $method, @args) = @_;
    my $m = $required_method->($tgt, $method);
    return $m->($tgt, @args);
};

my $call_optional_method = sub {
    my ($tgt, $method, @args) = @_;
    my $m = $tgt->can($method) or return;
    return $m->($tgt, @args);
};

my $call_indirect_method = sub {
    my ($tgt, $name_getter, @args) = @_;
    my $g = $call_required_method->($tgt, $name_getter);
    my $m = $required_method->($tgt, $g);
    return $m->($tgt, @args);
};

## no critic qw(ProhibitExcessComplexity)
sub _initialize_from_cmd
{
    my ($class, %params) = @_;

    my @args = shellwords(join ' ', map { quotemeta } @ARGV);

    my (@used_args, $cmd, $cmd_name, $cmd_name_index);

    my %cmd_create_params = %params;
    delete @cmd_create_params{qw(command_commands), @private_init_params};

    defined $params{command_commands} or $params{command_commands} = $class->_build_command_commands(\%params);
    if (($cmd_name_index = first_index { $cmd = $params{command_commands}->{$_} } @args) >= 0)
    {
        @used_args = splice @args, 0, $cmd_name_index;
        shift @args;    # be careful about relics
        $cmd_name = _mkcommand($cmd, $params{command_base});

        use_module($cmd);
        defined $cmd_create_params{command_execute_method_name}
          or $cmd_create_params{command_execute_method_name} =
          $call_optional_method->($cmd, "_build_command_execute_method_name", \%cmd_create_params);
        defined $cmd_create_params{command_execute_method_name}
          or $cmd_create_params{command_execute_method_name} = "execute";
        $required_method->($cmd, $cmd_create_params{command_execute_method_name});
    }
    else
    {
        @used_args = @args;
        @args      = ();
    }

    defined $params{command_creation_chain_methods}
      or $params{command_creation_chain_methods} = $class->_build_command_creation_chain_methods(\%params);
    my @creation_chain =
      _ARRAY($params{command_creation_chain_methods})
      ? @{$params{command_creation_chain_methods}}
      : ($params{command_creation_chain_methods});
    (my $creation_method = first_result { defined $_ and $class->can($_) } @creation_chain)
      or croak "Can't find a creation method on $class";

    ## no critic qw(RequireLocalizedPunctuationVars)
    @ARGV                 = @used_args;
    $params{command_args} = [@args];
    $params{command_name} = $cmd_name;
    defined $params{command_chain} or $params{command_chain} = [];
    my $self = $creation_method->($class, %params);
    push @{$self->command_chain}, $self;

    if ($cmd)
    {
        @ARGV = @args;
        my ($creation_method, $creation_method_name, $cmd_plugin);
        $cmd->can("_build_command_creation_method_name")
          and $creation_method_name = $cmd->_build_command_creation_method_name(\%params);
        $creation_method_name and $creation_method = $cmd->can($creation_method_name);
        if ($creation_method)
        {
            @cmd_create_params{qw(command_chain)} = @$self{qw(command_chain)};
            $cmd_plugin = $creation_method->($cmd, %cmd_create_params);
            $self->{$self->command_execute_return_method_name} =
              [@{$call_indirect_method->($cmd_plugin, "command_execute_return_method_name")}];
        }
        else
        {
            ($creation_method = first_result { defined $_ and $cmd->can($_) } @creation_chain)
              or croak "Can't find a creation method on " . $cmd;
            $cmd_plugin = $creation_method->($cmd);
            push @{$self->command_chain}, $cmd_plugin;

            my $cemn     = $cmd_plugin->can("command_execute_method_name");
            my $exec_fun = $cemn ? $cemn->() : $self->command_execute_method_name();
            $self->command_execute_from_new
              and $self->{$self->command_execute_return_method_name} =
              [$call_required_method->($cmd_plugin, $exec_fun, \@ARGV, $self->command_chain)];
        }
    }
    else
    {
        $self->command_execute_from_new
          and $self->{$self->command_execute_return_method_name} =
          [$call_indirect_method->($self, "command_execute_method_name", \@ARGV, $self->command_chain)];
    }

    return $self;
}


# XXX should be an r/w attribute - can be renamed on loading ...
sub execute_return { $_[0]->{execute_return} }

1;

__END__