lib/Sepia.pm

   1 package Sepia;
   2
   3 =head1 NAME
   4
   5 Sepia - Simple Emacs-Perl Interface
   6
   7 =cut
   8
   9 $VERSION = '0.69';
  10 @ISA = qw(Exporter);
  11
  12 require Exporter;
  13 use strict;
  14 use Cwd 'abs_path';
  15 use Scalar::Util 'looks_like_number';
  16 use Module::Info;
  17 use PadWalker qw(peek_my peek_our peek_sub closed_over);
  18 use Sub::Uplevel;
  19 use Text::Abbrev;
  20 use Carp;
  21 use B;
  22
  23 =item C<@compls = completions($string [, $type])>
  24
  25 Find a list of completions for C<$string> with glob type $type.
  26 Completion operates on word subparts separated by [:_], so
  27 e.g. "S:m_w" completes to "Sepia::my_walksymtable".
  28
  29 =cut
  30
  31 sub _apropos_re($)
  32 {
  33     # Do that crazy multi-word identifier completion thing:
  34     my $re = shift;
  35     if (wantarray) {
  36         map {
  37             s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
  38             qr/^$_/
  39         } split /:+/, $re, -1;
  40     } else {
  41         if ($re !~ /[^\w\d_^:]/) {
  42             $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
  43         }
  44         qr/$re/;
  45     }
  46 }
  47
  48 sub _completions1
  49 {
  50     no strict;
  51     my $stash = shift;
  52     if (@_ == 1) {
  53         map {
  54             "$stash$_"
  55         } grep /$_[0]/, keys %$stash;
  56     } else {
  57         my $re = shift;
  58         map {
  59             _completions1("$stash$_", @_);
  60         } grep /$re.*::$/, keys %$stash;
  61     };
  62 }
  63
  64 sub _completions
  65 {
  66     _completions1 '::', _apropos_re($_[0]);
  67 }
  68
  69 my %sigil;
  70 BEGIN {
  71     %sigil = qw(ARRAY @ SCALAR $ HASH %);
  72 }
  73
  74 sub completions
  75 {
  76     no strict;
  77     my ($str, $type, $infunc) = @_;
  78     my @ret = map { s/^:://; $_ } ($type ? do {
  79         (grep { defined *{$_}{$type} } _completions $str),
  80             (defined $infunc && defined *{$infunc}{CODE}) ? do {
  81                 my ($apre) = _apropos_re($str);
  82                 my $st = $sigil{$type};
  83                 grep {
  84                     (my $tmp = $_) =~ s/^\Q$st//;
  85                     $tmp =~ /$apre/;
  86                 } lexicals($infunc);
  87             } : ();
  88     } : do {
  89         grep {
  90             defined *{$_}{CODE} || defined *{$_}{IO}
  91                 || (/::$/ && defined *{$_}{HASH});
  92         } _completions $str;
  93     });
  94     if (!@ret && $str !~ /[^\w\d]/) {
  95         ## Complete "simple" sequences as abbreviations, e.g.:
  96         ##   wtci -> Want_To_Complete_It, NOT
  97         ##        -> WaTCh_trIpe
  98         my $broad = join '.*', map "\\b$_", split '', $str;
  99         @ret = map { s/^:://; $_ } ($type ? do {
 100             (grep { defined *{$_}{$type} } _completions1 '::', qr/$broad/),
 101                 (defined $infunc && defined *{$infunc}{CODE}) ? do {
 102                     my ($apre) = _apropos_re($str);
 103                     my $st = $sigil{$type};
 104                     grep {
 105                         (my $tmp = $_) =~ s/^\Q$st//;
 106                         $tmp =~ /$apre/;
 107                     } lexicals($infunc);
 108                 } : ();
 109         } : do {
 110             grep {
 111                 defined *{$_}{CODE} || defined *{$_}{IO}
 112                     || (/::$/ && defined *{$_}{HASH});
 113             } _completions1 '::', qr/$broad/;
 114         })
 115     }
 116     @ret;
 117 }
 118
 119 =item C<@locs = location(@names)>
 120
 121 Return a list of [file, line, name] triples, one for each function
 122 name in C<@names>.
 123
 124 =cut
 125
 126 sub location
 127 {
 128     no strict;
 129     my @x= map {
 130         my $str = $_;
 131         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 132             if ($pfx) {
 133                 warn "Sorry -- can't lookup variables.";
 134                 [];
 135             } else {
 136                 # XXX: svref_2object only seems to work with a package
 137                 # tacked on, but that should probably be done
 138                 # elsewhere...
 139                 $name = 'main::'.$name unless $name =~ /::/;
 140                 my $cv = B::svref_2object(\&{$name});
 141                 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
 142                     my ($file, $line) = ($cv->file, $cv->line);
 143                     if ($file !~ /^\//) {
 144                         for (@INC) {
 145                             if (-f "$_/$file") {
 146                                 $file = "$_/$file";
 147                                 last;
 148                             }
 149                         }
 150                     }
 151                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 152                     [Cwd::abs_path($file), $line, $shortname || $name]
 153                 } else {
 154 #                    warn "Bad CV for $name: $cv";
 155                     [];
 156                 }
 157             }
 158         } else {
 159             []
 160         }
 161     } @_;
 162     return @x;
 163 }
 164
 165 =item C<@matches = apropos($name [, $is_regex])>
 166
 167 Search for function C<$name>, either in all packages or, if C<$name>
 168 is qualified, only in one package.  If C<$is_regex> is true, the
 169 non-package part of C<$name> is a regular expression.
 170
 171 =cut
 172
 173 sub my_walksymtable(&*)
 174 {
 175     no strict;
 176     my ($f, $st) = @_;
 177     local *_walk = sub {
 178         local ($stash) = @_;
 179         &$f for keys %$stash;
 180         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 181     };
 182     _walk($st);
 183 }
 184
 185 sub apropos
 186 {
 187     my ($it, $re, @types) = @_;
 188     my $stashp;
 189     if (@types) {
 190         $stashp = grep /STASH/, @types;
 191         @types = grep !/STASH/, @types;
 192     } else {
 193         @types = qw(CODE);
 194     }
 195     no strict;
 196     if ($it =~ /^(.*::)([^:]+)$/) {
 197         my ($stash, $name) = ($1, $2);
 198         if (!defined %$stash) {
 199             return;
 200         }
 201         if ($re) {
 202             my $name = qr/^$name/;
 203             map {
 204                 "$stash$_"
 205             }
 206             grep {
 207                 my $stashnm = "$stash$_";
 208                 /$name/ &&
 209                     (($stashp && /::$/)
 210                      || scalar grep { defined *{$stashnm}{$_} } @types)
 211             } keys %$stash;
 212         } else {
 213             defined &$it ? $it : ();
 214         }
 215     } else {
 216         my @ret;
 217         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 218         my_walksymtable {
 219             push @ret, "$stash$_" if /$findre/;
 220         } '::';
 221         map { s/^:*(?:main:+)*//;$_ } @ret;
 222     }
 223 }
 224
 225 =item C<@names = mod_subs($pack)>
 226
 227 Find subs in package C<$pack>.
 228
 229 =cut
 230
 231 sub mod_subs
 232 {
 233     no strict;
 234     my $p = shift;
 235     my $stash = \%{"$p\::"};
 236     if (defined $stash) {
 237         grep { defined &{"$p\::$_"} } keys %$stash;
 238     }
 239 }
 240
 241 =item C<@decls = mod_decls($pack)>
 242
 243 Generate a list of declarations for all subroutines in package
 244 C<$pack>.
 245
 246 =cut
 247
 248 sub mod_decls
 249 {
 250     my $pack = shift;
 251     no strict 'refs';
 252     my @ret = map {
 253         my $sn = $_;
 254         my $proto = prototype(\&{"$pack\::$sn"});
 255         $proto = defined($proto) ? "($proto)" : '';
 256         "sub $sn $proto;\n";
 257     } mod_subs($pack);
 258     return wantarray ? @ret : join '', @ret;
 259 }
 260
 261 =item C<$info = module_info($module, $type)>
 262
 263 Emacs-called function to get module information.
 264
 265 =cut
 266
 267 sub module_info($$)
 268 {
 269     my ($m, $func) = @_;
 270     my $info;
 271     if (-f $m) {
 272         $info = Module::Info->new_from_file($m);
 273     } else {
 274         (my $file = $m) =~ s|::|/|g;
 275         $file .= '.pm';
 276         if (exists $INC{$file}) {
 277             $info = Module::Info->new_from_loaded($m);
 278         } else {
 279             $info = Module::Info->new_from_module($m);
 280         }
 281     }
 282     if ($info) {
 283         return $info->$func;
 284     }
 285 }
 286
 287 =item C<$file = mod_file($mod)>
 288
 289 Find the likely file owner for module C<$mod>.
 290
 291 =cut
 292
 293 sub mod_file
 294 {
 295     my $m = shift;
 296     $m =~ s/::/\//g;
 297     while ($m && !exists $INC{"$m.pm"}) {
 298         $m =~ s#(?:^|/)[^/]+$##;
 299     }
 300     $m ? $INC{"$m.pm"} : undef;
 301 }
 302
 303 =item C<@mods = package_list>
 304
 305 Gather a list of all distributions on the system. XXX UNUSED
 306
 307 =cut
 308
 309 our $INST;
 310 sub inst()
 311 {
 312     unless ($INST) {
 313         eval 'require ExtUtils::Installed';
 314         $INST = new ExtUtils::Installed;
 315     }
 316     $INST;
 317 }
 318
 319 sub package_list
 320 {
 321     sort inst->modules;
 322 }
 323
 324 =item C<@mods = module_list>
 325
 326 Gather a list of all packages (.pm files, really) installed on the
 327 system, grouped by distribution. XXX UNUSED
 328
 329 =cut
 330
 331 sub module_list
 332 {
 333     @_ = package_list unless @_;
 334     my $incre = join '|', map quotemeta, @INC;
 335     $incre = qr|(?:$incre)/|;
 336     my $inst = inst;
 337     map {
 338         [$_, sort map {
 339             s/$incre//; s|/|::|g;$_
 340         } grep /\.pm$/, $inst->files($_)]
 341     } @_;
 342 }
 343
 344 =item C<@mods = doc_list>
 345
 346 Gather a list of all documented packages (.?pm files, really)
 347 installed on the system, grouped by distribution. XXX UNUSED
 348
 349 =cut
 350
 351 sub doc_list
 352 {
 353     @_ = package_list unless @_;
 354     my $inst = inst;
 355     map {
 356         [$_, sort map {
 357             s/.*man.\///; s|/|::|g;s/\..?pm//; $_
 358         } grep /\..pm$/, $inst->files($_)]
 359     } @_;
 360 }
 361
 362 =item C<lexicals($subname)>
 363
 364 Return a list of C<$subname>'s lexical variables.  Note that this
 365 includes all nested scopes -- I don't know if or how Perl
 366 distinguishes inner blocks.
 367
 368 =cut
 369
 370 sub lexicals
 371 {
 372     my $cv = B::svref_2object(\&{+shift});
 373     return unless $cv && ($cv = $cv->PADLIST);
 374     my ($names, $vals) = $cv->ARRAY;
 375     map {
 376         my $name = $_->PV; $name =~ s/\0.*$//; $name
 377     } grep B::class($_) ne 'SPECIAL', $names->ARRAY;
 378 }
 379
 380 =item C<$lisp = tolisp($perl)>
 381
 382 Convert a Perl scalar to some ELisp equivalent.
 383
 384 =cut
 385
 386 sub tolisp($)
 387 {
 388     my $thing = @_ == 1 ? shift : \@_;
 389     my $t = ref $thing;
 390     if (!$t) {
 391         if (!defined $thing) {
 392             'nil'
 393         } elsif (looks_like_number $thing) {
 394             ''.(0+$thing);
 395         } else {
 396             qq{"$thing"};
 397         }
 398     } elsif ($t eq 'GLOB') {
 399         (my $name = $$thing) =~ s/\*main:://;
 400         $name;
 401     } elsif ($t eq 'ARRAY') {
 402         '(' . join(' ', map { tolisp($_) } @$thing).')'
 403     } elsif ($t eq 'HASH') {
 404         '(' . join(' ', map {
 405             '(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
 406         } keys %$thing).')'
 407     } elsif ($t eq 'Regexp') {
 408         "'(regexp . \"" . quotemeta($thing) . '")';
 409 #     } elsif ($t eq 'IO') {
 410     } else {
 411         qq{"$thing"};
 412     }
 413 }
 414
 415 =item C<printer(\@res [, $iseval])>
 416
 417 Print C<@res> appropriately on the current filehandle.  If C<$iseval>
 418 is true, use terse format.  Otherwise, use human-readable format.
 419
 420 =cut
 421
 422 sub print_dumper
 423 {
 424     local $Data::Dumper::Deparse = 1;
 425     local $Data::Dumper::Indent = 0;
 426     no strict;
 427     eval {
 428         local $_ = Data::Dumper::Dumper(@res > 1 ? \@res : $res[0]);
 429         s/^\$VAR1 = //;
 430         s/;$//;
 431         $_;
 432     };
 433 }
 434
 435 sub print_plain
 436 {
 437     no strict;
 438     $__ = "@res";
 439 }
 440
 441 sub print_yaml
 442 {
 443     no strict;
 444     eval { require YAML };
 445     if ($@) {
 446         print_dumper;
 447     } else {
 448         YAML::Dump(\@res);
 449     }
 450 }
 451
 452 sub print_dump
 453 {
 454     no strict;
 455     eval { require Data::Dump };
 456     if ($@) {
 457         print_dumper;
 458     } else {
 459         Data::Dump::dump;
 460     }
 461 }
 462
 463 sub printer
 464 {
 465     no strict;
 466     local *res = shift;
 467     my ($iseval, $wantarray) = @_;
 468     @__ = @res;
 469     my $str;
 470     if ($iseval) {
 471         $__ = "@res";
 472     } elsif (@res == 1 && (ref $res[0]) =~ /^PDL/) {
 473         $__ = "$res[0]";
 474     } else {
 475         $__ = $PRINTER->();
 476     }
 477     if ($iseval) {
 478         print ';;;', length $__, "\n$__\n";
 479     } else {
 480         print "=> $__\n";
 481     }
 482 }
 483
 484 =item C<repl(\*FH)>
 485
 486 Execute a command interpreter on FH.  The prompt has a few bells and
 487 whistles, including:
 488
 489   * Obviously-incomplete lines are treated as multiline input.
 490
 491   * C<die> is overridden to enter a recursive interpreter at the point
 492     C<die> is called.  From within this interpreter, you can examine a
 493     backtrace by calling "bt", return from C<die> with "r EXPR", or
 494     go ahead and die by pressing Control-c.
 495
 496 Behavior is controlled in part through the following package-globals:
 497
 498 =over 4
 499
 500 =item C<$PS1> -- the default prompt
 501
 502 =item C<$STOPDIE> -- true to enter the inspector on C<die()>
 503
 504 =item C<$STOPWARN> -- true to enter the inspector on C<warn()>
 505
 506 =item C<%REPL> -- maps shortcut names to handlers
 507
 508 =item C<$PACKAGE> -- evaluation package
 509
 510 =item C<$WANTARRAY> -- evaluation context
 511
 512 =item C<$PRINTER> -- result printer (default: print_dumper)
 513
 514 =cut
 515
 516 use vars qw($PS1 $dies $STOPDIE $STOPWARN %REPL %RK
 517             $PACKAGE $WANTARRAY $PRINTER);
 518 BEGIN {
 519     no strict;
 520     $PS1 = "> ";
 521     $dies = 0;
 522     $STOPDIE = 1;
 523     $STOPWARN = 0;
 524     $PACKAGE = 'main';
 525     $WANTARRAY = 1;
 526     $PRINTER = \&Sepia::print_dumper;
 527     %REPL = (help => \&Sepia::repl_help,
 528              cd => \&Sepia::repl_chdir,
 529              package => \&Sepia::repl_package,
 530              who => \&Sepia::repl_who,
 531              wantarray => \&Sepia::repl_wantarray,
 532              format => \&Sepia::repl_format,
 533          );
 534     %RK = abbrev keys %REPL;
 535 }
 536
 537 sub prompt()
 538 {
 539     "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
 540 }
 541
 542 sub Dump {
 543     eval {
 544         Data::Dumper->Dump([$_[0]], [$_[1]]);
 545     };
 546 }
 547
 548 my $FRAMES = 4;
 549
 550 sub hiding_me
 551 {
 552     my ($fn, @args) = @_;
 553     sub {
 554         uplevel $FRAMES, $fn, @args
 555     }
 556 }
 557
 558 sub eval_in_env
 559 {
 560     my ($expr, $env) = @_;
 561     local $::ENV = $env;
 562     my $str = '';
 563     for (keys %$env) {
 564         next unless /^([\$\@%])(.+)/;
 565         $str .= "local *$2 = \$::ENV->{'$_'}; ";
 566     }
 567     eval "do { no strict; $str $expr }";
 568 }
 569
 570 sub debug_upeval
 571 {
 572     my ($lev, $exp) = $_[0] =~ /^\s*(\d+)\s+(.*)/;
 573     print " <= $exp\n";
 574     (0, eval_in_env($exp, PadWalker::peek_my(0+$lev)));
 575 }
 576
 577 sub debug_inspect
 578 {
 579     local $_ = shift;
 580     for my $i (split) {
 581         my $sub = (caller $i)[3];
 582         next unless $sub;
 583         my $h = PadWalker::peek_my($i);
 584         print "[$i] $sub:\n";
 585         for (sort keys %$h) {
 586             print "\t", Sepia::Dump($h->{$_}, $_);
 587         }
 588     }
 589     0;
 590 }
 591
 592 sub repl_help
 593 {
 594     print <<EOS;
 595 REPL commands (prefixed with ','):
 596     cd DIR             Change directory to DIR
 597     define
 598     format [dumper|dump|yaml|plain]
 599                        Set output formatter (default: dumper)
 600     help               Display this message
 601     package PACKAGE    Set evaluation package to PACKAGE
 602     wantarray [0|1]    Set or toggle evaluation context
 603     who PACKAGE        List variables and subs in PACKAGE
 604 EOS
 605     0;
 606 }
 607
 608 sub repl_format
 609 {
 610     my $t = shift;
 611     chomp $t;
 612     $t = 'dumper' if $t eq '';
 613     my %formats = abbrev qw(dumper dump yaml plain);
 614     if (exists $formats{$t}) {
 615         no strict;
 616         $PRINTER = \&{'print_'.$formats{$t}};
 617     } else {
 618         warn "No such format '$t' (dumper, dump, yaml, plain).\n";
 619     }
 620     0;
 621 }
 622
 623 sub repl_chdir
 624 {
 625     chomp(my $dir = shift);
 626     $dir =~ s/^~\//$ENV{HOME}\//;
 627     $dir =~ s/\$HOME/$ENV{HOME}/;
 628     if (-d $dir) {
 629
 630         chdir $dir;
 631         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 632         print ";;;###".length($ecmd)."\n$ecmd\n";
 633     } else {
 634         warn "Can't chdir\n";
 635     }
 636     0;
 637 }
 638
 639 sub who
 640 {
 641     my $pack = shift || '';
 642     no strict;
 643     sort map {
 644         (defined %{$pack.'::'.$_} ? '%'.$_ : (),
 645          defined ${$pack.'::'.$_} ? '$'.$_ : (), # ?
 646          defined @{$pack.'::'.$_} ? '@'.$_ : (),
 647          defined &{$pack.'::'.$_} ? $_ : (),
 648      )
 649     } grep !/::$/ && !/^(?:_<|[^\w])/, keys %{$pack.'::'};
 650 }
 651
 652 sub repl_who
 653 {
 654     my @who = who @_;
 655     Sepia::printer(\@who);
 656     0;
 657 }
 658
 659 sub repl_wantarray
 660 {
 661     my $x = shift;
 662     $WANTARRAY = defined $x ? $x : !$WANTARRAY;
 663     0;
 664 }
 665
 666 sub repl_package
 667 {
 668     chomp(my $p = shift);
 669     no strict;
 670     if (defined %{$p.'::'}) {
 671         $PACKAGE = $p;
 672 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
 673 #         print ";;;###".length($ecmd)."\n$ecmd\n";
 674     } else {
 675         warn "Can't go to package $p -- doesn't exist!\n";
 676     }
 677     0;
 678 }
 679
 680 sub debug_help
 681 {
 682     print <<EOS;
 683 Inspector commands (prefixed with ','):
 684     \\C-c        Pop one debugger level
 685     backtrace       show backtrace
 686     inspect N ...   inspect lexicals in frame(s) N ...
 687     eval N EXPR     evaluate EXPR in lexical environment of frame N
 688     return EXPR     return EXPR
 689     die/warn        keep on dying/warning
 690 EOS
 691     0;
 692 }
 693
 694 sub debug_backtrace
 695 {
 696     Carp::cluck;0
 697 }
 698
 699 sub debug_return
 700 {
 701     (1, repl_eval(@_));
 702 }
 703
 704 sub repl_eval
 705 {
 706     my ($buf, $wantarray, $pkg) = @_;
 707     no strict;
 708     local $PACKAGE = $pkg || $PACKAGE;
 709     $buf = "do { package $PACKAGE; no strict; $buf }";
 710     my $wa = $WANTARRAY;
 711     if (!defined $wa) {
 712         $wa = wantarray ? 'ARRAY' : 'SCALAR';
 713     }
 714     if ($wa) {
 715         eval $buf;
 716     } else {
 717         scalar eval $buf;
 718     }
 719 }
 720
 721 sub repl
 722 {
 723     my ($fh, $level) = @_;
 724     select((select($fh), $|=1)[0]);
 725     my $in;
 726     my $buf = '';
 727     my $sigged = 0;
 728
 729     my $nextrepl = sub { $sigged = 1; };
 730
 731     local *__;
 732     my $MSG = "('\\C-c' to exit, ',h' for help)";
 733     my %dhooks = (
 734                 backtrace => \&Sepia::debug_backtrace,
 735                 inspect => \&Sepia::debug_inspect,
 736                 eval => \&Sepia::debug_upeval,
 737                 return => \&Sepia::debug_return,
 738                 help => \&Sepia::debug_help,
 739             );
 740     local *CORE::GLOBAL::die = sub {
 741         my @dieargs = @_;
 742         if ($STOPDIE) {
 743             local $dies = $dies+1;
 744             local $PS1 = "*$dies*> ";
 745             no strict;
 746             local %Sepia::REPL = (
 747                 %dhooks, die => sub { local $Sepia::STOPDIE=0; die @dieargs });
 748             local %Sepia::RK = abbrev keys %Sepia::REPL;
 749             print "@_\nDied $MSG\n";
 750             return Sepia::repl($fh, 1);
 751         }
 752         CORE::die(@_);
 753     };
 754
 755     local *CORE::GLOBAL::warn = sub {
 756         if ($STOPWARN) {
 757             local $dies = $dies+1;
 758             local $PS1 = "*$dies*> ";
 759             no strict;
 760             local %Sepia::REPL = (
 761                 %dhooks, warn => sub { local $Sepia::STOPWARN=0; warn @dieargs });
 762             local %Sepia::RK = abbrev keys %Sepia::REPL;
 763             print "@_\nWarned $MSG\n";
 764             return Sepia::repl($fh, 1);
 765         }
 766         CORE::warn(@_);
 767     };
 768
 769     print prompt;
 770     my @sigs = qw(INT TERM PIPE ALRM);
 771     local @SIG{@sigs};
 772     $SIG{$_} = $nextrepl for @sigs;
 773  repl: while (my $in = <$fh>) {
 774             if ($sigged) {
 775                 $buf = '';
 776                 $sigged = 0;
 777                 print "\n", prompt;
 778                 next repl;
 779             }
 780             $buf .= $in;
 781             my $iseval;
 782             if ($buf =~ /^<<(\d+)\n(.*)/) {
 783                 $iseval = 1;
 784                 my $len = $1;
 785                 my $tmp;
 786                 $buf = $2;
 787                 while ($len && defined($tmp = read $fh, $buf, $len, length $buf)) {
 788                     $len -= $tmp;
 789                 }
 790             }
 791             my (@res, @warn);
 792             local $SIG{__WARN__} = sub {
 793                 push @warn, shift;
 794             };
 795             if ($buf =~ /^,(\S+)\s*(.*)/s) {
 796                 ## Inspector shortcuts
 797                 if (exists $Sepia::RK{$1}) {
 798                     my $ret;
 799                     my $arg = $2;
 800                     chomp $arg;
 801                     ($ret, @res) = $Sepia::REPL{$Sepia::RK{$1}}->($arg, wantarray);
 802                     if ($ret) {
 803                         return wantarray ? @res : $res[0];
 804                     }
 805                 } else {
 806                     print "Unrecignized shortcut '$1'\n";
 807                     $buf = '';
 808                     print prompt;
 809                     next repl;
 810                 }
 811             } else {
 812                 ## Ordinary eval
 813                 @res = repl_eval $buf, wantarray;
 814
 815                 if ($@) {
 816                     if ($@ =~ /at EOF$/m) {
 817                         ## Possibly-incomplete line
 818                         if ($in eq "\n") {
 819                             print "*** cancel ***\n", prompt;
 820                             $buf = '';
 821                         } else {
 822                             print ">> ";
 823                         }
 824                         next repl;
 825                     } else {
 826                         warn $@;
 827                         $buf = '';
 828                         Sepia::printer \@res, $iseval, wantarray if $iseval;
 829                     }
 830                 }
 831             }
 832             if ($buf !~ /;$/) {
 833                 ## Be quiet if it ends with a semicolon.
 834                 Sepia::printer \@res, $iseval, wantarray;
 835             }
 836             $buf = '';
 837             if (@warn) {
 838                 if ($iseval) {
 839                     my $tmp = "@warn";
 840                     print ';;;'.length($tmp)."\n$tmp\n";
 841                 } else {
 842                     print "@warn\n";
 843                 }
 844             }
 845             print prompt;
 846         }
 847 }
 848
 849 sub perl_eval
 850 {
 851     tolisp(repl_eval(shift));
 852 }
 853
 854 1;