pmacs3/tools/iperl

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

use Data::Dumper;
use File::Basename;
use Getopt::Long;
use Perl6::Slurp;
use Scalar::Util;
use Term::ReadLine;

Getopt::Long::Configure('bundling');

$| = 1;
$Data::Dumper::Terse  = 1;
$Data::Dumper::Indent = 1;

sub usage {
    my($status) = @_;
    my $prog = 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)
    -q,--quiet           do not output eval results
    -r,--run PATH        run PATH before interaction
    -v,--verbose         output eval results (default)

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

my @OLDARGV = @ARGV;
my $verbose = 'yes';
my $pipe;
my @preload;
GetOptions(
    'help|h'    => sub { usage(0); },
    'eval|e=s'  => sub { push(@preload, ['eval', $_[1]]); },
    'pipe|p'    => sub { $pipe = 'line' },
    'quiet|q'   => sub { $verbose = 0 },
    'run|r=s'   => sub { push(@preload, ['run', $_[1]]); },
    'use|u=s'   => sub { push(@preload, ['use', $_[1]]); },
    'verbose|v' => sub { $verbose = 'please'; },
) || usage(1);

my ($prompt, $input) = (">>>", "");
unless($pipe) {
    print "Welcome to Erik's Perl Interpreter\n";
    print "(Type \"help\", \"exit\", or something else)\n";
}

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

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

sub repr {
    my @output;
    foreach my $item (@_) {
        push(@output, _repr($item));
    }
    return join("\n", @output);
}

sub escape {
    my($s) = @_;
    $s =~ s/\\/\\\\/g;
    $s =~ s/\n/\\n/g;
    return $s;
}

sub _draw {
    my ($s, $prefix, $suffix) = @_;
    if($pipe) {
        print "$prefix:" . escape($s) . "\n";
    } else {
        print $s . ($suffix ? $suffix : '');
    }
}

sub draw_prompt {
    my($p) = @_;
    _draw($p, "PROMPT", " ");
}
sub draw_result {
    my ($result) = @_;
    $result = 'undef' unless defined($result);
    _draw($result, "RESULT", "\n");
}
sub draw_error {
    my ($err) = @_;
    _draw($err, "ERROR");
}
sub draw_completions {
    my (@items) = @_;
    if($pipe) {
        print 'COMPLETIONS:' . join('|', @items) . "\n";
    } else {
        print join("\n", @items) . "\n";
    }
}
sub draw_message {
    my ($mesg) = @_;
    _draw($mesg, "MESSAGE");
}
sub draw_exit {
    _draw("Bye.", "EXIT", "\n");
}

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

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 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 you enter. Sorry.
EOT

my $term;

sub main {
    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 $@;
        }
    }
    
    unless($pipe) {
        $term = Term::ReadLine->new('IPERL');
        my $attribs = $term->Attribs();
        $attribs->{special_prefixes} = '$@%*&';
        $attribs->{completion_function} = sub {
            my ($word, $line, $x) = @_;
            return complete($word);
        };
    }

    while(1) {
        my $line;
        if($pipe) {
            draw_prompt($prompt);
            $line = <STDIN>;
        } else {
            $line = $term->readline("$prompt ");
        }
        last unless defined($line);
        chomp($line);

        if($pipe) {
            if($line =~ m/ENTER:(.*)$/) {
                $line = $1;
            } else {
                if($line =~ m/COMPLETE:(.*)$/) {
                    draw_completions(complete($1));
                } else {
                    draw_error("malformed pipe input line");
                }
                next;
            }
        }

        if($line eq '') {
        } elsif($line eq 'exit') {
            last;
        } elsif($line eq 'help') {
            ($input, $prompt) = ("", ">>>");
            draw_message($HELP);
        } elsif($line eq 'reload') {
            ($input, $prompt) = ("", ">>>");
            draw_message("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 =~ m/^:tab *(.*)$/) {
        } 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/\{ *$/) {
            $input .= $line;
            $prompt = "..>";
        } elsif($line =~ m/\\ *$/) {
            $line =~ s/\\ *$//;
            $input .= $line;
            $prompt = "..>";
        } else {
            $input .= $line;
            my @results = map { chomp($_); repr($_); } eval($input);
            if($@) {
                draw_error($@);
            } elsif(scalar(@results) < 2) {
                draw_result($results[0]);
            } else {
                draw_result(join(", ", @results));
            }
            ($input, $prompt) = ("", ">>>");
        }
    }
    draw_exit();
}
main();