#! /usr/local/bin/perl
#
#	$Id: perlsh,v 1.12 1998-09-28 00:40:52+09 hayashi Exp $	
#
#	Copyright (c) 1996,1997 Hiroo Hayashi. All Rights 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, and evaluates it by 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.
The variable name completion function is also available.

=cut

package PerlSh;

use strict;
use Term::ReadLine;

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

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

$HOSTNAME = $ENV{HOSTNAME};
$LOGNAME = $ENV{LOGNAME};

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

package PerlSh;

my $term = new Term::ReadLine 'PerlSh';
my $attribs = $term->Attribs;

&toplevel;			# never returns

sub toplevel {
    # 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->{completion_entry_function} = \&perl_symbol_completion_function;

    $attribs->{special_prefixes} = '$@';

    $SIG{'INT'} = \&quit;

    my ($strict, $command, @result);
    $strict = $STRICT ? '' : 'no strict;';
    while (defined($command = &reader)) {
	@result = eval ("$strict package main; $command");
	use strict;
	if ($@) { print "Error: $@\n"; next; }
	printer (@result);
    }
    &quit;
}

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

sub reader {
    my ($line, $command);
    $command = '';
    while (1) {
	$line = $term->readline($command ? $PS2 : prompt($PS1));
	return undef unless (defined $line);
	
	if ($line =~ /\\$/) {
	    chop $line;
	    $command = $command ? $command . " $line" : $line;
	} else {
	    $command = $command ? $command . " $line" : $line;
	    $term->addhistory($command);
	    return $command;
	}
    }
}

sub printer {
    my (@res) = @_;
    my ($i);
    foreach $i (@res) { print "$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, \!: history number
    s/\\h/$HOSTNAME/g;
    s/\\u/$LOGNAME/g;
    s/\\!/$attribs->{history_base} + $attribs->{history_length}/eg;
    $_;
}
#
#	variable name completion
#
{
    my $i;
    use vars qw(@symbol_list);

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

	if ($state) {
	    $i++;
	} else {
	    # the first call
	    $i = 0;		# clear index
	    if ($text =~ /^(\@|\$\#)/) {
		@symbol_list = symbol_array($1);
	    } elsif ($text =~ /^(\%)/) {
		@symbol_list = symbol_hash($1);
	    } elsif ($text =~ /^(\$)/) {
		@symbol_list = (symbol_scalar($1),
				symbol_array($1, '['),
				symbol_hash($1, '{'));
	    } else {
		@symbol_list = ();
	    }
	}

	my $entry;
	$text = quotemeta($text); # $foo -> \$foo
	for (; $i <= $#symbol_list; $i++) {
	    $entry = $symbol_list[$i];
	    return $entry if ($entry =~ /^$text/);
	}
	return undef;
    }
}

# return scalar variable name list
sub symbol_scalar ($) {
    my ($pre) = @_;
    my ($key, $val, @list);
    no strict 'vars';
    local(*stab) = eval("*main::");
    while (($key,$val) = each(%stab)) {
	next if $key =~ /^_</;
	local(*entry) = $val;
	# How can I distinguish a variable which is not defined
	#	from one which has undefined value?
	push (@list, $pre . $key)
	    if (defined $entry or ! defined @entry && ! defined %entry);
    }
    return @list;
}

# return array variable name list
sub symbol_array ($;$) {
    my ($pre, $pos) = @_;
    my ($key, $val, @list);
    no strict 'vars';
    local(*stab) = eval("*main::");
    while (($key,$val) = each(%stab)) {
	local(*entry) = $val;
	push (@list, $pre . $key . $pos)
	    if (defined @entry or ! defined %entry && ! defined $entry);
    }
    return @list;
}

# return hash variable name list
sub symbol_hash ($;$) {
    my ($pre, $pos) = @_;
    my ($key, $val, @list);
    local(*stab) = eval("*main::");
    no strict 'vars';
    while (($key,$val) = each(%stab)) {
	local(*entry) = $val;
	push (@list, $pre . $key . $pos)
	    if (defined %entry or ! defined $entry && ! defined @entry);
    }
    return @list;
}

__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 default value is "$ ".

=item C<$PerlSh::PS2>

The secondary prompt string.  The default value is "> ".

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

=item F<~/.perlsh_history>

=item F<~/.inputrc>

=back

=head1 SEE ALSO

Term::ReadLine::Gnu

GNU Readline Library Texinfo Manual

=head1 AUTHOR

Hiroo Hayashi <hiroo.hayashi@computer.org>

=head1 BUGS

Completion does not work for variable name whose value is 'undef'.

Completion does not work for variable name with package name (`foo::bar').

=cut
