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