d6
/
pmacs3
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

--HG-- 

branch : pmacs2
This commit is contained in:
moculus 2008-05-18 14:39:08 +00:00
parent 7c4250b4c2
commit 3a93d0145d
1 changed files with 154 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

176
tools/iperl
View File

@ -10,6 +10,9 @@ use File::Basename qw();
use Getopt::Long qw(); use Getopt::Long qw();
use Perl6::Slurp qw(slurp); use Perl6::Slurp qw(slurp);
use Scalar::Util qw(); 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 qw();
# globals # globals
@ -38,25 +41,85 @@ EOT
# handy function for inspecting the symbol table # handy function for inspecting the symbol table
my $pkgregex = qr/^(?:[a-zA-Z_][a-zA-Z0-9_]*::)+$/; my $pkgregex = qr/^(?:[a-zA-Z_][a-zA-Z0-9_]*::)+$/;
my $nameregex = 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) = @_; my ($pkg, $sigil, $base, $proc) = @_;
$base = "" unless $base; my $base = $pkg eq 'main::' ? '' : $pkg;
$proc = {$pkg => 1} unless $proc; $proc = {$pkg => 1} unless $proc;
$pkg = $base if $base;
my @results; my @results;
foreach my $item (eval("keys(\%${pkg})")) { foreach my $item (eval("keys(\%${pkg})")) {
my $item2 = $base . $item; my $item2 = $base . $item;
next if $proc->{$item2}; next if $proc->{$item2};
if($item =~ m/$nameregex/) { 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/) { } elsif($item =~ m/$pkgregex/) {
$proc->{$item2} = 1; $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; 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 # handy function for printing nice representations of data
sub repr { sub repr {
my ($item) = @_; 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) # use sigilfind to get completions for particular word(s)
sub complete { sub complete {
my ($word, $line, $x) = @_; my ($word, $line, $x1, $x2) = @_;
$word =~ m/^([&\$%@\*]?)(.*)$/; $word =~ m/^([&\$%@\*]?)(.*)$/;
my $sigil = $1 ? $1 : '&'; my $sigil = $1;
my $name = $2; my $name = $2;
my @candidates = grep { 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/ $_ =~ m/^$name/
} sigilfind('main::', $sigil); } sigilfind($pkgname, $name);
return map { "${1}$_" } sort(@candidates); }
return sort(@candidates);
}
} }
# display completions to the user # display completions to the user
@ -110,6 +232,10 @@ EOT
# the big one! # the big one!
sub main { 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 # process the arguments provided; save original @ARGV for use later
my @preload; my @preload;
my @oldargv = @ARGV; my @oldargv = @ARGV;
@ -122,7 +248,8 @@ sub main {
) || usage(1); ) || usage(1);
# let's display a nice banner to the user # 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) { unless($pipe) {
print "Welcome to Erik's Perl Interpreter\n"; print "Welcome to Erik's Perl Interpreter\n";
print "(Type \":help\", \":exit\", or something else)\n"; print "(Type \":help\", \":exit\", or something else)\n";
@ -150,7 +277,8 @@ sub main {
$term = Term::ReadLine->new('IPERL'); $term = Term::ReadLine->new('IPERL');
my $attribs = $term->Attribs(); my $attribs = $term->Attribs();
$attribs->{special_prefixes} = '$@%*&'; $attribs->{special_prefixes} = '$@%*&';
$attribs->{completion_function} = sub { return complete(@_) }; $attribs->{completion_function} = \&complete;
$attribs->{completion_append_character} = '';
} }
# the mighty read-exec-print loop! # the mighty read-exec-print loop!
@ -184,33 +312,35 @@ sub main {
} elsif($line eq ':exit' || $line eq ':quit') { } elsif($line eq ':exit' || $line eq ':quit') {
last; last;
} elsif($line eq ':help') { } elsif($line eq ':help') {
($input, $prompt) = ("", ">>>"); ($input, $prompt) = ("", $prompt1);
print $HELP; print $HELP;
} elsif($line eq ':reload') { } elsif($line eq ':reload') {
($input, $prompt) = ("", ">>>"); ($input, $prompt) = ("", $prompt1);
print "reloading...\n"; print "reloading...\n";
exec($0, @oldargv); exec($0, @oldargv);
} elsif($line eq ':sh') { } elsif($line eq ':sh') {
($input, $prompt) = ("", ">>>"); ($input, $prompt) = ("", $prompt1);
system("bash") unless $pipe; system("bash") unless $pipe;
} elsif($line =~ m/^:sh (.+)$/) { } elsif($line =~ m/^:sh (.+)$/) {
($input, $prompt) = ("", ">>>"); ($input, $prompt) = ("", $prompt1);
system($1) unless $pipe; system($1) unless $pipe;
} elsif($line eq ':code') { } elsif($line eq ':code') {
draw_completions(sigilfind('main::', '&')); draw_completions(sort(sigilread('main::', '&')));
} elsif($line eq ':scalar') { } elsif($line eq ':scalar') {
draw_completions(sigilfind('main::', '$')); draw_completions(sort(sigilread('main::', '$')));
} elsif($line eq ':hash') { } elsif($line eq ':hash') {
draw_completions(sigilfind('main::', '%')); draw_completions(sort(sigilread('main::', '%')));
} elsif($line eq ':array') { } elsif($line eq ':array') {
draw_completions(sigilfind('main::', '@')); draw_completions(sort(sigilread('main::', '@')));
} elsif($line eq ':glob') { } 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/\\ *$/) { } elsif($line =~ m/^[\t ]/ || $line =~ m/\{ *$/ || m/\\ *$/) {
# we're dealing with an incomplete statement, so defer execution # we're dealing with an incomplete statement, so defer execution
$line =~ s/\\ *$//; $line =~ s/\\ *$//;
$input .= $line; $input .= $line;
$prompt = "..>"; $prompt = $prompt2;
} else { } else {
# we're dealing with a complete statement, so execute and display # we're dealing with a complete statement, so execute and display
$input .= $line; $input .= $line;
@ -223,7 +353,7 @@ sub main {
} else { } else {
print join(", ", @results) . "\n"; print join(", ", @results) . "\n";
} }
($input, $prompt) = ("", ">>>"); ($input, $prompt) = ("", $prompt1);
} }
} }
print "Bye.\n"; print "Bye.\n";