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