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