lib/Sepia.pm

   1 package Sepia;
   2
   3 =head1 NAME
   4
   5 Sepia - Simple Emacs-Perl Interface
   6
   7 =cut
   8
   9 $VERSION = '0.63';
  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     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 }
  95
  96 =item C<@locs = location(@names)>
  97
  98 Return a list of [file, line, name] triples, one for each function
  99 name in C<@names>.
 100
 101 =cut
 102
 103 sub location
 104 {
 105     no strict;
 106     my @x= map {
 107         my $str = $_;
 108         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 109             if ($pfx) {
 110                 warn "Sorry -- can't lookup variables.";
 111                 [];
 112             } else {
 113                 # XXX: svref_2object only seems to work with a package
 114                 # tacked on, but that should probably be done
 115                 # elsewhere...
 116                 $name = 'main::'.$name unless $name =~ /::/;
 117                 my $cv = B::svref_2object(\&{$name});
 118                 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
 119                     my ($file, $line) = ($cv->file, $cv->line);
 120                     if ($file !~ /^\//) {
 121                         for (@INC) {
 122                             if (-f "$_/$file") {
 123                                 $file = "$_/$file";
 124                                 last;
 125                             }
 126                         }
 127                     }
 128                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 129                     [Cwd::abs_path($file), $line, $shortname || $name]
 130                 } else {
 131 #                    warn "Bad CV for $name: $cv";
 132                     [];
 133                 }
 134             }
 135         } else {
 136             []
 137         }
 138     } @_;
 139     return @x;
 140 }
 141
 142 =item C<@matches = apropos($name [, $is_regex])>
 143
 144 Search for function C<$name>, either in all packages or, if C<$name>
 145 is qualified, only in one package.  If C<$is_regex> is true, the
 146 non-package part of C<$name> is a regular expression.
 147
 148 =cut
 149
 150 sub my_walksymtable(&*)
 151 {
 152     no strict;
 153     my ($f, $st) = @_;
 154     local *_walk = sub {
 155         local ($stash) = @_;
 156         &$f for keys %$stash;
 157         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 158     };
 159     _walk($st);
 160 }
 161
 162 sub apropos
 163 {
 164     my ($it, $re, @types) = @_;
 165     my $stashp;
 166     if (@types) {
 167         $stashp = grep /STASH/, @types;
 168         @types = grep !/STASH/, @types;
 169     } else {
 170         @types = qw(CODE);
 171     }
 172     no strict;
 173     if ($it =~ /^(.*::)([^:]+)$/) {
 174         my ($stash, $name) = ($1, $2);
 175         if ($re) {
 176             my $name = qr/^$name/;
 177             map {
 178                 "$stash$_"
 179             }
 180             grep {
 181                 my $stashnm = "$stash$_";
 182                 /$name/ &&
 183                     (($stashp && /::$/)
 184                      || scalar grep { defined *{$stashnm}{$_} } @types)
 185             } keys %$stash;
 186         } else {
 187             defined &$it ? $it : ();
 188         }
 189     } else {
 190         my @ret;
 191         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 192         my_walksymtable {
 193             push @ret, "$stash$_" if /$findre/;
 194         } '::';
 195         map { s/^:*(?:main:+)*//;$_ } @ret;
 196     }
 197 }
 198
 199 =item C<@names = mod_subs($pack)>
 200
 201 Find subs in package C<$pack>.
 202
 203 =cut
 204
 205 sub mod_subs
 206 {
 207     no strict;
 208     my $p = shift;
 209     my $stash = \%{"$p\::"};
 210     if (defined $stash) {
 211         grep { defined &{"$p\::$_"} } keys %$stash;
 212     }
 213 }
 214
 215 =item C<@decls = mod_decls($pack)>
 216
 217 Generate a list of declarations for all subroutines in package
 218 C<$pack>.
 219
 220 =cut
 221
 222 sub mod_decls
 223 {
 224     my $pack = shift;
 225     no strict 'refs';
 226     my @ret = map {
 227         my $sn = $_;
 228         my $proto = prototype(\&{"$pack\::$sn"});
 229         $proto = defined($proto) ? "($proto)" : '';
 230         "sub $sn $proto;\n";
 231     } mod_subs($pack);
 232     return wantarray ? @ret : join '', @ret;
 233 }
 234
 235 =item C<$info = module_info($module, $type)>
 236
 237 Emacs-called function to get module information.
 238
 239 =cut
 240
 241 sub module_info($$)
 242 {
 243     my ($m, $func) = @_;
 244     my $info;
 245     if (-f $m) {
 246         $info = Module::Info->new_from_file($m);
 247     } else {
 248         (my $file = $m) =~ s|::|/|g;
 249         $file .= '.pm';
 250         if (exists $INC{$file}) {
 251             $info = Module::Info->new_from_loaded($m);
 252         } else {
 253             $info = Module::Info->new_from_module($m);
 254         }
 255     }
 256     if ($info) {
 257         return $info->$func;
 258     }
 259 }
 260
 261 =item C<$file = mod_file($mod)>
 262
 263 Find the likely file owner for module C<$mod>.
 264
 265 =cut
 266
 267 sub mod_file
 268 {
 269     my $m = shift;
 270     $m =~ s/::/\//g;
 271     while ($m && !exists $INC{"$m.pm"}) {
 272         $m =~ s#(?:^|/)[^/]+$##;
 273     }
 274     $m ? $INC{"$m.pm"} : undef;
 275 }
 276
 277 =item C<lexicals($subname)>
 278
 279 Return a list of C<$subname>'s lexical variables.  Note that this
 280 includes all nested scopes -- I don't know if or how Perl
 281 distinguishes inner blocks.
 282
 283 =cut
 284
 285 sub lexicals
 286 {
 287     my $cv = B::svref_2object(\&{+shift});
 288     return unless $cv && ($cv = $cv->PADLIST);
 289     my ($names, $vals) = $cv->ARRAY;
 290     map {
 291         my $name = $_->PV; $name =~ s/\0.*$//; $name
 292     } grep B::class($_) ne 'SPECIAL', $names->ARRAY;
 293 }
 294
 295 =item C<$lisp = tolisp($perl)>
 296
 297 Convert a Perl scalar to some ELisp equivalent.
 298
 299 =cut
 300
 301 sub tolisp($)
 302 {
 303     my $thing = @_ == 1 ? shift : \@_;
 304     my $t = ref $thing;
 305     if (!$t) {
 306         if (looks_like_number $thing) {
 307             ''.$thing;
 308         } else {
 309             qq{"$thing"};
 310         }
 311     } elsif ($t eq 'GLOB') {
 312         (my $name = $$thing) =~ s/\*main:://;
 313         $name;
 314     } elsif ($t eq 'ARRAY') {
 315         '(' . join(' ', map { tolisp($_) } @$thing).')'
 316     } elsif ($t eq 'HASH') {
 317         '(' . join(' ', map {
 318             '(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
 319         } keys %$thing).')'
 320     } elsif ($t eq 'Regexp') {
 321         "'(regexp . \"" . quotemeta($thing) . '")';
 322 #     } elsif ($t eq 'IO') {
 323     } else {
 324         qq{"$thing"};
 325     }
 326 }
 327
 328 =item C<printer(\@res [, $iseval])>
 329
 330 Print C<@res> appropriately on the current filehandle.  If C<$iseval>
 331 is true, use terse format.  Otherwise, use human-readable format.
 332
 333 =cut
 334
 335 sub printer
 336 {
 337     no strict;
 338     local *res = shift;
 339     my ($iseval, $wantarray) = @_;
 340     @__ = @res;
 341     my $str;
 342     if ($iseval) {
 343         $__ = "@res";
 344     } elsif ($fancy) {
 345         local $Data::Dumper::Deparse = 1;
 346         local $Data::Dumper::Indent = 0;
 347         $__ = Data::Dumper::Dumper(@res > 1 ? \@res : $res[0]);
 348         $__ =~ s/^\$VAR1 = //;
 349         $__ =~ s/;$//;
 350     } else {
 351         $__ = "@res";
 352     }
 353     if ($iseval) {
 354         print ';;;', length $__, "\n$__\n";
 355     } else {
 356         print "=> $__\n";
 357     }
 358 }
 359
 360 =item C<repl(\*FH)>
 361
 362 Execute a command interpreter on FH.  The prompt has a few bells and
 363 whistles, including:
 364
 365   * Obviously-incomplete lines are treated as multiline input.
 366
 367   * C<die> is overridden to enter a recursive interpreter at the point
 368     C<die> is called.  From within this interpreter, you can examine a
 369     backtrace by calling "bt", return from C<die> with "r EXPR", or
 370     go ahead and die by pressing Control-c.
 371
 372 Behavior is controlled in part through the following package-globals:
 373
 374 =over 4
 375
 376 =item C<$PS1> -- the default prompt
 377
 378 =item C<$stopdie> -- true to enter the inspector on C<die()>
 379
 380 =item C<$stopwarn> -- true to enter the inspector on C<warn()>
 381
 382 =item C<$fancy> -- true for pretty-printing via L<Data::Dumper>
 383
 384 =item C<%REPL> -- maps shortcut names to handlers
 385
 386 =cut
 387
 388 use vars qw($PS1 $dies $stopdie $stopwarn $fancy %REPL %RK $PACKAGE);
 389 BEGIN {
 390     no strict;
 391     $PS1 = "> ";
 392     $dies = 0;
 393     $stopdie = 1;
 394     $stopwarn = 0;
 395     $fancy = 1;
 396     $PACKAGE = 'main';
 397     %REPL = (help => \&Sepia::repl_help,
 398              cd => \&Sepia::repl_chdir,
 399              package => \&Sepia::repl_package);
 400     %RK = abbrev keys %REPL;
 401 }
 402
 403 sub prompt()
 404 {
 405     "$PACKAGE\:$PS1"
 406 }
 407
 408 sub Dump {
 409     Data::Dumper->Dump([$_[0]], [$_[1]]);
 410 }
 411
 412 my $FRAMES = 4;
 413
 414 sub hiding_me
 415 {
 416     my ($fn, @args) = @_;
 417     sub {
 418         uplevel $FRAMES, $fn, @args
 419     }
 420 }
 421
 422 sub eval_in_env
 423 {
 424     my ($expr, $env) = @_;
 425     local $::ENV = $env;
 426     my $str = '';
 427     for (keys %$env) {
 428         next unless /^([\$\@%])(.+)/;
 429         $str .= "local *$2 = \$::ENV->{'$_'}; ";
 430     }
 431     eval "do { no strict; $str $expr }";
 432 }
 433
 434 sub debug_upeval
 435 {
 436     my ($lev, $exp) = $_[0] =~ /^\s*(\d+)\s+(.*)/;
 437     print " <= $exp\n";
 438     (0, eval_in_env($exp, PadWalker::peek_my(0+$lev)));
 439 }
 440
 441 sub debug_inspect
 442 {
 443     local $_ = shift;
 444     for my $i (split) {
 445         my $sub = (caller $i)[3];
 446         next unless $sub;
 447         my $h = PadWalker::peek_my($i);
 448         print "[$i] $sub:\n";
 449         for (sort keys %$h) {
 450             print "\t", Sepia::Dump($h->{$_}, $_);
 451         }
 452     }
 453     0;
 454 }
 455
 456 sub repl_help
 457 {
 458     print <<EOS;
 459 REPL commands (prefixed with ','):
 460     cd DIR             Change directory to DIR
 461     package PACKAGE    Set evaluation package to PACKAGE
 462 EOS
 463     0;
 464 }
 465
 466 sub repl_chdir
 467 {
 468     chomp(my $dir = shift);
 469     if (-d $dir) {
 470         chdir $dir;
 471         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 472         print ";;;###".length($ecmd)."\n$ecmd\n";
 473     } else {
 474         warn "Can't chdir\n";
 475     }
 476     0;
 477 }
 478
 479 sub repl_package
 480 {
 481     chomp(my $p = shift);
 482     no strict;
 483     if (defined %{$p.'::'}) {
 484         $PACKAGE = $p;
 485 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
 486 #         print ";;;###".length($ecmd)."\n$ecmd\n";
 487     } else {
 488         warn "Can't go to package $p -- doesn't exist!\n";
 489     }
 490     0;
 491 }
 492
 493 sub debug_help
 494 {
 495     print <<EOS;
 496 Inspector commands (prefixed with ','):
 497     \\C-c        Pop one debugger level
 498     backtrace       show backtrace
 499     inspect N ...   inspect lexicals in frame(s) N ...
 500     eval N EXPR     evaluate EXPR in lexical environment of frame N
 501     return EXPR     return EXPR
 502     die/warn        keep on dying/warning
 503 EOS
 504     0;
 505 }
 506
 507 sub debug_backtrace
 508 {
 509     Carp::cluck;0
 510 }
 511
 512 sub debug_return
 513 {
 514     (1, repl_eval(@_));
 515 }
 516
 517 sub repl_eval
 518 {
 519     my ($buf, $wantarray, $pkg) = @_;
 520     no strict;
 521     local $PACKAGE = $pkg || $PACKAGE;
 522     $buf = "do { package $PACKAGE; no strict; $buf }";
 523 #     open O, ">>/tmp/blah";
 524 #     print O "##############################\n$buf";
 525 #     close O;
 526     if ($wantarray || !defined($wantarray)) {
 527         eval $buf;
 528     } else {
 529         scalar eval $buf;
 530     }
 531 }
 532
 533 sub repl
 534 {
 535     my ($fh, $level) = @_;
 536     select((select($fh), $|=1)[0]);
 537     my $in;
 538     my $buf = '';
 539     my $sigged = 0;
 540
 541     my $nextrepl = sub { $sigged = 1; };
 542
 543     local *__;
 544     my $MSG = "('\\C-c' to exit, ',h' for help)";
 545     my %dhooks = (
 546                 backtrace => \&Sepia::debug_backtrace,
 547                 inspect => \&Sepia::debug_inspect,
 548                 eval => \&Sepia::debug_upeval,
 549                 return => \&Sepia::debug_return,
 550                 help => \&Sepia::debug_help,
 551             );
 552     local *CORE::GLOBAL::die = sub {
 553         my @dieargs = @_;
 554         if ($stopdie) {
 555             local $dies = $dies+1;
 556             local $PS1 = "*$dies*> ";
 557             no strict;
 558             local %Sepia::REPL = (
 559                 %dhooks, die => sub { local $Sepia::stopdie=0; die @dieargs });
 560             local %Sepia::RK = abbrev keys %Sepia::REPL;
 561             print "@_\nDied $MSG\n";
 562             return Sepia::repl($fh, 1);
 563         }
 564         CORE::die(@_);
 565     };
 566
 567     local *CORE::GLOBAL::warn = sub {
 568         if ($stopwarn) {
 569             local $dies = $dies+1;
 570             local $PS1 = "*$dies*> ";
 571             no strict;
 572             local %Sepia::REPL = (
 573                 %dhooks, warn => sub { local $Sepia::stopwarn=0; warn @dieargs });
 574             local %Sepia::RK = abbrev keys %Sepia::REPL;
 575             print "@_\nWarned $MSG\n";
 576             return Sepia::repl($fh, 1);
 577         }
 578         CORE::warn(@_);
 579     };
 580
 581     print prompt;
 582     my @sigs = qw(INT TERM PIPE ALRM);
 583     local @SIG{@sigs};
 584     $SIG{$_} = $nextrepl for @sigs;
 585  repl: while (my $in = <$fh>) {
 586             if ($sigged) {
 587                 $buf = '';
 588                 $sigged = 0;
 589                 print "\n", prompt;
 590                 next repl;
 591             }
 592             $buf .= $in;
 593             my $iseval;
 594             if ($buf =~ /^<<(\d+)\n(.*)/) {
 595                 $iseval = 1;
 596                 my $len = $1;
 597                 my $tmp;
 598                 $buf = $2;
 599                 while ($len && defined($tmp = read $fh, $buf, $len, length $buf)) {
 600                     $len -= $tmp;
 601                 }
 602             }
 603             my (@res, @warn);
 604             local $SIG{__WARN__} = sub {
 605                 push @warn, shift;
 606             };
 607             if ($buf =~ /^,(\S+)\s*(.*)/s) {
 608                 ## Inspector shortcuts
 609                 if (exists $Sepia::RK{$1}) {
 610                     my $ret;
 611                     ($ret, @res) = $Sepia::REPL{$Sepia::RK{$1}}->($2, wantarray);
 612                     if ($ret) {
 613                         return wantarray ? @res : $res[0];
 614                     }
 615                 } else {
 616                     print "Unrecignized shortcut '$1'\n";
 617                     $buf = '';
 618                     print prompt;
 619                     next repl;
 620                 }
 621             } else {
 622                 ## Ordinary eval
 623                 @res = repl_eval $buf, wantarray;
 624
 625                 if ($@) {
 626                     if ($@ =~ /at EOF$/m) {
 627                         ## Possibly-incomplete line
 628                         if ($in eq "\n") {
 629                             print "*** cancel ***\n", prompt;
 630                             $buf = '';
 631                         } else {
 632                             print ">> ";
 633                         }
 634                         next repl;
 635                     } else {
 636                         warn $@;
 637                         $buf = '';
 638                         Sepia::printer \@res, $iseval, wantarray if $iseval;
 639                     }
 640                 }
 641             }
 642             if ($buf !~ /;$/) {
 643                 ## Be quiet if it ends with a semicolon.
 644                 Sepia::printer \@res, $iseval, wantarray;
 645             }
 646             $buf = '';
 647             if (@warn) {
 648                 if ($iseval) {
 649                     my $tmp = "@warn";
 650                     print ';;;'.length($tmp)."\n$tmp\n";
 651                 } else {
 652                     print "@warn\n";
 653                 }
 654             }
 655             print prompt;
 656         }
 657 }
 658
 659 sub perl_eval
 660 {
 661     tolisp(repl_eval(shift));
 662 }
 663
 664 1;