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

package Shell::Perl;

use strict;
use warnings;

our $VERSION = '0.004';

use base qw(Class::Accessor); # soon use base qw(Shell::Base);
Shell::Perl->mk_accessors(qw(
    out_type
    dumper
    context
    package
    perl_version
    term
    ornaments
    library
    on_quit
)); # XXX use_strict

use lib ();
use Getopt::Long 2.43 qw(:config no_auto_abbrev no_ignore_case bundling_values);
use version 0.77;

use Term::ReadLine;
use Shell::Perl::Dumper;

# out_type defaults to one of 'D', 'DD', 'Y', 'P';
# dumper XXX
# context defaults to 'list'
# package defaults to __PACKAGE__ . '::sandbox'
# XXX use_strict defaults to 0

sub new {
    my $self = shift;
    my $sh = $self->SUPER::new({
                           context => 'list', # print context
                           on_quit => 'exit',
                           perl_version => $],
                           @_ });
    $sh->_init;
    return $sh;
}

my %dumper_for = (
   'D' => 'Shell::Perl::Data::Dump',
   'DD' => 'Shell::Perl::Data::Dumper',
   'Y' => 'Shell::Perl::Dumper::YAML',
   'Data::Dump' => 'Shell::Perl::Data::Dump',
   'Data::Dumper' => 'Shell::Perl::Data::Dumper',
   'YAML' => 'Shell::Perl::Dumper::YAML',
   'DDS' => 'Shell::Perl::Data::Dump::Streamer',

   'P' => 'Shell::Perl::Dumper::Plain',
   'plain' => 'Shell::Perl::Dumper::Plain',
);

sub _init {
    my $self = shift;

    # loop until you find one available alternative for dump format
    my $dumper_class;
    for my $format ( qw(D DD DDS Y P) ) {
        if ($dumper_for{$format}->is_available) {
            #$self->print("format: $format\n");
            $self->set_out($format);
            last
        } # XXX this is not working 100% - and I have no clue about it
    }

    # Set library paths
    if ($self->library) {
        warn "Setting library paths (@{$self->library})\n";
        lib->import(@{ $self->library });
    }

    $self->set_package( __PACKAGE__ . '::sandbox' );

    $self->_set_on_quit( $self->on_quit );
}

sub _shell_name {
    require File::Basename;
    return File::Basename::basename($0);
}

sub print {
    my $self = shift;
    print {$self->term->OUT} @_;
}

## # XXX remove: code and docs
## sub out {
##     my $self = shift;
##
##     # XXX I want to improve this: preferably with an easy way to add dumpers
##     if ($self->context eq 'scalar') {
##         $self->print($self->dumper->dump_scalar(shift), "\n");
##     } else { # list
##         $self->print($self->dumper->dump_list(@_), "\n");
##     }
## }

# XXX I want to improve this: preferably with an easy way to add dumpers

=begin private

=item B<_print_scalar>

    $sh->_print_scalar($answer);

That corresponds to the 'print' in the read-eval-print
loop (in scalar context). It outputs the evaluation result
after passing it through the current dumper.

=end private

=cut

sub _print_scalar { # XXX make public, document
    my $self = shift;
    $self->print($self->dumper->dump_scalar(shift));
}

=begin private

=item B<_print_scalar>

    $sh->_print_list(@answers);

That corresponds to the 'print' in the read-eval-print
loop (in list context). It outputs the evaluation result
after passing it through the current dumper.

=end private

=cut

sub _print_list { # XXX make public, document
    my $self = shift;
    $self->print($self->dumper->dump_list(@_));
}

sub _warn {
    shift;
    my $shell_name = _shell_name;
    warn "$shell_name: ", @_, "\n";
}

sub set_out {
    my $self = shift;
    my $type = shift;
    my $dumper_class = $dumper_for{$type};
    if (!defined $dumper_class) {
        $self->_warn("unknown dumper $type");
        return;
    }
    if ($dumper_class->is_available) {
        $self->dumper($dumper_class->new);
        $self->out_type($type);
    } else {
        $self->_warn("can't load dumper $dumper_class");
    }
}

sub _ctx {
    my $context = shift;

    if ($context =~ /^(s|scalar|\$)$/i) {
        return 'scalar';
    } elsif ($context =~ /^(l|list|@)$/i) {
        return 'list';
    } elsif ($context =~ /^(v|void|_)$/i) {
        return 'void';
    } else {
        return undef;
    }
}

sub set_ctx {
    my $self    = shift;
    my $context = _ctx $_[0];

    if ($context) {
        $self->context($context);
    } else {
        $self->_warn("unknown context $_[0]");
    }
}

sub set_package {
    my $self    = shift;
    my $package = shift;

    if ($package =~ /( [a-zA-Z_] \w*  :: )* [a-zA-Z_] \w* /x) {
        $self->package($package);

        no strict 'refs';
        *{ "${package}::quit" } = *{ "${package}::exit" } = sub { $self->{quitting} = 1 };

    } else {
        $self->_warn("bad package name $package");
    }
}

my %on_quit = (
    'exit'   => sub { exit 0 },
    'return' => sub {},
);

sub _quit_handler {
    my $handler = shift;

    if (exists $on_quit{$handler}) {
        return $on_quit{$handler};
    }
    elsif (ref $handler eq 'CODE') {
        return $handler;
    }
    return undef;
}

sub _set_on_quit {
    my $self    = shift;
    my $handler = _quit_handler($_[0]);

    if ($handler) {
        $self->on_quit($handler);
    }
    else {
        $self->_warn("bad on_quit handler $_[0]");
        $self->on_quit($on_quit{'exit'});
    }
}

# $err = _check_perl_version($version);
sub _check_perl_version {
    my $version = shift;
    my $ver = eval { version->parse($version) };
    if ($@) {
        (my $err = $@) =~ s/at \S+ line \d+.$//;
        return $err;
    }
    # Current perl
    my $v = $^V || version->parse($]);
    if ($ver > $v) {
        return "This is only $v";
    }
    return undef; # good
}

sub set_perl_version {
    my $self = shift;
    my $version = shift;

    if (!defined $version) {
        $self->perl_version($]);
    }
    elsif ($version eq q{''} || $version eq q{""}) {
        $self->perl_version('');
    }
    else {
        my $err = _check_perl_version($version);
        if ($err) {
            $self->_warn("bad perl_version ($version): $err");
        }
        else {
            $self->perl_version($version);
        }
    }
}

use constant HELP =>
    <<'HELP';
Shell commands:           (begin with ':')
  :e(x)it or :q(uit) - leave the shell
  :set out (D|DD|DDS|Y|P) - setup the output format
  :set ctx (scalar|list|void|s|l|v|$|@|_) - setup the eval context
  :set package  - set package in which shell eval statements
  :set perl_version  - set perl version to eval statements
  :reset - reset the environment
  :dump history  - (experimental) print the history to STDOUT or a file
  :h(elp) - get this help screen

HELP

sub help {
    print HELP;
}

# :reset is a nice idea - but I wanted more like CPAN reload
# I retreated the current implementation of :reset
#    because %main:: is used as the evaluation package
#    and %main:: = () is too severe by now

sub reset {
    my $self = shift;
    my $package = $self->package;
    return if $package eq 'main'; # XXX don't reset %main::
    no strict 'refs';
    %{"${package}::"} = ();
    #%main:: = (); # this segfaults at my machine
}

sub prompt_title {
    my $self = shift;
    my $shell_name = _shell_name;
    my $sigil = { scalar => '$', list => '@', void => '' }->{$self->{context}};
    return "$shell_name $sigil> ";
}

sub _readline {
    my $self = shift;
    return $self->term->readline($self->prompt_title);
}

sub _history_file { # XXX
    require Path::Class;
    require File::HomeDir;
    return Path::Class::file( File::HomeDir->my_home, '.pirl-history-xxx' );
}

sub _read_history { # XXX belongs to Shell::Perl::ReadLine
    my $term = shift;
    my $h    = _history_file;
    #warn "read history from $h\n"; # XXX
    if ( $term->Features->{readHistory} ) {
        $term->ReadHistory( "$h" );
    } elsif ( $term->Features->{setHistory} ) {
        if ( -e $h ) {
            my @h = $h->slurp( chomp => 1 );
            $term->SetHistory( @h );
        }
    } else {
        # warn "Your ReadLine doesn't support setHistory\n";
    }

}

sub _write_history { # XXX belongs to Shell::Perl::ReadLine
   my $term = shift;
   my $h    = _history_file;
   #warn "write history to $h\n"; # XXX
   if ( $term->Features->{writeHistory} ) {
       $term->WriteHistory( "$h" );
   } elsif ( $term->Features->{getHistory} ) {
       my @h = $term->GetHistory;
       $h->spew_lines(\@h);
   } else {
       # warn "Your ReadLine doesn't support getHistory\n";
   }
}

sub _new_term {
    my $self = shift;
    my $name = shift;
    my $term = Term::ReadLine->new( $name );
    $term->ornaments($self->ornaments) if $term->Features->{ornaments};
    _read_history( $term );
    return $term;
}

sub run {
    my $self = shift;
    my $shell_name = _shell_name;
    $self->term( my $term = $self->_new_term( $shell_name ) );
    my $prompt = "$shell_name > ";

    print "Welcome to the Perl shell. Type ':help' for more information\n\n";

    local $self->{quitting} = 0;

    REPL: while ( defined ($_ = $self->_readline) ) {

        # trim
        s/^\s+//g;
        s/\s+$//g;

        # Shell commands start with ':' followed by something else
        # which is not ':', so we can use things like '::my_subroutine()'.
        if (/^:[^:]/) {
            last REPL if /^:(exit|quit|q|x)/;
            $self->set_out($1) if /^:set out (\S+)/;
            $self->set_ctx($1) if /^:set ctx (\S+)/;
            $self->set_package($1) if /^:set package (\S+)/;
            $self->set_perl_version($1) if /^:set perl_version(?: (\S+))?/;
            $self->reset if /^:reset/;
            $self->help if /^:h(elp)?/;
            $self->dump_history($1) if /^:dump history(?:\s+(\S*))?/;
            # unknown shell command ?!
            next REPL;
        }

        my $context;
        $context = _ctx($1) if s/#(s|scalar|\$|l|list|\@|v|void|_)\z//;
        $context = $self->context unless $context;
        if ( $context eq 'scalar' ) {
            my $out = $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
            $self->_print_scalar($out);
        } elsif ( $context eq 'list' ) {
            my @out = $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
            $self->_print_list(@out);
        } elsif ( $context eq 'void' ) {
            $self->eval($_);
            if ($@) { warn "ERROR: $@"; next }
        } else {
            # XXX should not happen
        }
        last if $self->{quitting};

    }
    return $self->quit;

}

sub _package_stmt {
    my $package = shift->package;
    ("package $package");
}

sub _use_perl_stmt {
    my $perl_version = shift->perl_version;
    $perl_version ? ("use $perl_version") : ();
}

# $shell->eval($exp)
sub eval {
    my $self = shift;
    my $exp = shift;

    my $preamble = join ";\n", (
        $self->_package_stmt,
        $self->_use_perl_stmt,
        "no strict qw(vars subs)",
        "",    # for the trailing ;
    );

    # XXX gotta restore $_, etc.
    return eval <
       $preamble
#line 1
       $exp
CHUNK
    # XXX gotta save $_, etc.
}

sub quit {
    my $self = shift;
    _write_history( $self->term );
    $self->print( "Bye.\n" ); # XXX
    return $self->on_quit->();
}

sub run_with_args {
    my $self = shift;

    # XXX do something with @ARGV (Getopt)
    my %options = ( ornaments => 1 );
    if ( @ARGV ) {
        # only require Getopt::Long if there are actually command line arguments
        require Getopt::Long;
        Getopt::Long::GetOptions( \%options, 'ornaments!', 'version|v', 'library|I=s@' );
    }

    my $shell = Shell::Perl->new(%options);
    if ( $options{version} ) {
        $shell->_show_version;
    } else {
        $shell->run;
    }
}

sub _show_version {
    my $self = shift;
    printf "This is %s, version %s (%s, using Shell::Perl %s)\n",
           _shell_name,
           $main::VERSION,
           $0,
           $Shell::Perl::VERSION;
    exit 0;
}

sub dump_history {
    my $self = shift;
    my $file = shift;

    if ( !$self->term->Features->{getHistory} ) {
        print "Your Readline doesn't support getHistory\n";
        return;
    }

    if ( $file ) {
        open( my $fh, ">>", $file )
            or do { warn "Couldn't open '$file' for history dump\n"; return; };
        for ( $self->term->GetHistory ) {
            print $fh $_, "\n";
        }
        close $fh;

        print "Dumped history to '$file'\n\n";
    } else {
        print $_, "\n" for($self->{term}->GetHistory);
        print "\n";
    }
    return 1;
}

1;

# OUTPUT Data::Dump, Data::Dumper, YAML, others
# document: use a different package when eval'ing
# reset the environment
# implement shell commands (:quit, :set, :exit, etc.)
# how to implement array contexts?
#    IDEA:    command  ":set ctx scalar | list | void"
#             terminators "#s" "#l" "#v" "#$" #@ #_
# allow multiline entries. how?

##sub set {} # sets up the instance variables of the shell
##
##sub run {} # run the read-eval-print loop
##
##sub read {} # read a chunk
##
##sub readline {} # read a line
##
##sub eval {}
##
##sub print {}
##
##sub warn {}
##
##sub help { shift->print(HELP) }
##
##sub out { ? }

__END__