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

# 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
    -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 inspecting the symbol table
my $pkgregex  = qr/^(?:[a-zA-Z_][a-zA-Z0-9_]*::)+$/;
my $nameregex = qr/^[a-zA-Z_][a-zA-Z0-9_]*$/;

# get all the objects of a particular sigil-type rooted in a package
sub sigilread {
    my ($pkg, $sigil, $base, $proc) = @_;
    my $base = $pkg eq 'main::' ? '' : $pkg;
    $proc = {$pkg => 1} unless $proc;
    my @results;
    foreach my $item (eval("keys(\%${pkg})")) {
        my $item2 = $base . $item;
        next if $proc->{$item2};
        if($item =~ m/$nameregex/) {
            if($sigil eq '$') {
                if(eval("defined(\$::${item2})")) {
                    push(@results, $item2);
                } elsif(eval("defined(\@::${item2})")) {
                    push(@results, $item2 . "[");
                } elsif(eval("defined(\%::${item2})")) {
                    push(@results, $item2 . "{");
                }
            } elsif(eval("defined(${sigil}::${item2})")) {
                push(@results, $item2);
            }
        } elsif($item =~ m/$pkgregex/) {
            $proc->{$item2} = 1;
            push(@results, sigilread($item2, $sigil, $item2, $proc));
            my $pkgname = substr($item2, 0, -2);
        }
    }
    return @results;
}

# find single-step completions for a particular package/name
sub sigilfind {
    my ($pkg, $name, $proc) = @_;
    my $base = $pkg eq 'main::' ? '' : $pkg;
    $proc = {$pkg => 1} unless $proc;
    my @results;
    foreach my $item (eval("keys(\%${pkg})")) {
        my $item2 = $base . $item;
        next if $proc->{$item2};
        if($item2 =~ m/^$name/) {
            if($item =~ m/$nameregex/ && eval("defined(&::${item2})")) {
                push(@results, $item2);
            } elsif($item =~ m/$pkgregex/) {
                $proc->{$item2} = 1;
                my $pkgname = substr($item2, 0, -2);
                if($name eq $pkgname) {
                    push(@results, "$pkgname->");
                    push(@results, sigilfind($item2, $name, $proc));
                } else {
                    push(@results,  $pkgname);
                }
            }
        }
    }
    return @results;
}

# find all functions accessible via a package's @ISA array. this could probably
# be implemented in a more efficient manner.
sub isafind {
    my ($pkg, $proc, $names) = @_;
    return if $proc && $proc->{$pkg};
    $proc = {$pkg => 1} unless $proc;
    $names = {} unless $names;

    my @pkgs = eval("\@${pkg}::ISA");
    foreach my $pkg2 (@pkgs) {
        isafind($pkg2, $proc, $names);
    } 

    foreach my $item (eval("keys(\%${pkg}::)")) {
        if($item =~ m/$nameregex/) {
            $names->{$item} = 1 if eval("defined(&::${pkg}::${item})");
        }
    }
    return keys(%$names);
}

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

# use sigilfind to get completions for particular word(s)
sub complete {
    my ($word, $line, $x1, $x2) = @_;
    $word =~ m/^([&\$%@\*]?)(.*)$/;
    my $sigil = $1;
    my $name = $2;
    my $pre = substr($line, 0, $x1);

    if(length($line) == $x1 && $pre =~ m/^[ \t]*$/) {
        # hack to handle the case where we really do want a tab
        return ("\t");
    }

    if($pre =~ m/(\$(?:[a-zA-Z_][a-zA-Z0-9_]*::)*[a-zA-Z_][a-zA-Z0-9_]*)->$/) {
        # ref dereference
        my($obj, $reftype, $package) = resolve_ref($1);
        if($reftype eq $package) {
            if($reftype eq 'CODE') {
                return ("$word\(");
            } elsif($reftype eq 'HASH') {
                return ("$word\{");
            } elsif($reftype eq 'ARRAY') {
                return ("$word\[");
            } else {
                return ();
            }
        } else {
            my @names = isafind($package);
            return grep { $_ =~ m/^$word/ } @names;
        }
    } elsif($pre =~ m/((?:[a-zA-Z_][a-zA-Z0-9_]*::)*[a-zA-Z_][a-zA-Z0-9_]*)->$/) {
        # package dereference
        my @names = isafind($1);
        return grep { $_ =~ m/^$word/ } @names;
    } elsif($pre =~ m/\$((?:[a-zA-Z_][a-zA-Z0-9_]*::)*[a-zA-Z_][a-zA-Z0-9_]*){$/) {
        # hash keys
        my $obj = eval("\\\%$1");
        return $obj ? grep { $_ =~ m/^$word/ } keys(%$obj) : ();
    } elsif($pre =~ m/(\$(?:[a-zA-Z_][a-zA-Z0-9_]*::)*[a-zA-Z_][a-zA-Z0-9_]*)->{$/) {
        # hashref keys
        my $obj = eval("$1");
        return $obj ? grep { $_ =~ m/^$word/ } keys(%$obj) : ();
    } else {
        # literals and ambiguous cases
        $name =~ m/^((?:[a-zA-Z_][a-zA-Z0-9_]*::)*)/;
        my $pkgname = $1 ? $1 : 'main::';
        my @candidates;
        if($sigil) {
            # if we have a sigil, then we can just jump to the actual object
            # completions.
            @candidates = map {
                "${sigil}${_}"
            } sigilread($pkgname, $sigil);
        } else {
            # if we don't have a sigil, the user might wanna call a function,
            # or complete a package to make an object-oriented call. so complete
            # step-by-step to avoid annoying the user.
            @candidates = map {
                "${sigil}${_}"
            } grep {
                $_ =~ m/^$name/
            } sigilfind($pkgname, $name);
        }
        return 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 {
    # 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) = (">>>", "", undef);
    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') {
            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} = \&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 "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) = ("", $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(sigilread('main::', '&')));
        } elsif($line eq ':scalar') {
            draw_completions(sort(sigilread('main::', '$')));
        } elsif($line eq ':hash') {
            draw_completions(sort(sigilread('main::', '%')));
        } elsif($line eq ':array') {
            draw_completions(sort(sigilread('main::', '@')));
        } elsif($line eq ':glob') {
            draw_completions(sort(sigilread('main::', '*')));
        } elsif($line =~ m/^:isa (.+)$/) {
            draw_completions(sort(isafind($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";
}
main();