File Coverage

blib/lib/Term/Shell/Pluggable.pm
Criterion Covered Total %
statement 16 51 31.3
branch 0 12 0.0
condition 0 7 0.0
subroutine 6 9 66.6
pod n/a
total 22 79 27.8


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;