diff --git a/tools/iperl b/tools/iperl index 9975fe8..74a05f9 100755 --- a/tools/iperl +++ b/tools/iperl @@ -10,6 +10,9 @@ 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 @@ -38,25 +41,85 @@ EOT # 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 { + +# get all the objects of a particular sigil-type rooted in a package +sub sigilread { my ($pkg, $sigil, $base, $proc) = @_; - $base = "" unless $base; + my $base = $pkg eq 'main::' ? '' : $pkg; $proc = {$pkg => 1} unless $proc; - $pkg = $base if $base; my @results; foreach my $item (eval("keys(\%${pkg})")) { my $item2 = $base . $item; next if $proc->{$item2}; if($item =~ m/$nameregex/) { - push(@results, $item2) if eval("defined(${sigil}::${base}${item})"); + 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, sigilfind($item2, $sigil, $item2, $proc)); + 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) = @_; @@ -73,16 +136,75 @@ sub repr { } } +# 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) = @_; + my ($word, $line, $x1, $x2) = @_; $word =~ m/^([&\$%@\*]?)(.*)$/; - my $sigil = $1 ? $1 : '&'; + my $sigil = $1; my $name = $2; - my @candidates = grep { - $_ =~ m/^$name/ - } sigilfind('main::', $sigil); - return map { "${1}$_" } sort(@candidates); + 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 @@ -110,6 +232,10 @@ 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; @@ -122,7 +248,8 @@ sub main { ) || usage(1); # let's display a nice banner to the user - my ($prompt, $input, $term) = (">>>", "", undef); + #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"; @@ -150,7 +277,8 @@ sub main { $term = Term::ReadLine->new('IPERL'); my $attribs = $term->Attribs(); $attribs->{special_prefixes} = '$@%*&'; - $attribs->{completion_function} = sub { return complete(@_) }; + $attribs->{completion_function} = \&complete; + $attribs->{completion_append_character} = ''; } # the mighty read-exec-print loop! @@ -184,33 +312,35 @@ sub main { } elsif($line eq ':exit' || $line eq ':quit') { last; } elsif($line eq ':help') { - ($input, $prompt) = ("", ">>>"); + ($input, $prompt) = ("", $prompt1); print $HELP; } elsif($line eq ':reload') { - ($input, $prompt) = ("", ">>>"); + ($input, $prompt) = ("", $prompt1); print "reloading...\n"; exec($0, @oldargv); } elsif($line eq ':sh') { - ($input, $prompt) = ("", ">>>"); + ($input, $prompt) = ("", $prompt1); system("bash") unless $pipe; } elsif($line =~ m/^:sh (.+)$/) { - ($input, $prompt) = ("", ">>>"); + ($input, $prompt) = ("", $prompt1); system($1) unless $pipe; } elsif($line eq ':code') { - draw_completions(sigilfind('main::', '&')); + draw_completions(sort(sigilread('main::', '&'))); } elsif($line eq ':scalar') { - draw_completions(sigilfind('main::', '$')); + draw_completions(sort(sigilread('main::', '$'))); } elsif($line eq ':hash') { - draw_completions(sigilfind('main::', '%')); + draw_completions(sort(sigilread('main::', '%'))); } elsif($line eq ':array') { - draw_completions(sigilfind('main::', '@')); + draw_completions(sort(sigilread('main::', '@'))); } elsif($line eq ':glob') { - draw_completions(sigilfind('main::', '*')); + 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 = "..>"; + $prompt = $prompt2; } else { # we're dealing with a complete statement, so execute and display $input .= $line; @@ -223,7 +353,7 @@ sub main { } else { print join(", ", @results) . "\n"; } - ($input, $prompt) = ("", ">>>"); + ($input, $prompt) = ("", $prompt1); } } print "Bye.\n";