File Coverage

lib/CLI/Framework/Command.pm

Criterion	Covered	Total	%
statement	107	136	78.6
branch	25	42	59.5
condition	1	9	11.1
subroutine	26	31	83.8
pod	19	19	100.0
total	178	237	75.1

package CLI::Framework::Command;

use strict;
use warnings;
#use warnings::register;

our $VERSION = 0.04;

use Carp;
use Getopt::Long::Descriptive;
use Exception::Class::TryCatch;
use Class::Inspector;

use CLI::Framework::Exceptions qw( :all );

#FIXME-TODO-CLASS_GENERATION:
#our %CLASSES; # remember which classes have been auto-generated
#
#sub import {
#    my ($class, %import_args) = @_;
#
#    # If caller has supplied import args, CLIF's "inline form" is being used;
#    # we need to generate command classes dynamically...
#    while( my ($cmd_pkg, $cmd_def) = each %import_args ) {
#
##FIXME-TODO-CLASS_GENERATION: Create the new classes named in $cmd_pkg, injecting the subs indicated
## (whether explicitly or implicitly) by the contents of $cmd_def...
#
##        $cmd_obj = __PACKAGE__->new();
#    }
#}

###############################
#
#   OBJECT CONSTRUCTION
#
###############################

sub manufacture {
    my ($class, $target_pkg) = @_;

    # Manufacture base command...
    eval "require $target_pkg"; # (may or may not be pre-loaded)
    my $object = $target_pkg->new()
        or croak "Failed to instantiate command package '$target_pkg' via new(): $!";

    # Recognize subcommands that were defined in their own package files...
    $object->_manufacture_subcommands_in_dir_tree();

    # Recognize subcommands that have been loaded via an inline definition...
    $object->_register_preloaded_subcommands();

    return $object;
}

sub _manufacture_subcommands_in_dir_tree {
    my ($parent_command_object) = @_;

    # Check for a subdirectory by the name of the current command containing .pm
    # files representing subcommands, then manufacture() any that are found...

    # Look for subdirectory with name of current command...
    my $subcommand_dir = Class::Inspector->resolved_filename( ref $parent_command_object );
    substr( $subcommand_dir, -3, 3 ) = ''; # trim trailing '.pm'

    if( -d $subcommand_dir ) {
        # Directory with name of current command exists; look inside for .pm
        # files representing subcommands...

        my $dh;
        opendir( $dh, $subcommand_dir ) or die "cannot opendir '$dh': $!";
        while( my $subcommand = readdir $dh ) {
            # Ignore non-module files...
            next unless substr( $subcommand, -3 ) =~ s/\.pm//; # trim trailing '.pm'

            my $subcommand_pkg = (ref $parent_command_object).'::'.$subcommand;
            eval "require $subcommand_pkg";
            if( $subcommand_pkg->isa(ref $parent_command_object) ) {
                my $subcommand_obj = $subcommand_pkg->new()
                    or croak 'Failed to instantiate subcommand',
                             "'$subcommand_pkg' via method new(): $!";

                $parent_command_object->register_subcommand( $subcommand_obj );

                $subcommand_obj->_manufacture_subcommands_in_dir_tree();
                $subcommand_obj->_register_preloaded_subcommands();
            }
#            else {
#                warnings::warn "Found a non-subclass Perl package file in search path: '$subcommand_pkg' -- ignoring..."
#                    if warnings::enabled;
#            }
        }
    }
    return 1;
}

sub _register_preloaded_subcommands {
    my ($parent_cmd_obj) = @_;

    # Find direct subclasses and register them beneath the given parent...

    # Class::Inspector::subclasses actually finds all *descendants*
    # (not just direct subclasses)...
    my $descendants = sub { Class::Inspector->subclasses(@_) };
    my $descendant_names = $descendants->( ref $parent_cmd_obj );
    return unless ref $descendant_names eq 'ARRAY';

    for my $descendant_cmd ( @$descendant_names ) {
        # (skip if already registered)
        next if $parent_cmd_obj->package_is_registered( $descendant_cmd );

        # Find the direct parent class(es) of the descendant...
        my @direct_parents;
        {   no strict 'refs';
            @direct_parents = @{ $descendant_cmd.'::ISA' };
        }
        for my $direct_parent_of_descendant (@direct_parents) {
            # If the descendant is a *direct* subclass of the given parent...
            if( $direct_parent_of_descendant eq ref $parent_cmd_obj ) {
                # ...register child command as subcommand of parent...
                my $child_cmd = $descendant_cmd->new();
                $parent_cmd_obj->register_subcommand( $child_cmd );
                $child_cmd->_register_preloaded_subcommands();
            }
        }
    }
    return 1;
}

sub new { bless { _cache => undef }, $_[0] }

sub set_cache { $_[0]->{_cache} = $_[1] }
sub cache { $_[0]->{_cache} }

###############################
#
#   COMMAND DISPATCHING
#
###############################

sub get_default_usage { $_[0]->{_default_usage}         }
sub set_default_usage { $_[0]->{_default_usage} = $_[1] }

sub usage {
    my ($cmd, $subcommand_name, @subcommand_args) = @_;

    # Allow subcommand aliases in place of subcommand name...
    $cmd->_canonicalize($subcommand_name);

    my $usage_text;
    if(my $subcommand = $cmd->registered_subcommand_object($subcommand_name)) {
        # Get usage from subcommand object...
        $usage_text = $subcommand->usage(@subcommand_args);
    }
    else {
        # Get usage from Command object...
        $usage_text = $cmd->usage_text();
    }
    # Finally, fall back to default command usage message...
    $usage_text ||= $cmd->get_default_usage();
    return $usage_text;
}

sub _canonicalize {
    my ($cmd, $input) = @_;

    # Translate shorthand aliases for subcommands to full names...

    return unless $input;

    my %aliases = $cmd->subcommand_alias();
    return unless %aliases;

    my $command_name = $aliases{$input} || $input;
    $_[1] = $command_name;
}

#
# ARGV_Format
#
# $ app [app-opts]  [cmd-opts]
#
# params contain: $cmd = , $cmd_opts = [cmd-opts], @args =
#
#  could, in turn, indicate nested subcommands:
#   {  [subcmd-opts] {...} } [subcmd-args]
#

sub dispatch {
    my ($cmd, $cmd_opts, @args) = @_;

    # --- VALIDATE COMMAND OPTIONS AND ARGS ---
    eval { $cmd->validate($cmd_opts, @args) };
    if( catch my $e ) { # (command failed validation)
        throw_cmd_validation_exception( error => $e );
    }
    # Check if a subcommand is being requested...
    my $first_arg = shift @args; # consume potential subcommand name from input
    $cmd->_canonicalize( $first_arg );
    my ($subcmd_opts, $subcmd_usage);
    if( my $subcommand = $cmd->registered_subcommand_object($first_arg) ) {
        # A subcommand is being requested; parse its options...
        @ARGV = @args;
        my $format = $cmd->name().' '.$subcommand->name().'%o ...';
        eval { ($subcmd_opts, $subcmd_usage) =
            describe_options( $format, $subcommand->option_spec() )
        };
        if( catch my $e ) { # (subcommand failed options parsing)
            $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow };
            throw_cmd_opts_parse_exception( error => $e );
        }
        $subcommand->set_default_usage( $subcmd_usage->text() );

        # Reset arg list to reflect only arguments ( options may have been
        # consumed by describe_options() )...
        @args = @ARGV;

        # Pass session data to subcommand...
        $subcommand->set_cache( $cmd->cache() );

        # --- NOTIFY MASTER COMMAND OF SUBCOMMAND DISPATCH ---
        $cmd->notify_of_subcommand_dispatch( $subcommand, $cmd_opts, @args );

        # Dispatch subcommand with its options and the remaining args...
        $subcommand->dispatch( $subcmd_opts, @args );
    }
    else {
        # If first arg is not a subcommand then put it back in input...
        unshift @args, $first_arg if defined $first_arg;

        # ...and run the command itself...
        my $output;
        eval { $output = $cmd->run( $cmd_opts, @args ) };
        if( catch my $e ) { # (error during command execution)
            $e->isa( 'CLI::Framework::Exception' ) && do{ $e->rethrow };
            throw_cmd_run_exception( error => $e );
        }
        return $output;
    }
}

###############################
#
#   COMMAND REGISTRATION
#
###############################

sub registered_subcommand_names { keys %{$_[0]->{_subcommands}} }

sub registered_subcommand_object {
    my ($cmd, $subcommand_name) = @_;

    return unless $subcommand_name;

    return $cmd->{_subcommands}->{$subcommand_name};
}

sub register_subcommand {
    my ($cmd, $subcommand_obj) = @_;

    return unless $subcommand_obj &&
        $subcommand_obj->isa("CLI::Framework::Command");

    my $subcommand_name = $subcommand_obj->name();
    $cmd->{_subcommands}->{$subcommand_name} = $subcommand_obj;

    return $subcommand_obj;
}

sub package_is_registered {
    my ($cmd, $pkg) = @_;
    my @registered_pkgs = map { ref $_ } values %{ $cmd->{_subcommands} };
    return grep { $pkg eq $_ } @registered_pkgs;
}

###############################
#
#   COMMAND SUBCLASS HOOKS
#
###############################

sub name {
    my ($cmd) = @_;

    # Use base name of package as command name...
    my $pkg = ref $cmd;
    my @pkg_parts = split /::/, $pkg;
    return lc $pkg_parts[-1];
}

sub option_spec { ( ) }

sub subcommand_alias { ( ) }

sub validate { }

sub notify_of_subcommand_dispatch { }

sub usage_text { }

sub run { $_[0]->usage() }

#-------
1;

__END__