File Coverage

blib/lib/App/PerlShell.pm

Criterion	Covered	Total	%
statement	35	306	11.4
branch	0	174	0.0
condition	0	39	0.0
subroutine	13	29	44.8
pod	15	15	100.0
total	63	563	11.1

package App::PerlShell;

########################################################
# AUTHOR = Michael Vincent
# www.VinsWorld.com
########################################################

use strict;
use warnings;
use Carp;

our $VERSION = "1.07";

use Cwd;
use Term::ReadLine;
use Data::Dumper;
$Data::Dumper::Sortkeys = 1;

my $HAVE_LexPersist = 0;
eval "use Lexical::Persistence 1.01 ()";
if ( !$@ ) {
    eval "use App::PerlShell::LexPersist";
    $HAVE_LexPersist = 1;
}
my $HAVE_ModRefresh = 0;
eval "use Module::Refresh";
if ( !$@ ) {
    eval "use App::PerlShell::ModRefresh";
    $HAVE_ModRefresh = 1;
}

my %COMMANDS_INT = (
    debug     => 'print command',
    exit      => 'exit shell'
);

my %COMMANDS = (
    cd        => 'change directory',
    cls       => 'clear screen',
    clear     => 'clear screen',
    commands  => 'print available "commands" (sub)',
    dir       => 'directory listing',
    dumper    => 'use Data::Dumper to display variable',
    help      => 'shell help - print this',
    ls        => 'directory listing',
    modules   => 'list used modules',
    perldoc   => 'perldoc for current package',
    pwd       => 'print working directory',
    session   => 'start / stop logging session',
    variables => 'list defined variables'
);

use Exporter;
our @EXPORT = sort ( keys ( %COMMANDS ) );
our @ISA = qw ( Exporter );

sub _shellCommands {
    return ( %COMMANDS, %COMMANDS_INT );
}

sub new {
    my $self = shift;
    my $class = ref($self) || $self;

    # Default parameters
    my %params = (
        homedir => ( $^O eq "MSWin32" ) ? $ENV{USERPROFILE} : $ENV{HOME},
        package => __PACKAGE__,
        prompt  => 'Perl> '
    );

    my $lex = 0;
    if ( @_ == 1 ) {
        croak("Insufficient number of args - @_");
    } else {
        my %cfg = @_;
        for ( keys(%cfg) ) {
            if (/^-?homedir$/i) {
                if ( -d $cfg{$_} ) {
                    $params{homedir} = $cfg{$_};
                } else {
                    croak("Cannot find directory `$cfg{$_}'");
                }
            } elsif (/^-?execute$/i) {
                $params{execute} = $cfg{$_};
            } elsif (/^-?lex(?:ical)?$/i) {
                $lex = 1;
            } elsif (/^-?package$/i) {
                $params{package} = $cfg{$_};
            } elsif (/^-?prompt$/i) {
                $params{prompt} = $cfg{$_};
            } elsif (/^-?session$/i) {

                # assign, will test open in run()
                $params{session} = $cfg{$_};
            } elsif (/^-?skipvars$/i) {
                if ( ref $cfg{$_} eq 'ARRAY' ) {
                    $params{skipvars} = $cfg{$_};
                } else {
                    croak("Not array reference `$cfg{$_}'");
                }
            } else {
                croak("Unknown parameter `$_' => `$cfg{$_}'");
            }
        }
    }

    if ($lex) {
        if ($HAVE_LexPersist) {
            $params{shellLexEnv}
              = App::PerlShell::LexPersist->new( $params{package} );
        } else {
            croak(
                "-lexical specified, `Lexical::Persistence' required but not found"
            );
        }
    } else {
        $ENV{PERLSHELL_PACKAGE} = $params{package};
    }
    $ENV{PERLSHELL_HOME}   = $params{homedir};
    $ENV{PERLSHELL_PROMPT} = $params{prompt};
    if ( defined $params{skipvars} ) {
        $ENV{PERLSHELL_SKIPVARS} = join ';', @{$params{skipvars}};
    }

    # clean up object
    delete $params{homedir};
    delete $params{package};
    delete $params{prompt};
    delete $params{skipvars};
    return bless \%params, $class;
}

sub run {
    my $App_PerlShell_Shell = shift;

    # handle session if requested
    if ( defined $App_PerlShell_Shell->{session} ) {
        if ( not defined session( $App_PerlShell_Shell->{session} ) ) {
            croak(
                "Cannot open session file `$App_PerlShell_Shell->{session}'");
        }
    }

    if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
        $App_PerlShell_Shell->{shell}
          = $App_PerlShell_Shell->{shellLexEnv}->get_package();
    } else {
        $App_PerlShell_Shell->{shell} = $ENV{PERLSHELL_PACKAGE};
    }
    $App_PerlShell_Shell->{shell}
      = Term::ReadLine->new( $App_PerlShell_Shell->{shell} );
    $App_PerlShell_Shell->{shell}->ornaments(0);

    #'use strict' is not used to allow "$p=" instead of "my $p=" at the prompt
    no strict 'vars';

    # will always exeucte without readline first time through (do ... while)
    while (1) {

        # do ... while loop won't support next and last
        # First check then clear {execute} to autopopulate
        # $App_PerlShell_Shell->{shellCmdLine}
        # otherwise, just do the readline.

        if ( defined $App_PerlShell_Shell->{execute} ) {
            $App_PerlShell_Shell->{shellCmdLine}
              = $App_PerlShell_Shell->{execute};

            # clear - it will never happen again
            delete $App_PerlShell_Shell->{execute};
        } else {
            $App_PerlShell_Shell->{shellCmdLine}
              .= $App_PerlShell_Shell->{shell}->readline(
                ( defined $App_PerlShell_Shell->{shellCmdLine} )
                ? 'More? '
                : $ENV{PERLSHELL_PROMPT}
              );
        }

        chomp $App_PerlShell_Shell->{shellCmdLine};

        # nothing
        if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*$/ ) {
            undef $App_PerlShell_Shell->{shellCmdLine};
            next;
        }

        # exit
        if ( $App_PerlShell_Shell->{shellCmdLine} =~ /^\s*exit\s*(;)?\s*$/ ) {
            if ( not defined $1 ) {
                $App_PerlShell_Shell->{shellCmdLine} .= ';';
            }
            last;
        }

        # debug multiline
        if ( $App_PerlShell_Shell->{shellCmdLine} =~ /\ndebug$/ ) {
            $App_PerlShell_Shell->{shellCmdLine} =~ s/debug$//;
            print Dumper $App_PerlShell_Shell;
            next;
        }

        # variables if in -lexical
        if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
            if ( $App_PerlShell_Shell->{shellCmdLine}
                =~ /^\s*variables\s*;\s*$/ ) {
                for my $var (
                    sort( keys(
                            %{  $App_PerlShell_Shell->{shellLexEnv}
                                  ->get_context('_')
                            }
                    ) )
                  ) {
                    print "$var\n";
                }
                undef $App_PerlShell_Shell->{shellCmdLine};
                next;
            }
        }

        # Complete statement
        %{$App_PerlShell_Shell->{shellCmdComplete}} = (
            'parenthesis' => 0,
            'bracket'     => 0,
            'brace'       => 0
        );
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\(/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis}
              += scalar(@c);
        }
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\)/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis}
              -= scalar(@c);
        }
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\[/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{bracket} += scalar(@c);
        }
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\]/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{bracket} -= scalar(@c);
        }
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\{/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{brace} += scalar(@c);
        }
        if ( my @c = ( $App_PerlShell_Shell->{shellCmdLine} =~ /\}/g ) ) {
            $App_PerlShell_Shell->{shellCmdComplete}->{brace} -= scalar(@c);
        }

        if (( ( $App_PerlShell_Shell->{shellCmdLine} =~ /,\s*$/ )
              or ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} != 0 )
              or ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} != 0 )
              or ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} != 0 )
            )
            or

            # valid endings are ; or }, but only if all groupings are closed
            ( ( $App_PerlShell_Shell->{shellCmdLine} !~ /(;|\})\s*$/ )
              and ( $App_PerlShell_Shell->{shellCmdComplete}->{parenthesis} == 0 )
              and ( $App_PerlShell_Shell->{shellCmdComplete}->{bracket} == 0 )
              and ( $App_PerlShell_Shell->{shellCmdComplete}->{brace} == 0 )
            )
          ) {
            if ( $App_PerlShell_Shell->{shellCmdLine} !~ /\n;$/ ) {
                $App_PerlShell_Shell->{shellCmdLine} .= "\n";
                next;
            }
        }

        # import subs if not default package
        # use redundant code in the if block so no variables are
        # created at top level in case we're not using LexPersist
        if ( exists $App_PerlShell_Shell->{shellLexEnv} ) {
            if ( $App_PerlShell_Shell->{shellLexEnv}->get_package() ne
                __PACKAGE__ ) {
                my $sp = $App_PerlShell_Shell->{shellLexEnv}->get_package();
                my $p  = __PACKAGE__;
                eval "package $sp; $p->import;";
                if ($HAVE_ModRefresh) {
                    App::PerlShell::ModRefresh->refresh($sp);
                }
            }

            # execute
            eval {
                $App_PerlShell_Shell->{shellLexEnv}
                  ->do( $App_PerlShell_Shell->{shellCmdLine} );
            };
        } else {
            if ( $ENV{PERLSHELL_PACKAGE} ne __PACKAGE__ ) {
                my $sp = $ENV{PERLSHELL_PACKAGE};
                my $p  = __PACKAGE__;
                eval "package $sp; $p->import;";
                if ($HAVE_ModRefresh) {
                    App::PerlShell::ModRefresh->refresh($sp);
                }
            }
            $App_PerlShell_Shell->{shellCmdLine}
              = "package "
              . $ENV{PERLSHELL_PACKAGE} . ";\n"
              . $App_PerlShell_Shell->{shellCmdLine}
              . "\nBEGIN {\$ENV{PERLSHELL_PACKAGE} = __PACKAGE__}";

            # execute
            eval $App_PerlShell_Shell->{shellCmdLine};
        }

        # error from execute?
        warn $@ if ($@);

        # logging if requested and no error
        if ( defined( $ENV{PERLSHELL_SESSION} ) and !$@ ) {

            # don't log session start command
            $App_PerlShell_Shell->{shellCmdLine} =~ s/\s*session\s*.*//;

            # clean up command if we added stuff while not in -lex mode
            $App_PerlShell_Shell->{shellCmdLine} =~ s/^package .*;\n//;
            $App_PerlShell_Shell->{shellCmdLine}
              =~ s/(?:\n)?BEGIN \{\$ENV\{PERLSHELL_PACKAGE\} = __PACKAGE__\}//;

            open( my $OUT, '>>', $ENV{PERLSHELL_SESSION} );
            print $OUT "$App_PerlShell_Shell->{shellCmdLine}\n"
              if ( $App_PerlShell_Shell->{shellCmdLine} ne '' );
            close $OUT;
        }

        # reset to normal before next input
        $App_PerlShell_Shell->{shellLastCmd}
          = $App_PerlShell_Shell->{shellCmdLine};
        undef $App_PerlShell_Shell->{shellCmdLine};
        print "\n";
    }
}

########################################################
# commands
########################################################

sub cd {
    my ($arg) = @_;

    my $ret = getcwd;
    if ( not defined $arg ) {
        chdir $ENV{PERLSHELL_HOME};
    } else {
        if ( -e $arg ) {
            chdir $arg;
        } else {
            print "Cannot find directory `$arg'\n";
        }
    }
    if ( defined wantarray ) {
        return $ret;
    }
}

sub cls {
    return clear();
}

sub clear {
    if ( $^O eq "MSWin32" ) {
        system('cls');
    } else {
        system('clear');
    }
}

sub commands {
    my ($arg) = @_;

    my @rets;
    my $retType = wantarray;

    my $stash = $ENV{PERLSHELL_PACKAGE} . '::';

    no strict 'refs';

    my $regex = qr/^.*$/;
    if ( defined($arg) ) {
        $regex = qr/$arg/;
    }

    for my $name ( sort( keys( %{$stash} ) ) ) {
        next if ( $name =~ /^_/ );

        my $sub = *{"${stash}${name}"}{CODE};
        next unless defined $sub;

        my $proto = prototype($sub);
        next if defined $proto and length($proto) == 0;

        if ( $name =~ /$regex/ ) {
            push @rets, $name;
        }
    }

    if ( not defined $retType ) {
        for (@rets) {
            print "$_\n";
        }
    } elsif ($retType) {
        return @rets;
    } else {
        return \@rets;
    }
}

sub dumper {
    my (@dump) = @_;

    use Data::Dumper;
    $Data::Dumper::Sortkeys = 1;
    print Dumper @dump;
}

sub help {
    my %cmds = _shellCommands();
    for my $h ( sort( keys(%cmds) ) ) {
        printf "%-15s %s\n", $h, $cmds{$h};
    }
}

sub dir {
    return ls(@_);
}

sub ls {
    my (@args) = @_;

    my $dircmd = 'ls';
    if ( $^O eq "MSWin32" ) {
        $dircmd = 'dir';
    }

    my @allArgs;
    for my $arg ( @args ) {
        my @temp = split /\s+/, $arg;
        push @allArgs, @temp;
    }
    @args = @allArgs;

    my @ret;
    my $retType = wantarray;
    if ( not defined $retType ) {
        system( $dircmd, @args );
    } else {
        @ret = `$dircmd @args`;
        if ($retType) {
            return @ret;
        } else {
            return \@ret;
        }
    }
}

sub modules {
    my ($arg) = @_;

    my %rets;
    my $retType = wantarray;

    my $FOUND = 0;
    for my $module ( sort( keys(%INC) ) ) {
        my $path = $INC{$module};
        $module =~ s/\//::/g;
        $module =~ s/\.pm$//;

        if ( defined $arg ) {
            if ( $module =~ /$arg/ ) {
                $rets{$module} = $path;
                $FOUND = 1;
            }
        } else {
            $rets{$module} = $path;
            $FOUND = 1;
        }
    }

    if ( !$FOUND ) {
        printf "Module(s) not found%s",
          ( defined $arg ) ? " - `$arg'\n" : "\n";
    }

    if ( not defined $retType ) {
        for my $module ( sort( keys(%rets) ) ) {
            printf "$module %s\n",
              ( defined $rets{$module} ) ? $rets{$module} : "[NOT LOADED]";
        }
    } elsif ($retType) {
        return %rets;
    } else {
        return \%rets;
    }
}

sub perldoc {
    my (@args) = @_;

    if ( $#args == -1 ) {
        push @args, $ENV{PERLSHELL_PACKAGE};
    }

    my @allArgs;
    for my $arg ( @args ) {
        my @temp = split /\s+/, $arg;
        push @allArgs, @temp;
    }
    @args = @allArgs;

    if ( $args[0] =~ /^::/ ) {
        $args[0] = $ENV{PERLSHELL_PACKAGE} . $args[0];
    }

    system( "perldoc", @args );
}

sub pwd {
    if ( not defined wantarray ) {
        print getcwd;
    } else {
        return getcwd;
    }
}

sub session {
    my ($arg) = @_;

    if ( not defined $arg ) {
        if ( defined $ENV{PERLSHELL_SESSION} ) {
            if ( not defined wantarray ) {
                print $ENV{PERLSHELL_SESSION} . "\n";
            }
            return $ENV{PERLSHELL_SESSION};
        } else {
            if ( not defined wantarray ) {
                print "No current session file\n";
            }
            return undef;
        }
    }

    if ( $arg eq ":close" ) {
        if ( defined $ENV{PERLSHELL_SESSION} ) {
            if ( not defined wantarray ) {
                print "$ENV{PERLSHELL_SESSION} closed\n";
            }
            $ENV{PERLSHELL_SESSION} = undef;
            return;
        } else {
            if ( not defined wantarray ) {
                print "No current session file\n";
            }
            return undef;
        }
    }

    if ( not defined $ENV{PERLSHELL_SESSION} ) {
        if ( -e $arg ) {
            if ( not defined wantarray ) {
                print "File `$arg' exists - will append\n";
            }
        }

        if ( open( my $fh, '>>', $arg ) ) {
            close $fh;
            $ENV{PERLSHELL_SESSION} = $arg;
            if ( not defined wantarray ) {
                print $ENV{PERLSHELL_SESSION} . "\n";
            }
            return $ENV{PERLSHELL_SESSION};
        } else {
            if ( not defined wantarray ) {
                print "Cannot open file `$arg' for writing\n";
            }
            return undef;
        }
    } else {
        if ( not defined wantarray ) {
            print "Session file already open - `$ENV{PERLSHELL_SESSION}'\n";
        }
        return;
    }
}

sub variables {

    my %SKIP = (
        '$VERSION' => 1,
        '@ISA'     => 1,
        '@EXPORT'  => 1
    );

    if ( !exists $ENV{PERLSHELL_PACKAGE} ) {
        print "In -lexical mode, try again on line by iteslf\n";
        return;
    }

    if ( defined $ENV{PERLSHELL_SKIPVARS} ) {
        for ( split /;/, $ENV{PERLSHELL_SKIPVARS} ) {
            $SKIP{"$_"} = 1;
        }
    }

    my @rets;
    my $retType = wantarray;

    no strict 'refs';
    for my $var ( sort( keys( %{$ENV{PERLSHELL_PACKAGE} . '::'} ) ) ) {
        if ( defined( ${$ENV{PERLSHELL_PACKAGE} . "::$var"} )
            and not defined( $SKIP{'$' . $var} ) ) {
            push @rets, "\$$var";
        } elsif ( @{$ENV{PERLSHELL_PACKAGE} . "::$var"}
            and not defined( $SKIP{'@' . $var} ) ) {
            push @rets, "\@$var";
        } elsif ( %{$ENV{PERLSHELL_PACKAGE} . "::$var"}
            and not defined( $SKIP{'%' . $var} ) ) {
            push @rets, "\%$var";
        }
    }

    if ( not defined $retType ) {
        for (@rets) {
            print "$_\n";
        }
    } elsif ($retType) {
        return @rets;
    } else {
        return \@rets;
    }
}

1;

__END__