pmacs3/tools/iperl

362 lines
12 KiB
Perl
Executable File

#!/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 (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_]*$/;
# 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($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 @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);
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) {
print $results[0] . "\n" unless $results[0] eq 'undef';
} else {
print join(", ", @results) . "\n";
}
($input, $prompt) = ("", $prompt1);
}
}
print "Bye.\n";
}
main();