File: SubCommandFactory.pm

package info (click to toggle)
libur-perl 0.470%2Bds-3
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 7,192 kB
  • sloc: perl: 61,814; javascript: 255; xml: 108; sh: 13; makefile: 9
file content (123 lines) | stat: -rw-r--r-- 3,777 bytes parent folder | download | duplicates (3)
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
123
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("\Q$full_ref_path\E/*.pm");
    my @target_class_names;
    for my $target_path (@target_paths) { 
        my $target = $target_path;
        $target =~ s#\Q$base_path\E\/$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;