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 );
 699
 700 sub printer
 701 {
 702     local *res = shift;
 703     my ($wantarray) = @_;
 704     my $res;
 705     @::__ = @res;
 706     $::__ = @res == 1 ? $res[0] : [@res];
 707     my $str;
 708     if ($ISEVAL) {
 709         $res = "@res";
 710     } elsif (@res == 1 && UNIVERSAL::can($res[0], '()')) {
 711         # overloaded?
 712         $res = $res[0];
 713     } elsif (!$ISEVAL && $PRINT_PRETTY && @res > 1 && !grep ref, @res) {
 714         $res = columnate(@res);
 715         print $res;
 716         return;
 717     } else {
 718         $res = $PRINTER{$PRINTER}->();
 719     }
 720     if ($ISEVAL) {
 721         print ';;;', length $res, "\n$res\n";
 722     } else {
 723         print "$res\n";
 724     }
 725 }
 726
 727 BEGIN {
 728     $PS1 = "> ";
 729     $PACKAGE = 'main';
 730     $WANTARRAY = 1;
 731     $PRINTER = 'dumper';
 732     $PRINT_PRETTY = 1;
 733 }
 734
 735 sub prompt()
 736 {
 737     "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
 738 }
 739
 740 sub Dump
 741 {
 742     eval {
 743         Data::Dumper->Dump([$_[0]], [$_[1]]);
 744     };
 745 }
 746
 747 sub flow
 748 {
 749     my $n = shift;
 750     my $n1 = int(2*$n/3);
 751     local $_ = shift;
 752     s/(.{$n1,$n}) /$1\n/g;
 753     $_
 754 }
 755
 756 sub load
 757 {
 758     my $a = shift;
 759     no strict;
 760     for (@$a) {
 761         *{$_->[0]} = $_->[1];
 762     }
 763 }
 764
 765 my %BADVARS;
 766 undef @BADVARS{qw(%INC @INC %SIG @ISA %ENV @ARGV)};
 767
 768 # magic variables
 769 sub saveable
 770 {
 771     local $_ = shift;
 772     return !/^.[^c-zA-Z]$/ # single-letter stuff (match vars, $_, etc.)
 773         && !/^.[\0-\060]/         # magic weirdness.
 774         && !/^._</        # debugger info
 775         && !exists $BADVARS{$_}; # others.
 776 }
 777
 778 sub save
 779 {
 780     my ($re) = @_;
 781     my @save;
 782     $re = qr/(?:^|::)$re/;
 783     no strict;                  # no kidding...
 784     my_walksymtable {
 785         return if /::$/
 786             || $stash =~ /^(?:::)?(?:warnings|Config|strict|B)\b/;
 787         if (/$re/) {
 788             my $name = "$stash$_";
 789             if (defined ${$name} and saveable '$'.$_) {
 790                 push @save, [$name, \$$name];
 791             }
 792             if (defined *{$name}{HASH} and saveable '%'.$_) {
 793                 push @save, [$name, \%{$name}];
 794             }
 795             if (defined *{$name}{ARRAY} and saveable '@'.$_) {
 796                 push @save, [$name, \@{$name}];
 797             }
 798         }
 799     } '::';
 800     print STDERR "$_->[0] " for @save;
 801     print STDERR "\n";
 802     \@save;
 803 }
 804
 805 =head2 C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
 806
 807 Define $name as a shortcut for function $sub.
 808
 809 =cut
 810
 811 sub define_shortcut
 812 {
 813     my ($name, $doc, $short, $fn);
 814     if (@_ == 2) {
 815         ($name, $fn) = @_;
 816         $short = $name;
 817         $doc = '';
 818     } elsif (@_ == 3) {
 819         ($name, $fn, $doc) = @_;
 820         $short = $name;
 821     } else {
 822         ($name, $fn, $short, $doc) = @_;
 823     }
 824     $REPL{$name} = $fn;
 825     $REPL_DOC{$name} = $doc;
 826     $REPL_SHORT{$name} = $short;
 827 }
 828
 829 sub define_shortcuts
 830 {
 831     define_shortcut 'help', \&Sepia::repl_help,
 832         'help [CMD]',
 833             'Display help on all commands, or just CMD.';
 834     define_shortcut 'cd', \&Sepia::repl_chdir,
 835         'cd DIR', 'Change directory to DIR';
 836     define_shortcut 'pwd', \&Sepia::repl_pwd,
 837         'Show current working directory';
 838     define_shortcut 'methods', \&Sepia::repl_methods,
 839         'methods X [RE]',
 840             'List methods for reference or package X, matching optional pattern RE';
 841     define_shortcut 'package', \&Sepia::repl_package,
 842         'package PKG', 'Set evaluation package to PKG';
 843     define_shortcut 'who', \&Sepia::repl_who,
 844         'who PKG [RE]',
 845             'List variables and subs in PKG matching optional pattern RE.';
 846     define_shortcut 'wantarray', \&Sepia::repl_wantarray,
 847         'wantarray [0|1]', 'Set or toggle evaluation context';
 848     define_shortcut 'format', \&Sepia::repl_format,
 849         'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
 850     define_shortcut 'strict', \&Sepia::repl_strict,
 851         'strict [0|1]', 'Turn \'use strict\' mode on or off';
 852     define_shortcut 'quit', \&Sepia::repl_quit,
 853         'Quit the REPL';
 854     define_shortcut 'restart', \&Sepia::repl_restart,
 855         'Reload Sepia.pm and relaunch the REPL.';
 856     define_shortcut 'shell', \&Sepia::repl_shell,
 857         'shell CMD ...', 'Run CMD in the shell';
 858     define_shortcut 'eval', \&Sepia::repl_eval,
 859         'eval EXP', '(internal)';
 860     define_shortcut 'size', \&Sepia::repl_size,
 861         'size PKG [RE]',
 862             'List total sizes of objects in PKG matching optional pattern RE.';
 863     define_shortcut define => \&Sepia::repl_define,
 864         'define NAME [\'doc\'] BODY',
 865             'Define NAME as a shortcut executing BODY';
 866     define_shortcut undef => \&Sepia::repl_undef,
 867         'undef NAME', 'Undefine shortcut NAME';
 868     define_shortcut test => \&Sepia::repl_test,
 869         'test FILE...', 'Run tests interactively.';
 870     define_shortcut load => \&Sepia::repl_load,
 871         'load [FILE]', 'Load state from FILE.';
 872     define_shortcut save => \&Sepia::repl_save,
 873         'save [PATTERN [FILE]]', 'Save variables matching PATTERN to FILE.';
 874     define_shortcut reload => \&Sepia::repl_reload,
 875         'reload [MODULE | /RE/]', 'Reload MODULE, or all modules matching RE.';
 876     define_shortcut freload => \&Sepia::repl_full_reload,
 877         'freload MODULE', 'Reload MODULE and all its dependencies.';
 878 }
 879
 880 sub repl_help
 881 {
 882     my $width = $ENV{COLUMNS} || 80;
 883     my $args = shift;
 884     if ($args =~ /\S/) {
 885         $args =~ s/^\s+//;
 886         $args =~ s/\s+$//;
 887         my $full = $RK{$args};
 888         if ($full) {
 889             my $short = $REPL_SHORT{$full};
 890             my $flow = flow($width - length $short - 4, $REPL_DOC{$full});
 891             $flow =~ s/(.)\n/"$1\n".(' 'x (4 + length $short))/eg;
 892             print "$short    $flow\n";
 893         } else {
 894             print "$args: no such command\n";
 895         }
 896     } else {
 897         my $left = 1 + max map length, values %REPL_SHORT;
 898         print "REPL commands (prefixed with ','):\n";
 899
 900         for (sort keys %REPL) {
 901             my $flow = flow($width - $left, $REPL_DOC{$_});
 902             $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
 903             printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
 904         }
 905     }
 906 }
 907
 908 sub repl_define
 909 {
 910     local $_ = shift;
 911     my ($name, $doc, $body);
 912     if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
 913         ($name, $doc, $body) = ($1, $2, $3);
 914     } elsif (/^\s*(\S+)\s+(\S.*)/) {
 915         ($name, $doc, $body) = ($1, $2, $2);
 916     } else {
 917         print "usage: define NAME ['doc'] BODY...\n";
 918         return;
 919     }
 920     my $sub = eval "sub { do { $body } }";
 921     if ($@) {
 922         print "usage: define NAME ['doc'] BODY...\n\t$@\n";
 923         return;
 924     }
 925     define_shortcut $name, $sub, $doc;
 926     %RK = abbrev keys %REPL;
 927 }
 928
 929 sub repl_undef
 930 {
 931     my $name = shift;
 932     $name =~ s/^\s*//;
 933     $name =~ s/\s*$//;
 934     my $full = $RK{$name};
 935     if ($full) {
 936         delete $REPL{$full};
 937         delete $REPL_SHORT{$full};
 938         delete $REPL_DOC{$full};
 939         %RK = abbrev keys %REPL;
 940     } else {
 941         print "$name: no such shortcut.\n";
 942     }
 943 }
 944
 945 sub repl_format
 946 {
 947     my $t = shift;
 948     chomp $t;
 949     if ($t eq '') {
 950         print "printer = $PRINTER, pretty = @{[$PRINT_PRETTY ? 1 : 0]}\n";
 951     } else {
 952         my %formats = abbrev keys %PRINTER;
 953         if (exists $formats{$t}) {
 954             $PRINTER = $formats{$t};
 955         } else {
 956             warn "No such format '$t' (dumper, dump, yaml, plain).\n";
 957         }
 958     }
 959 }
 960
 961 sub repl_chdir
 962 {
 963     chomp(my $dir = shift);
 964     $dir =~ s/^~\//$ENV{HOME}\//;
 965     $dir =~ s/\$HOME/$ENV{HOME}/;
 966     if (-d $dir) {
 967         chdir $dir;
 968         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 969         print ";;;###".length($ecmd)."\n$ecmd\n";
 970     } else {
 971         warn "Can't chdir\n";
 972     }
 973 }
 974
 975 sub repl_pwd
 976 {
 977     print Cwd::getcwd(), "\n";
 978 }
 979
 980 sub who
 981 {
 982     my ($pack, $re_str) = @_;
 983     $re_str ||= '.?';
 984     my $re = qr/$re_str/;
 985     no strict;
 986     if ($re_str =~ /^[\$\@\%\&]/) {
 987         ## sigil given -- match it
 988         sort grep /$re/, map {
 989             my $name = $pack.'::'.$_;
 990             (defined *{$name}{HASH} ? '%'.$_ : (),
 991              defined *{$name}{ARRAY} ? '@'.$_ : (),
 992              defined *{$name}{CODE} ? $_ : (),
 993              defined ${$name} ? '$'.$_ : (), # ?
 994          )
 995         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
 996     } else {
 997         ## no sigil -- don't match it
 998         sort map {
 999             my $name = $pack.'::'.$_;
1000             (defined *{$name}{HASH} ? '%'.$_ : (),
1001              defined *{$name}{ARRAY} ? '@'.$_ : (),
1002              defined *{$name}{CODE} ? $_ : (),
1003              defined ${$name} ? '$'.$_ : (), # ?
1004          )
1005         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1006     }
1007 }
1008
1009
1010 sub columnate
1011 {
1012     my $len = 0;
1013     my $width = $ENV{COLUMNS} || 80;
1014     for (@_) {
1015         $len = length if $len < length;
1016     }
1017     my $nc = int($width / ($len+1)) || 1;
1018     my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
1019     my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
1020     my @incs = map { $_ * $nr } 0..$nc-1;
1021     my $str = '';
1022     for my $r (0..$nr-1) {
1023         $str .= sprintf $fmt, map { defined($_) ? $_ : '' }
1024             @_[map { $r + $_ } @incs];
1025     }
1026     $str =~ s/ +$//m;
1027     $str
1028 }
1029
1030 sub repl_who
1031 {
1032     my ($pkg, $re) = split ' ', shift;
1033     no strict;
1034     if ($pkg && $pkg =~ /^\/(.*)\/?$/) {
1035         $pkg = $PACKAGE;
1036         $re = $1;
1037     } elsif (!$re && !%{$pkg.'::'}) {
1038         $re = $pkg;
1039         $pkg = $PACKAGE;
1040     }
1041     print columnate who($pkg || $PACKAGE, $re);
1042 }
1043
1044 sub methods
1045 {
1046     my ($pack, $qualified) = @_;
1047     no strict;
1048     my @own = $qualified ? grep {
1049         defined *{$_}{CODE}
1050     } map { "$pack\::$_" } keys %{$pack.'::'}
1051         : grep {
1052             defined *{"$pack\::$_"}{CODE}
1053         } keys %{$pack.'::'};
1054     (@own, defined *{$pack.'::ISA'}{ARRAY}
1055          ? (map methods($_, $qualified), @{$pack.'::ISA'}) : ());
1056 }
1057
1058 sub repl_methods
1059 {
1060     my ($x, $re) = split ' ', shift;
1061     $x =~ s/^\s+//;
1062     $x =~ s/\s+$//;
1063     if ($x =~ /^\$/) {
1064         $x = $REPL{eval}->("ref $x");
1065         return 0 if $@;
1066     }
1067     $re ||= '.?';
1068     $re = qr/$re/;
1069     print columnate sort { $a cmp $b } grep /$re/, methods $x;
1070 }
1071
1072 sub as_boolean
1073 {
1074     my ($val, $cur) = @_;
1075     $val =~ s/\s+//g;
1076     length($val) ? $val : !$cur;
1077 }
1078
1079 sub repl_wantarray
1080 {
1081     $WANTARRAY = as_boolean shift, $WANTARRAY;
1082 }
1083
1084 sub repl_package
1085 {
1086     chomp(my $p = shift);
1087     no strict;
1088     if (%{$p.'::'}) {
1089         $PACKAGE = $p;
1090 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
1091 #         print ";;;###".length($ecmd)."\n$ecmd\n";
1092     } else {
1093         warn "Can't go to package $p -- doesn't exist!\n";
1094     }
1095 }
1096
1097 sub repl_quit
1098 {
1099     last repl;
1100 }
1101
1102 sub repl_restart
1103 {
1104     do $INC{'Sepia.pm'};
1105     if ($@) {
1106         print "Restart failed:\n$@\n";
1107     } else {
1108         $REPL_LEVEL = 0;        # ok?
1109         goto &Sepia::repl;
1110     }
1111 }
1112
1113 sub repl_shell
1114 {
1115     my $cmd = shift;
1116     print `$cmd 2>& 1`;
1117 }
1118
1119 sub repl_eval
1120 {
1121     my ($buf) = @_;
1122     no strict;
1123     # local $PACKAGE = $pkg || $PACKAGE;
1124     if ($STRICT) {
1125         if (!$WANTARRAY) {
1126             $buf = 'scalar($buf)';
1127         }
1128         my $ctx = join(',', keys %{$STRICT->get_context('_')});
1129         $ctx = $ctx ? "my ($ctx);" : '';
1130         $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1131         if ($@) {
1132             print "ERROR\n$@\n";
1133             return;
1134         }
1135         $STRICT->call($buf);
1136     } else {
1137         $buf = "do { package $PACKAGE; no strict; $buf }";
1138         if ($WANTARRAY) {
1139             eval $buf;
1140         } else {
1141             scalar eval $buf;
1142         }
1143     }
1144 }
1145
1146 sub repl_test
1147 {
1148     my ($buf) = @_;
1149     my @files;
1150     if ($buf =~ /\S/) {
1151         $buf =~ s/^\s+//;
1152         $buf =~ s/\s+$//;
1153         if (-f $buf) {
1154             push @files, $buf;
1155         } elsif (-f "t/$buf") {
1156             push @files, $buf;
1157         }
1158     } else {
1159         find({ no_chdir => 1,
1160                wanted => sub {
1161                    push @files, $_ if /\.t$/;
1162             }}, Cwd::getcwd() =~ /t\/?$/ ? '.' : './t');
1163     }
1164     if (@files) {
1165         # XXX: this is cribbed from an EU::MM-generated Makefile.
1166         system $^X, qw(-MExtUtils::Command::MM -e),
1167             "test_harness(0, 'blib/lib', 'blib/arch')", @files;
1168      } else {
1169         print "No test files for '$buf' in ", Cwd::getcwd, "\n";
1170     }
1171 }
1172
1173 sub repl_load
1174 {
1175     my ($file) = split ' ', shift;
1176     $file ||= "$ENV{HOME}/.sepia-save";
1177     load(retrieve $file);
1178 }
1179
1180 sub repl_save
1181 {
1182     my ($re, $file) = split ' ', shift;
1183     $re ||= '.';
1184     $file ||= "$ENV{HOME}/.sepia-save";
1185     store save($re), $file;
1186 }
1187
1188 sub full_reload
1189 {
1190     (my $name = shift) =~ s!::!/!g;
1191     $name .= '.pm';
1192     print STDERR "full reload $name\n";
1193     my %save_inc = %INC;
1194     local %INC;
1195     require $name;
1196     my @ret = keys %INC;
1197     while (my ($k, $v) = each %save_inc) {
1198         $INC{$k} ||= $v;
1199     }
1200     @ret;
1201 }
1202
1203 sub repl_full_reload
1204 {
1205     chomp (my $pat = shift);
1206     my @x = full_reload $pat;
1207     print "Reloaded: @x\n";
1208 }
1209
1210 sub repl_reload
1211 {
1212     chomp (my $pat = shift);
1213     if ($pat =~ /^\/(.*)\/?$/) {
1214         $pat = $1;
1215         $pat =~ s#::#/#g;
1216         $pat = qr/$pat/;
1217         my @rel;
1218         for (keys %INC) {
1219             next unless /$pat/;
1220             if (!do $_) {
1221                 print "$_: $@\n";
1222             }
1223             s#/#::#g;
1224             s/\.pm$//;
1225             push @rel, $_;
1226         }
1227     } else {
1228         my $mod = $pat;
1229         $pat =~ s#::#/#g;
1230         $pat .= '.pm';
1231         if (exists $INC{$pat}) {
1232             delete $INC{$pat};
1233             eval 'require $mod';
1234             import $mod if $@;
1235             print "Reloaded $mod.\n"
1236         } else {
1237             print "$mod not loaded.\n"
1238         }
1239     }
1240 }
1241
1242 ## Collects warnings for REPL
1243 my @warn;
1244
1245 sub sig_warn
1246 {
1247     push @warn, shift
1248 }
1249
1250 sub print_warnings
1251 {
1252     if (@warn) {
1253         if ($ISEVAL) {
1254             my $tmp = "@warn";
1255             print ';;;'.length($tmp)."\n$tmp\n";
1256         } else {
1257             for (@warn) {
1258                 # s/(.*) at .*/$1/;
1259                 print "warning: $_\n";
1260             }
1261         }
1262     }
1263 }
1264
1265 sub repl_banner
1266 {
1267     print <<EOS;
1268 I need user feedback!  Please send questions or comments to seano\@cpan.org.
1269 Sepia version $Sepia::VERSION.
1270 Type ",h" for help, or ",q" to quit.
1271 EOS
1272 }
1273
1274 =head2 C<repl()>
1275
1276 Execute a command interpreter on standard input and standard output.
1277 If you want to use different descriptors, localize them before
1278 calling C<repl()>.  The prompt has a few bells and whistles, including:
1279
1280 =over 4
1281
1282 =item Obviously-incomplete lines are treated as multiline input (press
1283 'return' twice or 'C-c' to discard).
1284
1285 =item C<die> is overridden to enter a debugging repl at the point
1286 C<die> is called.
1287
1288 =back
1289
1290 Behavior is controlled in part through the following package-globals:
1291
1292 =over 4
1293
1294 =item C<$PACKAGE> -- evaluation package
1295
1296 =item C<$PRINTER> -- result printer (default: dumper)
1297
1298 =item C<$PS1> -- the default prompt
1299
1300 =item C<$STRICT> -- whether 'use strict' is applied to input
1301
1302 =item C<$WANTARRAY> -- evaluation context
1303
1304 =item C<$PRINT_PRETTY> -- format some output nicely (default = 1)
1305
1306 Format some values nicely, independent of $PRINTER.  Currently, this
1307 displays arrays of scalars as columns.
1308
1309 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1310
1311 If zero, then initialization takes place.
1312
1313 =item C<%REPL> -- maps shortcut names to handlers
1314
1315 =item C<%REPL_DOC> -- maps shortcut names to documentation
1316
1317 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1318
1319 =back
1320
1321 =cut
1322
1323 sub repl
1324 {
1325     $| = 1;
1326     if ($REPL_LEVEL == 0) {
1327         define_shortcuts;
1328         -f "$ENV{HOME}/.sepiarc" and do "$ENV{HOME}/.sepiarc";
1329         warn ".sepiarc: $@\n" if $@;
1330     }
1331     local $REPL_LEVEL = $REPL_LEVEL + 1;
1332
1333     my $in;
1334     my $buf = '';
1335     my $sigged = 0;
1336
1337     my $nextrepl = sub { $sigged = 1; };
1338
1339     local *__;
1340     local *CORE::GLOBAL::die = \&Sepia::Debug::die;
1341     local *CORE::GLOBAL::warn = \&Sepia::Debug::warn;
1342     local @REPL_RESULT;
1343     Sepia::Debug::add_repl_commands;
1344     repl_banner if $REPL_LEVEL == 1;
1345     print prompt;
1346     my @sigs = qw(INT TERM PIPE ALRM);
1347     local @SIG{@sigs};
1348     $SIG{$_} = $nextrepl for @sigs;
1349  repl: while (defined(my $in = <STDIN>)) {
1350             if ($sigged) {
1351                 $buf = '';
1352                 $sigged = 0;
1353                 print "\n", prompt;
1354                 next repl;
1355             }
1356             $buf .= $in;
1357             $buf =~ s/^\s*//;
1358             local $ISEVAL;
1359             if ($buf =~ /^<<(\d+)\n(.*)/) {
1360                 $ISEVAL = 1;
1361                 my $len = $1;
1362                 my $tmp;
1363                 $buf = $2;
1364                 while ($len && defined($tmp = read STDIN, $buf, $len, length $buf)) {
1365                     $len -= $tmp;
1366                 }
1367             }
1368             my (@res);
1369             ## Only install a magic handler if no one else is playing.
1370             local $SIG{__WARN__} = $SIG{__WARN__};
1371             @warn = ();
1372             unless ($SIG{__WARN__}) {
1373                 $SIG{__WARN__} = 'Sepia::sig_warn';
1374             }
1375             if (!$ISEVAL) {
1376                 if ($buf eq '') {
1377                     # repeat last interactive command
1378                     $buf = $LAST_INPUT;
1379                 } else {
1380                     $LAST_INPUT = $buf;
1381                 }
1382             }
1383             if ($buf =~ /^,(\S+)\s*(.*)/s) {
1384                 ## Inspector shortcuts
1385                 my $short = $1;
1386                 if (exists $Sepia::RK{$short}) {
1387                     my $ret;
1388                     my $arg = $2;
1389                     chomp $arg;
1390                     $Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
1391                 } else {
1392                     if (grep /^$short/, keys %Sepia::REPL) {
1393                         print "Ambiguous shortcut '$short': ",
1394                             join(', ', sort grep /^$short/, keys %Sepia::REPL),
1395                                 "\n";
1396                     } else {
1397                         print "Unrecognized shortcut '$short'\n";
1398                     }
1399                     $buf = '';
1400                     print prompt;
1401                     next repl;
1402                 }
1403             } else {
1404                 ## Ordinary eval
1405                 @res = $REPL{eval}->($buf);
1406                 if ($@) {
1407                     if ($ISEVAL) {
1408                         ## Always return results for an eval request
1409                         Sepia::printer \@res, wantarray;
1410                         Sepia::printer [$@], wantarray;
1411                         # print_warnings $ISEVAL;
1412                         $buf = '';
1413                         print prompt;
1414                     } elsif ($@ =~ /(?:at|before) EOF(?:$| at)/m) {
1415                         ## Possibly-incomplete line
1416                         if ($in eq "\n") {
1417                             print "Error:\n$@\n*** cancel ***\n", prompt;
1418                             $buf = '';
1419                         } else {
1420                             print ">> ";
1421                         }
1422                     } else {
1423                         print_warnings;
1424                         # $@ =~ s/(.*) at eval .*/$1/;
1425                         # don't complain if we're abandoning execution
1426                         # from the debugger.
1427                         unless (ref $@ eq 'Sepia::Debug') {
1428                             print "error: $@";
1429                             print "\n" unless $@ =~ /\n\z/;
1430                         }
1431                         print prompt;
1432                         $buf = '';
1433                     }
1434                     next repl;
1435                 }
1436             }
1437             if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1438                 ## Be quiet if it ends with a semicolon, or if we
1439                 ## executed a shortcut.
1440                 Sepia::printer \@res, wantarray;
1441             }
1442             $buf = '';
1443             print_warnings;
1444             print prompt;
1445         }
1446     wantarray ? @REPL_RESULT : $REPL_RESULT[0]
1447 }
1448
1449 sub perl_eval
1450 {
1451     tolisp($REPL{eval}->(shift));
1452 }
1453
1454 =head2 C<$status = html_module_list([$file [, $prefix]])>
1455
1456 Generate an HTML list of installed modules, looking inside of
1457 packages.  If C<$prefix> is missing, uses "about://perldoc/".  If
1458 $file is given, write the result to $file; otherwise, return it as a
1459 string.
1460
1461 =head2 C<$status = html_package_list([$file [, $prefix]])>
1462
1463 Generate an HTML list of installed top-level modules, without looking
1464 inside of packages.  If C<$prefix> is missing, uses
1465 "about://perldoc/".  $file is the same as for C<html_module_list>.
1466
1467 =cut
1468
1469 sub html_module_list
1470 {
1471     my ($file, $base) = @_;
1472     $base ||= 'about://perldoc/';
1473     my $inst = inst();
1474     return unless $inst;
1475     my $out;
1476     open OUT, ">", $file || \$out or return;
1477     print OUT "<html><body>";
1478     my $pfx = '';
1479     my %ns;
1480     for (package_list) {
1481         push @{$ns{$1}}, $_ if /^([^:]+)/;
1482     }
1483     # Handle core modules.
1484     my %fs;
1485     undef $fs{$_} for map {
1486         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1487     } grep {
1488         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ # && !/^(?:\/|perl)/
1489     } $inst->files('Perl');
1490     my @fs = sort keys %fs;
1491     print OUT qq{<h2>Core Modules</h2><ul>};
1492     for (@fs) {
1493         print OUT qq{<li><a href="$base$_">$_</a>};
1494     }
1495     print OUT '</ul><h2>Installed Modules</h2><ul>';
1496
1497     # handle the rest
1498     for (sort keys %ns) {
1499         next if $_ eq 'Perl';   # skip Perl core.
1500         print OUT qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
1501         for (sort @{$ns{$_}}) {
1502             my %fs;
1503             undef $fs{$_} for map {
1504                 s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1505             } grep {
1506                 /\.\d(?:pm)?$/ && !/man1/
1507             } $inst->files($_);
1508             my @fs = sort keys %fs;
1509             next unless @fs > 0;
1510             if (@fs == 1) {
1511                 print OUT qq{<li><a href="$base$fs[0]">$fs[0]</a>};
1512             } else {
1513                 print OUT qq{<li>$_<ul>};
1514                 for (@fs) {
1515                     print OUT qq{<li><a href="$base$_">$_</a>};
1516                 }
1517                 print OUT '</ul>';
1518             }
1519         }
1520         print OUT qq{</ul>} if @{$ns{$_}} > 1;
1521     }
1522
1523     print OUT "</ul></body></html>\n";
1524     close OUT;
1525     $file ? 1 : $out;
1526 }
1527
1528 sub html_package_list
1529 {
1530     my ($file, $base) = @_;
1531     return unless inst();
1532     $base ||= 'about://perldoc/';
1533     my $out;
1534     open OUT, ">", $file || \$out or return;
1535     print OUT "<html><body><ul>";
1536     my $pfx = '';
1537     my %ns;
1538     for (package_list) {
1539         push @{$ns{$1}}, $_ if /^([^:]+)/;
1540     }
1541     for (sort keys %ns) {
1542         if (@{$ns{$_}} == 1) {
1543             print OUT
1544                 qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
1545         } else {
1546             print OUT qq{<li><b>$_</b><ul>};
1547             print OUT qq{<li><a href="$base$_">$_</a>}
1548                 for sort @{$ns{$_}};
1549             print OUT qq{</ul>};
1550         }
1551     }
1552     print OUT "</ul></body></html>\n";
1553     close OUT;
1554     $file ? 1 : $out;
1555 }
1556
1557 sub apropos_module
1558 {
1559     my $re = qr/$_[0]/;
1560     my $inst = inst();
1561     my %ret;
1562     for (package_list) {
1563         undef $ret{$_} if /$re/;
1564     }
1565     undef $ret{$_} for map {
1566         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1567     } grep {
1568         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ && /$re/
1569     } $inst->files('Perl');
1570     sort keys %ret;
1571 }
1572
1573 1;
1574 __END__
1575
1576 =head1 TODO
1577
1578 See the README file included with the distribution.
1579
1580 =head1 SEE ALSO
1581
1582 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
1583
1584 There are several modules for Perl development in Emacs on CPAN,
1585 including L<Devel::PerlySense> and L<PDE>.  For a complete list, see
1586 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
1587
1588 =head1 AUTHOR
1589
1590 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
1591
1592 Bug reports welcome, patches even more welcome.
1593
1594 =head1 COPYRIGHT
1595
1596 Copyright (C) 2005-2009 Sean O'Rourke.  All rights reserved, some
1597 wrongs reversed.  This module is distributed under the same terms as
1598 Perl itself.
1599
1600 =cut