moculus
parent
31327aae83
commit
b725b91375
140
tools/iperl
140
tools/iperl
|
|
@ -12,12 +12,14 @@ use Perl6::Slurp qw(slurp);
|
|||
use Scalar::Util qw();
|
||||
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);
|
||||
|
|
@ -26,35 +28,14 @@ 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;
|
||||
Getopt::Long::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";
|
||||
}
|
||||
|
||||
# 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_]*$/;
|
||||
sub sigilfind {
|
||||
|
|
@ -76,7 +57,8 @@ sub sigilfind {
|
|||
return @results;
|
||||
}
|
||||
|
||||
sub _repr {
|
||||
# handy function for printing nice representations of data
|
||||
sub repr {
|
||||
my ($item) = @_;
|
||||
if(!defined($item)) {
|
||||
return 'undef';
|
||||
|
|
@ -91,36 +73,9 @@ sub _repr {
|
|||
}
|
||||
}
|
||||
|
||||
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_prompt {
|
||||
my($p) = @_;
|
||||
print $pipe ? "$prefix:" . escape($p) . "\n" : $p;
|
||||
}
|
||||
sub draw_completions {
|
||||
my (@items) = @_;
|
||||
if($pipe) {
|
||||
print 'COMPLETIONS:' . join('|', @items) . "\n";
|
||||
} else {
|
||||
print join("\n", @items) . "\n";
|
||||
}
|
||||
}
|
||||
|
||||
# use sigilfind to get completions for particular word(s)
|
||||
sub complete {
|
||||
my ($word) = @_;
|
||||
my ($word, $line, $x) = @_;
|
||||
$word =~ m/^([&\$%@\*]?)(.*)$/;
|
||||
my $sigil = $1 ? $1 : '&';
|
||||
my $name = $2;
|
||||
|
|
@ -130,24 +85,51 @@ sub complete {
|
|||
return map { "${1}$_" } 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.
|
||||
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 you enter. Sorry.
|
||||
do with the way I evaluate blocks. Sorry.
|
||||
EOT
|
||||
|
||||
my $term;
|
||||
|
||||
# the big one!
|
||||
sub main {
|
||||
# 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);
|
||||
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];
|
||||
|
|
@ -163,20 +145,20 @@ sub main {
|
|||
}
|
||||
}
|
||||
|
||||
# set up readline if necessary
|
||||
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);
|
||||
};
|
||||
$attribs->{completion_function} = sub { return complete(@_) };
|
||||
}
|
||||
|
||||
# the mighty read-exec-print loop!
|
||||
while(1) {
|
||||
# display the prompt and read some input
|
||||
my $line;
|
||||
if($pipe) {
|
||||
draw_prompt($prompt);
|
||||
print "PROMPT:$prompt\n";
|
||||
$line = <STDIN>;
|
||||
} else {
|
||||
$line = $term->readline("$prompt ");
|
||||
|
|
@ -184,36 +166,36 @@ sub main {
|
|||
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;
|
||||
} else {
|
||||
if($line =~ m/COMPLETE:(.*)$/) {
|
||||
} 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') {
|
||||
} elsif($line eq ':exit' || $line eq ':quit') {
|
||||
last;
|
||||
} elsif($line eq 'help') {
|
||||
} elsif($line eq ':help') {
|
||||
($input, $prompt) = ("", ">>>");
|
||||
print $HELP;
|
||||
} elsif($line eq 'reload') {
|
||||
} elsif($line eq ':reload') {
|
||||
($input, $prompt) = ("", ">>>");
|
||||
print "reloading...\n";
|
||||
exec($0, @OLDARGV);
|
||||
} elsif($line eq 'sh') {
|
||||
exec($0, @oldargv);
|
||||
} elsif($line eq ':sh') {
|
||||
($input, $prompt) = ("", ">>>");
|
||||
system("bash") unless $pipe;
|
||||
} elsif($line =~ m/^sh (.+)$/) {
|
||||
} 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') {
|
||||
|
|
@ -224,20 +206,20 @@ sub main {
|
|||
draw_completions(sigilfind('main::', '@'));
|
||||
} elsif($line eq ':glob') {
|
||||
draw_completions(sigilfind('main::', '*'));
|
||||
} elsif($line =~ m/^[\t ]/ || $line =~ m/\{ *$/) {
|
||||
$input .= $line;
|
||||
$prompt = "..>";
|
||||
} elsif($line =~ m/\\ *$/) {
|
||||
} elsif($line =~ m/^[\t ]/ || $line =~ m/\{ *$/ || m/\\ *$/) {
|
||||
# we're dealing with an incomplete statement, so defer execution
|
||||
$line =~ s/\\ *$//;
|
||||
$input .= $line;
|
||||
$prompt = "..>";
|
||||
} else {
|
||||
# we're dealing with a complete statement, so execute and display
|
||||
$input .= $line;
|
||||
my @results = map { $_ =~ s/\n$//; repr($_); } eval($input);
|
||||
my @results = map { repr($_) } eval($input);
|
||||
if($@) {
|
||||
print $@;
|
||||
} elsif(scalar(@results) < 2) {
|
||||
print $results[0] . "\n";
|
||||
} elsif(scalar(@results) == 0) {
|
||||
} elsif(scalar(@results) == 1) {
|
||||
print $results[0] . "\n" unless $results[0] eq 'undef';
|
||||
} else {
|
||||
print join(", ", @results) . "\n";
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue