File Coverage

blib/lib/Shell/Perl.pm
Criterion Covered Total %
statement 85 245 34.6
branch 9 96 9.3
condition 0 6 0.0
subroutine 24 47 51.0
pod 14 14 100.0
total 132 408 32.3


line stmt bran cond sub pod time code
1             package Shell::Perl;
2              
3 4     4   38492 use strict;
  4         9  
  4         108  
4 4     4   18 use warnings;
  4         10  
  4         172  
5              
6             our $VERSION = '0.004';
7              
8 4     4   26 use base qw(Class::Accessor); # soon use base qw(Shell::Base);
  4         6  
  4         1917  
9             Shell::Perl->mk_accessors(qw(
10             out_type
11             dumper
12             context
13             package
14             perl_version
15             term
16             ornaments
17             library
18             on_quit
19             )); # XXX use_strict
20              
21 4     4   7269 use lib ();
  4         2042  
  4         106  
22 4     4   2276 use Getopt::Long 2.43 qw(:config no_auto_abbrev no_ignore_case bundling_values);
  4         34642  
  4         106  
23 4     4   2367 use version 0.77;
  4         5841  
  4         28  
24              
25 4     4   2696 use Term::ReadLine;
  4         8082  
  4         108  
26 4     4   1840 use Shell::Perl::Dumper;
  4         10  
  4         26  
27              
28             # out_type defaults to one of 'D', 'DD', 'Y', 'P';
29             # dumper XXX
30             # context defaults to 'list'
31             # package defaults to __PACKAGE__ . '::sandbox'
32             # XXX use_strict defaults to 0
33              
34             sub new {
35 2     2 1 75 my $self = shift;
36 2         40 my $sh = $self->SUPER::new({
37             context => 'list', # print context
38             on_quit => 'exit',
39             perl_version => $],
40             @_ });
41 2         61 $sh->_init;
42 2         33 return $sh;
43             }
44              
45             my %dumper_for = (
46             'D' => 'Shell::Perl::Data::Dump',
47             'DD' => 'Shell::Perl::Data::Dumper',
48             'Y' => 'Shell::Perl::Dumper::YAML',
49             'Data::Dump' => 'Shell::Perl::Data::Dump',
50             'Data::Dumper' => 'Shell::Perl::Data::Dumper',
51             'YAML' => 'Shell::Perl::Dumper::YAML',
52             'DDS' => 'Shell::Perl::Data::Dump::Streamer',
53              
54             'P' => 'Shell::Perl::Dumper::Plain',
55             'plain' => 'Shell::Perl::Dumper::Plain',
56             );
57              
58             sub _init {
59 2     2   7 my $self = shift;
60              
61             # loop until you find one available alternative for dump format
62 2         6 my $dumper_class;
63 2         10 for my $format ( qw(D DD DDS Y P) ) {
64 4 100       49 if ($dumper_for{$format}->is_available) {
65             #$self->print("format: $format\n");
66 2         19 $self->set_out($format);
67             last
68 2         29 } # XXX this is not working 100% - and I have no clue about it
69             }
70              
71             # Set library paths
72 2 50       10 if ($self->library) {
73 0         0 warn "Setting library paths (@{$self->library})\n";
  0         0  
74 0         0 lib->import(@{ $self->library });
  0         0  
75             }
76              
77 2         56 $self->set_package( __PACKAGE__ . '::sandbox' );
78              
79 2         12 $self->_set_on_quit( $self->on_quit );
80             }
81              
82             sub _shell_name {
83 0     0   0 require File::Basename;
84 0         0 return File::Basename::basename($0);
85             }
86              
87             sub print {
88 0     0 1 0 my $self = shift;
89 0         0 print {$self->term->OUT} @_;
  0         0  
90             }
91              
92             ## # XXX remove: code and docs
93             ## sub out {
94             ## my $self = shift;
95             ##
96             ## # XXX I want to improve this: preferably with an easy way to add dumpers
97             ## if ($self->context eq 'scalar') {
98             ## $self->print($self->dumper->dump_scalar(shift), "\n");
99             ## } else { # list
100             ## $self->print($self->dumper->dump_list(@_), "\n");
101             ## }
102             ## }
103              
104             # XXX I want to improve this: preferably with an easy way to add dumpers
105              
106             =begin private
107              
108             =item B<_print_scalar>
109              
110             $sh->_print_scalar($answer);
111              
112             That corresponds to the 'print' in the read-eval-print
113             loop (in scalar context). It outputs the evaluation result
114             after passing it through the current dumper.
115              
116             =end private
117              
118             =cut
119              
120             sub _print_scalar { # XXX make public, document
121 0     0   0 my $self = shift;
122 0         0 $self->print($self->dumper->dump_scalar(shift));
123             }
124              
125             =begin private
126              
127             =item B<_print_scalar>
128              
129             $sh->_print_list(@answers);
130              
131             That corresponds to the 'print' in the read-eval-print
132             loop (in list context). It outputs the evaluation result
133             after passing it through the current dumper.
134              
135             =end private
136              
137             =cut
138              
139             sub _print_list { # XXX make public, document
140 0     0   0 my $self = shift;
141 0         0 $self->print($self->dumper->dump_list(@_));
142             }
143              
144             sub _warn {
145 0     0   0 shift;
146 0         0 my $shell_name = _shell_name;
147 0         0 warn "$shell_name: ", @_, "\n";
148             }
149              
150             sub set_out {
151 2     2 1 8 my $self = shift;
152 2         7 my $type = shift;
153 2         10 my $dumper_class = $dumper_for{$type};
154 2 50       13 if (!defined $dumper_class) {
155 0         0 $self->_warn("unknown dumper $type");
156 0         0 return;
157             }
158 2 50       24 if ($dumper_class->is_available) {
159 2         32 $self->dumper($dumper_class->new);
160 2         104 $self->out_type($type);
161             } else {
162 0         0 $self->_warn("can't load dumper $dumper_class");
163             }
164             }
165              
166             sub _ctx {
167 0     0   0 my $context = shift;
168              
169 0 0       0 if ($context =~ /^(s|scalar|\$)$/i) {
    0          
    0          
170 0         0 return 'scalar';
171             } elsif ($context =~ /^(l|list|@)$/i) {
172 0         0 return 'list';
173             } elsif ($context =~ /^(v|void|_)$/i) {
174 0         0 return 'void';
175             } else {
176 0         0 return undef;
177             }
178             }
179              
180             sub set_ctx {
181 0     0 1 0 my $self = shift;
182 0         0 my $context = _ctx $_[0];
183              
184 0 0       0 if ($context) {
185 0         0 $self->context($context);
186             } else {
187 0         0 $self->_warn("unknown context $_[0]");
188             }
189             }
190              
191             sub set_package {
192 2     2 1 7 my $self = shift;
193 2         5 my $package = shift;
194              
195 2 50       27 if ($package =~ /( [a-zA-Z_] \w* :: )* [a-zA-Z_] \w* /x) {
196 2         12 $self->package($package);
197              
198 4     4   2600 no strict 'refs';
  4         9  
  4         1655  
199 2     0   34 *{ "${package}::quit" } = *{ "${package}::exit" } = sub { $self->{quitting} = 1 };
  2         16  
  2         24  
  0         0  
200              
201             } else {
202 0         0 $self->_warn("bad package name $package");
203             }
204             }
205              
206             my %on_quit = (
207             'exit' => sub { exit 0 },
208             'return' => sub {},
209             );
210              
211             sub _quit_handler {
212 2     2   5 my $handler = shift;
213              
214 2 50       10 if (exists $on_quit{$handler}) {
    0          
215 2         8 return $on_quit{$handler};
216             }
217             elsif (ref $handler eq 'CODE') {
218 0         0 return $handler;
219             }
220 0         0 return undef;
221             }
222              
223             sub _set_on_quit {
224 2     2   31 my $self = shift;
225 2         10 my $handler = _quit_handler($_[0]);
226              
227 2 50       9 if ($handler) {
228 2         15 $self->on_quit($handler);
229             }
230             else {
231 0         0 $self->_warn("bad on_quit handler $_[0]");
232 0         0 $self->on_quit($on_quit{'exit'});
233             }
234             }
235              
236             # $err = _check_perl_version($version);
237             sub _check_perl_version {
238 0     0   0 my $version = shift;
239 0         0 my $ver = eval { version->parse($version) };
  0         0  
240 0 0       0 if ($@) {
241 0         0 (my $err = $@) =~ s/at \S+ line \d+.$//;
242 0         0 return $err;
243             }
244             # Current perl
245 0   0     0 my $v = $^V || version->parse($]);
246 0 0       0 if ($ver > $v) {
247 0         0 return "This is only $v";
248             }
249 0         0 return undef; # good
250             }
251              
252             sub set_perl_version {
253 0     0 1 0 my $self = shift;
254 0         0 my $version = shift;
255              
256 0 0 0     0 if (!defined $version) {
    0          
257 0         0 $self->perl_version($]);
258             }
259             elsif ($version eq q{''} || $version eq q{""}) {
260 0         0 $self->perl_version('');
261             }
262             else {
263 0         0 my $err = _check_perl_version($version);
264 0 0       0 if ($err) {
265 0         0 $self->_warn("bad perl_version ($version): $err");
266             }
267             else {
268 0         0 $self->perl_version($version);
269             }
270             }
271             }
272              
273 4         411 use constant HELP =>
274 4     4   27 <<'HELP';
  4         9  
275             Shell commands: (begin with ':')
276             :e(x)it or :q(uit) - leave the shell
277             :set out (D|DD|DDS|Y|P) - setup the output format
278             :set ctx (scalar|list|void|s|l|v|$|@|_) - setup the eval context
279             :set package - set package in which shell eval statements
280             :set perl_version - set perl version to eval statements
281             :reset - reset the environment
282             :dump history - (experimental) print the history to STDOUT or a file
283             :h(elp) - get this help screen
284              
285             HELP
286              
287             sub help {
288 0     0 1 0 print HELP;
289             }
290              
291             # :reset is a nice idea - but I wanted more like CPAN reload
292             # I retreated the current implementation of :reset
293             # because %main:: is used as the evaluation package
294             # and %main:: = () is too severe by now
295              
296             sub reset {
297 0     0 1 0 my $self = shift;
298 0         0 my $package = $self->package;
299 0 0       0 return if $package eq 'main'; # XXX don't reset %main::
300 4     4   25 no strict 'refs';
  4         6  
  4         4717  
301 0         0 %{"${package}::"} = ();
  0         0  
302             #%main:: = (); # this segfaults at my machine
303             }
304              
305             sub prompt_title {
306 0     0 1 0 my $self = shift;
307 0         0 my $shell_name = _shell_name;
308 0         0 my $sigil = { scalar => '$', list => '@', void => '' }->{$self->{context}};
309 0         0 return "$shell_name $sigil> ";
310             }
311              
312             sub _readline {
313 0     0   0 my $self = shift;
314 0         0 return $self->term->readline($self->prompt_title);
315             }
316              
317             sub _history_file { # XXX
318 0     0   0 require Path::Class;
319 0         0 require File::HomeDir;
320 0         0 return Path::Class::file( File::HomeDir->my_home, '.pirl-history-xxx' );
321             }
322              
323             sub _read_history { # XXX belongs to Shell::Perl::ReadLine
324 0     0   0 my $term = shift;
325 0         0 my $h = _history_file;
326             #warn "read history from $h\n"; # XXX
327 0 0       0 if ( $term->Features->{readHistory} ) {
    0          
328 0         0 $term->ReadHistory( "$h" );
329             } elsif ( $term->Features->{setHistory} ) {
330 0 0       0 if ( -e $h ) {
331 0         0 my @h = $h->slurp( chomp => 1 );
332 0         0 $term->SetHistory( @h );
333             }
334             } else {
335             # warn "Your ReadLine doesn't support setHistory\n";
336             }
337              
338             }
339              
340             sub _write_history { # XXX belongs to Shell::Perl::ReadLine
341 0     0   0 my $term = shift;
342 0         0 my $h = _history_file;
343             #warn "write history to $h\n"; # XXX
344 0 0       0 if ( $term->Features->{writeHistory} ) {
    0          
345 0         0 $term->WriteHistory( "$h" );
346             } elsif ( $term->Features->{getHistory} ) {
347 0         0 my @h = $term->GetHistory;
348 0         0 $h->spew_lines(\@h);
349             } else {
350             # warn "Your ReadLine doesn't support getHistory\n";
351             }
352             }
353              
354             sub _new_term {
355 0     0   0 my $self = shift;
356 0         0 my $name = shift;
357 0         0 my $term = Term::ReadLine->new( $name );
358 0 0       0 $term->ornaments($self->ornaments) if $term->Features->{ornaments};
359 0         0 _read_history( $term );
360 0         0 return $term;
361             }
362              
363             sub run {
364 0     0 1 0 my $self = shift;
365 0         0 my $shell_name = _shell_name;
366 0         0 $self->term( my $term = $self->_new_term( $shell_name ) );
367 0         0 my $prompt = "$shell_name > ";
368              
369 0         0 print "Welcome to the Perl shell. Type ':help' for more information\n\n";
370              
371 0         0 local $self->{quitting} = 0;
372              
373 0         0 REPL: while ( defined ($_ = $self->_readline) ) {
374              
375             # trim
376 0         0 s/^\s+//g;
377 0         0 s/\s+$//g;
378              
379             # Shell commands start with ':' followed by something else
380             # which is not ':', so we can use things like '::my_subroutine()'.
381 0 0       0 if (/^:[^:]/) {
382 0 0       0 last REPL if /^:(exit|quit|q|x)/;
383 0 0       0 $self->set_out($1) if /^:set out (\S+)/;
384 0 0       0 $self->set_ctx($1) if /^:set ctx (\S+)/;
385 0 0       0 $self->set_package($1) if /^:set package (\S+)/;
386 0 0       0 $self->set_perl_version($1) if /^:set perl_version(?: (\S+))?/;
387 0 0       0 $self->reset if /^:reset/;
388 0 0       0 $self->help if /^:h(elp)?/;
389 0 0       0 $self->dump_history($1) if /^:dump history(?:\s+(\S*))?/;
390             # unknown shell command ?!
391 0         0 next REPL;
392             }
393              
394 0         0 my $context;
395 0 0       0 $context = _ctx($1) if s/#(s|scalar|\$|l|list|\@|v|void|_)\z//;
396 0 0       0 $context = $self->context unless $context;
397 0 0       0 if ( $context eq 'scalar' ) {
    0          
    0          
398 0         0 my $out = $self->eval($_);
399 0 0       0 if ($@) { warn "ERROR: $@"; next }
  0         0  
  0         0  
400 0         0 $self->_print_scalar($out);
401             } elsif ( $context eq 'list' ) {
402 0         0 my @out = $self->eval($_);
403 0 0       0 if ($@) { warn "ERROR: $@"; next }
  0         0  
  0         0  
404 0         0 $self->_print_list(@out);
405             } elsif ( $context eq 'void' ) {
406 0         0 $self->eval($_);
407 0 0       0 if ($@) { warn "ERROR: $@"; next }
  0         0  
  0         0  
408             } else {
409             # XXX should not happen
410             }
411 0 0       0 last if $self->{quitting};
412              
413             }
414 0         0 return $self->quit;
415              
416             }
417              
418             sub _package_stmt {
419 2     2   8 my $package = shift->package;
420 2         35 ("package $package");
421             }
422              
423             sub _use_perl_stmt {
424 2     2   10 my $perl_version = shift->perl_version;
425 2 50       36 $perl_version ? ("use $perl_version") : ();
426             }
427              
428             # $shell->eval($exp)
429             sub eval {
430 2     2 1 814 my $self = shift;
431 2         6 my $exp = shift;
432              
433 2         9 my $preamble = join ";\n", (
434             $self->_package_stmt,
435             $self->_use_perl_stmt,
436             "no strict qw(vars subs)",
437             "", # for the trailing ;
438             );
439              
440             # XXX gotta restore $_, etc.
441 2     1   168 return eval <
  1     1   27  
  1     1   4  
  1     1   9  
  1         3  
  1         44  
  1         19  
  1         5  
  1         7  
  1         3  
  1         24  
442             $preamble
443             #line 1
444             $exp
445             CHUNK
446             # XXX gotta save $_, etc.
447             }
448              
449             sub quit {
450 0     0 1 0 my $self = shift;
451 0         0 _write_history( $self->term );
452 0         0 $self->print( "Bye.\n" ); # XXX
453 0         0 return $self->on_quit->();
454             }
455              
456             sub run_with_args {
457 0     0 1 0 my $self = shift;
458              
459             # XXX do something with @ARGV (Getopt)
460 0         0 my %options = ( ornaments => 1 );
461 0 0       0 if ( @ARGV ) {
462             # only require Getopt::Long if there are actually command line arguments
463 0         0 require Getopt::Long;
464 0         0 Getopt::Long::GetOptions( \%options, 'ornaments!', 'version|v', 'library|I=s@' );
465             }
466              
467 0         0 my $shell = Shell::Perl->new(%options);
468 0 0       0 if ( $options{version} ) {
469 0         0 $shell->_show_version;
470             } else {
471 0         0 $shell->run;
472             }
473             }
474              
475             sub _show_version {
476 0     0   0 my $self = shift;
477 0         0 printf "This is %s, version %s (%s, using Shell::Perl %s)\n",
478             _shell_name,
479             $main::VERSION,
480             $0,
481             $Shell::Perl::VERSION;
482 0         0 exit 0;
483             }
484              
485             sub dump_history {
486 0     0 1 0 my $self = shift;
487 0         0 my $file = shift;
488              
489 0 0       0 if ( !$self->term->Features->{getHistory} ) {
490 0         0 print "Your Readline doesn't support getHistory\n";
491 0         0 return;
492             }
493              
494 0 0       0 if ( $file ) {
495             open( my $fh, ">>", $file )
496 0 0       0 or do { warn "Couldn't open '$file' for history dump\n"; return; };
  0         0  
  0         0  
497 0         0 for ( $self->term->GetHistory ) {
498 0         0 print $fh $_, "\n";
499             }
500 0         0 close $fh;
501              
502 0         0 print "Dumped history to '$file'\n\n";
503             } else {
504 0         0 print $_, "\n" for($self->{term}->GetHistory);
505 0         0 print "\n";
506             }
507 0         0 return 1;
508             }
509              
510             1;
511              
512             # OUTPUT Data::Dump, Data::Dumper, YAML, others
513             # document: use a different package when eval'ing
514             # reset the environment
515             # implement shell commands (:quit, :set, :exit, etc.)
516             # how to implement array contexts?
517             # IDEA: command ":set ctx scalar | list | void"
518             # terminators "#s" "#l" "#v" "#$" #@ #_
519             # allow multiline entries. how?
520              
521             ##sub set {} # sets up the instance variables of the shell
522             ##
523             ##sub run {} # run the read-eval-print loop
524             ##
525             ##sub read {} # read a chunk
526             ##
527             ##sub readline {} # read a line
528             ##
529             ##sub eval {}
530             ##
531             ##sub print {}
532             ##
533             ##sub warn {}
534             ##
535             ##sub help { shift->print(HELP) }
536             ##
537             ##sub out { ? }
538              
539             __END__