From 3a93d0145d2807e945a56b2b7d71391cc4079f45 Mon Sep 17 00:00:00 2001
From: moculus <none@none>
Date: Sun, 18 May 2008 14:39:08 +0000
Subject: [PATCH] --HG-- branch : pmacs2

---
 tools/iperl | 178 +++++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 154 insertions(+), 24 deletions(-)

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";