pmacs3/tools/iperl

#!/usr/bin/perl
#
# by Erik Osheim
#
# licensed under the GNU GPL version 2

# try not to pollute the namespace
use Data::Dumper qw(Dumper);
use File::Basename qw();
use Getopt::Long qw();
use Perl6::Slurp qw(slurp);
use Scalar::Util qw();
use Term::ReadLine qw();

# globals
Getopt::Long::Configure('bundling');
$| = 1;
$Data::Dumper::Terse  = 1;
$Data::Dumper::Indent = 1;
my $PIPE;

# usage function
sub usage {
    my($status) = @_;
    my $prog = File::Basename::basename($0);
    print <<EOT;
usage: $prog [options]
    -h,--help            show this message
    -e,--eval STR        eval STR before interaction
    -p,--pipe            run in pipe mode (as a subprocess)
    -r,--run PATH        run PATH before interaction

perl needs a good interpreter.
EOT
    exit($status);
}

# handy function for inspecting the symbol table
my $pkgregex  = qr/^(?:[a-zA-Z_][a-zA-Z0-9_]*::)+$/;
my $nameregex = qr/^[a-zA-Z_][a-zA-Z0-9_]*$/;
sub sigilfind {
    my ($pkg, $sigil, $base, $proc) = @_;
    $base = "" unless $base;
    $proc = {$pkg => 1} unless $proc;
    $pkg  = $base if $base;
    my @results;
    foreach my $item (eval("keys(\%${pkg})")) {
        my $item2 = $base . $item;
        next if $proc->{$item2};
        if($item =~ m/$nameregex/) {
            push(@results, $item2) if eval("defined(${sigil}::${base}${item})");
        } elsif($item =~ m/$pkgregex/) {
            $proc->{$item2} = 1;
            push(@results, sigilfind($item2, $sigil, $item2, $proc));
        }
    }
    return @results;
}

# handy function for printing nice representations of data
sub repr {
    my ($item) = @_;
    if(!defined($item)) {
        return 'undef';
    } elsif(Scalar::Util::blessed($item)) {
        return "$item";
    } elsif(ref($item) eq 'CODE') {
        return "$item";
    } else {
        my $s = Dumper($item);
        $s =~ s/\n+$//;
        return $s;
    }
}

# use sigilfind to get completions for particular word(s)
sub complete {
    my ($word, $line, $x) = @_;
    $word =~ m/^([&\$%@\*]?)(.*)$/;
    my $sigil = $1 ? $1 : '&';
    my $name = $2;
    my @candidates = grep {
        $_ =~ m/^$name/
    } sigilfind('main::', $sigil);
    return map { "${1}$_" } sort(@candidates);
}

# display completions to the user
sub draw_completions {
    my (@items) = @_;
    my($prefix, $delim) = $pipe ? ("COMPLETIONS", "|") : ("", "\n");
    print $prefix . join($delim, @items) . "\n";
}

# some help text
my $HELP = <<EOT;
Greetings!

I'm program is designed to help you write Perl. Like the "perl" command,
I can parse and execute Perl code. Unlike it, I can execute perl code
interactively, allowing you to call functions, save their results, inspect
the results, and repeat. I also support tab-completion!

I contain a lot of tricky functionality.

One side-note: I can't be run under the "strict" pragma; thus, you don't
need to use my() or our() to declare variables. The reaon for this has to
do with the way I evaluate blocks. Sorry.
EOT

# the big one!
sub main {
    # process the arguments provided; save original @ARGV for use later
    my @preload;
    my @oldargv = @ARGV;
    Getopt::Long::GetOptions(
        'help|h'    => sub { usage(0); },
        'eval|e=s'  => sub { push(@preload, ['eval', $_[1]]); },
        'pipe|p'    => sub { $pipe = 'line' },
        'run|r=s'   => sub { push(@preload, ['run', $_[1]]); },
        'use|u=s'   => sub { push(@preload, ['use', $_[1]]); },
    ) || usage(1);

    # let's display a nice banner to the user
    my ($prompt, $input, $term) = (">>>", "", undef);
    unless($pipe) {
        print "Welcome to Erik's Perl Interpreter\n";
        print "(Type \":help\", \":exit\", or something else)\n";
    }

    # for every file or perl string we were given, eval them in order; we should
    # die if any of them fail to load.
    foreach my $pair (@preload) {
        if($pair->[0] eq 'eval') {
            eval $pair->[1];
            die "failed to eval '$pair->[1]': $@" if $@;
        } elsif($pair->[0] eq 'run') {
            die "no path named $pair->[1] found" unless -e $pair->[1];
            my $data = slurp($pair->[1]);
            eval $data;
            die "failed to run $pair->[1]: $@" if $@;
        } elsif($pair->[0] eq 'use') {
            eval "use $pair->[1]";
            die "failed to use $pair->[1]: $@" if $@;
        }
    }

    # set up readline if necessary
    unless($pipe) {
        $term = Term::ReadLine->new('IPERL');
        my $attribs = $term->Attribs();
        $attribs->{special_prefixes} = '$@%*&';
        $attribs->{completion_function} = sub { return complete(@_) };
    }

    # the mighty read-exec-print loop!
    while(1) {
        # display the prompt and read some input
        my $line;
        if($pipe) {
            print "PROMPT:$prompt\n";
            $line = <STDIN>;
        } else {
            $line = $term->readline("$prompt ");
        }
        last unless defined($line);
        chomp($line);

        # if we're in pipe-mode then we expect input in a special form
        if($pipe) {
            if($line =~ m/ENTER:(.*)$/) {
                $line = $1;
            } elsif($line =~ m/COMPLETE:(.*)$/) {
                draw_completions(complete($1));
                next;
            } else {
                print "malformed pipe input line\n";
                next;
            }
        }

        # process the line of input
        if($line eq '') {
        } elsif($line eq ':exit' || $line eq ':quit') {
            last;
        } elsif($line eq ':help') {
            ($input, $prompt) = ("", ">>>");
            print $HELP;
        } elsif($line eq ':reload') {
            ($input, $prompt) = ("", ">>>");
            print "reloading...\n";
            exec($0, @oldargv);
        } elsif($line eq ':sh') {
            ($input, $prompt) = ("", ">>>");
            system("bash") unless $pipe;
        } elsif($line =~ m/^:sh (.+)$/) {
            ($input, $prompt) = ("", ">>>");
            system($1) unless $pipe;
        } elsif($line eq ':code') {
            draw_completions(sigilfind('main::', '&'));
        } elsif($line eq ':scalar') {
            draw_completions(sigilfind('main::', '$'));
        } elsif($line eq ':hash') {
            draw_completions(sigilfind('main::', '%'));
        } elsif($line eq ':array') {
            draw_completions(sigilfind('main::', '@'));
        } elsif($line eq ':glob') {
            draw_completions(sigilfind('main::', '*'));
        } elsif($line =~ m/^[\t ]/ || $line =~ m/\{ *$/ || m/\\ *$/) {
            # we're dealing with an incomplete statement, so defer execution
            $line =~ s/\\ *$//;
            $input .= $line;
            $prompt = "..>";
        } else {
            # we're dealing with a complete statement, so execute and display
            $input .= $line;
            my @results = map { repr($_) } eval($input);
            if($@) {
                print $@;
            } elsif(scalar(@results) == 0) {
            } elsif(scalar(@results) == 1) {
                print $results[0] . "\n" unless $results[0] eq 'undef';
            } else {
                print join(", ", @results) . "\n";
            }
            ($input, $prompt) = ("", ">>>");
        }
    }
    print "Bye.\n";
}
main();