line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Term::Shell::Pluggable; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
14996
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
32
|
|
4
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
18
|
|
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
582
|
use Getopt::Long; Getopt::Long::Configure('pass_through'); |
|
1
|
|
|
|
|
9752
|
|
|
1
|
|
|
|
|
5
|
|
7
|
1
|
|
|
1
|
|
570
|
use Sys::Hostname; |
|
1
|
|
|
|
|
823
|
|
|
1
|
|
|
|
|
48
|
|
8
|
1
|
|
|
1
|
|
6
|
use File::Basename; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
392
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 NAME |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
Term::Shell::Pluggable - Pluggable command-line framework |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 VERSION |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
Version 0.03 |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=cut |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 SYNOPSIS |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
There is Term::Shell module in the first place. This is hybrid of that |
25
|
|
|
|
|
|
|
one with Module::Pluggable. So you could add command line hooks to your |
26
|
|
|
|
|
|
|
big and scary multi-module perl application. |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
#!/usr/bin/env perl |
29
|
|
|
|
|
|
|
package Example; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
use warnings; |
32
|
|
|
|
|
|
|
use strict; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
use Getopt::Long qw(GetOptionsFromArray); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub smry_bubble { 'bubblesort numbers' } |
37
|
|
|
|
|
|
|
sub run_bubble { |
38
|
|
|
|
|
|
|
my $class = shift; |
39
|
|
|
|
|
|
|
Getopt::Long::GetOptionsFromArray(\@_, |
40
|
|
|
|
|
|
|
'verbose' => \my $verbose, |
41
|
|
|
|
|
|
|
) and @_ or die "wrong options or numbers are missing\n" . $class->help_bubble; |
42
|
|
|
|
|
|
|
my @numbers = @_; |
43
|
|
|
|
|
|
|
... |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
sub help_bubble { <
|
46
|
|
|
|
|
|
|
usage: bubble [-v] ... |
47
|
|
|
|
|
|
|
HELP |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
package main; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
use Term::Shell::Pluggable; |
53
|
|
|
|
|
|
|
Term::Shell::Pluggable->run(packages => [ |
54
|
|
|
|
|
|
|
'Example', |
55
|
|
|
|
|
|
|
'Some::Other::Example' # another package i.e. defined in separate .pm file |
56
|
|
|
|
|
|
|
]); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=head1 SEE ALSO |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
L |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head1 COPYRIGHT |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
Copyright 2013 Dmitri Popov. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify |
67
|
|
|
|
|
|
|
it under the same terms as Perl itself. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=cut |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub run { |
72
|
0
|
|
|
0
|
|
|
my $class = shift; |
73
|
0
|
|
|
|
|
|
my $args = {@_}; |
74
|
|
|
|
|
|
|
|
75
|
0
|
|
|
|
|
|
GetOptions( |
76
|
|
|
|
|
|
|
'namespace=s' => \my @namespaces, |
77
|
|
|
|
|
|
|
'file=s' => \my @files, |
78
|
|
|
|
|
|
|
'package=s' => \my @packages, |
79
|
|
|
|
|
|
|
'help' => \my $help_wanted, |
80
|
|
|
|
|
|
|
'compgen' => \my $compgen_wanted, |
81
|
|
|
|
|
|
|
); |
82
|
|
|
|
|
|
|
|
83
|
0
|
0
|
|
|
|
|
if ($help_wanted) { |
84
|
0
|
|
|
|
|
|
print $class->help_message; |
85
|
0
|
|
|
|
|
|
exit 73; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
0
|
|
|
|
my $arg_namespaces = $args->{namespaces} || []; |
89
|
|
|
|
|
|
|
|
90
|
0
|
|
|
|
|
|
basename($0) =~ /^(.*)\./; |
91
|
0
|
|
0
|
|
|
|
my $name = $1 || basename($0); |
92
|
0
|
|
|
|
|
|
my $prompt = $name . '@' . hostname() . '> '; |
93
|
0
|
|
0
|
0
|
|
|
my $arg_prompt = $args->{prompt} || sub { $prompt }; |
|
0
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
|
95
|
0
|
|
|
|
|
|
my $ctx = Term::Shell::Pluggable::Context->new( |
96
|
|
|
|
|
|
|
namespaces => [@namespaces, @$arg_namespaces], |
97
|
|
|
|
|
|
|
prompt => $arg_prompt |
98
|
|
|
|
|
|
|
); |
99
|
|
|
|
|
|
|
|
100
|
0
|
|
|
|
|
|
my $a_packages = $args->{packages}; |
101
|
0
|
|
|
|
|
|
foreach my $name (@packages, @$a_packages) { |
102
|
0
|
|
|
|
|
|
$ctx->load_package($name); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
0
|
|
|
|
|
|
my $a_files = $args->{files}; |
106
|
0
|
|
|
|
|
|
foreach my $path (@files, @$a_files) { |
107
|
0
|
|
|
|
|
|
$ctx->load_file($path); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
0
|
0
|
|
|
|
|
if ($compgen_wanted) { |
111
|
0
|
|
|
|
|
|
$ctx->compgen(@ARGV); |
112
|
0
|
|
|
|
|
|
exit 0; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
0
|
0
|
|
|
|
|
if (scalar @ARGV > 0) { |
116
|
|
|
|
|
|
|
# preserving quotes for complex commands |
117
|
0
|
|
|
|
|
|
my $cmd = ''; |
118
|
0
|
|
|
|
|
|
for my $arg (@ARGV) { |
119
|
0
|
0
|
|
|
|
|
$cmd .= ' ' if $cmd; |
120
|
0
|
0
|
|
|
|
|
if ($arg =~ /\s/) { |
121
|
0
|
|
|
|
|
|
$cmd .= "'$arg'"; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
else { |
124
|
0
|
|
|
|
|
|
$cmd .= $arg; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
} |
127
|
0
|
|
|
|
|
|
$ctx->cmd($cmd); |
128
|
0
|
0
|
|
|
|
|
exit 13 if $ctx->{last_cmd_error}; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
else { |
131
|
0
|
|
|
|
|
|
$ctx->cmdloop; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
|
135
|
0
|
|
|
0
|
|
|
sub help_message { <
|
136
|
|
|
|
|
|
|
usage: $0 [--file=/home/joe/test.pm] [--namespace=Some::Namespace] [--package=Some::Shell] [command] [options...] |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
try $0 help for list of commands |
139
|
|
|
|
|
|
|
EOF |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
package Term::Shell::Pluggable::Context; |
143
|
|
|
|
|
|
|
|
144
|
1
|
|
|
1
|
|
254
|
use Module::Pluggable search_path => [], require => 1, inner => 0; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
use base 'Term::Shell'; |
146
|
|
|
|
|
|
|
use Sys::Hostname; |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub compgen { |
149
|
|
|
|
|
|
|
my $self = shift; |
150
|
|
|
|
|
|
|
my ($word, $line, $point) = @_; |
151
|
|
|
|
|
|
|
if ($line =~ /^(\w+\s+)/) { # remove program name |
152
|
|
|
|
|
|
|
my $l = length $1; |
153
|
|
|
|
|
|
|
$line = substr $line, $l; |
154
|
|
|
|
|
|
|
$point -= $l; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
my $start = $point; |
157
|
|
|
|
|
|
|
if ($word) { # set to start of the current word |
158
|
|
|
|
|
|
|
$start = $start - length $word; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
else { |
161
|
|
|
|
|
|
|
$word = ''; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
my $reply = join "\n", $self->rl_complete($word, $line, $start); |
164
|
|
|
|
|
|
|
print $reply . "\n"; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub new { |
168
|
|
|
|
|
|
|
my $class = shift; |
169
|
|
|
|
|
|
|
my $args = {@_}; |
170
|
|
|
|
|
|
|
if (my $namespaces = $args->{namespaces}) { |
171
|
|
|
|
|
|
|
foreach my $search_path (@$namespaces) { |
172
|
|
|
|
|
|
|
$class->search_path(add => $search_path); |
173
|
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
my $self = $class->SUPER::new(); |
176
|
|
|
|
|
|
|
$self->{prompt} = $args->{prompt}; |
177
|
|
|
|
|
|
|
return $self; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
sub prompt_str { |
181
|
|
|
|
|
|
|
shift->{prompt}->(); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub preloop { |
185
|
|
|
|
|
|
|
my $self = shift; |
186
|
|
|
|
|
|
|
my $modules = join ', ', @{$self->{modules}}; |
187
|
|
|
|
|
|
|
if ($modules) { |
188
|
|
|
|
|
|
|
#print "CLT [$modules]\n"; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
else { |
191
|
|
|
|
|
|
|
die "no modules\n"; |
192
|
|
|
|
|
|
|
} |
193
|
|
|
|
|
|
|
my (undef, undef, $f) = File::Spec->splitpath($0); |
194
|
|
|
|
|
|
|
$f =~ s/\.pl$//; # remove .pl |
195
|
|
|
|
|
|
|
$f =~ s/\W/_/g; # cleanup |
196
|
|
|
|
|
|
|
$self->{history_path} = File::Spec->catfile($ENV{HOME}, '.' . $f . '_history') if $f; |
197
|
|
|
|
|
|
|
if ($self->{term}->Features->{setHistory} and $self->{history_path} and -r $self->{history_path}) { |
198
|
|
|
|
|
|
|
open my $fh, '<', $self->{history_path} or die "can't read $self->{history_path}: $!"; |
199
|
|
|
|
|
|
|
my @history = <$fh>; |
200
|
|
|
|
|
|
|
chomp @history; |
201
|
|
|
|
|
|
|
$self->{term}->SetHistory(@history); |
202
|
|
|
|
|
|
|
close $fh; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub postloop { |
207
|
|
|
|
|
|
|
my $self = shift; |
208
|
|
|
|
|
|
|
print "\n"; |
209
|
|
|
|
|
|
|
if ($self->{term}->Features->{getHistory} and $self->{history_path}) { |
210
|
|
|
|
|
|
|
open my $fh, '>', $self->{history_path} or die "can't write $self->{history_path}: $!"; |
211
|
|
|
|
|
|
|
my $prev_line; |
212
|
|
|
|
|
|
|
foreach my $line ($self->{term}->GetHistory()) { |
213
|
|
|
|
|
|
|
next unless length $line; # skip empty lines |
214
|
|
|
|
|
|
|
next if $prev_line and $line eq $prev_line; # skip repeated commands |
215
|
|
|
|
|
|
|
print $fh "$line\n"; |
216
|
|
|
|
|
|
|
$prev_line = $line; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
close $fh; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
sub run { # overrides Term::Shell::run() to recover on commands errors |
223
|
|
|
|
|
|
|
my $self = shift; |
224
|
|
|
|
|
|
|
eval { |
225
|
|
|
|
|
|
|
$self->SUPER::run(@_); |
226
|
|
|
|
|
|
|
}; |
227
|
|
|
|
|
|
|
my $error = $@; |
228
|
|
|
|
|
|
|
if ($error) { |
229
|
|
|
|
|
|
|
print STDERR "command failed: $error"; |
230
|
|
|
|
|
|
|
$self->{last_cmd_error} = $error; |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
else { |
233
|
|
|
|
|
|
|
$self->{last_cmd_error} = undef; |
234
|
|
|
|
|
|
|
} |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
our @ISA; |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub init { # loading pluggable modules |
240
|
|
|
|
|
|
|
my $self = shift; |
241
|
|
|
|
|
|
|
$self->{modules} = []; |
242
|
|
|
|
|
|
|
$self->{r} = {}; |
243
|
|
|
|
|
|
|
for my $module ($self->plugins) { |
244
|
|
|
|
|
|
|
$self->attach_package($module); |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub load_package { |
249
|
|
|
|
|
|
|
my $self = shift; |
250
|
|
|
|
|
|
|
my ($package_name) = @_; |
251
|
|
|
|
|
|
|
{ |
252
|
|
|
|
|
|
|
no strict 'refs'; |
253
|
|
|
|
|
|
|
unless (grep {$_ !~ /::$/} %{$package_name . '::'}) { # skip requiring packages that may be loaded from start .pl script or loaded .pm files |
254
|
|
|
|
|
|
|
no warnings; |
255
|
|
|
|
|
|
|
eval "require $package_name" or die "can't load $package_name: $@"; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
$self->attach_package($package_name); |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
sub load_file { |
262
|
|
|
|
|
|
|
my $self = shift; |
263
|
|
|
|
|
|
|
my ($path) = @_; |
264
|
|
|
|
|
|
|
die "file not found: $path" unless -f $path; |
265
|
|
|
|
|
|
|
open my $fh, $path or die "can't read $path: $!"; |
266
|
|
|
|
|
|
|
my $in_pod = 0; |
267
|
|
|
|
|
|
|
{ |
268
|
|
|
|
|
|
|
my $result = do $path; |
269
|
|
|
|
|
|
|
if (my $errror = $@) { |
270
|
|
|
|
|
|
|
warn; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
elsif (not defined $result) { |
273
|
|
|
|
|
|
|
warn "can't do $path: $!"; |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
elsif (not $result) { |
276
|
|
|
|
|
|
|
warn "$path returns false"; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
while (my $line = <$fh>) { |
280
|
|
|
|
|
|
|
$in_pod = 1 if $line =~ m/^=\w/; |
281
|
|
|
|
|
|
|
$in_pod = 0 if $line =~ /^=cut/; |
282
|
|
|
|
|
|
|
next if ($in_pod || $line =~ /^=cut/); # skip pod text |
283
|
|
|
|
|
|
|
next if $line =~ /^\s*#/; # and comments |
284
|
|
|
|
|
|
|
if ($line =~ m/^\s*package\s+(.*::)?(.*)\s*;/i) { |
285
|
|
|
|
|
|
|
my @up = split /::/, $1 if defined $1; |
286
|
|
|
|
|
|
|
$self->attach_package(join "::", @up, $2); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
close $fh; |
290
|
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
sub attach_package { |
293
|
|
|
|
|
|
|
my $self = shift; |
294
|
|
|
|
|
|
|
my ($package_name, $sub_package_name) = @_; |
295
|
|
|
|
|
|
|
die 'missing package name' unless $package_name; |
296
|
|
|
|
|
|
|
my @t = split '::', $package_name; |
297
|
|
|
|
|
|
|
my $modules = $self->{modules}; |
298
|
|
|
|
|
|
|
push @$modules, pop @t unless $sub_package_name; |
299
|
|
|
|
|
|
|
{ |
300
|
|
|
|
|
|
|
no strict 'refs'; |
301
|
|
|
|
|
|
|
foreach my $sub_name (keys %{$package_name . '::'}) { |
302
|
|
|
|
|
|
|
next unless $sub_name =~ /^(run|help|smry|comp|catch|alias)_/o; |
303
|
|
|
|
|
|
|
$self->{r}->{$sub_name} = $sub_package_name || $package_name; |
304
|
|
|
|
|
|
|
$self->add_handlers($sub_name); |
305
|
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
{ |
308
|
|
|
|
|
|
|
no strict 'refs'; |
309
|
|
|
|
|
|
|
foreach my $super_package_name (@{$package_name . '::ISA'}) { |
310
|
|
|
|
|
|
|
$self->attach_package($super_package_name, $sub_package_name || $package_name); |
311
|
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
our $AUTOLOAD; |
316
|
|
|
|
|
|
|
sub AUTOLOAD { |
317
|
|
|
|
|
|
|
my $self = shift; |
318
|
|
|
|
|
|
|
my @t = split /::/, $AUTOLOAD; |
319
|
|
|
|
|
|
|
my $sub_name = pop @t; |
320
|
|
|
|
|
|
|
my $class = join '::', @t; |
321
|
|
|
|
|
|
|
return unless ref $self eq $class; |
322
|
|
|
|
|
|
|
if (my $package_name = $self->{r}->{$sub_name}) { |
323
|
|
|
|
|
|
|
$package_name->$sub_name(@_); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
else { |
326
|
|
|
|
|
|
|
return undef; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
1; |