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