/usr/share/perl5/Command/SubCommandFactory.pm is in libur-perl 0.430-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | 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;
|