File Coverage

lib/Command/SubCommandFactory.pm

Criterion	Covered	Total	%
statement	69	80	86.2
branch	13	20	65.0
condition	1	3	33.3
subroutine	9	13	69.2
pod			n/a
total	92	116	79.3

package Command::SubCommandFactory;

use strict;
use warnings;
use UR;

class Command::SubCommandFactory {
    is => 'Command::Tree',
    is_abstract => 1,
    doc => 'Base class for commands that delegate to sub-commands that may need to be dynamically created',
};

sub _init_subclass {
    my $subclass = shift;
    my $meta = $subclass->__meta__;
    if (grep { $_ eq __PACKAGE__ } $meta->parent_class_names) {
        my $delegating_class_name = $subclass;
        eval "sub ${subclass}::_delegating_class_name { '$delegating_class_name' }";
    }

    return 1;
}

sub _build_sub_command_mapping {
    my ($class) = @_;

    unless ($class->can('_sub_commands_from')) {
        die "Class $class does not implement _sub_commands_from()!\n"
            . "This method should return the namespace to use a reference "
            . "for defining sub-commands."
    }
    my $ref_class = $class->_sub_commands_from;

    my @inheritance;
    if ($class->can('_sub_commands_inherit_from') and defined $class->_sub_commands_inherit_from) {
        @inheritance = $class->_sub_commands_inherit_from();
    }
    else {
        @inheritance = $class;
    }

    my $module = $ref_class;
    $module =~ s/::/\//g;
    $module .= '.pm';
    my $base_path = $INC{$module};
    unless ($base_path) {
        if (UR::Object::Type->get($ref_class)) {
            $base_path = $INC{$module};
        }
        unless ($base_path) {
           die "Failed to find the path for ref class $ref_class!";
        }
    }
    $base_path =~ s/$module//;

    my $ref_path = $ref_class;
    $ref_path =~ s/::/\//g;
    my $full_ref_path = $base_path . '/' . $ref_path;

    my @target_paths = glob("$full_ref_path/*.pm");
    my @target_class_names;
    for my $target_path (@target_paths) {
        my $target = $target_path;
        $target =~ s#$base_path\/$ref_path/##;
        $target =~ s/\.pm//;

        my $target_base_class = $class->_target_base_class;
        my $target_class_name = $target_base_class . '::' . $target;

        my $target_meta = UR::Object::Type->get($target_class_name);
        next unless $target_meta;
        next unless $target_class_name->isa($target_base_class);

        push @target_class_names, $target => $target_class_name;
    }
    my %target_classes = @target_class_names;

    # Create a mapping of command names to command classes, and either find or
    # create those command classes
    my $mapping;
    for my $target (sort keys %target_classes) {
        my $target_class_name = $target_classes{$target};

        my $command_class_name = $class . '::' . $target;
        my $command_module_name = $command_class_name;
        $command_module_name =~ s|::|/|g;
        $command_module_name .= '.pm';

        # If the command class already exists, load it. Otherwise, create one.
        if (grep { -e $_ . '/' . $command_module_name } @INC) {
            UR::Object::Type->get($command_class_name);
        }
        else {
            next if not $class->_build_sub_command($command_class_name, @inheritance);
        }

        # Created commands need to know where their parameters came from
        no warnings 'redefine';
        eval "sub ${command_class_name}::_target_class_name { '$target_class_name' }";
        use warnings;

        my $command_name = $class->_command_name_for_class_word($target);
        $mapping->{$command_name} = $command_class_name;
    }

    return $mapping;
}

sub _build_sub_command {
    my ($self, $class_name, @inheritance) = @_;
    class {$class_name} {
        is => \@inheritance,
        doc => '',
    };
    return $class_name;
}

sub _target_base_class { return $_[0]->_sub_commands_from; }
sub _target_class_name { undef }
sub _sub_commands_inherit_from { undef }

1;