lib/Sepia.pm

   1 package Sepia;
   2
   3 =head1 NAME
   4
   5 Sepia - Simple Emacs-Perl Interface
   6
   7 =head1 SYNOPSIS
   8
   9 From inside Emacs:
  10
  11    M-x load-library RET sepia RET
  12    M-x sepia-init RET
  13
  14 At the prompt in the C<*perl-interaction*> buffer:
  15
  16    main @> ,help
  17
  18 =cut
  19
  20 $VERSION = '0.75';
  21 @ISA = qw(Exporter);
  22
  23 require Exporter;
  24 use strict;
  25 use Cwd 'abs_path';
  26 use Scalar::Util 'looks_like_number';
  27 use Module::Info;
  28 use Text::Abbrev;
  29 use Carp;
  30 use B;
  31
  32 use vars qw($PS1 $dies $STOPDIE $STOPWARN %REPL %RK %REPL_DOC
  33             $PACKAGE $WANTARRAY $PRINTER $STRICT $PRINT_PRETTY);
  34
  35 BEGIN {
  36     eval { require PadWalker; import PadWalker qw(peek_my) };
  37     if ($@) {
  38         *peek_my = sub { +{ } };
  39     }
  40     eval { require Lexical::Persistence; import Lexical::Persistence };
  41     if ($@) {
  42         *repl_strict = sub {
  43             print STDERR "Strict mode requires Lexical::Persistence.\n";
  44             0;
  45         };
  46     } else {
  47         *repl_strict = sub {
  48             my $x = as_boolean(shift, $STRICT);
  49             if ($x && !$STRICT) {
  50                 $STRICT = new Lexical::Persistence;
  51             } elsif (!$x) {
  52                 undef $STRICT;
  53             }
  54             0;
  55         };
  56     }
  57 }
  58
  59 =head1 DESCRIPTION
  60
  61 Sepia is a set of features to make Emacs a better tool for Perl
  62 development.  This package contains the Perl side of the
  63 implementation, including all user-serviceable parts (for the
  64 cross-referencing facility see L<Sepia::Xref>).
  65
  66 Though not intended to be used independent of the Emacs interface, the
  67 Sepia module's functionality can be used through a rough procedural
  68 interface.
  69
  70 =head2 C<@compls = completions($string [, $type])>
  71
  72 Find a list of completions for C<$string> with glob type $type.
  73 Completion operates on word subparts separated by [:_], so
  74 e.g. "S:m_w" completes to "Sepia::my_walksymtable".
  75
  76 =cut
  77
  78 sub _apropos_re($)
  79 {
  80     # Do that crazy multi-word identifier completion thing:
  81     my $re = shift;
  82     return qr/.*/ if $re eq '';
  83     if (wantarray) {
  84         map {
  85             s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
  86             qr/^$_/
  87         } split /:+/, $re, -1;
  88     } else {
  89         if ($re !~ /[^\w\d_^:]/) {
  90             $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
  91         }
  92         qr/$re/;
  93     }
  94 }
  95
  96 sub _completions1
  97 {
  98     no strict;
  99     my $stash = shift;
 100     my $re = shift || '';
 101     $re = qr/$re/;
 102     if (@_ == 0 || !defined $_[0]) {
 103         map "$stash$_", grep /$re/, keys %$stash;
 104     } else {
 105         map {
 106             _completions1("$stash$_", @_);
 107         } grep /$re.*::$/, keys %$stash;
 108     };
 109 }
 110
 111 sub _completions
 112 {
 113     _completions1 '::', _apropos_re($_[0]);
 114 }
 115
 116 my %sigil;
 117 BEGIN {
 118     %sigil = qw(ARRAY @ SCALAR $ HASH %);
 119 }
 120
 121 sub completions
 122 {
 123     no strict;
 124     my ($str, $type, $infunc) = @_;
 125     my @ret;
 126
 127     if (!$type) {
 128         @ret = grep {
 129             defined *{$_}{CODE} || defined *{$_}{IO}
 130                 || (/::$/ && defined *{$_}{HASH});
 131         } _completions $str;
 132     } else {
 133         @ret = grep {
 134             $type eq 'SCALAR' ? defined ${$_} : defined *{$_}{$type}
 135         } _completions $str;
 136         if (defined $infunc && defined *{$infunc}{CODE}) {
 137             my ($apre) = _apropos_re($str);
 138             my $st = $sigil{$type};
 139             push @ret, grep {
 140                 (my $tmp = $_) =~ s/^\Q$st//;
 141                 $tmp =~ /$apre/;
 142             } lexicals($infunc);
 143         }
 144     }
 145
 146     ## Complete "simple" sequences as abbreviations, e.g.:
 147     ##   wtci -> Want_To_Complete_It, NOT
 148     ##        -> WaTCh_trIpe
 149     if (!@ret && $str !~ /[^\w\d]/) {
 150         my $broad = join '.*', map "\\b$_", split '', $str;
 151         if ($type) {
 152             @ret = grep {
 153                 defined *{$_}{CODE} || defined *{$_}{IO}
 154                     || (/::$/ && defined *{$_}{HASH});
 155             } _completions1 '::', qr/$broad/;
 156         } else {
 157             @ret = grep {
 158                 $type eq 'SCALAR' ? defined ${$_} : defined *{$_}{$type}
 159             } _completions1 '::', qr/$broad/;
 160         }
 161         if (defined $infunc && defined *{$infunc}{CODE}) {
 162             my $st = $sigil{$type};
 163             grep {
 164                 (my $tmp = $_) =~ s/^\Q$st//;
 165                 $tmp =~ /$broad/;
 166             } lexicals($infunc);
 167         }
 168     }
 169     ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
 170     ## remove them.
 171     grep {
 172         !looks_like_number $_ && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
 173     } map { s/^:://; $_ } @ret;
 174 }
 175
 176 =head2 C<@locs = location(@names)>
 177
 178 Return a list of [file, line, name] triples, one for each function
 179 name in C<@names>.
 180
 181 =cut
 182
 183 sub location
 184 {
 185     no strict;
 186     my @x= map {
 187         my $str = $_;
 188         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 189             if ($pfx) {
 190                 warn "Sorry -- can't lookup variables.";
 191                 [];
 192             } else {
 193                 # XXX: svref_2object only seems to work with a package
 194                 # tacked on, but that should probably be done
 195                 # elsewhere...
 196                 $name = 'main::'.$name unless $name =~ /::/;
 197                 my $cv = B::svref_2object(\&{$name});
 198                 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
 199                     my ($file, $line) = ($cv->file, $cv->line);
 200                     if ($file !~ /^\//) {
 201                         for (@INC) {
 202                             if (-f "$_/$file") {
 203                                 $file = "$_/$file";
 204                                 last;
 205                             }
 206                         }
 207                     }
 208                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 209                     [Cwd::abs_path($file), $line, $shortname || $name]
 210                 } else {
 211 #                    warn "Bad CV for $name: $cv";
 212                     [];
 213                 }
 214             }
 215         } else {
 216             []
 217         }
 218     } @_;
 219     return @x;
 220 }
 221
 222 =head2 C<@matches = apropos($name [, $is_regex])>
 223
 224 Search for function C<$name>, either in all packages or, if C<$name>
 225 is qualified, only in one package.  If C<$is_regex> is true, the
 226 non-package part of C<$name> is a regular expression.
 227
 228 =cut
 229
 230 sub my_walksymtable(&*)
 231 {
 232     no strict;
 233     my ($f, $st) = @_;
 234     local *_walk = sub {
 235         local ($stash) = @_;
 236         &$f for keys %$stash;
 237         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 238     };
 239     _walk($st);
 240 }
 241
 242 sub apropos
 243 {
 244     my ($it, $re, @types) = @_;
 245     my $stashp;
 246     if (@types) {
 247         $stashp = grep /STASH/, @types;
 248         @types = grep !/STASH/, @types;
 249     } else {
 250         @types = qw(CODE);
 251     }
 252     no strict;
 253     if ($it =~ /^(.*::)([^:]+)$/) {
 254         my ($stash, $name) = ($1, $2);
 255         if (!defined %$stash) {
 256             return;
 257         }
 258         if ($re) {
 259             my $name = qr/^$name/;
 260             map {
 261                 "$stash$_"
 262             }
 263             grep {
 264                 my $stashnm = "$stash$_";
 265                 /$name/ &&
 266                     (($stashp && /::$/)
 267                      || scalar grep { defined *{$stashnm}{$_} } @types)
 268             } keys %$stash;
 269         } else {
 270             defined &$it ? $it : ();
 271         }
 272     } else {
 273         my @ret;
 274         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 275         my_walksymtable {
 276             push @ret, "$stash$_" if /$findre/;
 277         } '::';
 278         map { s/^:*(?:main:+)*//;$_ } @ret;
 279     }
 280 }
 281
 282 =head2 C<@names = mod_subs($pack)>
 283
 284 Find subs in package C<$pack>.
 285
 286 =cut
 287
 288 sub mod_subs
 289 {
 290     no strict;
 291     my $p = shift;
 292     my $stash = \%{"$p\::"};
 293     if (defined $stash) {
 294         grep { defined &{"$p\::$_"} } keys %$stash;
 295     }
 296 }
 297
 298 =head2 C<@decls = mod_decls($pack)>
 299
 300 Generate a list of declarations for all subroutines in package
 301 C<$pack>.
 302
 303 =cut
 304
 305 sub mod_decls
 306 {
 307     my $pack = shift;
 308     no strict 'refs';
 309     my @ret = map {
 310         my $sn = $_;
 311         my $proto = prototype(\&{"$pack\::$sn"});
 312         $proto = defined($proto) ? "($proto)" : '';
 313         "sub $sn $proto;\n";
 314     } mod_subs($pack);
 315     return wantarray ? @ret : join '', @ret;
 316 }
 317
 318 =head2 C<$info = module_info($module, $type)>
 319
 320 Emacs-called function to get module information.
 321
 322 =cut
 323
 324 sub module_info($$)
 325 {
 326     my ($m, $func) = @_;
 327     my $info;
 328     if (-f $m) {
 329         $info = Module::Info->new_from_file($m);
 330     } else {
 331         (my $file = $m) =~ s|::|/|g;
 332         $file .= '.pm';
 333         if (exists $INC{$file}) {
 334             $info = Module::Info->new_from_loaded($m);
 335         } else {
 336             $info = Module::Info->new_from_module($m);
 337         }
 338     }
 339     if ($info) {
 340         return $info->$func;
 341     }
 342 }
 343
 344 =head2 C<$file = mod_file($mod)>
 345
 346 Find the likely file owner for module C<$mod>.
 347
 348 =cut
 349
 350 sub mod_file
 351 {
 352     my $m = shift;
 353     $m =~ s/::/\//g;
 354     while ($m && !exists $INC{"$m.pm"}) {
 355         $m =~ s#(?:^|/)[^/]+$##;
 356     }
 357     $m ? $INC{"$m.pm"} : undef;
 358 }
 359
 360 =head2 C<@mods = package_list>
 361
 362 Gather a list of all distributions on the system. XXX UNUSED
 363
 364 =cut
 365
 366 our $INST;
 367 sub inst()
 368 {
 369     unless ($INST) {
 370         eval 'require ExtUtils::Installed';
 371         $INST = new ExtUtils::Installed;
 372     }
 373     $INST;
 374 }
 375
 376 sub package_list
 377 {
 378     sort { $a cmp $b } inst()->modules;
 379 }
 380
 381 =head2 C<@mods = module_list>
 382
 383 Gather a list of all packages (.pm files, really) installed on the
 384 system, grouped by distribution. XXX UNUSED
 385
 386 =cut
 387
 388 sub module_list
 389 {
 390     @_ = package_list unless @_;
 391     my $incre = join '|', map quotemeta, @INC;
 392     $incre = qr|(?:$incre)/|;
 393     my $inst = inst;
 394     map {
 395         [$_, sort map {
 396             s/$incre//; s|/|::|g;$_
 397         } grep /\.pm$/, $inst->files($_)]
 398     } @_;
 399 }
 400
 401 =head2 C<@mods = doc_list>
 402
 403 Gather a list of all documented packages (.?pm files, really)
 404 installed on the system, grouped by distribution. XXX UNUSED
 405
 406 =cut
 407
 408 sub doc_list
 409 {
 410     @_ = package_list unless @_;
 411     my $inst = inst;
 412     map {
 413         [$_, sort map {
 414             s/.*man.\///; s|/|::|g;s/\..?pm//; $_
 415         } grep /\..pm$/, $inst->files($_)]
 416     } @_;
 417 }
 418
 419 =head2 C<lexicals($subname)>
 420
 421 Return a list of C<$subname>'s lexical variables.  Note that this
 422 includes all nested scopes -- I don't know if or how Perl
 423 distinguishes inner blocks.
 424
 425 =cut
 426
 427 sub lexicals
 428 {
 429     my $cv = B::svref_2object(\&{+shift});
 430     return unless $cv && ($cv = $cv->PADLIST);
 431     my ($names, $vals) = $cv->ARRAY;
 432     map {
 433         my $name = $_->PV; $name =~ s/\0.*$//; $name
 434     } grep B::class($_) ne 'SPECIAL', $names->ARRAY;
 435 }
 436
 437 =head2 C<$lisp = tolisp($perl)>
 438
 439 Convert a Perl scalar to some ELisp equivalent.
 440
 441 =cut
 442
 443 sub tolisp($)
 444 {
 445     my $thing = @_ == 1 ? shift : \@_;
 446     my $t = ref $thing;
 447     if (!$t) {
 448         if (!defined $thing) {
 449             'nil'
 450         } elsif (looks_like_number $thing) {
 451             ''.(0+$thing);
 452         } else {
 453             qq{"$thing"};
 454         }
 455     } elsif ($t eq 'GLOB') {
 456         (my $name = $$thing) =~ s/\*main:://;
 457         $name;
 458     } elsif ($t eq 'ARRAY') {
 459         '(' . join(' ', map { tolisp($_) } @$thing).')'
 460     } elsif ($t eq 'HASH') {
 461         '(' . join(' ', map {
 462             '(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
 463         } keys %$thing).')'
 464     } elsif ($t eq 'Regexp') {
 465         "'(regexp . \"" . quotemeta($thing) . '")';
 466 #     } elsif ($t eq 'IO') {
 467     } else {
 468         qq{"$thing"};
 469     }
 470 }
 471
 472 =head2 C<printer(\@res [, $iseval])>
 473
 474 Print C<@res> appropriately on the current filehandle.  If C<$iseval>
 475 is true, use terse format.  Otherwise, use human-readable format,
 476 which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
 477
 478 =cut
 479
 480 sub print_dumper
 481 {
 482     local $Data::Dumper::Deparse = 1;
 483     local $Data::Dumper::Indent = 0;
 484     no strict;
 485     eval {
 486         local $_ = Data::Dumper::Dumper(@res > 1 ? \@res : $res[0]);
 487         s/^\$VAR1 = //;
 488         s/;$//;
 489         $_;
 490     };
 491 }
 492
 493 sub print_plain
 494 {
 495     no strict;
 496     "@res";
 497 }
 498
 499 sub print_yaml
 500 {
 501     no strict;
 502     eval { require YAML };
 503     if ($@) {
 504         print_dumper;
 505     } else {
 506         YAML::Dump(\@res);
 507     }
 508 }
 509
 510 sub print_dump
 511 {
 512     no strict;
 513     eval { require Data::Dump };
 514     if ($@) {
 515         print_dumper;
 516     } else {
 517         Data::Dump::dump;
 518     }
 519 }
 520
 521 sub printer
 522 {
 523     no strict;
 524     local *res = shift;
 525     my ($iseval, $wantarray) = @_;
 526     @::__ = @res;
 527     $::__ = @res == 1 ? $res[0] : [@res];
 528     my $str;
 529     if ($iseval) {
 530         $res = "@res";
 531     } elsif (@res == 1 && (ref $res[0]) =~ /^PDL/) {
 532         $res = $res[0];
 533     } elsif (!$iseval && $PRINT_PRETTY && @res > 1 && grep !ref $_, @res) {
 534         $res = columnate(@res);
 535         print $res;
 536         return;
 537     } else {
 538         $res = $PRINTER->();
 539     }
 540     if ($iseval) {
 541         print ';;;', length $res, "\n$::__\n";
 542     } else {
 543         print "=> $res\n";
 544     }
 545 }
 546
 547 =head2 C<repl(\*FH)>
 548
 549 Execute a command interpreter on FH.  The prompt has a few bells and
 550 whistles, including:
 551
 552   * Obviously-incomplete lines are treated as multiline input (press
 553     'return' twice or 'C-c' to discard).
 554
 555   * C<die> is overridden to enter a recursive interpreter at the point
 556     C<die> is called.  From within this interpreter, you can examine a
 557     backtrace by calling "bt", return from C<die> with "r EXPR", or
 558     go ahead and die by pressing Control-c.
 559
 560 Behavior is controlled in part through the following package-globals:
 561
 562 =over 4
 563
 564 =item C<$PACKAGE> -- evaluation package
 565
 566 =item C<$PRINTER> -- result printer (default: print_dumper)
 567
 568 =item C<$PS1> -- the default prompt
 569
 570 =item C<$STOPDIE> -- true to enter the inspector on C<die()>
 571
 572 =item C<$STOPWARN> -- true to enter the inspector on C<warn()>
 573
 574 =item C<$STRICT> -- whether 'use strict' is applied to input
 575
 576 =item C<$WANTARRAY> -- evaluation context
 577
 578 =item C<$PRINT_PRETTY> -- format some output nicely (default = 0)
 579
 580 Format some values nicely, independent of $PRINTER.  Currently, this
 581 displays arrays of scalars as columns.
 582
 583 =item C<%REPL> -- maps shortcut names to handlers
 584
 585 =item C<%REPL_DOC> -- maps shortcut names to documentation
 586
 587 =back
 588
 589 =cut
 590
 591 BEGIN {
 592     no strict;
 593     $PS1 = "> ";
 594     $dies = 0;
 595     $STOPDIE = 1;
 596     $STOPWARN = 0;
 597     $PACKAGE = 'main';
 598     $WANTARRAY = 1;
 599     $PRINTER = \&Sepia::print_dumper;
 600     $PRINT_PRETTY = 0;
 601     %REPL = (help => \&Sepia::repl_help,
 602              cd => \&Sepia::repl_chdir,
 603              methods => \&Sepia::repl_methods,
 604              package => \&Sepia::repl_package,
 605              who => \&Sepia::repl_who,
 606              wantarray => \&Sepia::repl_wantarray,
 607              format => \&Sepia::repl_format,
 608              strict => \&Sepia::repl_strict,
 609              quit => \&Sepia::repl_quit,
 610          );
 611     %REPL_DOC = (
 612         cd =>
 613     'cd DIR            Change directory to DIR',
 614         format =>
 615     'format [dumper|dump|yaml|plain]
 616                        Set output formatter (default: dumper)',
 617         help =>
 618     'help               Display this message',
 619         methods => <<EOS,
 620     'methods X [RE]     List methods for reference or package X,
 621                         matching optional pattern RE.
 622 EOS
 623         package =>
 624     'package PACKAGE    Set evaluation package to PACKAGE',
 625         quit =>
 626     'quit               Quit the REPL',
 627         strict =>
 628     'strict [0|1]       Turn \'use strict\' mode on or off',
 629         wantarray =>
 630     'wantarray [0|1]    Set or toggle evaluation context',
 631         who => <<EOS,
 632 who PACKAGE [RE]   List variables and subs in PACKAGE matching optional
 633                    pattern RE.
 634 EOS
 635     );
 636     %RK = abbrev keys %REPL;
 637 }
 638
 639 sub prompt()
 640 {
 641     "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
 642 }
 643
 644 sub Dump {
 645     eval {
 646         Data::Dumper->Dump([$_[0]], [$_[1]]);
 647     };
 648 }
 649
 650 sub eval_in_env
 651 {
 652     my ($expr, $env) = @_;
 653     local $::ENV = $env;
 654     my $str = '';
 655     for (keys %$env) {
 656         next unless /^([\$\@%])(.+)/;
 657         $str .= "local *$2 = \$::ENV->{'$_'}; ";
 658     }
 659     eval "do { no strict; $str $expr }";
 660 }
 661
 662 sub debug_upeval
 663 {
 664     my ($lev, $exp) = $_[0] =~ /^\s*(\d+)\s+(.*)/;
 665     print " <= $exp\n";
 666     (0, eval_in_env($exp, peek_my(0+$lev)));
 667 }
 668
 669 sub debug_inspect
 670 {
 671     local $_ = shift;
 672     for my $i (split) {
 673         my $sub = (caller $i)[3];
 674         next unless $sub;
 675         my $h = peek_my($i);
 676         print "[$i] $sub:\n";
 677         no strict;
 678         for (sort keys %$h) {
 679             local @res = $h->{$_};
 680             print "\t$_ = ", $PRINTER->(), "\n";
 681         }
 682     }
 683     0;
 684 }
 685
 686 sub repl_help
 687 {
 688     print "REPL commands (prefixed with ','):\n";
 689     for (sort keys %REPL) {
 690         print "    ",
 691             exists $REPL_DOC{$_} ? "$REPL_DOC{$_}\n": "$_    (undocumented)\n";
 692     }
 693     0;
 694 }
 695
 696 sub repl_format
 697 {
 698     my $t = shift;
 699     chomp $t;
 700     $t = 'dumper' if $t eq '';
 701     my %formats = abbrev qw(dumper dump yaml plain);
 702     if (exists $formats{$t}) {
 703         no strict;
 704         $PRINTER = \&{'print_'.$formats{$t}};
 705     } else {
 706         warn "No such format '$t' (dumper, dump, yaml, plain).\n";
 707     }
 708     0;
 709 }
 710
 711 sub repl_chdir
 712 {
 713     chomp(my $dir = shift);
 714     $dir =~ s/^~\//$ENV{HOME}\//;
 715     $dir =~ s/\$HOME/$ENV{HOME}/;
 716     if (-d $dir) {
 717
 718         chdir $dir;
 719         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 720         print ";;;###".length($ecmd)."\n$ecmd\n";
 721     } else {
 722         warn "Can't chdir\n";
 723     }
 724     0;
 725 }
 726
 727 sub who
 728 {
 729     my ($pack, $re) = @_;
 730     $re ||= '.?';
 731     $re = qr/$re/;
 732     no strict;
 733     sort grep /$re/, map {
 734         (defined %{$pack.'::'.$_} ? '%'.$_ : (),
 735          defined ${$pack.'::'.$_} ? '$'.$_ : (), # ?
 736          defined @{$pack.'::'.$_} ? '@'.$_ : (),
 737          defined &{$pack.'::'.$_} ? $_ : (),
 738      )
 739     } grep !/::$/ && !/^(?:_<|[^\w])/, keys %{$pack.'::'};
 740 }
 741
 742
 743 sub columnate
 744 {
 745     my $len = 0;
 746     my $width = $ENV{COLUMNS} || 80;
 747     for (@_) {
 748         $len = length if $len < length;
 749     }
 750     my $nc = int($width / ($len+1)) || 1;
 751     my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
 752     my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
 753     my @incs = map { $_ * $nr } 0..$nc-1;
 754     my $str = '';
 755     for my $r (0..$nr-1) {
 756         $str .= sprintf $fmt, map { $_ || '' } @_[map { $r + $_ } @incs];
 757     }
 758     $str =~ s/ +$//m;
 759     $str
 760 }
 761
 762 sub repl_who
 763 {
 764     my ($pkg, $re) = split ' ', shift;
 765     print columnate who($pkg || $PACKAGE, $re);
 766     0;
 767 }
 768
 769 sub methods
 770 {
 771     my $pack = shift;
 772     no strict;
 773     (grep(defined *{"$pack\::$_"}{CODE}, keys %{$pack.'::'}),
 774      defined @{$pack.'::ISA'} ? (map methods($_), @{$pack.'::ISA'}) : ());
 775 }
 776
 777 sub repl_methods
 778 {
 779     my ($x, $re) = split ' ', shift;
 780     $x =~ s/^\s+//;
 781     $x =~ s/\s+$//;
 782     if ($x =~ /^\$/) {
 783         $x = repl_eval("ref $x");
 784         return 0 if $@;
 785     }
 786     $re ||= '.?';
 787     $re = qr/$re/;
 788     print columnate sort { $a cmp $b } grep /$re/, methods $x;
 789     0;
 790 }
 791
 792 sub as_boolean
 793 {
 794     my ($val, $cur) = @_;
 795     $val =~ s/\s+//g;
 796     length($val) ? $val : !$cur;
 797 }
 798
 799 sub repl_wantarray
 800 {
 801     $WANTARRAY = as_boolean shift, $WANTARRAY;
 802     0;
 803 }
 804
 805 sub repl_package
 806 {
 807     chomp(my $p = shift);
 808     no strict;
 809     if (defined %{$p.'::'}) {
 810         $PACKAGE = $p;
 811 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
 812 #         print ";;;###".length($ecmd)."\n$ecmd\n";
 813     } else {
 814         warn "Can't go to package $p -- doesn't exist!\n";
 815     }
 816     0;
 817 }
 818
 819 sub repl_quit
 820 {
 821     1;
 822 }
 823
 824 sub debug_help
 825 {
 826     print <<EOS;
 827 Inspector commands (prefixed with ','):
 828     \\C-c        Pop one debugger level
 829     backtrace       show backtrace
 830     inspect N ...   inspect lexicals in frame(s) N ...
 831     eval N EXPR     evaluate EXPR in lexical environment of frame N
 832     return EXPR     return EXPR
 833     die/warn        keep on dying/warning
 834 EOS
 835     0;
 836 }
 837
 838 sub debug_backtrace
 839 {
 840     Carp::cluck;0
 841 }
 842
 843 sub debug_return
 844 {
 845     (1, repl_eval(@_));
 846 }
 847
 848 sub repl_eval
 849 {
 850     my ($buf, $wantarray, $pkg) = @_;
 851     no strict;
 852     local $PACKAGE = $pkg || $PACKAGE;
 853     if ($STRICT) {
 854         if (!$WANTARRAY) {
 855             $buf = 'scalar($buf)';
 856         }
 857         my $ctx = join(',', keys %{$STRICT->get_context('_')});
 858         $ctx = $ctx ? "my ($ctx);" : '';
 859         $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
 860         if ($@) {
 861             print STDERR "ERROR\n$@\n";
 862             return;
 863         }
 864         $STRICT->call($buf);
 865     } else {
 866         $buf = "do { package $PACKAGE; no strict; $buf }";
 867         if ($WANTARRAY) {
 868             eval $buf;
 869         } else {
 870             scalar eval $buf;
 871         }
 872     }
 873 }
 874
 875 sub repl
 876 {
 877     my ($fh, $level) = @_;
 878     select((select($fh), $|=1)[0]);
 879     my $in;
 880     my $buf = '';
 881     my $sigged = 0;
 882
 883     my $nextrepl = sub { $sigged = 1; };
 884
 885     local *__;
 886     my $MSG = "('\\C-c' to exit, ',h' for help)";
 887     my %dhooks = (
 888                 backtrace => \&Sepia::debug_backtrace,
 889                 inspect => \&Sepia::debug_inspect,
 890                 eval => \&Sepia::debug_upeval,
 891                 return => \&Sepia::debug_return,
 892                 help => \&Sepia::debug_help,
 893             );
 894     local *CORE::GLOBAL::die = sub {
 895         my @dieargs = @_;
 896         if ($STOPDIE) {
 897             local $dies = $dies+1;
 898             local $PS1 = "*$dies*> ";
 899             no strict;
 900             local %Sepia::REPL = (
 901                 %dhooks, die => sub { local $Sepia::STOPDIE=0; die @dieargs });
 902             local %Sepia::RK = abbrev keys %Sepia::REPL;
 903             print "@_\nDied $MSG\n";
 904             return Sepia::repl($fh, 1);
 905         }
 906         CORE::die(@_);
 907     };
 908
 909     local *CORE::GLOBAL::warn = sub {
 910         if ($STOPWARN) {
 911             local $dies = $dies+1;
 912             local $PS1 = "*$dies*> ";
 913             no strict;
 914             local %Sepia::REPL = (
 915                 %dhooks, warn => sub { local $Sepia::STOPWARN=0; warn @dieargs });
 916             local %Sepia::RK = abbrev keys %Sepia::REPL;
 917             print "@_\nWarned $MSG\n";
 918             return Sepia::repl($fh, 1);
 919         }
 920         CORE::warn(@_);
 921     };
 922     print <<EOS;
 923 Sepia version $Sepia::VERSION.
 924 Press ",h" for help, or "^D" or ",q" to exit.
 925 EOS
 926     print prompt;
 927     my @sigs = qw(INT TERM PIPE ALRM);
 928     local @SIG{@sigs};
 929     $SIG{$_} = $nextrepl for @sigs;
 930  repl: while (my $in = <$fh>) {
 931             if ($sigged) {
 932                 $buf = '';
 933                 $sigged = 0;
 934                 print "\n", prompt;
 935                 next repl;
 936             }
 937             $buf .= $in;
 938             my $iseval;
 939             if ($buf =~ /^<<(\d+)\n(.*)/) {
 940                 $iseval = 1;
 941                 my $len = $1;
 942                 my $tmp;
 943                 $buf = $2;
 944                 while ($len && defined($tmp = read $fh, $buf, $len, length $buf)) {
 945                     $len -= $tmp;
 946                 }
 947             }
 948             my (@res, @warn);
 949             local $SIG{__WARN__} = sub {
 950                 push @warn, shift;
 951             };
 952             if ($buf =~ /^,(\S+)\s*(.*)/s) {
 953                 ## Inspector shortcuts
 954                 my $short = $1;
 955                 if (exists $Sepia::RK{$short}) {
 956                     my $ret;
 957                     my $arg = $2;
 958                     chomp $arg;
 959                     ($ret, @res) = $Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
 960                     if ($ret) {
 961                         return wantarray ? @res : $res[0];
 962                     }
 963                 } else {
 964                     if (grep /^$short/, keys %Sepia::REPL) {
 965                         print "Ambiguous shortcut '$short': ",
 966                             join(', ', sort grep /^$short/, keys %Sepia::REPL),
 967                                 "\n";
 968                     } else {
 969                         print "Unrecognized shortcut '$short'\n";
 970                     }
 971                     $buf = '';
 972                     print prompt;
 973                     next repl;
 974                 }
 975             } else {
 976                 ## Ordinary eval
 977                 @res = repl_eval $buf, wantarray;
 978
 979                 if ($@) {
 980                     if ($@ =~ /at EOF$/m) {
 981                         ## Possibly-incomplete line
 982                         if ($in eq "\n") {
 983                             print "Error:\n$@\n*** cancel ***\n", prompt;
 984                             $buf = '';
 985                         } else {
 986                             print ">> ";
 987                         }
 988                         next repl;
 989                     } else {
 990                         warn $@;
 991                         $buf = '';
 992                         Sepia::printer \@res, $iseval, wantarray if $iseval;
 993                     }
 994                 }
 995             }
 996             if ($buf !~ /;$/ && $buf !~ /^,/) {
 997                 ## Be quiet if it ends with a semicolon, or if we
 998                 ## executed a shortcut.
 999                 Sepia::printer \@res, $iseval, wantarray;
1000             }
1001             $buf = '';
1002             if (@warn) {
1003                 if ($iseval) {
1004                     my $tmp = "@warn";
1005                     print ';;;'.length($tmp)."\n$tmp\n";
1006                 } else {
1007                     print "@warn\n";
1008                 }
1009             }
1010             print prompt;
1011         }
1012 }
1013
1014 sub perl_eval
1015 {
1016     tolisp(repl_eval(shift));
1017 }
1018
1019 =head2 C<$status = html_module_list($file [, $prefix])>
1020
1021 Generate an HTML list of installed modules, looking inside of
1022 packages.  If C<$prefix> is missing, uses "about://perldoc/".
1023
1024 =head2 C<$status = html_package_list($file [, $prefix])>
1025
1026 Generate an HTML list of installed top-level modules, without looking
1027 inside of packages.  If C<$prefix> is missing, uses
1028 "about://perldoc/".
1029
1030 =cut
1031
1032 sub html_module_list
1033 {
1034     my ($file, $base) = @_;
1035     $base ||= 'about://perldoc/';
1036     my $inst = inst();
1037     return unless $inst;
1038     return unless open OUT, ">$file";
1039     print "<html><body><ul>";
1040     my $pfx = '';
1041     my %ns;
1042     for (package_list) {
1043         push @{$ns{$1}}, $_ if /^([^:]+)/;
1044     }
1045     for (sort keys %ns) {
1046         print qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
1047         for (sort @{$ns{$_}}) {
1048             my @fs = map {
1049                 s/.*man.\///; s|/|::|g; s/\..?pm//; $_
1050             } grep /\.\dpm$/, sort $inst->files($_);
1051             if (@fs == 1) {
1052                 print qq{<li><a href="$base$fs[0]">$fs[0]</a>};
1053             } else {
1054                 print qq{<li>$_<ul>};
1055                 for (@fs) {
1056                     print qq{<li><a href="$base$_">$_</a>};
1057                 }
1058                 print '</ul>';
1059             }
1060         }
1061         print qq{</ul>} if @{$ns{$_}} > 1;
1062     }
1063     print "</ul></body></html>\n";
1064     close OUT;
1065     1;
1066 }
1067
1068 sub html_package_list
1069 {
1070     my ($file, $base) = @_;
1071     return unless inst();
1072     $base ||= 'about://perldoc/';
1073     return unless open OUT, ">$file";
1074     print OUT "<html><body><ul>";
1075     my $pfx = '';
1076     my %ns;
1077     for (package_list) {
1078         push @{$ns{$1}}, $_ if /^([^:]+)/;
1079     }
1080     for (sort keys %ns) {
1081         if (@{$ns{$_}} == 1) {
1082             print OUT
1083                 qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
1084         } else {
1085             print OUT qq{<li><b>$_</b><ul>};
1086             print OUT qq{<li><a href="$base$_">$_</a>}
1087                 for sort @{$ns{$_}};
1088             print OUT qq{</ul>};
1089         }
1090     }
1091     print OUT "</ul></body></html>\n";
1092     close OUT;
1093     1;
1094 }
1095
1096 1;
1097 __END__
1098
1099 =head1 TODO
1100
1101 See the README file included with the distribution.
1102
1103 =head1 AUTHOR
1104
1105 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
1106
1107 Bug reports welcome, patches even more welcome.
1108
1109 =head1 COPYRIGHT
1110
1111 Copyright (C) 2005-2007 Sean O'Rourke.  All rights reserved, some
1112 wrongs reversed.  This module is distributed under the same terms as
1113 Perl itself.
1114
1115 =cut