383 lines
12 KiB
Perl
Executable File
383 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
|
|
-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, $x) = @_;
|
|
|
|
#print STDERR "'$word' '$line' $x\n";
|
|
|
|
$word =~ m/^([&\$%@\*]?)(.*)$/;
|
|
my $sigil = $1;
|
|
my $name = $2;
|
|
my $pre = substr($line, 0, $x);
|
|
|
|
if(length($line) == $x && $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}${_}"
|
|
} grep {
|
|
$_ =~ m/^$name/
|
|
} 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 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) = (">>>", "", 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 "\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:(\d+):(\d+):(.*)$/) {
|
|
my $x = $2;
|
|
my $line = $3;
|
|
my $word = substr($line, $1, $x - $1);
|
|
draw_completions(complete($line, $word, $x));
|
|
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(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";
|
|
}
|
|
run();
|