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