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