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();

# NOTE: some Term::ReadLine implementations don't support features that we sort
# of need. Term::ReadLine::Gnu is recommended.
use Term::ReadLine qw();
use Term::ReadLine::Gnu qw();

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

# 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
    -q,--quiet           hide undef eval output
    -r,--run PATH        run PATH before interaction
    -v,--verbose         output all eval results (default)

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

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

# find the object referenced by a name
sub resolve_ref {
    my ($name) = @_;
    my ($obj, $reftype, $package);
    $obj = eval("$name");
    my $reftype = $obj ? Scalar::Util::reftype($obj) : '';
    my $package = $obj ? ref($obj) : '';
    return ($obj, $reftype, $package);
}

# the completer used by readline
sub readline_complete {
    my ($word, $line, $x) = @_;
    my $full_word = readline_full_word($word, $line, $x);
    my $delta = length($full_word) - length($word);
    my @candidates = complete($full_word);
    return map { substr($_, $delta) } @candidates;
}

# some handy regexs
my $name_re    = qr/[a-zA-Z_][a-zA-Z0-9_]*/;
my $name2_re   = qr/(?:[a-zA-Z_][a-zA-Z0-9_]*)?/;
my $sub_pkg_re = qr/(?:${name_re}::)*/;
my $pkg_re     = qr/(?:${name_re}::)*${name_re}/;

my $hash_re       = qr/\$(${pkg_re}){/;
my $hash_ref_re   = qr/\$(${pkg_re})->{/;
my $obj_method_re = qr/(\$${pkg_re})->/;
my $cls_method_re = qr/(${pkg_re})->/;
my $default_re1   = qr/([\@\$\%\&\*]?)()()(${name_re})/;
my $default_re2   = qr/([\@\$\%\&\*]?)(${pkg_re})(::)(${name_re})/;
my $default_re3   = qr/([\@\$\%\&\*]?)(${pkg_re})(:{0,2})()/;

# XYZ
sub isa_complete {
    my ($var_name, $pkg, $method_name) = @_;
    my $names = {};
    _isa_complete($pkg, $method_name, {}, $names);
    return map { "${var_name}->$_" } keys(%$names);
}
sub _isa_complete {
    my ($pkg, $name, $proc, $names) = @_;
    return if $proc->{$pkg};
    $proc->{$pkg} = 1;
    map { _isa_complete($_, $name, $proc, $names) } (eval("\@${pkg}::ISA"));
    foreach my $item (eval("keys(\%${pkg}::)")) {
        next unless $item =~ m/^${name_re}$/;
        if(!$names->{$item} && $item =~ m/^$name/) {
            $names->{$item} = 1 if eval("defined(&::${pkg}::${item})");
        }
    }
}
sub sigil_complete {
    my ($type, $sigil, $pkg, $sep, $name) = @_;
    #print STDERR "    $type|$sigil|$pkg|$sep|$name\n";
    my $base = $pkg . $sep . $name;
    my @names;
    my @pkgs = _pkg_complete($pkg, $sep, $name, 1);
    foreach my $pkg2 (@pkgs) {
        #print "  XYZ '$type' '$name' '$pkg2'\n";
        foreach my $item (eval("\%${pkg2}::")) {
            next unless $item =~ m/^${name_re}$/;
            my $base2 = $pkg2 . ($pkg2 ? '::' : '') . $item;
            next unless $base2 =~ m/^$base/;
            #print "    OOP defined(${type}::${base2})\n";
            if(eval("defined(${type}::${base2})\n")) {
                #print "    YES ${sigil}${base2}\n";
                push(@names, $sigil . $base2);
            }
        }
    }
    return @names;
}
sub pkg_complete {
    my ($pkg, $sep, $name) = @_;
    my @pkgs = _pkg_complete($pkg, $sep, $name, !($pkg && $sep));
    my $base = $pkg . $sep . $name;
    return grep {$_ =~ m/^$base/ } @pkgs;
}
sub _pkg_complete {
    my ($pkg, $sep, $name, $returnself) = @_;
    my @pkgs = $returnself ? ($pkg) : ();
    foreach my $item (eval("\%${pkg}::")) {
        next unless $item =~ m/^(${name_re})::$/;
        my $item2 = $1;
        next if $pkg =~ m/::$item2$/;
        if($item =~ m/^$name/) {
            my $pkg2 = ($pkg ? "${pkg}::" : "") . $item2;
            push(@pkgs, _pkg_complete($pkg2, undef, "", 1));
        }
    }
    return @pkgs;
}

sub complete {
    my ($word) = @_;

    my @words;
    if($word =~ m/^${obj_method_re}(${name2_re})$/) {
        # obj dereference
        my ($obj_name, $method_name) = ($1, $2);
        my($obj, $reftype, $package) = resolve_ref($obj_name);
        if($reftype eq $package) {
            unless($method_name) {
                if($reftype eq 'CODE') {
                    @words = ("$word\(");
                } elsif($reftype eq 'HASH') {
                    @words = ("$word\{");
                } elsif($reftype eq 'ARRAY') {
                    @words = ("$word\[");
                }
            }
        } else {
            @words = isa_complete($obj_name, $package, $method_name);
        }
    } elsif($word =~ m/^${cls_method_re}(${name2_re})$/) {
        # package dereference
        my ($cls_name, $method_name) = ($1, $2);
        @words = isa_complete($cls_name, $cls_name, $method_name);
    } elsif($word =~ m/^${hash_re}(.*)$/) {
        # literal hash
        my ($hash, $key) = ($1, $2);
        #print STDERR "\n$hash|$key\n";
        my $obj = eval("\\\%$hash");
        if($obj) {
            @words = map { "\$${hash}{$_" } grep { $_ =~ m/^$key/ } keys(%$obj);
        }
        #print STDERR Dumper(\@words);
    } elsif($word =~ m/^${hash_ref_re}(.*)$/) {
        # hashref
        my ($hash, $key) = ($1, $2);
        my $obj = eval("\$$hash");
        if($obj) {
            @words = map { "\$${hash}->{$_" } grep { $_ =~ m/^$key/ } keys(%$obj);
        }
    } elsif($word =~ m/^${default_re1}$/ || $word =~ m/^${default_re2}$/ || $word =~ m/^${default_re3}$/) {
        # package or simple var
        my($sigil, $pkg, $sep, $name) = ($1, $2, $3, $4);
        #print STDERR "\n$sigil|$pkg|$sep|$name\n";
        my($oldpkg, $oldsep) = ($pkg, $sep);
        if($PKG && $pkg eq '' && $sep eq '') {
            ($pkg, $sep) = ($PKG, '::');
        }
        if($sigil eq '$') {
            foreach my $pair ([$pkg, $sep], ['', '']) {
                my ($_pkg, $_sep) = @$pair;
                push(@words, sigil_complete('$', '$', $_pkg, $_sep, $name));
                push(@words, map {"$_\["} sigil_complete('@', '$', $_pkg, $_sep, $name));
                push(@words, map {"$_\{"} sigil_complete('%', '$', $_pkg, $_sep, $name));
            }
        } elsif($sigil) {
            @words = sigil_complete($sigil, $sigil, $pkg, $sep, $name);
        } else {
            push(@words, pkg_complete($pkg, $sep, $name));
            push(@words, sigil_complete('&', '', $pkg, $sep, $name));
        }
        if($oldpkg ne $pkg) {
            @words = map { $_ =~ s/^${pkg}${sep}//; $_ } @words;
        }
    }
    return sort(@words);
}

# use sigilfind to get completions for particular word(s)
sub readline_full_word {
    my ($word, $line, $x) = @_;
    my $pre = substr($line, 0, $x);
    if(length($line) == $x && $pre =~ m/^[ \t]*$/) {
        return undef;
    } elsif($pre =~ m/$obj_method_re$/) {
        return $1 . "->" . $word;
    } elsif($pre =~ m/$cls_method_re$/) {
        return $1 . "->" . $word;
    } elsif($pre =~ m/$hash_re$/) {
        return '$' . $1 . "{" . $word;
    } elsif($pre =~ m/$hash_ref_re$/) {
        return '$' . $1 . "->{" . $word;
    } else {
        return $word;
    }
}

# 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 run {
    # ugh stupid fucking Term::ReadLine's automatic escapes
    my ($prompt1, $prompt2) = (">>>", '..>');
    #my ($prompt1, $prompt2) = ("\001\033[24m\002>>>", "\001\033[24m\002..>");

    # process the arguments provided; save original @ARGV for use later
    my $quiet;
    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]]); },
        'quiet|q'   => sub { $quiet = 1; },
        'verbose|v' => sub { $quiet = undef; },
    ) || usage(1);

    # let's display a nice banner to the user
    my ($prompt, $input, $term) = ($prompt1, "", 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') {
            $PKG = eval "$pair->[1]; return __PACKAGE__";
            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]);
            $PKG = eval "$data; return __PACKAGE__";
            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} = \&readline_complete;
        $attribs->{completion_append_character} = '';
    }

    # the mighty read-exec-print loop!
    while(1) {
        # display the prompt and read some input
        my $line;
        if($pipe) {
            print "\nPROMPT:$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:(.*)$/) {
                my @candidates = complete($1);
                draw_completions(@candidates);
                next;
            } elsif($line =~ m/^READLINE:(\d+):(\d+):(.*)$/) {
                my $x = $2;
                my $line = $3;
                my $word = substr($line, $1, $x - $1);
                my @candidates = readline_complete($line, $word, $x);
                draw_completions(@candidates);
                next;
            } else {
                print "malformed pipe input line: $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) = ("", $prompt1);
            print $HELP;
        } elsif($line eq ':reload') {
            ($input, $prompt) = ("", $prompt1);
            print "reloading...\n";
            exec($0, @oldargv);
        } elsif($line eq ':sh') {
            ($input, $prompt) = ("", $prompt1);
            system("bash") unless $pipe;
        } elsif($line =~ m/^:sh (.+)$/) {
            ($input, $prompt) = ("", $prompt1);
            system($1) unless $pipe;
        } elsif($line eq ':code') {
            draw_completions(sort(sigil_complete('&', '&', $PKG, '', '')));
        } elsif($line eq ':scalar') {
            draw_completions(sort(sigil_complete('$', '$', $PKG, '', '')));
        } elsif($line eq ':hash') {
            draw_completions(sort(sigil_complete('%', '%', $PKG, '', '')));
        } elsif($line eq ':array') {
            draw_completions(sort(sigil_complete('@', '@', $PKG, '', '')));
        } elsif($line eq ':glob') {
            draw_completions(sort(sigil_complete('*', '*', $PKG, '', '')));
        } elsif($line =~ m/^\:isa (${pkg_re})$/) {
            draw_completions(sort(isa_complete($1, $1, '')));
        } elsif($line =~ m/^[\t ]/ || $line =~ m/\{ *$/ || m/\\ *$/) {
            # we're dealing with an incomplete statement, so defer execution
            $line =~ s/\\ *$//;
            $input .= $line;
            $prompt = $prompt2;
        } 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) {
                if(!$quiet || $results[0] ne 'undef') {
                    print $results[0] . "\n";
                }
            } else {
                print join(", ", @results) . "\n";
            }
            ($input, $prompt) = ("", $prompt1);
        }
    }
    print "Bye.\n";
}
run();