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.html> or F<sepia.info>, which
  19 come with the distribution.
  20
  21 =cut
  22
  23 $VERSION = '0.991';
  24 use strict;
  25 use B;
  26 use Sepia::Debug;               # THIS TURNS ON DEBUGGING INFORMATION!
  27 use Cwd 'abs_path';
  28 use Scalar::Util 'looks_like_number';
  29 use Text::Abbrev;
  30 use File::Find;
  31 use Storable qw(store retrieve);
  32
  33 use vars qw($PS1 %REPL %RK %REPL_DOC %REPL_SHORT %PRINTER
  34             @REPL_RESULT @res
  35             $REPL_LEVEL $PACKAGE $WANTARRAY $PRINTER $STRICT $PRINT_PRETTY
  36             $ISEVAL $LAST_INPUT);
  37
  38 sub repl_strict
  39 {
  40     eval { require Lexical::Persistence; import Lexical::Persistence };
  41     if ($@) {
  42         print "Strict mode requires Lexical::Persistence.\n";
  43     } else {
  44         *repl_strict = sub {
  45             my $x = as_boolean(shift, $STRICT);
  46             if ($x && !$STRICT) {
  47                 $STRICT = new Lexical::Persistence;
  48             } elsif (!$x) {
  49                 undef $STRICT;
  50             }
  51         };
  52         goto &repl_strict;
  53     }
  54 }
  55
  56 sub core_version
  57 {
  58     eval { require Module::CoreList };
  59     if ($@) {
  60         '???';
  61     } else {
  62         *core_version = sub { Module::CoreList->first_release(@_) };
  63         goto &core_version;
  64     }
  65 }
  66
  67 BEGIN {
  68     eval { use List::Util 'max' };
  69     if ($@) {
  70         *Sepia::max = sub {
  71             my $ret = shift;
  72             for (@_) {
  73                 $ret = $_ if $_ > $ret;
  74             }
  75             $ret;
  76         };
  77     }
  78 }
  79
  80 sub repl_size
  81 {
  82     eval { require Devel::Size };
  83     if ($@) {
  84         print "Size requires Devel::Size.\n";
  85     } else {
  86         *Sepia::repl_size = sub {
  87             no strict 'refs';
  88             ## XXX: C&P from repl_who:
  89             my ($pkg, $re) = split ' ', shift || '';
  90             if ($pkg =~ /^\/(.*)\/?$/) {
  91                 $pkg = $PACKAGE;
  92                 $re = $1;
  93             } elsif (!$re && !%{$pkg.'::'}) {
  94                 $re = $pkg;
  95                 $pkg = $PACKAGE;
  96             }
  97             my @who = who($pkg, $re);
  98             my $len = max(3, map { length } @who) + 4;
  99             my $fmt = '%-'.$len."s%10d\n";
 100             # print "$pkg\::/$re/\n";
 101             print 'Var', ' ' x ($len + 2), "Bytes\n";
 102             print '-' x ($len-4), ' ' x 9, '-' x 5, "\n";
 103             my %res;
 104             for (@who) {
 105                 next unless /^[\$\@\%\&]/; # skip subs.
 106                 next if $_ eq '%SIG';
 107                 $res{$_} = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
 108             }
 109             for (sort { $res{$b} <=> $res{$a} } keys %res) {
 110                 printf $fmt, $_, $res{$_};
 111             }
 112         };
 113         goto &repl_size;
 114     }
 115 }
 116
 117 =head1 DESCRIPTION
 118
 119 Sepia is a set of features to make Emacs a better tool for Perl
 120 development.  This package contains the Perl side of the
 121 implementation, including all user-serviceable parts (for the
 122 cross-referencing facility see L<Sepia::Xref>).  This document is
 123 aimed as Sepia developers; for user documentation, see
 124 L<Sepia.html> or L<sepia.info>.
 125
 126 Though not intended to be used independent of the Emacs interface, the
 127 Sepia module's functionality can be used through a rough procedural
 128 interface.
 129
 130 =head2 C<@compls = completions($string [, $type])>
 131
 132 Find a list of completions for C<$string> with glob type C<$type>,
 133 which may be "SCALAR", "HASH", "ARRAY", "CODE", "IO", or the special
 134 value "VARIABLE", which means either scalar, hash, or array.
 135 Completion operates on word subparts separated by [:_], so
 136 e.g. "S:m_w" completes to "Sepia::my_walksymtable".
 137
 138 =head2 C<@compls = method_completions($expr, $string [,$eval])>
 139
 140 Complete among methods on the object returned by C<$expr>.  The
 141 C<$eval> argument, if present, is a function used to do the
 142 evaluation; the default is C<eval>, but for example the Sepia REPL
 143 uses C<Sepia::repl_eval>.  B<Warning>: Since it has to evaluate
 144 C<$expr>, method completion can be extremely problematic.  Use with
 145 care.
 146
 147 =cut
 148
 149 sub _apropos_re($)
 150 {
 151     # Do that crazy multi-word identifier completion thing:
 152     my $re = shift;
 153     return qr/.*/ if $re eq '';
 154     if (wantarray) {
 155         map {
 156             s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
 157             qr/^$_/
 158         } split /:+/, $re, -1;
 159     } else {
 160         if ($re !~ /[^\w\d_^:]/) {
 161             $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
 162         }
 163         qr/$re/;
 164     }
 165 }
 166
 167 my %sigil;
 168 BEGIN {
 169     %sigil = qw(ARRAY @ SCALAR $ HASH %);
 170 }
 171
 172 sub filter_untyped
 173 {
 174     no strict;
 175     local $_ = /^::/ ? $_ : "::$_";
 176     defined *{$_}{CODE} || defined *{$_}{IO} || (/::$/ && %$_);
 177 }
 178
 179 ## XXX: Careful about autovivification here!  Specifically:
 180 ##     defined *FOO{HASH} # => ''
 181 ##     defined %FOO       # => ''
 182 ##     defined *FOO{HASH} # => 1
 183 sub filter_typed
 184 {
 185     no strict;
 186     my $type = shift;
 187     local $_ = /^::/ ? $_ : "::$_";
 188     if ($type eq 'SCALAR') {
 189         defined $$_;
 190     } elsif ($type eq 'VARIABLE') {
 191         defined $$_ || defined *{$_}{HASH} || defined *{$_}{ARRAY};
 192     } else {
 193         defined *{$_}{$type}
 194     }
 195 }
 196
 197 sub maybe_icase
 198 {
 199     my $ch = shift;
 200     return '' if $ch eq '';
 201     $ch =~ /[A-Z]/ ? $ch : '['.uc($ch).$ch.']';
 202 }
 203
 204 sub all_abbrev_completions
 205 {
 206     use vars '&_completions';
 207     local *_completions = sub {
 208         no strict;
 209         my ($stash, @e) = @_;
 210         my $ch = '[A-Za-z0-9]*';
 211         my $re1 = "^".maybe_icase($e[0]).$ch.join('', map {
 212             '_'.maybe_icase($_).$ch
 213         } @e[1..$#e]);
 214         $re1 = qr/$re1/;
 215         my $re2 = maybe_icase $e[0];
 216         $re2 = qr/^$re2.*::$/;
 217         my @ret = grep !/::$/ && /$re1/, keys %{$stash};
 218         my @pkgs = grep /$re2/, keys %{$stash};
 219         (map("$stash$_", @ret),
 220          @e > 1 ? map { _completions "$stash$_", @e[1..$#e] } @pkgs :
 221              map { "$stash$_" } @pkgs)
 222     };
 223     map { s/^:://; $_ } _completions('::', split //, shift);
 224 }
 225
 226 sub apropos_re
 227 {
 228     my ($icase, $re) = @_;
 229     $re =~ s/_/[^_]*_/g;
 230     $icase ? qr/^$re.*$/i : qr/^$re.*$/;
 231 }
 232
 233 sub all_completions
 234 {
 235     my $icase = $_[0] !~ /[A-Z]/;
 236     my @parts = split /:+/, shift, -1;
 237     my $re = apropos_re $icase, pop @parts;
 238     use vars '&_completions';
 239     local *_completions = sub {
 240         no strict;
 241         my $stash = shift;
 242         if (@_ == 0) {
 243             map { "$stash$_" } grep /$re/, keys %{$stash};
 244         } else {
 245             my $re2 = $icase ? qr/^$_[0].*::$/i : qr/^$_[0].*::$/;
 246             my @pkgs = grep /$re2/, keys %{$stash};
 247             map { _completions "$stash$_", @_[1..$#_] } @pkgs
 248         }
 249     };
 250     map { s/^:://; $_ } _completions('::', @parts);
 251 }
 252
 253 # Filter exact matches so that e.g. "A::x" completes to "A::xx" when
 254 # both "Ay::xx" and "A::xx" exist.
 255 sub filter_exact_prefix
 256 {
 257     my @parts = split /:+/, shift, -1;
 258     my @res = @_;
 259     my @tmp;
 260     my $pre = shift @parts;
 261     while (@parts && (@tmp = grep /^\Q$pre\E(?:::|$)/, @res)) {
 262         @res = @tmp;
 263         $pre .= '::'.shift @parts;
 264     }
 265     @res;
 266 }
 267
 268 sub lexical_completions
 269 {
 270     eval { require PadWalker; import PadWalker 'peek_sub' };
 271     # "internal" function, so don't warn on failure
 272     return if $@;
 273     *lexical_completions = sub {
 274         my ($type, $str, $sub) = @_;
 275         $sub = "$PACKAGE\::$sub" unless $sub =~ /::/;
 276         # warn "Completing $str of type $type in $sub\n";
 277         no strict;
 278         return unless defined *{$sub}{CODE};
 279         my $pad = peek_sub(\&$sub);
 280         if ($type) {
 281             map { s/^[\$\@&\%]//;$_ } grep /^\Q$type$str\E/, keys %$pad;
 282         } else {
 283             map { s/^[\$\@&\%]//;$_ } grep /^.\Q$str\E/, keys %$pad;
 284         }
 285     };
 286     goto &lexical_completions;
 287 }
 288
 289 sub completions
 290 {
 291     my ($type, $str, $sub) = @_;
 292     my $t;
 293     my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
 294     my %rh;
 295     @rh{values %h} = keys %h;
 296     $type ||= '';
 297     $t = $type ? $rh{$type} : '';
 298     my @ret;
 299     if ($sub && $type ne '') {
 300         @ret = lexical_completions $t, $str, $sub;
 301     }
 302     if (!@ret) {
 303         @ret = grep {
 304             $type ? filter_typed $type : filter_untyped
 305         } all_completions $str;
 306     }
 307     if (!@ret && $str !~ /:/) {
 308         @ret = grep {
 309             $type ? filter_typed $type : filter_untyped
 310         } all_abbrev_completions $str;
 311     }
 312     @ret = map { s/^:://; "$t$_" } filter_exact_prefix $str, @ret;
 313 #     ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
 314 #     ## remove them.
 315     grep {
 316         length $_ > 0 && !looks_like_number($_) && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
 317     } @ret;
 318 }
 319
 320 sub method_completions
 321 {
 322     my ($x, $fn, $eval) = @_;
 323     $x =~ s/^\s+//;
 324     $x =~ s/\s+$//;
 325     $eval ||= 'CORE::eval';
 326     no strict;
 327     return unless ($x =~ /^\$/ && ($x = $eval->("ref($x)")))
 328         || $eval->('%'.$x.'::');
 329     unless ($@) {
 330         my $re = _apropos_re $fn;
 331         ## Filter out overload methods "(..."
 332         return sort { $a cmp $b } map { s/.*:://; $_ }
 333             grep { defined *{$_}{CODE} && /::$re/ && !/\(/ }
 334                 methods($x, 1);
 335     }
 336 }
 337
 338 =head2 C<@locs = location(@names)>
 339
 340 Return a list of [file, line, name] triples, one for each function
 341 name in C<@names>.
 342
 343 =cut
 344
 345 sub location
 346 {
 347     no strict;
 348     my @x= map {
 349         my $str = $_;
 350         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 351             if ($pfx) {
 352                 warn "Sorry -- can't lookup variables.";
 353                 [];
 354             } else {
 355                 # XXX: svref_2object only seems to work with a package
 356                 # tacked on, but that should probably be done
 357                 # elsewhere...
 358                 $name = 'main::'.$name unless $name =~ /::/;
 359                 my $cv = B::svref_2object(\&{$name});
 360                 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
 361                     my ($file, $line) = ($cv->file, $cv->line);
 362                     if ($file !~ /^\//) {
 363                         for (@INC) {
 364                             if (-f "$_/$file") {
 365                                 $file = "$_/$file";
 366                                 last;
 367                             }
 368                         }
 369                     }
 370                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 371                     [Cwd::abs_path($file), $line, $shortname || $name]
 372                 } else {
 373 #                    warn "Bad CV for $name: $cv";
 374                     [];
 375                 }
 376             }
 377         } else {
 378             []
 379         }
 380     } @_;
 381     return @x;
 382 }
 383
 384 =head2 C<@matches = apropos($name [, $is_regex])>
 385
 386 Search for function C<$name>, either in all packages or, if C<$name>
 387 is qualified, only in one package.  If C<$is_regex> is true, the
 388 non-package part of C<$name> is a regular expression.
 389
 390 =cut
 391
 392 sub my_walksymtable(&*)
 393 {
 394     no strict;
 395     my ($f, $st) = @_;
 396     local *_walk = sub {
 397         local ($stash) = @_;
 398         &$f for keys %$stash;
 399         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 400     };
 401     _walk($st);
 402 }
 403
 404 sub apropos
 405 {
 406     my ($it, $re, @types) = @_;
 407     my $stashp;
 408     if (@types) {
 409         $stashp = grep /STASH/, @types;
 410         @types = grep !/STASH/, @types;
 411     } else {
 412         @types = qw(CODE);
 413     }
 414     no strict;
 415     if ($it =~ /^(.*::)([^:]+)$/) {
 416         my ($stash, $name) = ($1, $2);
 417         if (!%$stash) {
 418             return;
 419         }
 420         if ($re) {
 421             my $name = qr/^$name/;
 422             map {
 423                 "$stash$_"
 424             }
 425             grep {
 426                 my $stashnm = "$stash$_";
 427                 /$name/ &&
 428                     (($stashp && /::$/)
 429                      || scalar grep {
 430                          defined($_ eq 'SCALAR' ? $$stashnm : *{$stashnm}{$_})
 431                      } @types)
 432             } keys %$stash;
 433         } else {
 434             defined &$it ? $it : ();
 435         }
 436     } else {
 437         my @ret;
 438         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 439         my_walksymtable {
 440             push @ret, "$stash$_" if /$findre/;
 441         } '::';
 442         map { s/^:*(?:main:+)*//;$_ } @ret;
 443     }
 444 }
 445
 446 =head2 C<@names = mod_subs($pack)>
 447
 448 Find subs in package C<$pack>.
 449
 450 =cut
 451
 452 sub mod_subs
 453 {
 454     no strict;
 455     my $p = shift;
 456     my $stash = \%{"$p\::"};
 457     if (%$stash) {
 458         grep { defined &{"$p\::$_"} } keys %$stash;
 459     }
 460 }
 461
 462 =head2 C<@decls = mod_decls($pack)>
 463
 464 Generate a list of declarations for all subroutines in package
 465 C<$pack>.
 466
 467 =cut
 468
 469 sub mod_decls
 470 {
 471     my $pack = shift;
 472     no strict 'refs';
 473     my @ret = map {
 474         my $sn = $_;
 475         my $proto = prototype(\&{"$pack\::$sn"});
 476         $proto = defined($proto) ? "($proto)" : '';
 477         "sub $sn $proto;";
 478     } mod_subs($pack);
 479     return wantarray ? @ret : join '', @ret;
 480 }
 481
 482 =head2 C<$info = module_info($module, $type)>
 483
 484 Emacs-called function to get module information.
 485
 486 =cut
 487
 488 sub module_info
 489 {
 490     eval { require Module::Info; import Module::Info };
 491     if ($@) {
 492         undef;
 493     } else {
 494         *module_info = sub {
 495             my ($m, $func) = @_;
 496             my $info;
 497             if (-f $m) {
 498                 $info = Module::Info->new_from_file($m);
 499             } else {
 500                 (my $file = $m) =~ s|::|/|g;
 501                 $file .= '.pm';
 502                 if (exists $INC{$file}) {
 503                     $info = Module::Info->new_from_loaded($m);
 504                 } else {
 505                     $info = Module::Info->new_from_module($m);
 506                 }
 507             }
 508             if ($info) {
 509                 return $info->$func;
 510             }
 511         };
 512         goto &module_info;
 513     }
 514 }
 515
 516 =head2 C<$file = mod_file($mod)>
 517
 518 Find the likely file owner for module C<$mod>.
 519
 520 =cut
 521
 522 sub mod_file
 523 {
 524     my $m = shift;
 525     $m =~ s/::/\//g;
 526     while ($m && !exists $INC{"$m.pm"}) {
 527         $m =~ s#(?:^|/)[^/]+$##;
 528     }
 529     $m ? $INC{"$m.pm"} : undef;
 530 }
 531
 532 =head2 C<@mods = package_list>
 533
 534 Gather a list of all distributions on the system. XXX UNUSED
 535
 536 =cut
 537
 538 our $INST;
 539 sub inst()
 540 {
 541     unless ($INST) {
 542         eval 'require ExtUtils::Installed';
 543         $INST = new ExtUtils::Installed;
 544     }
 545     $INST;
 546 }
 547
 548 sub package_list
 549 {
 550     sort { $a cmp $b } inst()->modules;
 551 }
 552
 553 =head2 C<@mods = module_list>
 554
 555 Gather a list of all packages (.pm files, really) installed on the
 556 system, grouped by distribution. XXX UNUSED
 557
 558 =cut
 559
 560 sub module_list
 561 {
 562     @_ = package_list unless @_;
 563     my $incre = join '|', map quotemeta, @INC;
 564     $incre = qr|(?:$incre)/|;
 565     my $inst = inst;
 566     map {
 567         [$_, sort map {
 568             s/$incre//; s|/|::|g;$_
 569         } grep /\.pm$/, $inst->files($_)]
 570     } @_;
 571 }
 572
 573 =head2 C<@mods = doc_list>
 574
 575 Gather a list of all documented packages (.?pm files, really)
 576 installed on the system, grouped by distribution. XXX UNUSED
 577
 578 =cut
 579
 580 sub doc_list
 581 {
 582     @_ = package_list unless @_;
 583     my $inst = inst;
 584     map {
 585         [$_, sort map {
 586             s/.*man.\///; s|/|::|g;s/\..?pm//; $_
 587         } grep /\..pm$/, $inst->files($_)]
 588     } @_;
 589 }
 590
 591 =head2 C<lexicals($subname)>
 592
 593 Return a list of C<$subname>'s lexical variables.  Note that this
 594 includes all nested scopes -- I don't know if or how Perl
 595 distinguishes inner blocks.
 596
 597 =cut
 598
 599 sub lexicals
 600 {
 601     my $cv = B::svref_2object(\&{+shift});
 602     return unless $cv && ($cv = $cv->PADLIST);
 603     my ($names, $vals) = $cv->ARRAY;
 604     map {
 605         my $name = $_->PV; $name =~ s/\0.*$//; $name
 606     } grep B::class($_) ne 'SPECIAL', $names->ARRAY;
 607 }
 608
 609 =head2 C<$lisp = tolisp($perl)>
 610
 611 Convert a Perl scalar to some ELisp equivalent.
 612
 613 =cut
 614
 615 sub tolisp($)
 616 {
 617     my $thing = @_ == 1 ? shift : \@_;
 618     my $t = ref $thing;
 619     if (!$t) {
 620         if (!defined $thing) {
 621             'nil'
 622         } elsif (looks_like_number $thing) {
 623             ''.(0+$thing);
 624         } else {
 625             ## XXX Elisp and perl have slightly different
 626             ## escaping conventions, so we do this crap instead.
 627             $thing =~ s/["\\]/\\$1/g;
 628             qq{"$thing"};
 629         }
 630     } elsif ($t eq 'GLOB') {
 631         (my $name = $$thing) =~ s/\*main:://;
 632         $name;
 633     } elsif ($t eq 'ARRAY') {
 634         '(' . join(' ', map { tolisp($_) } @$thing).')'
 635     } elsif ($t eq 'HASH') {
 636         '(' . join(' ', map {
 637             '(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
 638         } keys %$thing).')'
 639     } elsif ($t eq 'Regexp') {
 640         "'(regexp . \"" . quotemeta($thing) . '")';
 641 #     } elsif ($t eq 'IO') {
 642     } else {
 643         qq{"$thing"};
 644     }
 645 }
 646
 647 =head2 C<printer(\@res, $wantarray)>
 648
 649 Print C<@res> appropriately on the current filehandle.  If C<$ISEVAL>
 650 is true, use terse format.  Otherwise, use human-readable format,
 651 which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
 652
 653 =cut
 654
 655 %PRINTER = (
 656     dumper => sub {
 657         eval { require Data::Dumper };
 658         local $Data::Dumper::Deparse = 1;
 659         local $Data::Dumper::Indent = 0;
 660         local $_;
 661         my $thing = @res > 1 ? \@res : $res[0];
 662         eval {
 663             $_ = Data::Dumper::Dumper($thing);
 664             s/^\$VAR1 = //;
 665             s/;$//;
 666         };
 667         if (length $_ > ($ENV{COLUMNS} || 80)) {
 668             $Data::Dumper::Indent = 1;
 669             eval {
 670                 $_ = Data::Dumper::Dumper($thing);
 671                 s/\A\$VAR1 = //;
 672                 s/;\Z//;
 673             };
 674             s/\A\$VAR1 = //;
 675             s/;\Z//;
 676         }
 677         $_;
 678     },
 679     plain => sub {
 680         "@res";
 681     },
 682     yaml => sub {
 683         eval { require YAML };
 684         if ($@) {
 685             $PRINTER{dumper}->();
 686         } else {
 687             YAML::Dump(\@res);
 688         }
 689     },
 690     dump => sub {
 691         eval { require Data::Dump };
 692         if ($@) {
 693             $PRINTER{dumper}->();
 694         } else {
 695             Data::Dump::dump(\@res);
 696         }
 697     },
 698     peek => sub {
 699         eval {
 700             require Devel::Peek;
 701             require IO::Scalar;
 702         };
 703         if ($@) {
 704             $PRINTER{dumper}->();
 705         } else {
 706             my $ret = new IO::Scalar;
 707             my $out = select $ret;
 708             Devel::Peek::Dump(@res == 1 ? $res[0] : \@res);
 709             select $out;
 710             $ret;
 711         }
 712     }
 713 );
 714
 715 sub printer
 716 {
 717     local *res = shift;
 718     my ($wantarray) = @_;
 719     my $res;
 720     @::__ = @res;
 721     $::__ = @res == 1 ? $res[0] : [@res];
 722     my $str;
 723     if ($ISEVAL) {
 724         $res = "@res";
 725     } elsif (@res == 1 && UNIVERSAL::can($res[0], '()')) {
 726         # overloaded?
 727         $res = $res[0];
 728     } elsif (!$ISEVAL && $PRINT_PRETTY && @res > 1 && !grep ref, @res) {
 729         $res = columnate(@res);
 730         print $res;
 731         return;
 732     } else {
 733         $res = $PRINTER{$PRINTER}->();
 734     }
 735     if ($ISEVAL) {
 736         print ';;;', length $res, "\n$res\n";
 737     } else {
 738         print "$res\n";
 739     }
 740 }
 741
 742 BEGIN {
 743     $PS1 = "> ";
 744     $PACKAGE = 'main';
 745     $WANTARRAY = 1;
 746     $PRINTER = 'dumper';
 747     $PRINT_PRETTY = 1;
 748 }
 749
 750 sub prompt()
 751 {
 752     "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
 753 }
 754
 755 sub Dump
 756 {
 757     eval {
 758         Data::Dumper->Dump([$_[0]], [$_[1]]);
 759     };
 760 }
 761
 762 sub flow
 763 {
 764     my $n = shift;
 765     my $n1 = int(2*$n/3);
 766     local $_ = shift;
 767     s/(.{$n1,$n}) /$1\n/g;
 768     $_
 769 }
 770
 771 sub load
 772 {
 773     my $a = shift;
 774     no strict;
 775     for (@$a) {
 776         *{$_->[0]} = $_->[1];
 777     }
 778 }
 779
 780 my %BADVARS;
 781 undef @BADVARS{qw(%INC @INC %SIG @ISA %ENV @ARGV)};
 782
 783 # magic variables
 784 sub saveable
 785 {
 786     local $_ = shift;
 787     return !/^.[^c-zA-Z]$/ # single-letter stuff (match vars, $_, etc.)
 788         && !/^.[\0-\060]/         # magic weirdness.
 789         && !/^._</        # debugger info
 790         && !exists $BADVARS{$_}; # others.
 791 }
 792
 793 sub save
 794 {
 795     my ($re) = @_;
 796     my @save;
 797     $re = qr/(?:^|::)$re/;
 798     no strict;                  # no kidding...
 799     my_walksymtable {
 800         return if /::$/
 801             || $stash =~ /^(?:::)?(?:warnings|Config|strict|B)\b/;
 802         if (/$re/) {
 803             my $name = "$stash$_";
 804             if (defined ${$name} and saveable '$'.$_) {
 805                 push @save, [$name, \$$name];
 806             }
 807             if (defined *{$name}{HASH} and saveable '%'.$_) {
 808                 push @save, [$name, \%{$name}];
 809             }
 810             if (defined *{$name}{ARRAY} and saveable '@'.$_) {
 811                 push @save, [$name, \@{$name}];
 812             }
 813         }
 814     } '::';
 815     print STDERR "$_->[0] " for @save;
 816     print STDERR "\n";
 817     \@save;
 818 }
 819
 820 =head2 C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
 821
 822 Define $name as a shortcut for function $sub.
 823
 824 =cut
 825
 826 sub define_shortcut
 827 {
 828     my ($name, $doc, $short, $fn);
 829     if (@_ == 2) {
 830         ($name, $fn) = @_;
 831         $short = $name;
 832         $doc = '';
 833     } elsif (@_ == 3) {
 834         ($name, $fn, $doc) = @_;
 835         $short = $name;
 836     } else {
 837         ($name, $fn, $short, $doc) = @_;
 838     }
 839     $REPL{$name} = $fn;
 840     $REPL_DOC{$name} = $doc;
 841     $REPL_SHORT{$name} = $short;
 842 }
 843
 844 sub define_shortcuts
 845 {
 846     define_shortcut 'help', \&Sepia::repl_help,
 847         'help [CMD]',
 848             'Display help on all commands, or just CMD.';
 849     define_shortcut 'cd', \&Sepia::repl_chdir,
 850         'cd DIR', 'Change directory to DIR';
 851     define_shortcut 'pwd', \&Sepia::repl_pwd,
 852         'Show current working directory';
 853     define_shortcut 'methods', \&Sepia::repl_methods,
 854         'methods X [RE]',
 855             'List methods for reference or package X, matching optional pattern RE';
 856     define_shortcut 'package', \&Sepia::repl_package,
 857         'package PKG', 'Set evaluation package to PKG';
 858     define_shortcut 'who', \&Sepia::repl_who,
 859         'who PKG [RE]',
 860             'List variables and subs in PKG matching optional pattern RE.';
 861     define_shortcut 'wantarray', \&Sepia::repl_wantarray,
 862         'wantarray [0|1]', 'Set or toggle evaluation context';
 863     define_shortcut 'format', \&Sepia::repl_format,
 864         'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
 865     define_shortcut 'strict', \&Sepia::repl_strict,
 866         'strict [0|1]', 'Turn \'use strict\' mode on or off';
 867     define_shortcut 'quit', \&Sepia::repl_quit,
 868         'Quit the REPL';
 869     define_shortcut 'restart', \&Sepia::repl_restart,
 870         'Reload Sepia.pm and relaunch the REPL.';
 871     define_shortcut 'shell', \&Sepia::repl_shell,
 872         'shell CMD ...', 'Run CMD in the shell';
 873     define_shortcut 'eval', \&Sepia::repl_eval,
 874         'eval EXP', '(internal)';
 875     define_shortcut 'size', \&Sepia::repl_size,
 876         'size PKG [RE]',
 877             'List total sizes of objects in PKG matching optional pattern RE.';
 878     define_shortcut define => \&Sepia::repl_define,
 879         'define NAME [\'doc\'] BODY',
 880             'Define NAME as a shortcut executing BODY';
 881     define_shortcut undef => \&Sepia::repl_undef,
 882         'undef NAME', 'Undefine shortcut NAME';
 883     define_shortcut test => \&Sepia::repl_test,
 884         'test FILE...', 'Run tests interactively.';
 885     define_shortcut load => \&Sepia::repl_load,
 886         'load [FILE]', 'Load state from FILE.';
 887     define_shortcut save => \&Sepia::repl_save,
 888         'save [PATTERN [FILE]]', 'Save variables matching PATTERN to FILE.';
 889     define_shortcut reload => \&Sepia::repl_reload,
 890         'reload [MODULE | /RE/]', 'Reload MODULE, or all modules matching RE.';
 891     define_shortcut freload => \&Sepia::repl_full_reload,
 892         'freload MODULE', 'Reload MODULE and all its dependencies.';
 893 }
 894
 895 sub repl_help
 896 {
 897     my $width = $ENV{COLUMNS} || 80;
 898     my $args = shift;
 899     if ($args =~ /\S/) {
 900         $args =~ s/^\s+//;
 901         $args =~ s/\s+$//;
 902         my $full = $RK{$args};
 903         if ($full) {
 904             my $short = $REPL_SHORT{$full};
 905             my $flow = flow($width - length $short - 4, $REPL_DOC{$full});
 906             $flow =~ s/(.)\n/"$1\n".(' 'x (4 + length $short))/eg;
 907             print "$short    $flow\n";
 908         } else {
 909             print "$args: no such command\n";
 910         }
 911     } else {
 912         my $left = 1 + max map length, values %REPL_SHORT;
 913         print "REPL commands (prefixed with ','):\n";
 914
 915         for (sort keys %REPL) {
 916             my $flow = flow($width - $left, $REPL_DOC{$_});
 917             $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
 918             printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
 919         }
 920     }
 921 }
 922
 923 sub repl_define
 924 {
 925     local $_ = shift;
 926     my ($name, $doc, $body);
 927     if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
 928         ($name, $doc, $body) = ($1, $2, $3);
 929     } elsif (/^\s*(\S+)\s+(\S.*)/) {
 930         ($name, $doc, $body) = ($1, $2, $2);
 931     } else {
 932         print "usage: define NAME ['doc'] BODY...\n";
 933         return;
 934     }
 935     my $sub = eval "sub { do { $body } }";
 936     if ($@) {
 937         print "usage: define NAME ['doc'] BODY...\n\t$@\n";
 938         return;
 939     }
 940     define_shortcut $name, $sub, $doc;
 941     %RK = abbrev keys %REPL;
 942 }
 943
 944 sub repl_undef
 945 {
 946     my $name = shift;
 947     $name =~ s/^\s*//;
 948     $name =~ s/\s*$//;
 949     my $full = $RK{$name};
 950     if ($full) {
 951         delete $REPL{$full};
 952         delete $REPL_SHORT{$full};
 953         delete $REPL_DOC{$full};
 954         %RK = abbrev keys %REPL;
 955     } else {
 956         print "$name: no such shortcut.\n";
 957     }
 958 }
 959
 960 sub repl_format
 961 {
 962     my $t = shift;
 963     chomp $t;
 964     if ($t eq '') {
 965         print "printer = $PRINTER, pretty = @{[$PRINT_PRETTY ? 1 : 0]}\n";
 966     } else {
 967         my %formats = abbrev keys %PRINTER;
 968         if (exists $formats{$t}) {
 969             $PRINTER = $formats{$t};
 970         } else {
 971             warn "No such format '$t' (dumper, dump, yaml, plain).\n";
 972         }
 973     }
 974 }
 975
 976 sub repl_chdir
 977 {
 978     chomp(my $dir = shift);
 979     $dir =~ s/^~\//$ENV{HOME}\//;
 980     $dir =~ s/\$HOME/$ENV{HOME}/;
 981     if (-d $dir) {
 982         chdir $dir;
 983         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 984         print ";;;###".length($ecmd)."\n$ecmd\n";
 985     } else {
 986         warn "Can't chdir\n";
 987     }
 988 }
 989
 990 sub repl_pwd
 991 {
 992     print Cwd::getcwd(), "\n";
 993 }
 994
 995 sub who
 996 {
 997     my ($pack, $re_str) = @_;
 998     $re_str ||= '.?';
 999     my $re = qr/$re_str/;
1000     no strict;
1001     if ($re_str =~ /^[\$\@\%\&]/) {
1002         ## sigil given -- match it
1003         sort grep /$re/, map {
1004             my $name = $pack.'::'.$_;
1005             (defined *{$name}{HASH} ? '%'.$_ : (),
1006              defined *{$name}{ARRAY} ? '@'.$_ : (),
1007              defined *{$name}{CODE} ? $_ : (),
1008              defined ${$name} ? '$'.$_ : (), # ?
1009          )
1010         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1011     } else {
1012         ## no sigil -- don't match it
1013         sort map {
1014             my $name = $pack.'::'.$_;
1015             (defined *{$name}{HASH} ? '%'.$_ : (),
1016              defined *{$name}{ARRAY} ? '@'.$_ : (),
1017              defined *{$name}{CODE} ? $_ : (),
1018              defined ${$name} ? '$'.$_ : (), # ?
1019          )
1020         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1021     }
1022 }
1023
1024
1025 sub columnate
1026 {
1027     my $len = 0;
1028     my $width = $ENV{COLUMNS} || 80;
1029     for (@_) {
1030         $len = length if $len < length;
1031     }
1032     my $nc = int($width / ($len+1)) || 1;
1033     my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
1034     my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
1035     my @incs = map { $_ * $nr } 0..$nc-1;
1036     my $str = '';
1037     for my $r (0..$nr-1) {
1038         $str .= sprintf $fmt, map { defined($_) ? $_ : '' }
1039             @_[map { $r + $_ } @incs];
1040     }
1041     $str =~ s/ +$//m;
1042     $str
1043 }
1044
1045 sub repl_who
1046 {
1047     my ($pkg, $re) = split ' ', shift;
1048     no strict;
1049     if ($pkg && $pkg =~ /^\/(.*)\/?$/) {
1050         $pkg = $PACKAGE;
1051         $re = $1;
1052     } elsif (!$re && !%{$pkg.'::'}) {
1053         $re = $pkg;
1054         $pkg = $PACKAGE;
1055     }
1056     print columnate who($pkg || $PACKAGE, $re);
1057 }
1058
1059 sub methods
1060 {
1061     my ($pack, $qualified) = @_;
1062     no strict;
1063     my @own = $qualified ? grep {
1064         defined *{$_}{CODE}
1065     } map { "$pack\::$_" } keys %{$pack.'::'}
1066         : grep {
1067             defined *{"$pack\::$_"}{CODE}
1068         } keys %{$pack.'::'};
1069     (@own, defined *{$pack.'::ISA'}{ARRAY}
1070          ? (map methods($_, $qualified), @{$pack.'::ISA'}) : ());
1071 }
1072
1073 sub repl_methods
1074 {
1075     my ($x, $re) = split ' ', shift;
1076     $x =~ s/^\s+//;
1077     $x =~ s/\s+$//;
1078     if ($x =~ /^\$/) {
1079         $x = $REPL{eval}->("ref $x");
1080         return 0 if $@;
1081     }
1082     $re ||= '.?';
1083     $re = qr/$re/;
1084     print columnate sort { $a cmp $b } grep /$re/, methods $x;
1085 }
1086
1087 sub as_boolean
1088 {
1089     my ($val, $cur) = @_;
1090     $val =~ s/\s+//g;
1091     length($val) ? $val : !$cur;
1092 }
1093
1094 sub repl_wantarray
1095 {
1096     $WANTARRAY = as_boolean shift, $WANTARRAY;
1097 }
1098
1099 sub repl_package
1100 {
1101     chomp(my $p = shift);
1102     no strict;
1103     if (%{$p.'::'}) {
1104         $PACKAGE = $p;
1105 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
1106 #         print ";;;###".length($ecmd)."\n$ecmd\n";
1107     } else {
1108         warn "Can't go to package $p -- doesn't exist!\n";
1109     }
1110 }
1111
1112 sub repl_quit
1113 {
1114     last repl;
1115 }
1116
1117 sub repl_restart
1118 {
1119     do $INC{'Sepia.pm'};
1120     if ($@) {
1121         print "Restart failed:\n$@\n";
1122     } else {
1123         $REPL_LEVEL = 0;        # ok?
1124         goto &Sepia::repl;
1125     }
1126 }
1127
1128 sub repl_shell
1129 {
1130     my $cmd = shift;
1131     print `$cmd 2>& 1`;
1132 }
1133
1134 sub repl_eval
1135 {
1136     my ($buf) = @_;
1137     no strict;
1138     # local $PACKAGE = $pkg || $PACKAGE;
1139     if ($STRICT) {
1140         if (!$WANTARRAY) {
1141             $buf = 'scalar($buf)';
1142         }
1143         my $ctx = join(',', keys %{$STRICT->get_context('_')});
1144         $ctx = $ctx ? "my ($ctx);" : '';
1145         $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1146         if ($@) {
1147             print "ERROR\n$@\n";
1148             return;
1149         }
1150         $STRICT->call($buf);
1151     } else {
1152         $buf = "do { package $PACKAGE; no strict; $buf }";
1153         if ($WANTARRAY) {
1154             eval $buf;
1155         } else {
1156             scalar eval $buf;
1157         }
1158     }
1159 }
1160
1161 sub repl_test
1162 {
1163     my ($buf) = @_;
1164     my @files;
1165     if ($buf =~ /\S/) {
1166         $buf =~ s/^\s+//;
1167         $buf =~ s/\s+$//;
1168         if (-f $buf) {
1169             push @files, $buf;
1170         } elsif (-f "t/$buf") {
1171             push @files, $buf;
1172         }
1173     } else {
1174         find({ no_chdir => 1,
1175                wanted => sub {
1176                    push @files, $_ if /\.t$/;
1177             }}, Cwd::getcwd() =~ /t\/?$/ ? '.' : './t');
1178     }
1179     if (@files) {
1180         # XXX: this is cribbed from an EU::MM-generated Makefile.
1181         system $^X, qw(-MExtUtils::Command::MM -e),
1182             "test_harness(0, 'blib/lib', 'blib/arch')", @files;
1183      } else {
1184         print "No test files for '$buf' in ", Cwd::getcwd, "\n";
1185     }
1186 }
1187
1188 sub repl_load
1189 {
1190     my ($file) = split ' ', shift;
1191     $file ||= "$ENV{HOME}/.sepia-save";
1192     load(retrieve $file);
1193 }
1194
1195 sub repl_save
1196 {
1197     my ($re, $file) = split ' ', shift;
1198     $re ||= '.';
1199     $file ||= "$ENV{HOME}/.sepia-save";
1200     store save($re), $file;
1201 }
1202
1203 sub full_reload
1204 {
1205     (my $name = shift) =~ s!::!/!g;
1206     $name .= '.pm';
1207     print STDERR "full reload $name\n";
1208     my %save_inc = %INC;
1209     local %INC;
1210     require $name;
1211     my @ret = keys %INC;
1212     while (my ($k, $v) = each %save_inc) {
1213         $INC{$k} ||= $v;
1214     }
1215     @ret;
1216 }
1217
1218 sub repl_full_reload
1219 {
1220     chomp (my $pat = shift);
1221     my @x = full_reload $pat;
1222     print "Reloaded: @x\n";
1223 }
1224
1225 sub repl_reload
1226 {
1227     chomp (my $pat = shift);
1228     if ($pat =~ /^\/(.*)\/?$/) {
1229         $pat = $1;
1230         $pat =~ s#::#/#g;
1231         $pat = qr/$pat/;
1232         my @rel;
1233         for (keys %INC) {
1234             next unless /$pat/;
1235             if (!do $_) {
1236                 print "$_: $@\n";
1237             }
1238             s#/#::#g;
1239             s/\.pm$//;
1240             push @rel, $_;
1241         }
1242     } else {
1243         my $mod = $pat;
1244         $pat =~ s#::#/#g;
1245         $pat .= '.pm';
1246         if (exists $INC{$pat}) {
1247             delete $INC{$pat};
1248             eval 'require $mod';
1249             import $mod if $@;
1250             print "Reloaded $mod.\n"
1251         } else {
1252             print "$mod not loaded.\n"
1253         }
1254     }
1255 }
1256
1257 ## Collects warnings for REPL
1258 my @warn;
1259
1260 sub sig_warn
1261 {
1262     push @warn, shift
1263 }
1264
1265 sub print_warnings
1266 {
1267     if (@warn) {
1268         if ($ISEVAL) {
1269             my $tmp = "@warn";
1270             print ';;;'.length($tmp)."\n$tmp\n";
1271         } else {
1272             for (@warn) {
1273                 # s/(.*) at .*/$1/;
1274                 print "warning: $_\n";
1275             }
1276         }
1277     }
1278 }
1279
1280 sub repl_banner
1281 {
1282     print <<EOS;
1283 I need user feedback!  Please send questions or comments to seano\@cpan.org.
1284 Sepia version $Sepia::VERSION.
1285 Type ",h" for help, or ",q" to quit.
1286 EOS
1287 }
1288
1289 =head2 C<repl()>
1290
1291 Execute a command interpreter on standard input and standard output.
1292 If you want to use different descriptors, localize them before
1293 calling C<repl()>.  The prompt has a few bells and whistles, including:
1294
1295 =over 4
1296
1297 =item Obviously-incomplete lines are treated as multiline input (press
1298 'return' twice or 'C-c' to discard).
1299
1300 =item C<die> is overridden to enter a debugging repl at the point
1301 C<die> is called.
1302
1303 =back
1304
1305 Behavior is controlled in part through the following package-globals:
1306
1307 =over 4
1308
1309 =item C<$PACKAGE> -- evaluation package
1310
1311 =item C<$PRINTER> -- result printer (default: dumper)
1312
1313 =item C<$PS1> -- the default prompt
1314
1315 =item C<$STRICT> -- whether 'use strict' is applied to input
1316
1317 =item C<$WANTARRAY> -- evaluation context
1318
1319 =item C<$PRINT_PRETTY> -- format some output nicely (default = 1)
1320
1321 Format some values nicely, independent of $PRINTER.  Currently, this
1322 displays arrays of scalars as columns.
1323
1324 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1325
1326 If zero, then initialization takes place.
1327
1328 =item C<%REPL> -- maps shortcut names to handlers
1329
1330 =item C<%REPL_DOC> -- maps shortcut names to documentation
1331
1332 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1333
1334 =back
1335
1336 =cut
1337
1338 sub repl_setup
1339 {
1340     $| = 1;
1341     if ($REPL_LEVEL == 0) {
1342         define_shortcuts;
1343         -f "$ENV{HOME}/.sepiarc" and do "$ENV{HOME}/.sepiarc";
1344         warn ".sepiarc: $@\n" if $@;
1345     }
1346     Sepia::Debug::add_repl_commands;
1347     repl_banner if $REPL_LEVEL == 1;
1348     print prompt;
1349 }
1350
1351 sub repl
1352 {
1353     repl_setup;
1354     local $REPL_LEVEL = $REPL_LEVEL + 1;
1355
1356     my $in;
1357     my $buf = '';
1358     my $sigged = 0;
1359
1360     my $nextrepl = sub { $sigged = 1; };
1361
1362     local *__;
1363     local *CORE::GLOBAL::die = \&Sepia::Debug::die;
1364     local *CORE::GLOBAL::warn = \&Sepia::Debug::warn;
1365     local @REPL_RESULT;
1366     my @sigs = qw(INT TERM PIPE ALRM);
1367     local @SIG{@sigs};
1368     $SIG{$_} = $nextrepl for @sigs;
1369  repl: while (defined(my $in = <STDIN>)) {
1370             if ($sigged) {
1371                 $buf = '';
1372                 $sigged = 0;
1373                 print "\n", prompt;
1374                 next repl;
1375             }
1376             $buf .= $in;
1377             $buf =~ s/^\s*//;
1378             local $ISEVAL;
1379             if ($buf =~ /^<<(\d+)\n(.*)/) {
1380                 $ISEVAL = 1;
1381                 my $len = $1;
1382                 my $tmp;
1383                 $buf = $2;
1384                 while ($len && defined($tmp = read STDIN, $buf, $len, length $buf)) {
1385                     $len -= $tmp;
1386                 }
1387             }
1388             my (@res);
1389             ## Only install a magic handler if no one else is playing.
1390             local $SIG{__WARN__} = $SIG{__WARN__};
1391             @warn = ();
1392             unless ($SIG{__WARN__}) {
1393                 $SIG{__WARN__} = 'Sepia::sig_warn';
1394             }
1395             if (!$ISEVAL) {
1396                 if ($buf eq '') {
1397                     # repeat last interactive command
1398                     $buf = $LAST_INPUT;
1399                 } else {
1400                     $LAST_INPUT = $buf;
1401                 }
1402             }
1403             if ($buf =~ /^,(\S+)\s*(.*)/s) {
1404                 ## Inspector shortcuts
1405                 my $short = $1;
1406                 if (exists $Sepia::RK{$short}) {
1407                     my $ret;
1408                     my $arg = $2;
1409                     chomp $arg;
1410                     $Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
1411                 } else {
1412                     if (grep /^$short/, keys %Sepia::REPL) {
1413                         print "Ambiguous shortcut '$short': ",
1414                             join(', ', sort grep /^$short/, keys %Sepia::REPL),
1415                                 "\n";
1416                     } else {
1417                         print "Unrecognized shortcut '$short'\n";
1418                     }
1419                     $buf = '';
1420                     print prompt;
1421                     next repl;
1422                 }
1423             } else {
1424                 ## Ordinary eval
1425                 @res = $REPL{eval}->($buf);
1426                 if ($@) {
1427                     if ($ISEVAL) {
1428                         ## Always return results for an eval request
1429                         Sepia::printer \@res, wantarray;
1430                         Sepia::printer [$@], wantarray;
1431                         # print_warnings $ISEVAL;
1432                         $buf = '';
1433                         print prompt;
1434                     } elsif ($@ =~ /(?:at|before) EOF(?:$| at)/m) {
1435                         ## Possibly-incomplete line
1436                         if ($in eq "\n") {
1437                             print "Error:\n$@\n*** cancel ***\n", prompt;
1438                             $buf = '';
1439                         } else {
1440                             print ">> ";
1441                         }
1442                     } else {
1443                         print_warnings;
1444                         # $@ =~ s/(.*) at eval .*/$1/;
1445                         # don't complain if we're abandoning execution
1446                         # from the debugger.
1447                         unless (ref $@ eq 'Sepia::Debug') {
1448                             print "error: $@";
1449                             print "\n" unless $@ =~ /\n\z/;
1450                         }
1451                         print prompt;
1452                         $buf = '';
1453                     }
1454                     next repl;
1455                 }
1456             }
1457             if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1458                 ## Be quiet if it ends with a semicolon, or if we
1459                 ## executed a shortcut.
1460                 Sepia::printer \@res, wantarray;
1461             }
1462             $buf = '';
1463             print_warnings;
1464             print prompt;
1465         }
1466     wantarray ? @REPL_RESULT : $REPL_RESULT[0]
1467 }
1468
1469 sub perl_eval
1470 {
1471     tolisp($REPL{eval}->(shift));
1472 }
1473
1474 =head2 C<$status = html_module_list([$file [, $prefix]])>
1475
1476 Generate an HTML list of installed modules, looking inside of
1477 packages.  If C<$prefix> is missing, uses "about://perldoc/".  If
1478 $file is given, write the result to $file; otherwise, return it as a
1479 string.
1480
1481 =head2 C<$status = html_package_list([$file [, $prefix]])>
1482
1483 Generate an HTML list of installed top-level modules, without looking
1484 inside of packages.  If C<$prefix> is missing, uses
1485 "about://perldoc/".  $file is the same as for C<html_module_list>.
1486
1487 =cut
1488
1489 sub html_module_list
1490 {
1491     my ($file, $base) = @_;
1492     $base ||= 'about://perldoc/';
1493     my $inst = inst();
1494     return unless $inst;
1495     my $out;
1496     open OUT, ">", $file || \$out or return;
1497     print OUT "<html><body>";
1498     my $pfx = '';
1499     my %ns;
1500     for (package_list) {
1501         push @{$ns{$1}}, $_ if /^([^:]+)/;
1502     }
1503     # Handle core modules.
1504     my %fs;
1505     undef $fs{$_} for map {
1506         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1507     } grep {
1508         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ # && !/^(?:\/|perl)/
1509     } $inst->files('Perl');
1510     my @fs = sort keys %fs;
1511     print OUT qq{<h2>Core Modules</h2><ul>};
1512     for (@fs) {
1513         print OUT qq{<li><a href="$base$_">$_</a>};
1514     }
1515     print OUT '</ul><h2>Installed Modules</h2><ul>';
1516
1517     # handle the rest
1518     for (sort keys %ns) {
1519         next if $_ eq 'Perl';   # skip Perl core.
1520         print OUT qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
1521         for (sort @{$ns{$_}}) {
1522             my %fs;
1523             undef $fs{$_} for map {
1524                 s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1525             } grep {
1526                 /\.\d(?:pm)?$/ && !/man1/
1527             } $inst->files($_);
1528             my @fs = sort keys %fs;
1529             next unless @fs > 0;
1530             if (@fs == 1) {
1531                 print OUT qq{<li><a href="$base$fs[0]">$fs[0]</a>};
1532             } else {
1533                 print OUT qq{<li>$_<ul>};
1534                 for (@fs) {
1535                     print OUT qq{<li><a href="$base$_">$_</a>};
1536                 }
1537                 print OUT '</ul>';
1538             }
1539         }
1540         print OUT qq{</ul>} if @{$ns{$_}} > 1;
1541     }
1542
1543     print OUT "</ul></body></html>\n";
1544     close OUT;
1545     $file ? 1 : $out;
1546 }
1547
1548 sub html_package_list
1549 {
1550     my ($file, $base) = @_;
1551     return unless inst();
1552     $base ||= 'about://perldoc/';
1553     my $out;
1554     open OUT, ">", $file || \$out or return;
1555     print OUT "<html><body><ul>";
1556     my $pfx = '';
1557     my %ns;
1558     for (package_list) {
1559         push @{$ns{$1}}, $_ if /^([^:]+)/;
1560     }
1561     for (sort keys %ns) {
1562         if (@{$ns{$_}} == 1) {
1563             print OUT
1564                 qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
1565         } else {
1566             print OUT qq{<li><b>$_</b><ul>};
1567             print OUT qq{<li><a href="$base$_">$_</a>}
1568                 for sort @{$ns{$_}};
1569             print OUT qq{</ul>};
1570         }
1571     }
1572     print OUT "</ul></body></html>\n";
1573     close OUT;
1574     $file ? 1 : $out;
1575 }
1576
1577 sub apropos_module
1578 {
1579     my $re = qr/$_[0]/;
1580     my $inst = inst();
1581     my %ret;
1582     for (package_list) {
1583         undef $ret{$_} if /$re/;
1584     }
1585     undef $ret{$_} for map {
1586         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1587     } grep {
1588         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ && /$re/
1589     } $inst->files('Perl');
1590     sort keys %ret;
1591 }
1592
1593 1;
1594 __END__
1595
1596 =head1 TODO
1597
1598 See the README file included with the distribution.
1599
1600 =head1 SEE ALSO
1601
1602 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
1603
1604 There are several modules for Perl development in Emacs on CPAN,
1605 including L<Devel::PerlySense> and L<PDE>.  For a complete list, see
1606 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
1607
1608 =head1 AUTHOR
1609
1610 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
1611
1612 Bug reports welcome, patches even more welcome.
1613
1614 =head1 COPYRIGHT
1615
1616 Copyright (C) 2005-2009 Sean O'Rourke.  All rights reserved, some
1617 wrongs reversed.  This module is distributed under the same terms as
1618 Perl itself.
1619
1620 =cut