Shell::Perl - A read-eval-print loop in Perl

    use Shell::Perl;
    Shell::Perl->run_with_args;

    $ pirl
    Welcome to the Perl shell. Type ':help' for more information




    pirl @> 1+1
    2

    pirl @> use YAML qw(Load Dump);
    ()

    pirl @> $data = Load("--- { a: 1, b: [ 1, 2, 3] }\n");
    { a => 1, b => [1, 2, 3] }

    pirl @> $var = 'a 1 2 3'; $var =~ /(\w+) (\d+) (\d+)/
    ("a", 1, 2)

    pirl @> :q

    $ perl -Mlib=lib bin/pirl
    Welcome to the Perl shell. Type ':help' for more information

    pirl @> $a = 2;
    2

    pirl @> :set out Y # output in YAML

    pirl @> \%Shell::Perl::sandbox::
    ---
    BEGIN: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: BEGIN
    a: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: a
      SCALAR: 2

    pirl @> :reset

    pirl @> \%Shell::Perl::sandbox::
    ---
    BEGIN: !!perl/glob:
      PACKAGE: Shell::Perl::sandbox
      NAME: BEGIN

    http://code.google.com/p/iperl/

    How can I use Perl interactively?
    http://perldoc.perl.org/perlfaq3.html#How-can-I-use-Perl-interactively%3f

    Is there a Perl shell?
    http://perldoc.perl.org/perlfaq3.html#How-can-I-use-Perl-interactively%3f

    http://www.focusresearch.com/gregor/document/psh-1.1.html#other_perl_shells

package Shell::Perl;

use 5.006;
use strict;
use warnings;

# /Id: Perl.pm 1131 2007-01-27 17:43:35Z me / # don't erase that for now
# $Id: /iperl/lib/Shell/Perl.pm 2317 2008-03-09T16:22:00.577930Z a.r.ferreira@gmail.com  $

our $VERSION = '0.0022';

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

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
                           @_ });
    $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
    }

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

}

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

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

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 shift;

    if ($context) {
        $self->context($context);
    } else {
        $self->_warn("unknown context $context");
    }
}

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" } = sub { $self->quit };
    } else {
        $self->_warn("bad package name $package");
    }
}

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 <name> - set package in which shell eval statements
  :reset - reset the environment
  :dump history <file> - (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' )->stringify;
}

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 ) {
            require File::Slurp;
            my @h = File::Slurp::read_file( $h );
            chomp @h;
            $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} ) {
       require File::Slurp;
       my @h = map { "$_\n" } $term->GetHistory;
       File::Slurp::write_file( $h, @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 );
    _read_history( $term );
    return $term;
}

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

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

    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->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
        }

    }
    $self->quit;

}

# $shell->eval($exp)
sub eval {
    my $self = shift;
    my $exp = shift;
    my $package = $self->package;
    # XXX gotta restore $_, etc.

    return eval <<CHUNK;
       package $package; # XXX
       no strict qw(vars subs);
#line 1
       $exp
CHUNK
    # XXX gotta save $_, etc.
}

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

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' );
    }

    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 { ? }

# svn:keywords Id
# svn:eol-style LF

__END__

# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: