line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package CLI::Dispatch; |
2
|
|
|
|
|
|
|
|
3
|
11
|
|
|
11
|
|
180963
|
use strict; |
|
11
|
|
|
|
|
20
|
|
|
11
|
|
|
|
|
268
|
|
4
|
11
|
|
|
11
|
|
38
|
use warnings; |
|
11
|
|
|
|
|
15
|
|
|
11
|
|
|
|
|
212
|
|
5
|
11
|
|
|
11
|
|
36
|
use Carp; |
|
11
|
|
|
|
|
13
|
|
|
11
|
|
|
|
|
472
|
|
6
|
11
|
|
|
11
|
|
6903
|
use Getopt::Long (); |
|
11
|
|
|
|
|
82507
|
|
|
11
|
|
|
|
|
323
|
|
7
|
11
|
|
|
11
|
|
4383
|
use String::CamelCase; |
|
11
|
|
|
|
|
3893
|
|
|
11
|
|
|
|
|
469
|
|
8
|
11
|
|
|
11
|
|
3282
|
use Try::Tiny; |
|
11
|
|
|
|
|
7549
|
|
|
11
|
|
|
|
|
8274
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
our $VERSION = '0.21'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# you may want to override these three methods. |
13
|
|
|
|
|
|
|
|
14
|
95
|
|
|
95
|
1
|
271
|
sub options {qw( help|h|? verbose|v debug logfilter=s )} |
15
|
|
|
|
|
|
|
|
16
|
9
|
|
|
9
|
1
|
36
|
sub default_command { 'help' } |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub get_command { |
19
|
81
|
|
|
81
|
1
|
98
|
my $self = shift; |
20
|
|
|
|
|
|
|
|
21
|
81
|
|
66
|
|
|
249
|
my $command = shift @ARGV || $self->default_command; |
22
|
81
|
|
|
|
|
179
|
return $self->convert_command($command); |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
sub convert_command { |
26
|
108
|
|
|
108
|
1
|
163
|
my ($self, $command) = @_; |
27
|
|
|
|
|
|
|
|
28
|
108
|
|
|
|
|
267
|
$command = String::CamelCase::camelize( $command ); |
29
|
108
|
|
|
|
|
1211
|
$command =~ tr/a-zA-Z0-9_//cd; |
30
|
108
|
|
|
|
|
176
|
return $command; |
31
|
|
|
|
|
|
|
} |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# you usually don't need to care below. |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub new { |
36
|
95
|
|
|
95
|
1
|
183
|
my ($class, %opts) = @_; |
37
|
95
|
|
|
|
|
207
|
bless \%opts, $class; |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
sub get_options { |
41
|
187
|
|
|
187
|
1
|
322
|
my ($self, @specs) = @_; |
42
|
|
|
|
|
|
|
|
43
|
187
|
|
|
|
|
878
|
my $parser = Getopt::Long::Parser->new( |
44
|
|
|
|
|
|
|
config => [qw( bundling ignore_case pass_through )] |
45
|
|
|
|
|
|
|
); |
46
|
|
|
|
|
|
|
|
47
|
187
|
|
|
|
|
11998
|
$parser->getoptions( \my %hash => @specs ); |
48
|
|
|
|
|
|
|
|
49
|
187
|
|
|
|
|
38381
|
return %hash; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub load_command { |
53
|
86
|
|
|
86
|
1
|
160
|
my ($self, $namespaces, $help) = @_; |
54
|
|
|
|
|
|
|
|
55
|
86
|
|
|
|
|
185
|
my $command = $self->get_command; |
56
|
|
|
|
|
|
|
|
57
|
86
|
100
|
|
|
|
257
|
if ( $help ) { |
58
|
8
|
|
|
|
|
19
|
unshift @ARGV, $command; |
59
|
8
|
|
|
|
|
12
|
$command = 'Help'; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
86
|
|
|
|
|
172
|
my $instance = $self->_load_command($namespaces, $command); |
63
|
83
|
100
|
|
|
|
334
|
return $instance if $instance; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# fallback to help (maybe the command is just a pod) |
66
|
6
|
|
|
|
|
16
|
unshift @ARGV, $command; |
67
|
6
|
|
|
|
|
18
|
$instance = $self->_load_command($namespaces, 'Help'); |
68
|
6
|
50
|
|
|
|
25
|
return $instance if $instance; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# this shouldn't happen |
71
|
0
|
|
|
|
|
0
|
print STDERR "Help command is missing or broken.\n"; |
72
|
0
|
|
|
|
|
0
|
print STDERR "Prerequisite modules may not be installed.\n"; |
73
|
0
|
|
|
|
|
0
|
print STDERR "Please check your installation.\n"; |
74
|
0
|
|
|
|
|
0
|
exit; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
sub _load_command { |
78
|
92
|
|
|
92
|
|
117
|
my ($self, $namespaces, $command) = @_; |
79
|
|
|
|
|
|
|
|
80
|
92
|
|
|
|
|
141
|
foreach my $namespace (@$namespaces) { |
81
|
96
|
|
|
|
|
165
|
my $package = $namespace.'::'.$command; |
82
|
96
|
100
|
|
|
|
867
|
return $package->new if $package->can('new'); |
83
|
|
|
|
|
|
|
|
84
|
49
|
|
|
|
|
44
|
my $error; |
85
|
49
|
100
|
|
49
|
|
3612
|
try { eval "require $package" or die } |
86
|
49
|
|
50
|
20
|
|
257
|
catch { $error = $_ || 'Obscure error' }; |
|
20
|
|
|
|
|
601
|
|
87
|
49
|
100
|
|
|
|
4200
|
return $package->new unless $error; |
88
|
|
|
|
|
|
|
|
89
|
20
|
|
|
|
|
43
|
my $file = _package_file($package); |
90
|
20
|
100
|
|
|
|
394
|
next if $error =~ /Can't locate $file/; |
91
|
3
|
|
|
|
|
384
|
croak $error; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
13
|
100
|
|
|
|
39
|
if ($command eq 'Help') { |
95
|
7
|
|
|
|
|
1035
|
require CLI::Dispatch::Help; |
96
|
7
|
|
|
|
|
64
|
return CLI::Dispatch::Help->new; |
97
|
|
|
|
|
|
|
} |
98
|
6
|
|
|
|
|
11
|
return; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub _package_file { |
102
|
20
|
|
|
20
|
|
38
|
my $package = shift; |
103
|
|
|
|
|
|
|
|
104
|
20
|
|
|
|
|
73
|
$package =~ s{::}{/}g; |
105
|
20
|
|
|
|
|
33
|
$package .= '\.(?:pm|pod)'; |
106
|
20
|
|
|
|
|
31
|
$package; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub run { |
110
|
86
|
|
|
86
|
1
|
126777
|
my ($self, @namespaces) = @_; |
111
|
|
|
|
|
|
|
|
112
|
86
|
|
|
|
|
107
|
my $class; |
113
|
86
|
100
|
|
|
|
241
|
unless ($class = ref $self) { |
114
|
78
|
|
|
|
|
108
|
$class = $self; |
115
|
78
|
|
|
|
|
190
|
$self = $self->new; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
86
|
100
|
|
|
|
180
|
if (!grep { $_ ne $class } @namespaces) { |
|
69
|
|
|
|
|
186
|
|
119
|
29
|
|
|
|
|
44
|
push @namespaces, $class; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
86
|
|
|
|
|
203
|
my %global = $self->get_options( $self->options ); |
123
|
86
|
|
|
|
|
323
|
my $command = $self->load_command( \@namespaces, $global{help} ); |
124
|
83
|
|
|
|
|
374
|
my %local = $self->get_options( $command->options ); |
125
|
|
|
|
|
|
|
|
126
|
83
|
|
|
|
|
552
|
$command->set_options( %$self, %global, %local, _namespaces => \@namespaces ); |
127
|
|
|
|
|
|
|
|
128
|
82
|
100
|
100
|
|
|
529
|
if ( $command->isa('CLI::Dispatch::Help') and @ARGV ) { |
129
|
27
|
|
|
|
|
76
|
$ARGV[0] = $self->convert_command($ARGV[0]); |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
82
|
100
|
|
|
|
334
|
$command->check if $command->can('check'); |
133
|
|
|
|
|
|
|
|
134
|
79
|
|
|
|
|
248
|
$command->run(@ARGV); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub run_directly { |
138
|
9
|
|
|
9
|
1
|
11
|
my ($self, $package) = @_; |
139
|
|
|
|
|
|
|
|
140
|
9
|
50
|
|
|
|
54
|
unless ($package->can('new')) { |
141
|
0
|
|
|
|
|
0
|
my $error; |
142
|
0
|
0
|
|
0
|
|
0
|
try { eval "require $package" or die } |
143
|
0
|
|
0
|
0
|
|
0
|
catch { $error = $_ || 'Obscure error' }; |
|
0
|
|
|
|
|
0
|
|
144
|
0
|
0
|
|
|
|
0
|
croak $error if $error; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
9
|
|
|
|
|
12
|
my $class; |
148
|
9
|
50
|
|
|
|
28
|
unless ($class = ref $self) { |
149
|
9
|
|
|
|
|
11
|
$class = $self; |
150
|
9
|
|
|
|
|
16
|
$self = $self->new; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
9
|
|
|
|
|
21
|
my %global = $self->get_options( $self->options ); |
154
|
9
|
|
|
|
|
29
|
my $command = $package->new; |
155
|
9
|
100
|
|
|
|
17
|
if ($global{help}) { |
156
|
1
|
|
|
|
|
376
|
require CLI::Dispatch::Help; |
157
|
1
|
|
|
|
|
12
|
$command = CLI::Dispatch::Help->new; |
158
|
1
|
|
|
|
|
5
|
unshift @ARGV, "+$package"; |
159
|
|
|
|
|
|
|
} |
160
|
9
|
|
|
|
|
28
|
my %local = $self->get_options( $command->options ); |
161
|
|
|
|
|
|
|
|
162
|
9
|
|
|
|
|
41
|
$command->set_options( %global, %local ); |
163
|
|
|
|
|
|
|
|
164
|
9
|
50
|
|
|
|
33
|
$command->check if $command->can('check'); |
165
|
|
|
|
|
|
|
|
166
|
9
|
|
|
|
|
24
|
$command->run(@ARGV); |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
1; |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
__END__ |