File Coverage

blib/lib/App/PerlShell.pm
Criterion Covered Total %
statement 35 312 11.2
branch 0 180 0.0
condition 0 33 0.0
subroutine 13 29 44.8
pod 15 15 100.0
total 63 569 11.0


line stmt bran cond sub pod time code
1             package App::PerlShell;
2              
3             ########################################################
4             # AUTHOR = Michael Vincent
5             # www.VinsWorld.com
6             ########################################################
7              
8 1     1   79175 use strict;
  1         12  
  1         35  
9 1     1   6 use warnings;
  1         2  
  1         31  
10 1     1   5 use Carp;
  1         2  
  1         102  
11              
12             our $VERSION = "1.08";
13              
14 1     1   8 use Cwd;
  1         2  
  1         84  
15 1     1   609 use Term::ReadLine;
  1         3149  
  1         42  
16 1     1   761 use Data::Dumper;
  1         7869  
  1         176  
17             $Data::Dumper::Sortkeys = 1;
18              
19             my $HAVE_LexPersist = 0;
20 1     1   239 eval "use Lexical::Persistence 1.01 ()";
  0         0  
  0         0  
21             if ( !$@ ) {
22             eval "use App::PerlShell::LexPersist";
23             $HAVE_LexPersist = 1;
24             }
25             my $HAVE_ModRefresh = 0;
26 1     1   178 eval "use Module::Refresh";
  0            
  0            
27             if ( !$@ ) {
28             eval "use App::PerlShell::ModRefresh";
29             $HAVE_ModRefresh = 1;
30             }
31              
32             my %COMMANDS_INT = (
33             debug => 'print command',
34             exit => 'exit shell'
35             );
36              
37             my %COMMANDS = (
38             cd => 'change directory',
39             cls => 'clear screen',
40             clear => 'clear screen',
41             commands => 'print available "commands" (sub)',
42             dir => 'directory listing',
43             dumper => 'use Data::Dumper to display variable',
44             help => 'shell help - print this',
45             ls => 'directory listing',
46             modules => 'list used modules',
47             perldoc => 'perldoc for current package',
48             pwd => 'print working directory',
49             session => 'start / stop logging session',
50             variables => 'list defined variables'
51             );
52              
53 1     1   11 use Exporter;
  1         2  
  1         729  
54             our @EXPORT = sort ( keys ( %COMMANDS ) );
55             our @ISA = qw ( Exporter );
56              
57             sub _shellCommands {
58 0     0     return ( %COMMANDS, %COMMANDS_INT );
59             }
60              
61             sub new {
62 0     0 1   my $self = shift;
63 0   0       my $class = ref($self) || $self;
64              
65             # Default parameters
66             my %params = (
67             homedir => ( $^O eq "MSWin32" ) ? $ENV{USERPROFILE} : $ENV{HOME},
68 0 0         package => __PACKAGE__,
69             prompt => 'Perl> '
70             );
71              
72 0           my $lex = 0;
73 0 0         if ( @_ == 1 ) {
74 0           croak("Insufficient number of args - @_");
75             } else {
76 0           my %cfg = @_;
77 0           for ( keys(%cfg) ) {
78 0 0         if (/^-?homedir$/i) {
    0          
    0          
    0          
    0          
    0          
    0          
79 0 0         if ( -d $cfg{$_} ) {
80 0           $params{homedir} = $cfg{$_};
81             } else {
82 0           croak("Cannot find directory `$cfg{$_}'");
83             }
84             } elsif (/^-?execute$/i) {
85 0           $params{execute} = $cfg{$_};
86             } elsif (/^-?lex(?:ical)?$/i) {
87 0           $lex = 1;
88             } elsif (/^-?package$/i) {
89 0           $params{package} = $cfg{$_};
90             } elsif (/^-?prompt$/i) {
91 0           $params{prompt} = $cfg{$_};
92             } elsif (/^-?session$/i) {
93              
94             # assign, will test open in run()
95 0           $params{session} = $cfg{$_};
96             } elsif (/^-?skipvars$/i) {
97 0 0         if ( ref $cfg{$_} eq 'ARRAY' ) {
98 0           $params{skipvars} = $cfg{$_};
99             } else {
100 0           croak("Not array reference `$cfg{$_}'");
101             }
102             } else {
103 0           croak("Unknown parameter `$_' => `$cfg{$_}'");
104             }
105             }
106             }
107              
108 0 0         if ($lex) {
109 0 0         if ($HAVE_LexPersist) {
110             $params{shellLexEnv}
111 0           = App::PerlShell::LexPersist->new( $params{package} );
112             } else {
113 0           croak(
114             "-lexical specified, `Lexical::Persistence' required but not found"
115             );
116             }
117             } else {
118 0           $ENV{PERLSHELL_PACKAGE} = $params{package};
119             }
120 0           $ENV{PERLSHELL_HOME} = $params{homedir};
121 0           $ENV{PERLSHELL_PROMPT} = $params{prompt};
122 0 0         if ( defined $params{skipvars} ) {
123 0           $ENV{PERLSHELL_SKIPVARS} = join ';', @{$params{skipvars}};
  0            
124             }
125              
126             # clean up object
127 0           delete $params{homedir};
128 0           delete $params{package};
129 0           delete $params{prompt};
130 0           delete $params{skipvars};
131 0           return bless \%params, $class;
132             }
133              
134             sub run {
135 0     0 1   my $App_PerlShell_Shell = shift;
136              
137             # handle session if requested
138 0 0         if ( defined $App_PerlShell_Shell->{session} ) {
139 0 0         if ( not defined session( $App_PerlShell_Shell->{session} ) ) {
140 0           croak(
141             "Cannot open session file `$App_PerlShell_Shell->{session}'");
142             }
143             }
144              
145 0 0         if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
146             $App_PerlShell_Shell->{shell}
147 0           = $App_PerlShell_Shell->{shellLexEnv}->get_package();
148             } else {
149 0           $App_PerlShell_Shell->{shell} = $ENV{PERLSHELL_PACKAGE};
150             }
151             $App_PerlShell_Shell->{shell}
152 0           = Term::ReadLine->new( $App_PerlShell_Shell->{shell} );
153 0           $App_PerlShell_Shell->{shell}->ornaments(0);
154              
155             #'use strict' is not used to allow "$p=" instead of "my $p=" at the prompt
156 1     1   9 no strict 'vars';
  1         4  
  1         1518  
157              
158             # will always exeucte without readline first time through (do ... while)
159 0           while (1) {
160              
161             # do ... while loop won't support next and last
162             # First check then clear {execute} to autopopulate
163             # $App_PerlShell_Shell->{shellCmdLine}
164             # otherwise, just do the readline.
165              
166 0 0         if ( defined $App_PerlShell_Shell->{execute} ) {
167             $App_PerlShell_Shell->{shellCmdLine}
168 0           = $App_PerlShell_Shell->{execute};
169              
170             # clear - it will never happen again
171 0           delete $App_PerlShell_Shell->{execute};
172             } else {
173             $App_PerlShell_Shell->{shellCmdLine}
174             .= $App_PerlShell_Shell->{shell}->readline(
175             ( defined $App_PerlShell_Shell->{shellCmdLine} )
176             ? 'More? '
177             : $ENV{PERLSHELL_PROMPT}
178 0 0         );
179             }
180              
181 0           chomp $App_PerlShell_Shell->{shellCmdLine};
182              
183             # nothing
184 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*$/ ) {
185 0           undef $App_PerlShell_Shell->{shellCmdLine};
186 0           next;
187             }
188              
189             # exit
190 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*exit\s*(;)?\s*$/ ) {
191 0 0         if ( not defined $1 ) {
192 0           $App_PerlShell_Shell->{shellCmdLine} .= ';';
193             }
194 0           last;
195             }
196              
197             # debug multiline
198 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} =~ /\ndebug$/ ) {
199 0           $App_PerlShell_Shell->{shellCmdLine} =~ s/debug$//;
200 0           print Dumper $App_PerlShell_Shell;
201 0           next;
202             }
203              
204             # variables if in -lexical
205 0 0         if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
206 0 0         if ( $App_PerlShell_Shell->{shellCmdLine}
207             =~ /^\s*variables\s*;\s*$/ ) {
208 0           for my $var (
209             sort( keys(
210             %{ $App_PerlShell_Shell->{shellLexEnv}
211 0           ->get_context('_')
212             }
213             ) )
214             ) {
215 0           print "$var\n";
216             }
217 0           undef $App_PerlShell_Shell->{shellCmdLine};
218 0           next;
219             }
220             }
221              
222             # Complete statement
223 0           %{$App_PerlShell_Shell->{shellCmdComplete}} = (
  0            
224             'parenthesis' => 0,
225             'bracket' => 0,
226             'brace' => 0
227             );
228 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\(/g ) ) {
229             $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis}
230 0           += scalar(@c);
231             }
232 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\)/g ) ) {
233             $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis}
234 0           -= scalar(@c);
235             }
236 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\[/g ) ) {
237 0           $App_PerlShell_Shell->{shellCmdComplete}->{bracket} += scalar(@c);
238             }
239 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\]/g ) ) {
240 0           $App_PerlShell_Shell->{shellCmdComplete}->{bracket} -= scalar(@c);
241             }
242 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\{/g ) ) {
243 0           $App_PerlShell_Shell->{shellCmdComplete}->{brace} += scalar(@c);
244             }
245 0 0         if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\}/g ) ) {
246 0           $App_PerlShell_Shell->{shellCmdComplete}->{brace} -= scalar(@c);
247             }
248              
249 0 0 0       if ( ( $App_PerlShell_Shell->{shellCmdLine} =~ /,\s*$/ )
      0        
      0        
250             or ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} != 0 )
251             or ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} != 0 )
252             or ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} != 0 )
253             ) {
254 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} !~ /\n;$/ ) {
255 0           $App_PerlShell_Shell->{shellCmdLine} .= "\n";
256 0           next;
257             }
258             }
259              
260             # if all groupings are closed
261 0 0 0       if ( ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} == 0 )
      0        
262             and ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} == 0 )
263             and ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} == 0 )
264             ) {
265             # valid endings are ; or }
266 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} !~ /(;|\})\s*$/ ) {
267             # unless PERLSHELL_SEMIOFF, we can add it and continue
268 0 0         if ( $ENV{PERLSHELL_SEMIOFF} ) {
269 0           $App_PerlShell_Shell->{shellCmdLine} .= ";";
270             } else {
271 0           $App_PerlShell_Shell->{shellCmdLine} .= "\n";
272 0           next;
273             }
274             }
275             }
276              
277             # import subs if not default package
278             # use redundant code in the if block so no variables are
279             # created at top level in case we're not using LexPersist
280 0 0         if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
281 0 0         if ( $App_PerlShell_Shell->{shellLexEnv}->get_package() ne
282             __PACKAGE__ ) {
283 0           my $sp = $App_PerlShell_Shell->{shellLexEnv}->get_package();
284 0           my $p = __PACKAGE__;
285 0           eval "package $sp; $p->import;";
286 0 0         if ($HAVE_ModRefresh) {
287 0           App::PerlShell::ModRefresh->refresh($sp);
288             }
289             }
290              
291             # execute
292 0           eval {
293             $App_PerlShell_Shell->{shellLexEnv}
294 0           ->do( $App_PerlShell_Shell->{shellCmdLine} );
295             };
296             } else {
297 0 0         if ( $ENV{PERLSHELL_PACKAGE} ne __PACKAGE__ ) {
298 0           my $sp = $ENV{PERLSHELL_PACKAGE};
299 0           my $p = __PACKAGE__;
300 0           eval "package $sp; $p->import;";
301 0 0         if ($HAVE_ModRefresh) {
302 0           App::PerlShell::ModRefresh->refresh($sp);
303             }
304             }
305             $App_PerlShell_Shell->{shellCmdLine}
306             = "package "
307             . $ENV{PERLSHELL_PACKAGE} . ";\n"
308             . $App_PerlShell_Shell->{shellCmdLine}
309 0           . "\nBEGIN {\$ENV{PERLSHELL_PACKAGE} = __PACKAGE__}";
310              
311             # execute
312 0           eval $App_PerlShell_Shell->{shellCmdLine};
313             }
314              
315             # error from execute?
316 0 0         warn $@ if ($@);
317              
318             # logging if requested and no error
319 0 0 0       if ( defined( $ENV{PERLSHELL_SESSION} ) and !$@ ) {
320              
321             # don't log session start command
322 0           $App_PerlShell_Shell->{shellCmdLine} =~ s/\s*session\s*.*//;
323              
324             # clean up command if we added stuff while not in -lex mode
325 0           $App_PerlShell_Shell->{shellCmdLine} =~ s/^package .*;\n//;
326             $App_PerlShell_Shell->{shellCmdLine}
327 0           =~ s/(?:\n)?BEGIN \{\$ENV\{PERLSHELL_PACKAGE\} = __PACKAGE__\}//;
328              
329 0           open( my $OUT, '>>', $ENV{PERLSHELL_SESSION} );
330             print $OUT "$App_PerlShell_Shell->{shellCmdLine}\n"
331 0 0         if ( $App_PerlShell_Shell->{shellCmdLine} ne '' );
332 0           close $OUT;
333             }
334              
335             # reset to normal before next input
336             $App_PerlShell_Shell->{shellLastCmd}
337 0           = $App_PerlShell_Shell->{shellCmdLine};
338 0           undef $App_PerlShell_Shell->{shellCmdLine};
339 0           print "\n";
340             }
341             }
342              
343             ########################################################
344             # commands
345             ########################################################
346              
347             sub cd {
348 0     0 1   my ($arg) = @_;
349              
350 0           my $ret = getcwd;
351 0 0         if ( not defined $arg ) {
352 0           chdir $ENV{PERLSHELL_HOME};
353             } else {
354 0 0         if ( -e $arg ) {
355 0           chdir $arg;
356             } else {
357 0           print "Cannot find directory `$arg'\n";
358             }
359             }
360 0 0         if ( defined wantarray ) {
361 0           return $ret;
362             }
363             }
364              
365             sub cls {
366 0     0 1   return clear();
367             }
368              
369             sub clear {
370 0 0   0 1   if ( $^O eq "MSWin32" ) {
371 0           system('cls');
372             } else {
373 0           system('clear');
374             }
375             }
376              
377             sub commands {
378 0     0 1   my ($arg) = @_;
379              
380 0           my @rets;
381 0           my $retType = wantarray;
382              
383 0           my $stash = $ENV{PERLSHELL_PACKAGE} . '::';
384              
385 1     1   10 no strict 'refs';
  1         2  
  1         358  
386              
387 0           my $regex = qr/^.*$/;
388 0 0         if ( defined($arg) ) {
389 0           $regex = qr/$arg/;
390             }
391              
392 0           for my $name ( sort( keys( %{$stash} ) ) ) {
  0            
393 0 0         next if ( $name =~ /^_/ );
394              
395 0           my $sub = *{"${stash}${name}"}{CODE};
  0            
396 0 0         next unless defined $sub;
397              
398 0           my $proto = prototype($sub);
399 0 0 0       next if defined $proto and length($proto) == 0;
400              
401 0 0         if ( $name =~ /$regex/ ) {
402 0           push @rets, $name;
403             }
404             }
405              
406 0 0         if ( not defined $retType ) {
    0          
407 0           for (@rets) {
408 0           print "$_\n";
409             }
410             } elsif ($retType) {
411 0           return @rets;
412             } else {
413 0           return \@rets;
414             }
415             }
416              
417             sub dumper {
418 0     0 1   my (@dump) = @_;
419              
420 1     1   8 use Data::Dumper;
  1         2  
  1         1293  
421 0           $Data::Dumper::Sortkeys = 1;
422 0           print Dumper @dump;
423             }
424              
425             sub help {
426 0     0 1   my %cmds = _shellCommands();
427 0           for my $h ( sort( keys(%cmds) ) ) {
428 0           printf "%-15s %s\n", $h, $cmds{$h};
429             }
430             }
431              
432             sub dir {
433 0     0 1   return ls(@_);
434             }
435              
436             sub ls {
437 0     0 1   my (@args) = @_;
438              
439 0           my $dircmd = 'ls';
440 0 0         if ( $^O eq "MSWin32" ) {
441 0           $dircmd = 'dir';
442             }
443              
444 0           my @allArgs;
445 0           for my $arg ( @args ) {
446 0           my @temp = split /\s+/, $arg;
447 0           push @allArgs, @temp;
448             }
449 0           @args = @allArgs;
450              
451 0           my @ret;
452 0           my $retType = wantarray;
453 0 0         if ( not defined $retType ) {
454 0           system( $dircmd, @args );
455             } else {
456 0           @ret = `$dircmd @args`;
457 0 0         if ($retType) {
458 0           return @ret;
459             } else {
460 0           return \@ret;
461             }
462             }
463             }
464              
465             sub modules {
466 0     0 1   my ($arg) = @_;
467              
468 0           my %rets;
469 0           my $retType = wantarray;
470              
471 0           my $FOUND = 0;
472 0           for my $module ( sort( keys(%INC) ) ) {
473 0           my $path = $INC{$module};
474 0           $module =~ s/\//::/g;
475 0           $module =~ s/\.pm$//;
476              
477 0 0         if ( defined $arg ) {
478 0 0         if ( $module =~ /$arg/ ) {
479 0           $rets{$module} = $path;
480 0           $FOUND = 1;
481             }
482             } else {
483 0           $rets{$module} = $path;
484 0           $FOUND = 1;
485             }
486             }
487              
488 0 0         if ( !$FOUND ) {
489 0 0         printf "Module(s) not found%s",
490             ( defined $arg ) ? " - `$arg'\n" : "\n";
491             }
492              
493 0 0         if ( not defined $retType ) {
    0          
494 0           for my $module ( sort( keys(%rets) ) ) {
495             printf "$module %s\n",
496 0 0         ( defined $rets{$module} ) ? $rets{$module} : "[NOT LOADED]";
497             }
498             } elsif ($retType) {
499 0           return %rets;
500             } else {
501 0           return \%rets;
502             }
503             }
504              
505             sub perldoc {
506 0     0 1   my (@args) = @_;
507              
508 0 0         if ( $#args == -1 ) {
509 0           push @args, $ENV{PERLSHELL_PACKAGE};
510             }
511              
512 0           my @allArgs;
513 0           for my $arg ( @args ) {
514 0           my @temp = split /\s+/, $arg;
515 0           push @allArgs, @temp;
516             }
517 0           @args = @allArgs;
518              
519 0 0         if ( $args[0] =~ /^::/ ) {
520 0           $args[0] = $ENV{PERLSHELL_PACKAGE} . $args[0];
521             }
522              
523 0           system( "perldoc", @args );
524             }
525              
526             sub pwd {
527 0 0   0 1   if ( not defined wantarray ) {
528 0           print getcwd;
529             } else {
530 0           return getcwd;
531             }
532             }
533              
534             sub session {
535 0     0 1   my ($arg) = @_;
536              
537 0 0         if ( not defined $arg ) {
538 0 0         if ( defined $ENV{PERLSHELL_SESSION} ) {
539 0 0         if ( not defined wantarray ) {
540 0           print $ENV{PERLSHELL_SESSION} . "\n";
541             }
542 0           return $ENV{PERLSHELL_SESSION};
543             } else {
544 0 0         if ( not defined wantarray ) {
545 0           print "No current session file\n";
546             }
547 0           return undef;
548             }
549             }
550              
551 0 0         if ( $arg eq ":close" ) {
552 0 0         if ( defined $ENV{PERLSHELL_SESSION} ) {
553 0 0         if ( not defined wantarray ) {
554 0           print "$ENV{PERLSHELL_SESSION} closed\n";
555             }
556 0           $ENV{PERLSHELL_SESSION} = undef;
557 0           return;
558             } else {
559 0 0         if ( not defined wantarray ) {
560 0           print "No current session file\n";
561             }
562 0           return undef;
563             }
564             }
565              
566 0 0         if ( not defined $ENV{PERLSHELL_SESSION} ) {
567 0 0         if ( -e $arg ) {
568 0 0         if ( not defined wantarray ) {
569 0           print "File `$arg' exists - will append\n";
570             }
571             }
572              
573 0 0         if ( open( my $fh, '>>', $arg ) ) {
574 0           close $fh;
575 0           $ENV{PERLSHELL_SESSION} = $arg;
576 0 0         if ( not defined wantarray ) {
577 0           print $ENV{PERLSHELL_SESSION} . "\n";
578             }
579 0           return $ENV{PERLSHELL_SESSION};
580             } else {
581 0 0         if ( not defined wantarray ) {
582 0           print "Cannot open file `$arg' for writing\n";
583             }
584 0           return undef;
585             }
586             } else {
587 0 0         if ( not defined wantarray ) {
588 0           print "Session file already open - `$ENV{PERLSHELL_SESSION}'\n";
589             }
590 0           return;
591             }
592             }
593              
594             sub variables {
595              
596 0     0 1   my %SKIP = (
597             '$VERSION' => 1,
598             '@ISA' => 1,
599             '@EXPORT' => 1
600             );
601              
602 0 0         if ( !exists $ENV{PERLSHELL_PACKAGE} ) {
603 0           print "In -lexical mode, try again on line by iteslf\n";
604 0           return;
605             }
606              
607 0 0         if ( defined $ENV{PERLSHELL_SKIPVARS} ) {
608 0           for ( split /;/, $ENV{PERLSHELL_SKIPVARS} ) {
609 0           $SKIP{"$_"} = 1;
610             }
611             }
612              
613 0           my @rets;
614 0           my $retType = wantarray;
615              
616 1     1   11 no strict 'refs';
  1         3  
  1         305  
617 0           for my $var ( sort( keys( %{$ENV{PERLSHELL_PACKAGE} . '::'} ) ) ) {
  0            
618 0 0 0       if ( defined( ${$ENV{PERLSHELL_PACKAGE} . "::$var"} )
  0 0 0        
    0 0        
619             and not defined( $SKIP{'$' . $var} ) ) {
620 0           push @rets, "\$$var";
621 0           } elsif ( @{$ENV{PERLSHELL_PACKAGE} . "::$var"}
622             and not defined( $SKIP{'@' . $var} ) ) {
623 0           push @rets, "\@$var";
624 0           } elsif ( %{$ENV{PERLSHELL_PACKAGE} . "::$var"}
625             and not defined( $SKIP{'%' . $var} ) ) {
626 0           push @rets, "\%$var";
627             }
628             }
629              
630 0 0         if ( not defined $retType ) {
    0          
631 0           for (@rets) {
632 0           print "$_\n";
633             }
634             } elsif ($retType) {
635 0           return @rets;
636             } else {
637 0           return \@rets;
638             }
639             }
640              
641             1;
642              
643             __END__