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