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