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 {
$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;