#!/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();