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