package POE::Wheel::ReadLine::Gnu;
use Carp   qw( croak carp );
use Symbol qw( gensym );
use POE    qw( Wheel );

use Term::ReadLine;
our @ISA = qw(Term::ReadLine);

# Private STDIN and STDOUT.
my $stdin  = gensym();
open($stdin, "<&STDIN") or die "Can't open private STDIN: $!";

my $stdout = gensym;
open($stdout, ">&STDOUT") or die "Can't open private STDOUT: $!";

# Offsets into $self->{POE}.
# OBJECT ($self) is 0
sub SELF_INPUT          () { 1 }
sub SELF_EVENT_INPUT    () { 2 }
sub SELF_READING_LINE   () { 3 }
sub SELF_STATE_READ     () { 4 }
sub SELF_STATE_IDLE     () { 5 }
sub SELF_UNIQUE_ID      () { 6 }
sub SELF_APP            () { 7 }

#---------------------------------------------------------------------
+---------

sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %params = @_;
    croak "$class requires a working Kernel" unless defined $poe_kerne
+l;

    my $input_event = delete $params{InputEvent};
    croak "$class requires an InputEvent parameter" unless defined $in
+put_event;

    my $put_mode = delete $params{PutMode};
    $put_mode = 'idle' unless defined $put_mode;
    croak "$class PutMode must be either 'immediate', 'idle', or 'afte
+r'"
        unless $put_mode =~ /^(immediate|idle|after)$/;

    my $idle_time = delete $params{IdleTime};
    $idle_time = 2 unless defined $idle_time;

    my $app = delete $params{appname};
    $app ||= 'poe-readline';

    if (scalar keys %params) {
        carp(
            "unknown parameters in $class constructor call: ",
            join(', ', keys %params)
        );
    }
    my $self = $proto->SUPER::new(__PACKAGE__, $stdin, $stdout);

    $self->{POE} = [
        undef,                                  # OBJECT
        undef,                                  # SELF_INPUT
        $input_event,                           # SELF_EVENT_INPUT
        0,                                      # SELF_READING_LINE
        undef,                                  # SELF_STATE_READ
        undef,                                  # SELF_STATE_IDLE
        &POE::Wheel::allocate_wheel_id(),       # SELF_UNIQUE_ID
        $app,                                   # SELF_APP

    ];
    bless $self, $class; 
    # set unbuffered IO
    select((select($stdout), $| = 1)[0]);
    # Set up the event handlers.  Idle goes first.
    $self->{POE}->[SELF_STATE_IDLE] = (
        ref($self) . "(" . $self->{POE}->[SELF_UNIQUE_ID] . ") -> inpu
+t timeout"
    );
    $poe_kernel->state($self->{POE}->[SELF_STATE_IDLE], $self, '_idle_
+state');
    $self->{POE}->[SELF_STATE_READ] = (
        ref($self) . "(" . $self->{POE}->[SELF_UNIQUE_ID] . ") -> sele
+ct read"
    );
    $poe_kernel->state($self->{POE}->[SELF_STATE_READ], $self, '_read_
+state');
    rl_callback_handler_install($self,$prompt,sub { $self->got_line(@_
+) } );

    return $self;
}

sub get {
    my ($self,$prompt,$preput) = @_;
    return if $self->{POE}->[SELF_READING_LINE];
    $self->{POE}->[SELF_READING_LINE] = 1;
    my $Attribs = $self->Attribs;
    # ornament support (now prompt only)
    $prompt = ${$Attribs{term_set}}[0] . $prompt . ${$Attribs{term_set
+}}[1];
    $Attribs{completion_entry_function} = $Attribs{_trp_completion_fun
+ction}
        if (!defined $Attribs{completion_entry_function}
            && defined $Attribs{completion_function});
    $self->rl_set_prompt($prompt);
    $self->rl_insert_text($preput) if defined $preput;
    $self->rl_redisplay();
    $poe_kernel->select_read($stdin, $self->{POE}->[SELF_STATE_READ]);
}

sub put {
    my $self = shift;
    print $stdout map { $_ =~ /\r?\n/? $_ : $_ . "\r\n" } @_;
    return;
};

sub got_line {
    my $self = $_[OBJECT];
    $self->{POE}->[SELF_READING_LINE] = 0;
    $poe_kernel->select_read($stdin);
    $self->rl_set_prompt('');
    $poe_kernel->yield(
        $self->{POE}->[SELF_EVENT_INPUT],
        $_[SELF_INPUT] || undef,
        $_[SELF_INPUT] ?  undef : 'eot',
        $self->{POE}->[SELF_UNIQUE_ID]
    );
}

sub _idle_state { }

sub _read_state { $_[OBJECT]->rl_callback_read_char }

sub DESTROY {
    my $self = shift;
    
    # Stop selecting on the handle.
    $poe_kernel->select($stdin);
    
    # Detach our tentacles from the parent session.
    if ($self->{POE}->[SELF_STATE_READ]) {
        $poe_kernel->state($self->{POE}->[SELF_STATE_READ]);
        $self->{POE}->[SELF_STATE_READ] = undef;
    }   
    if ($self->{POE}->[SELF_STATE_IDLE]) {
        $poe_kernel->alarm($self->{POE}->[SELF_STATE_IDLE]);
        $poe_kernel->state($self->{POE}->[SELF_STATE_IDLE]);
        $self->{POE}->[SELF_STATE_IDLE] = undef;
    }   
    
    # restore terminal state
    $self->rl_deprep_terminal();
    
    POE::Wheel::free_wheel_id($self->{POE}->[SELF_UNIQUE_ID]);
}
1;
[download]

#! /usr/bin/perl
#
#       $Id: perlsh,v 1.24 2001-10-27 22:59:15-05 hayashi Exp $
#
#       Copyright (c) 2000 Hiroo Hayashi. All Rights Reserved.
#       Copyright (c) 2008 shmem for the POE part, right or reserved?
#
#       This program is free software; you can redistribute it and/or
#       modify it under the same terms as Perl itself.

=head1 NAME

perlsh - one-line perl evaluator with line editing function and
         variable name completion function

=head1 SYNOPSIS

  perlsh

=head1 DESCRIPTION

This program reads input a line, shells the command out to the system
shell, or if the line begins with a semicolon (;) evaluates it by the
perl interpreter, and prints the result.

If the result is a list value then each value of the list is printed
line by line.  This program can be used as a very strong calculator
which has whole perl functions.

This is a sample program Term::ReadLine::Gnu module.  When you input a
line, the line editing function of GNU Readline Library is available.
Perl symbol name completion function is also available.

This version uses POE together with Term::ReadLine::Gnu. Implementatio
+n
of job control is under way. 

See the subroutine 'process_line' for more on syntax quirks.

=head2 TODO:

=over4

=item documentation (pod update)

=item job control

=item decent parser for shell commands

=item ...

=back

=cut

package PerlSh;

use strict;
# use Term::ReadLine;
use Cwd;
use POE qw(Wheel::ReadLine::Gnu Wheel::Run Filter::Line);
# 
#use Devel::Leak::Object qw(GLOBAL_bless);

use vars qw($PS1 $PS2 $HISTFILE $HISTSIZE $INPUTRC $STRICT
            $HOSTNAME $LOGNAME $CWP);

$PS1        ='package \w; # [\!] ~ > ';
$PS2        = '> ';
$HISTFILE   = ".perlsh_history" if -f ".perlsh_history";
$HISTFILE ||= ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlsh_history"
+;
$HISTSIZE   = undef; #256;
$INPUTRC    = ($ENV{HOME} || ((getpwuid($<))[7])) . "/.perlshrc";
$STRICT     = 0;

$HOSTNAME   = $ENV{HOSTNAME};
$LOGNAME    = $ENV{LOGNAME};
$CWP        = 'main';                   # current working package

package main;
if (-f $PerlSh::INPUTRC) {
    do $PerlSh::INPUTRC;
}

package PerlSh;

use vars qw($term $attribs);    # to access as `$PerlSh::term' from pr
+ompt

POE::Session->create (
    inline_states       => {
        _start    => \&readline_start,
        got_input => \&reader,
        _stop     => \&readline_stop,
    }
);

$poe_kernel->run();

######################################################################
+##

sub readline_stop { delete $_[HEAP]->{readline_wheel} }

sub sigint {
    my $term = shift;
    $term->modifying;
    $term->delete_text;
    $attribs->{point} = $attribs->{end} = 0;
    $term->redisplay;
}

sub readline_start {
    my ($heap) = $_[HEAP];
    $term = $heap->{readline_wheel} = POE::Wheel::ReadLine::Gnu->new(
        InputEvent => 'got_input'
    );
    $attribs = $term->Attribs;

    $term->bind_key(ord "^", 'history-expand-line', 'emacs-meta');
    $term->bind_key(ord "\cv", 'display-readline-version', 'emacs-ctlx
+');
    $term->bind_key(ord "\cc", 'abort'); # not works yet FIXME!!!

    $term->ornaments(0);

    if (defined &main::afterinit) {
        package main;
        &afterinit;
        package PerlSh;
    }

    # disable implicit add_history() call
    $term->MinLine(undef);

    $term->stifle_history($HISTSIZE);
    if (-f $HISTFILE) {
        $term->ReadHistory($HISTFILE)
            or warn "perlsh: cannot read history file: $!\n";
    }
    $attribs->{attempted_completion_function} = \&attempt_perl_complet
+ion;
    $attribs->{special_prefixes} = '$@%&';
    $attribs->{completion_display_matches_hook}
        = \&perl_symbol_display_match_list;
    
    $poe_kernel->yield('got_input');
}

sub process_line {
    my ($heap) = $_[HEAP];
    my $command = $heap->{command};
    my ($strict, @result);
    $strict = $STRICT ? '' : 'no strict;';
    if ( defined($command) ) {
        if ($command =~ s/^(=|\+|;)\s*//) {
            my $fh; 
            my $ext;
            if ($command =~ s/#\s*(\|.*)//) {
                $ext = 1;
                open(O,"$1");
                $fh = select O;
            } 
            @result = eval ("$strict package $CWP; $command");
            use strict;
            if ($@) { print "Error: $@\n"; return; }
            printer (@result);
            if($ext) {
                $ext = 0;
                close (O);
                select $fh if $fh;
            }
            undef @result;
            #$CWP = $1 if ($command =~ /^\s*package\s+([\w:]+)/);
            my $dnammoc = reverse $command;
            $CWP = reverse $1 if ($dnammoc =~ /([\w:]+)\s+egakcap\b/);
        } elsif ($command =~ s/^\s*cd\b\s*//) {
            if($command) {
                if (-d $command) {
                    chdir $command;
                } else {
                    warn "'$command': Not a directory\n";
                } 
            } else {
                chdir $ENV{HOME};
            } 
        } elsif ($command =~ s/^:$//) {
            system $ENV{EDITOR} || 'vi',"/tmp/perlshell.$$";
            {
                local $/;
                open my $fh, '<', "/tmp/perlshell.$$";
                chop($PerlSh::PREPUT = <$fh>);
            }
        } elsif ($command =~ /^s$/) {
            eval {
                require Devel::Leak::Object;
                Devel::Leak::Object->import qw(GLOBAL_bless)
            };
            if($@) {
                warn $@;
            } else {
                Devel::Leak::Object::status();
            }
        } elsif ($command =~ /^(exit|q)$/) {
            delete $heap->{readline_wheel};
            $term->DESTROY;
            quit();
        } else {
            # experimental - beginning of Job Control
            # implementation
            #
            # XXX Too simplistic command line parsing
            $command =~ s/(\w+)/$PerlSh::ALIAS{$1} || $1/e;
            if ($command =~ s/\&\s*$//) {
                my ($prog, @args) = split /\s+/, $command;
                for(@args){s/^'|'$//g}
                my $session = POE::Session->create (
                    inline_states       => {
                        _start => sub {
                            my $job =  POE::Wheel::Run->new (
                                Program => [$prog, (@args) x ! ! @args
+],
                                #StdioFilter  => POE::Filter::Line->ne
+w(),
                                #StderrFilter => POE::Filter::Line->ne
+w(),
                                StdinEvent   => "got_job_stdin",
                                StdoutEvent  => "got_job_stdout",
                                StderrEvent  => "got_job_stderr",
                                CloseEvent   => "got_job_close",
                            );
                            $heap->{job} = $job;
                            push @PerlSh::Jobs, $job->PID;
                            print '[',$job->PID,"] $command\n";
                        },
                        got_job_stdout => sub { print "out $_[ARG0]\n"
+ },
                        got_job_stderr => sub { print "ERR: $_[ARG0]\n
+" },
                        got_job_stdin  => sub { print "in: $_[ARG0]\n"
+ },
                        got_job_close  => sub {
                            my ( $kernel, $heap ) = @_[ KERNEL, HEAP ]
+;
                            my $job = delete $heap->{job};
                            if ($job) {
                                print  "Job " . $job->PID . " stopped.
+\n";
                            } else {
                                print  "Job stopped.\n";
                            }
                            wait; # reap child
                        },
                    }
                );
            } else {
                # default: shell out command
                system $command;
            }
        } 
    }
}

sub sigint {
    $term->modifying;
    $term->delete_text;
    $attribs->{point} = $attribs->{end} = 0;
    $term->redisplay;
}

sub quit {
    $term->WriteHistory($HISTFILE)
        or warn "perlsh: cannot write history file: $!\n";
    exit (0);
}

sub reader {
    my ( $heap, $kernel, $line, $exception ) = @_[ HEAP, KERNEL, ARG0,
+ ARG1 ];
    my $command = $heap->{command};
    my $term    = $heap->{readline_wheel};

    if ( defined ($line)  && $line !~ /^\r?$/) {
        #warn "\nline:$line\n";
        if ($line =~ /\\$/) {
            chop $line;
            $heap->{command} = $command ? $command . " $line" : $line;
        } else {
            $heap->{command} = $command ? $command . " $line" : $line;
            unless($command =~ /^(q|\+h|exit)/) {
                $term->addhistory($heap->{command})
                    if (length($heap->{command}) > 0);
            }
            &process_line;
            $heap->{command} = '';
        }
    }
    #warn "\$heap->{readline_wheel} = $heap->{readline_wheel}\n";
    $term->get($command ? $PS2 : prompt($PS1),$PerlSh::PREPUT)
        if $heap->{readline_wheel};
    $PerlSh::PREPUT = '';
    #return(("Foo!") x 32);
}

sub printer {
    my (@res) = @_;
    my ($i);
    foreach $i (@res) { print "result: $i\n"; }
}

sub prompt {
    local($_) = @_;
    # if reference to a subroutine return the return value of it
    return &$_ if (ref($_) eq 'CODE');

    # \h: hostname, \u: username, \w: package name, \!: history number
    s/\\h/$HOSTNAME/g;
    s/\\u/$LOGNAME/g;
    s/\\w/$CWP/g;
    s/\\!/$attribs->{history_base} + $attribs->{history_length}/eg;
    my $dir = getcwd;
    s/~/$dir/;
    $_;
}


#
#       custom completion for Perl
#

sub perl_symbol_display_match_list ($$$) {
    my($matches, $num_matches, $max_length) = @_;
    map { $_ =~ s/^((\$#|[\@\$%&])?).*::(.+)/$3/; }(@{$matches});
    $term->display_match_list($matches);
    $term->forced_update_display;
}

sub attempt_perl_completion ($$$$) {
    my ($text, $line, $start, $end) = @_;
    no strict qw(refs);
    if (substr($line, 0, $end) =~ m/\!(\d+)?$/) {
        $attribs->{completion_append_character} = '';
        return $term->history_get($1) if length($1);
        my $c = 0;
        $term->display_match_list(
            [undef,map { ++$c.(" "x (6-length($c))).$_ } $term->GetHis
+tory]
        );
        $term->forced_update_display;
        return undef;
    } elsif (substr($line, 0, $start) =~ m/\$([\w:]+)\s*(->)?\s*{\s*['
+"]?$/) {
        # $foo{key, $foo->{key
        $attribs->{completion_append_character} = '}';
        return $term->completion_matches($text,
                                         \&perl_hash_key_completion_fu
+nction);
    } elsif (substr($line, 0, $start) =~ m/\$([\w:]+)\s*->\s*['"]?$/) 
+{
        # $foo->method
        $attribs->{completion_append_character} = ' ';
        return $term->completion_matches($text,
                                         \&perl_method_completion_func
+tion);
    } else { # Perl symbol completion
        $attribs->{completion_append_character} = '';
        return  $term->completion_matches($text,
                                          \&perl_symbol_completion_fun
+ction);
    }
}

# static global variables for completion functions
use vars qw($i @matches);

sub perl_history_completion_function ($$) {
    my($text, $state) = @_;
print "\ntext='$text',state='$state'\n";

} 
sub perl_hash_key_completion_function ($$) {
    my($text, $state) = @_;
    
    if ($state) {
        $i++;
    } else {
        # the first call
        $i = 0;                 # clear index
        my ($var,$arrow) = (substr($attribs->{line_buffer},
                                   0, $attribs->{point} - length($text
+))
                            =~ m/\$([\w:]+)\s*(->)?\s*{\s*['"]?$/); # 
+});
        no strict qw(refs);
        $var = "${CWP}::$var" unless ($var =~ m/::/);
        if ($arrow) {
            my $hashref = eval "\$$var";
            @matches = keys %$hashref;
        } else {
            @matches = keys %$var;
        }

    }
    for (; $i <= $#matches; $i++) {
        return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
    }
    return undef;
}

sub _search_ISA ($) {
    my ($mypkg) = @_;
    no strict 'refs';
    my $isa = "${mypkg}::ISA";
    return $mypkg, map _search_ISA($_), @$isa;
}

sub perl_method_completion_function ($$) {
    my($text, $state) = @_;
    
    if ($state) {
        $i++;
    } else {
        # the first call
        my ($var, $pkg, $sym, $pk);
        $i = 0;                 # clear index
        $var = (substr($attribs->{line_buffer},
                       0, $attribs->{point} - length($text))
                =~ m/\$([\w:]+)\s*->\s*$/)[0];
        $pkg = ref eval (($var =~ m/::/) ? "\$$var" : "\$${CWP}::$var"
+);
        no strict qw(refs);
        @matches = map { $pk = $_ . '::';
                         grep (/^\w+$/
                               && ($sym = "${pk}$_", defined *$sym{COD
+E}),
                               keys %$pk);
                     } _search_ISA($pkg);
    }
    for (; $i <= $#matches; $i++) {
        return $matches[$i] if ($matches[$i] =~ /^\Q$text/);
    }
    return undef;
}

#
#       Perl symbol name completion
#
{
    my ($prefix, %type, @keyword);

    sub perl_symbol_completion_function ($$) {
        my($text, $state) = @_;

        if ($state) {
            $i++;
        } else {
            # the first call
            my ($pre, $pkg, $sym);
            $i = 0;             # clear index

            no strict qw(refs);
            ($prefix, $pre, $pkg) = ($text =~ m/^((\$#|[\@\$%&])?(.*::
+)?)/);
            @matches = grep /::$/, $pkg ? keys %$pkg : keys %::;
            $pkg = ($CWP eq 'main' ? '::' : $CWP . '::') unless $pkg;

            if ($pre) {         # $foo, @foo, $#foo, %foo, &foo
                @matches = (@matches,
                            grep (/^\w+$/
                                  && ($sym = $pkg . $_,
                                      defined *$sym{$type{$pre}}),
                                  keys %$pkg));
            } else {            # foo
                @matches = (@matches,
                            !$prefix && @keyword,
                            grep (/^\w+$/
                                  && ($sym = $pkg . $_,
                                      defined *$sym{CODE}
                                      || defined *$sym{FILEHANDLE}
                                     ),
                                  keys %$pkg));
            }
        }
        my $entry;
        for (; $i <= $#matches; $i++) {
            $entry = $prefix . $matches[$i];
            return $entry if ($entry =~ /^\Q$text/);
        }
        return undef;
    }

    BEGIN {
        %type = ('$' => 'SCALAR', '*' => 'SCALAR',
                 '@' => 'ARRAY', '$#' => 'ARRAY',
                 '%' => 'HASH',
                 '&' => 'CODE'); # '

        # from perl5.004_02 perlfunc
        @keyword = qw(
                    chomp chop chr crypt hex index lc lcfirst
                    length oct ord pack q qq
                    reverse rindex sprintf substr tr uc ucfirst
                    y
                    
                    m pos quotemeta s split study qr

                    abs atan2 cos exp hex int log oct rand sin
                    sqrt srand

                    pop push shift splice unshift

                    grep join map qw reverse sort unpack
                    
                    delete each exists keys values
                    
                    binmode close closedir dbmclose dbmopen die
                    eof fileno flock format getc print printf
                    read readdir rewinddir seek seekdir select
                    syscall sysread sysseek syswrite tell telldir
                    truncate warn write
                    
                    pack read syscall sysread syswrite unpack vec
                    
                    chdir chmod chown chroot fcntl glob ioctl
                    link lstat mkdir open opendir readlink rename
                    rmdir stat symlink umask unlink utime
                    
                    caller continue die do dump eval exit goto
                    last next redo return sub wantarray
                    
                    caller import local my package use
                    
                    defined dump eval formline local my reset
                    scalar undef wantarray
                    
                    alarm exec fork getpgrp getppid getpriority
                    kill pipe qx setpgrp setpriority sleep
                    system times wait waitpid
                    
                    do import no package require use
                    
                    bless dbmclose dbmopen package ref tie tied
                    untie use
                    
                    accept bind connect getpeername getsockname
                    getsockopt listen recv send setsockopt shutdown
                    socket socketpair
                    
                    msgctl msgget msgrcv msgsnd semctl semget
                    semop shmctl shmget shmread shmwrite
                    
                    endgrent endhostent endnetent endpwent getgrent
                    getgrgid getgrnam getlogin getpwent getpwnam
                    getpwuid setgrent setpwent
                    
                    endprotoent endservent gethostbyaddr
                    gethostbyname gethostent getnetbyaddr
                    getnetbyname getnetent getprotobyname
                    getprotobynumber getprotoent getservbyname
                    getservbyport getservent sethostent setnetent
                    setprotoent setservent
                    
                    gmtime localtime time times
                    
                    abs bless chomp chr exists formline glob
                    import lc lcfirst map my no prototype qx qw
                    readline readpipe ref sub sysopen tie tied
                    uc ucfirst untie use
                    
                    dbmclose dbmopen
                   );
    }
}

__END__


=pod

Before invoking, this program reads F<~/.perlshrc> and evaluates the
content of the file.

When this program is terminated, the content of the history buffer is
saved in a file F<~/.perlsh_history>, and it is read at next
invoking.

=head1 VARIABLES

You can customize the behavior of C<perlsh> by setting following
variables in F<~/.perlshrc>;

=over 4

=item C<$PerlSh::PS1>

The primary prompt string.  The following backslash-escaped special
characters can be used.

        \h: host name
        \u: user name
        \w: package name
        \!: history number

The default value is `C<\w[\!]$ >'.

=item C<$PerlSh::PS2>

The secondary prompt string.  The default value is `C<E<gt> >'.

=item C<$PerlSh::HISTFILE>

The name of the file to which the command history is saved.  The
default value is C<~/.perlsh_history>.

=item C<$PerlSh::HISTSIZE>

If not C<undef>, this is the maximum number of commands to remember in
the history.  The default value is 256.

=item C<$PerlSh::STRICT>

If true, restrict unsafe constructs.  See C<use strict> in perl man
page.  The default value is 0;

=over

=head1 FILES

=over 4

=item F<~/.perlshrc>

This file is eval-ed at initialization.  If a subroutine C<afterinit>
is defined in this file, it will be eval-ed after initialization.
Here is a sample.

        # -*- mode: perl -*-
        # decimal to hexa
        sub h { map { sprintf("0x%x", $_ ) } @_;}

        sub tk {
            $t->tkRunning(1);
            use Tk;
            $mw = MainWindow->new();
        }

        # for debugging Term::ReadLine::Gnu
        sub afterinit {
            *t = \$PerlSh::term;
            *a = \$PerlSh::attribs;
        }

=item F<~/.perlsh_history>

=item F<~/.inputrc>

A initialization file for the GNU Readline Library.  Refer its manual
for details.

=back

=head1 SEE ALSO

Term::ReadLine::Gnu

GNU Readline Library Manual

=head1 AUTHOR

Hiroo Hayashi <hiroo.hayashi@computer.org>

=cut
[download]