lib/Sepia.pm

   1 package Sepia;
   2
   3 =head1 NAME
   4
   5 Sepia - Simple Emacs-Perl Interface
   6
   7 =head1 SYNOPSIS
   8
   9 From inside Emacs:
  10
  11    M-x load-library RET sepia RET
  12    M-x sepia-repl RET
  13
  14 At the prompt in the C<*sepia-repl*> buffer:
  15
  16    main @> ,help
  17
  18 For more information, please see F<Sepia.html> or F<sepia.info>, which
  19 come with the distribution.
  20
  21 =head1 DESCRIPTION
  22
  23 Sepia is a set of features to make Emacs a better tool for Perl
  24 development.  This package contains the Perl side of the
  25 implementation, including all user-serviceable parts (for the
  26 cross-referencing facility see L<Sepia::Xref>).  This document is
  27 aimed as Sepia developers; for user documentation, see
  28 L<Sepia.html> or L<sepia.info>.
  29
  30 Though not intended to be used independent of the Emacs interface, the
  31 Sepia module's functionality can be used through a rough procedural
  32 interface.
  33
  34 =cut
  35
  36 $VERSION = '0.991_03';
  37 BEGIN {
  38     # a less annoying version of strict and warnings
  39     if (!eval 'use common::sense;1') {
  40         eval 'use strict';
  41     }
  42     no warnings 'deprecated';       # undo some of the 5.12 suck.
  43     # 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])>
 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".
 335
 336 =item C<@compls = method_completions($expr, $string [,$eval])>
 337
 338 Complete among methods on the object returned by C<$expr>.  The
 339 C<$eval> argument, if present, is a function used to do the
 340 evaluation; the default is C<eval>, but for example the Sepia REPL
 341 uses C<Sepia::repl_eval>.  B<Warning>: Since it has to evaluate
 342 C<$expr>, method completion can be extremely problematic.  Use with
 343 care.
 344
 345 =cut
 346
 347 sub completions
 348 {
 349     my ($type, $str, $sub) = @_;
 350     my $t;
 351     my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
 352     my %rh;
 353     @rh{values %h} = keys %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         eval '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<define_shortcuts()>
 987
 988 Define the default REPL shortcuts.
 989
 990 =cut
 991
 992 sub define_shortcuts
 993 {
 994     define_shortcut 'help', \&Sepia::repl_help,
 995         'help [CMD]',
 996             'Display help on all commands, or just CMD.';
 997     define_shortcut 'cd', \&Sepia::repl_chdir,
 998         'cd DIR', 'Change directory to DIR';
 999     define_shortcut 'pwd', \&Sepia::repl_pwd,
1000         'Show current working directory';
1001     define_shortcut 'methods', \&Sepia::repl_methods,
1002         'methods X [RE]',
1003             'List methods for reference or package X, matching optional pattern RE';
1004     define_shortcut 'package', \&Sepia::repl_package,
1005         'package PKG', 'Set evaluation package to PKG';
1006     define_shortcut 'who', \&Sepia::repl_who,
1007         'who PKG [RE]',
1008             'List variables and subs in PKG matching optional pattern RE.';
1009     define_shortcut 'wantarray', \&Sepia::repl_wantarray,
1010         'wantarray [0|1]', 'Set or toggle evaluation context';
1011     define_shortcut 'format', \&Sepia::repl_format,
1012         'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
1013     define_shortcut 'strict', \&Sepia::repl_strict,
1014         'strict [0|1]', 'Turn \'use strict\' mode on or off';
1015     define_shortcut 'quit', \&Sepia::repl_quit,
1016         'Quit the REPL';
1017     define_shortcut 'restart', \&Sepia::repl_restart,
1018         'Reload Sepia.pm and relaunch the REPL.';
1019     define_shortcut 'shell', \&Sepia::repl_shell,
1020         'shell CMD ...', 'Run CMD in the shell';
1021     define_shortcut 'eval', \&Sepia::repl_eval,
1022         'eval EXP', '(internal)';
1023     define_shortcut 'size', \&Sepia::repl_size,
1024         'size PKG [RE]',
1025             'List total sizes of objects in PKG matching optional pattern RE.';
1026     define_shortcut define => \&Sepia::repl_define,
1027         'define NAME [\'DOC\'] BODY',
1028             'Define NAME as a shortcut executing BODY';
1029     define_shortcut undef => \&Sepia::repl_undef,
1030         'undef NAME', 'Undefine shortcut NAME';
1031     define_shortcut test => \&Sepia::repl_test,
1032         'test FILE...', 'Run tests interactively.';
1033     define_shortcut load => \&Sepia::repl_load,
1034         'load [FILE]', 'Load state from FILE.';
1035     define_shortcut save => \&Sepia::repl_save,
1036         'save [PATTERN [FILE]]', 'Save variables matching PATTERN to FILE.';
1037     define_shortcut reload => \&Sepia::repl_reload,
1038         'reload [MODULE | /RE/]', 'Reload MODULE, or all modules matching RE.';
1039     define_shortcut freload => \&Sepia::repl_full_reload,
1040         'freload MODULE', 'Reload MODULE and all its dependencies.';
1041     define_shortcut time => \&Sepia::repl_time,
1042         'time [0|1]', 'Print timing information for each command.';
1043     define_shortcut lsmod => \&Sepia::repl_lsmod,
1044         'lsmod [PATTERN]', 'List loaded modules matching PATTERN.';
1045 }
1046
1047 =item C<repl_strict([$value])>
1048
1049 Toggle strict mode.  Requires L<Lexical::Persistence>.
1050
1051 =cut
1052
1053 sub repl_strict
1054 {
1055     eval q{ require Lexical::Persistence; import Lexical::Persistence };
1056     if ($@) {
1057         print "Strict mode requires Lexical::Persistence.\n";
1058     } else {
1059         # L::P has the stupid behavior of not persisting variables
1060         # starting with '_', and dividing them into "contexts" based
1061         # on whatever comes before the first underscore.  Get rid of
1062         # that.
1063         *Lexical::Persistence::parse_variable = sub {
1064             my ($self, $var) = @_;
1065
1066             return unless (
1067                 my ($sigil, $member) = (
1068                     $var =~ /^([\$\@\%])(\S+)/
1069                 )
1070             );
1071             my $context = '_';
1072
1073             if (defined $context) {
1074                 if (exists $self->{context}{$context}) {
1075                     return $sigil, $context, $member if $context eq "arg";
1076                     return $sigil, $context, "$sigil$member";
1077                 }
1078                 return $sigil, "_", "$sigil$context\_$member";
1079             }
1080
1081             return $sigil, "_", "$sigil$member";
1082         };
1083
1084         *repl_strict = sub {
1085             my $x = as_boolean(shift, $STRICT);
1086             if ($x && !$STRICT) {
1087                 $STRICT = new Lexical::Persistence;
1088             } elsif (!$x) {
1089                 undef $STRICT;
1090             }
1091         };
1092         goto &repl_strict;
1093     }
1094 }
1095
1096 sub repl_size
1097 {
1098     eval q{ require Devel::Size };
1099     if ($@) {
1100         print "Size requires Devel::Size.\n";
1101     } else {
1102         *Sepia::repl_size = sub {
1103             no strict 'refs';
1104             ## XXX: C&P from repl_who:
1105             my ($pkg, $re) = split ' ', shift || '';
1106             if ($pkg =~ /^\/(.*)\/?$/) {
1107                 $pkg = $PACKAGE;
1108                 $re = $1;
1109             } elsif (!$pkg) {
1110                 $pkg = 'main';
1111                 $re = '.';
1112             } elsif (!$re && !%{$pkg.'::'}) {
1113                 $re = $pkg;
1114                 $pkg = $PACKAGE;
1115             }
1116             my @who = who($pkg, $re);
1117             my $len = max(3, map { length } @who) + 4;
1118             my $fmt = '%-'.$len."s%10d\n";
1119             # print "$pkg\::/$re/\n";
1120             print 'Var', ' ' x ($len + 2), "Bytes\n";
1121             print '-' x ($len-4), ' ' x 9, '-' x 5, "\n";
1122             my %res;
1123             for (@who) {
1124                 next unless /^[\$\@\%\&]/; # skip subs.
1125                 next if $_ eq '%SIG';
1126                 $res{$_} = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
1127             }
1128             for (sort { $res{$b} <=> $res{$a} } keys %res) {
1129                 printf $fmt, $_, $res{$_};
1130             }
1131         };
1132         goto &repl_size;
1133     }
1134 }
1135
1136 =item C<repl_time([$value])>
1137
1138 Toggle command timing.
1139
1140 =cut
1141
1142 my ($time_res, $TIME);
1143 sub time_pre_prompt_bsd
1144 {
1145     printf "(%.2gr, %.2gu, %.2gs) ", @{$time_res} if defined $time_res;
1146 };
1147
1148 sub time_pre_prompt_plain
1149 {
1150     printf "(%.2gs) ", $time_res if defined $time_res;
1151 }
1152
1153 sub repl_time
1154 {
1155     $TIME = as_boolean(shift, $TIME);
1156     if (!$TIME) {
1157         print STDERR "Removing time hook.\n";
1158         remove_hook @PRE_PROMPT, 'Sepia::time_pre_prompt';
1159         remove_hook @PRE_EVAL, 'Sepia::time_pre_eval';
1160         remove_hook @POST_EVAL, 'Sepia::time_post_eval';
1161         return;
1162     }
1163     print STDERR "Adding time hook.\n";
1164     add_hook @PRE_PROMPT, 'Sepia::time_pre_prompt';
1165     add_hook @PRE_EVAL, 'Sepia::time_pre_eval';
1166     add_hook @POST_EVAL, 'Sepia::time_post_eval';
1167     my $has_bsd = eval q{ use BSD::Resource 'getrusage';1 };
1168     my $has_hires = eval q{ use Time::HiRes qw(gettimeofday tv_interval);1 };
1169     my ($t0);
1170     if ($has_bsd) {                    # sweet!  getrusage!
1171         my ($user, $sys, $real);
1172         *time_pre_eval = sub {
1173             undef $time_res;
1174             ($user, $sys) = getrusage();
1175             $real = $has_hires ? [gettimeofday()] : $user+$sys;
1176         };
1177         *time_post_eval = sub {
1178             my ($u2, $s2) = getrusage();
1179             $time_res = [$has_hires ? tv_interval($real, [gettimeofday()])
1180                              : $s2 + $u2 - $real,
1181                          ($u2 - $user), ($s2 - $sys)];
1182         };
1183         *time_pre_prompt = *time_pre_prompt_bsd;
1184     } elsif ($has_hires) {      # at least we have msec...
1185         *time_pre_eval = sub {
1186             undef $time_res;
1187             $t0 = [gettimeofday()];
1188         };
1189         *time_post_eval = sub {
1190             $time_res = tv_interval($t0, [gettimeofday()]);
1191         };
1192         *time_pre_prompt = *time_pre_prompt_plain;
1193     } else {
1194         *time_pre_eval = sub {
1195             undef $time_res;
1196             $t0 = time;
1197         };
1198         *time_post_eval = sub {
1199             $time_res = (time - $t0);
1200         };
1201         *time_pre_prompt = *time_pre_prompt_plain;
1202     }
1203 }
1204
1205 sub repl_help
1206 {
1207     my $width = $ENV{COLUMNS} || 80;
1208     my $args = shift;
1209     if ($args =~ /\S/) {
1210         $args =~ s/^\s+//;
1211         $args =~ s/\s+$//;
1212         my $full = $RK{$args};
1213         if ($full) {
1214             my $short = $REPL_SHORT{$full};
1215             my $flow = flow($width - length $short - 4, $REPL_DOC{$full});
1216             $flow =~ s/(.)\n/"$1\n".(' 'x (4 + length $short))/eg;
1217             print "$short    $flow\n";
1218         } else {
1219             print "$args: no such command\n";
1220         }
1221     } else {
1222         my $left = 1 + max map length, values %REPL_SHORT;
1223         print "REPL commands (prefixed with ','):\n";
1224
1225         for (sort keys %REPL) {
1226             my $flow = flow($width - $left, $REPL_DOC{$_});
1227             $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
1228             printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
1229         }
1230     }
1231 }
1232
1233 sub repl_define
1234 {
1235     local $_ = shift;
1236     my ($name, $doc, $body);
1237     if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
1238         ($name, $doc, $body) = ($1, $2, $3);
1239     } elsif (/^\s*(\S+)\s+(\S.*)/) {
1240         ($name, $doc, $body) = ($1, $2, $2);
1241     } else {
1242         print "usage: define NAME ['doc'] BODY...\n";
1243         return;
1244     }
1245     my $sub = eval "sub { do { $body } }";
1246     if ($@) {
1247         print "usage: define NAME ['doc'] BODY...\n\t$@\n";
1248         return;
1249     }
1250     define_shortcut $name, $sub, $doc;
1251     # %RK = abbrev keys %REPL;
1252 }
1253
1254 sub repl_undef
1255 {
1256     my $name = shift;
1257     $name =~ s/^\s*//;
1258     $name =~ s/\s*$//;
1259     my $full = $RK{$name};
1260     if ($full) {
1261         delete $REPL{$full};
1262         delete $REPL_SHORT{$full};
1263         delete $REPL_DOC{$full};
1264         abbrev \%RK, keys %REPL;
1265     } else {
1266         print "$name: no such shortcut.\n";
1267     }
1268 }
1269
1270 sub repl_format
1271 {
1272     my $t = shift;
1273     chomp $t;
1274     if ($t eq '') {
1275         print "printer = $PRINTER, columnate = @{[$COLUMNATE ? 1 : 0]}\n";
1276     } else {
1277         my %formats = abbrev keys %PRINTER;
1278         if (exists $formats{$t}) {
1279             $PRINTER = $formats{$t};
1280         } else {
1281             warn "No such format '$t' (dumper, dump, yaml, plain).\n";
1282         }
1283     }
1284 }
1285
1286 sub repl_chdir
1287 {
1288     chomp(my $dir = shift);
1289     $dir =~ s/^~\//$ENV{HOME}\//;
1290     $dir =~ s/\$HOME/$ENV{HOME}/;
1291     if (-d $dir) {
1292         chdir $dir;
1293         my $ecmd = '(cd "'.Cwd::getcwd().'")';
1294         print ";;;###".length($ecmd)."\n$ecmd\n";
1295     } else {
1296         warn "Can't chdir\n";
1297     }
1298 }
1299
1300 sub repl_pwd
1301 {
1302     print Cwd::getcwd(), "\n";
1303 }
1304
1305 =item C<who($package [, $re])>
1306
1307 List variables and functions in C<$package> matching C<$re>, or all
1308 variables if C<$re> is absent.
1309
1310 =cut
1311
1312 sub who
1313 {
1314     my ($pack, $re_str) = @_;
1315     $re_str ||= '.?';
1316     my $re = qr/$re_str/;
1317     no strict;
1318     if ($re_str =~ /^[\$\@\%\&]/) {
1319         ## sigil given -- match it
1320         sort grep /$re/, map {
1321             my $name = $pack.'::'.$_;
1322             (defined *{$name}{HASH} ? '%'.$_ : (),
1323              defined *{$name}{ARRAY} ? '@'.$_ : (),
1324              defined *{$name}{CODE} ? $_ : (),
1325              defined ${$name} ? '$'.$_ : (), # ?
1326          )
1327         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1328     } else {
1329         ## no sigil -- don't match it
1330         sort map {
1331             my $name = $pack.'::'.$_;
1332             (defined *{$name}{HASH} ? '%'.$_ : (),
1333              defined *{$name}{ARRAY} ? '@'.$_ : (),
1334              defined *{$name}{CODE} ? $_ : (),
1335              defined ${$name} ? '$'.$_ : (), # ?
1336          )
1337         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1338     }
1339 }
1340
1341 =item C<$text = columnate(@items)>
1342
1343 Format C<@items> in columns such that they fit within C<$ENV{COLUMNS}>
1344 columns.
1345
1346 =cut
1347
1348 sub columnate
1349 {
1350     my $len = 0;
1351     my $width = $ENV{COLUMNS} || 80;
1352     for (@_) {
1353         $len = length if $len < length;
1354     }
1355     my $nc = int($width / ($len+1)) || 1;
1356     my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
1357     my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
1358     my @incs = map { $_ * $nr } 0..$nc-1;
1359     my $str = '';
1360     for my $r (0..$nr-1) {
1361         $str .= sprintf $fmt, map { defined($_) ? $_ : '' }
1362             @_[map { $r + $_ } @incs];
1363     }
1364     $str =~ s/ +$//m;
1365     $str
1366 }
1367
1368 sub repl_who
1369 {
1370     my ($pkg, $re) = split ' ', shift;
1371     no strict;
1372     if ($pkg && $pkg =~ /^\/(.*)\/?$/) {
1373         $pkg = $PACKAGE;
1374         $re = $1;
1375     } elsif (!$re && !%{$pkg.'::'}) {
1376         $re = $pkg;
1377         $pkg = $PACKAGE;
1378     }
1379     print columnate who($pkg || $PACKAGE, $re);
1380 }
1381
1382 =item C<@m = methods($package [, $qualified])>
1383
1384 List method names in C<$package> and its parents.  If C<$qualified>,
1385 return full "CLASS::NAME" rather than just "NAME."
1386
1387 =cut
1388
1389 sub methods
1390 {
1391     my ($pack, $qualified) = @_;
1392     no strict;
1393     my @own = $qualified ? grep {
1394         defined *{$_}{CODE}
1395     } map { "$pack\::$_" } keys %{$pack.'::'}
1396         : grep {
1397             defined &{"$pack\::$_"}
1398         } keys %{$pack.'::'};
1399     if (exists ${$pack.'::'}{ISA} && *{$pack.'::ISA'}{ARRAY}) {
1400         my %m;
1401         undef @m{@own, map methods($_, $qualified), @{$pack.'::ISA'}};
1402         @own = keys %m;
1403     }
1404     @own;
1405 }
1406
1407 sub repl_methods
1408 {
1409     my ($x, $re) = split ' ', shift;
1410     $x =~ s/^\s+//;
1411     $x =~ s/\s+$//;
1412     if ($x =~ /^\$/) {
1413         $x = $REPL{eval}->("ref $x");
1414         return 0 if $@;
1415     }
1416     $re ||= '.?';
1417     $re = qr/$re/;
1418     print columnate sort { $a cmp $b } grep /$re/, methods $x;
1419 }
1420
1421 sub as_boolean
1422 {
1423     my ($val, $cur) = @_;
1424     $val =~ s/\s+//g;
1425     length($val) ? $val : !$cur;
1426 }
1427
1428 sub repl_wantarray
1429 {
1430     $WANTARRAY = shift || $WANTARRAY;
1431     $WANTARRAY = '' unless $WANTARRAY eq '@' || $WANTARRAY eq '$';
1432 }
1433
1434 sub repl_package
1435 {
1436     chomp(my $p = shift);
1437     $PACKAGE = $p;
1438 }
1439
1440 sub repl_quit
1441 {
1442     $REPL_QUIT = 1;
1443     last repl;
1444 }
1445
1446 sub repl_restart
1447 {
1448     do $INC{'Sepia.pm'};
1449     if ($@) {
1450         print "Restart failed:\n$@\n";
1451     } else {
1452         $REPL_LEVEL = 0;        # ok?
1453         goto &Sepia::repl;
1454     }
1455 }
1456
1457 sub repl_shell
1458 {
1459     my $cmd = shift;
1460     print `$cmd 2>& 1`;
1461 }
1462
1463 sub repl_eval
1464 {
1465     my ($buf) = @_;
1466     no strict;
1467     # local $PACKAGE = $pkg || $PACKAGE;
1468     if ($STRICT) {
1469         if ($WANTARRAY eq '$') {
1470             $buf = 'scalar($buf)';
1471         } elsif ($WANTARRAY ne '@') {
1472             $buf = '$buf;1';
1473         }
1474         my $ctx = join(',', keys %{$STRICT->get_context('_')});
1475         $ctx = $ctx ? "my ($ctx);" : '';
1476         $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1477         if ($@) {
1478             print "ERROR\n$@\n";
1479             return;
1480         }
1481         $STRICT->call($buf);
1482     } else {
1483         $buf = "do { package $PACKAGE; no strict; $buf }";
1484         if ($WANTARRAY eq '@') {
1485             eval $buf;
1486         } elsif ($WANTARRAY eq '$') {
1487             scalar eval $buf;
1488         } else {
1489             eval $buf; undef
1490         }
1491     }
1492 }
1493
1494 sub repl_test
1495 {
1496     my ($buf) = @_;
1497     my @files;
1498     if ($buf =~ /\S/) {
1499         $buf =~ s/^\s+//;
1500         $buf =~ s/\s+$//;
1501         if (-f $buf) {
1502             push @files, $buf;
1503         } elsif (-f "t/$buf") {
1504             push @files, $buf;
1505         }
1506     } else {
1507         find({ no_chdir => 1,
1508                wanted => sub {
1509                    push @files, $_ if /\.t$/;
1510             }}, Cwd::getcwd() =~ /t\/?$/ ? '.' : './t');
1511     }
1512     if (@files) {
1513         # XXX: this is cribbed from an EU::MM-generated Makefile.
1514         system $^X, qw(-MExtUtils::Command::MM -e),
1515             "test_harness(0, 'blib/lib', 'blib/arch')", @files;
1516      } else {
1517         print "No test files for '$buf' in ", Cwd::getcwd, "\n";
1518     }
1519 }
1520
1521 sub repl_load
1522 {
1523     my ($file) = split ' ', shift;
1524     $file ||= "$ENV{HOME}/.sepia-save";
1525     load(retrieve $file);
1526 }
1527
1528 sub repl_save
1529 {
1530     my ($re, $file) = split ' ', shift;
1531     $re ||= '.';
1532     $file ||= "$ENV{HOME}/.sepia-save";
1533     store save($re), $file;
1534 }
1535
1536 sub modules_matching
1537 {
1538     my $pat = shift;
1539     if ($pat =~ /^\/(.*)\/?$/) {
1540         $pat = $1;
1541         $pat =~ s#::#/#g;
1542         $pat = qr/$pat/;
1543         grep /$pat/, keys %INC;
1544     } else {
1545         my $mod = $pat;
1546         $pat =~ s#::#/#g;
1547         exists $INC{"$pat.pm"} ? "$pat.pm" : ();
1548     }
1549 }
1550
1551 sub full_reload
1552 {
1553     my %save_inc = %INC;
1554     local %INC;
1555     for my $name (modules_matching $_[0]) {
1556         print STDERR "full reload $name\n";
1557         require $name;
1558     }
1559     my @ret = keys %INC;
1560     while (my ($k, $v) = each %save_inc) {
1561         $INC{$k} ||= $v;
1562     }
1563     @ret;
1564 }
1565
1566 sub repl_full_reload
1567 {
1568     chomp (my $pat = shift);
1569     my @x = full_reload $pat;
1570     print "Reloaded: @x\n";
1571 }
1572
1573 sub repl_reload
1574 {
1575     chomp (my $pat = shift);
1576     # for my $name (modules_matching $pat) {
1577     #     delete $INC{$PAT};
1578     #     eval "require $name";
1579     #     if (!$@) {
1580     #     (my $mod = $name) =~ s/
1581     if ($pat =~ /^\/(.*)\/?$/) {
1582         $pat = $1;
1583         $pat =~ s#::#/#g;
1584         $pat = qr/$pat/;
1585         my @rel;
1586         for (keys %INC) {
1587             next unless /$pat/;
1588             if (!do $_) {
1589                 print "$_: $@\n";
1590             }
1591             s#/#::#g;
1592             s/\.pm$//;
1593             push @rel, $_;
1594         }
1595     } else {
1596         my $mod = $pat;
1597         $pat =~ s#::#/#g;
1598         $pat .= '.pm';
1599         if (exists $INC{$pat}) {
1600             delete $INC{$pat};
1601             eval 'require $mod';
1602             import $mod unless $@;
1603             print "Reloaded $mod.\n"
1604         } else {
1605             print "$mod not loaded.\n"
1606         }
1607     }
1608 }
1609
1610 sub repl_lsmod
1611 {
1612     chomp (my $pat = shift);
1613     $pat ||= '.';
1614     $pat = qr/$pat/;
1615     my $first = 1;
1616     my $fmt =  "%-20s%8s  %s\n";
1617     for (sort keys %INC) {
1618         my $file = $_;
1619         s!/!::!g;
1620         s/\.p[lm]$//;
1621         next if /^::/ || !/$pat/;
1622         if ($first) {
1623             printf $fmt, qw(Module Version File);
1624             printf $fmt, qw(------ ------- ----);
1625             $first = 0;
1626         }
1627         printf $fmt, $_, (UNIVERSAL::VERSION($_)||'???'), $INC{$file};
1628     }
1629     if ($first) {
1630         print "No modules found.\n";
1631     }
1632 }
1633
1634 =item C<sig_warn($warning)>
1635
1636 Collect C<$warning> for later printing.
1637
1638 =item C<print_warnings()>
1639
1640 Print and clear accumulated warnings.
1641
1642 =cut
1643
1644 my @warn;
1645
1646 sub sig_warn
1647 {
1648     push @warn, shift
1649 }
1650
1651 sub print_warnings
1652 {
1653     if (@warn) {
1654         if ($ISEVAL) {
1655             my $tmp = "@warn";
1656             print ';;;'.length($tmp)."\n$tmp\n";
1657         } else {
1658             for (@warn) {
1659                 # s/(.*) at .*/$1/;
1660                 print "warning: $_\n";
1661             }
1662         }
1663     }
1664 }
1665
1666 sub repl_banner
1667 {
1668     print <<EOS;
1669 I need user feedback!  Please send questions or comments to seano\@cpan.org.
1670 Sepia version $Sepia::VERSION.
1671 Type ",h" for help, or ",q" to quit.
1672 EOS
1673 }
1674
1675 =item C<repl()>
1676
1677 Execute a command interpreter on standard input and standard output.
1678 If you want to use different descriptors, localize them before
1679 calling C<repl()>.  The prompt has a few bells and whistles, including:
1680
1681 =over 4
1682
1683 =item Obviously-incomplete lines are treated as multiline input (press
1684 'return' twice or 'C-c' to discard).
1685
1686 =item C<die> is overridden to enter a debugging repl at the point
1687 C<die> is called.
1688
1689 =back
1690
1691 Behavior is controlled in part through the following package-globals:
1692
1693 =over 4
1694
1695 =item C<$PACKAGE> -- evaluation package
1696
1697 =item C<$PRINTER> -- result printer (default: dumper)
1698
1699 =item C<$PS1> -- the default prompt
1700
1701 =item C<$STRICT> -- whether 'use strict' is applied to input
1702
1703 =item C<$WANTARRAY> -- evaluation context
1704
1705 =item C<$COLUMNATE> -- format some output nicely (default = 1)
1706
1707 Format some values nicely, independent of $PRINTER.  Currently, this
1708 displays arrays of scalars as columns.
1709
1710 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1711
1712 If zero, then initialization takes place.
1713
1714 =item C<%REPL> -- maps shortcut names to handlers
1715
1716 =item C<%REPL_DOC> -- maps shortcut names to documentation
1717
1718 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1719
1720 =back
1721
1722 =back
1723
1724 =cut
1725
1726 sub repl_setup
1727 {
1728     $| = 1;
1729     if ($REPL_LEVEL == 0) {
1730         define_shortcuts;
1731         -f "$ENV{HOME}/.sepiarc" and eval qq#package $Sepia::PACKAGE; do "$ENV{HOME}/.sepiarc"#;
1732         warn ".sepiarc: $@\n" if $@;
1733     }
1734     Sepia::Debug::add_repl_commands;
1735     repl_banner if $REPL_LEVEL == 0;
1736 }
1737
1738 $READLINE = sub { print prompt(); <STDIN> };
1739
1740 sub repl
1741 {
1742     repl_setup;
1743     local $REPL_LEVEL = $REPL_LEVEL + 1;
1744
1745     my $in;
1746     my $buf = '';
1747     $SIGGED = 0;
1748
1749     my $nextrepl = sub { $SIGGED++; };
1750
1751     local (@_, $_);
1752     local *CORE::GLOBAL::die = \&Sepia::Debug::die;
1753     local *CORE::GLOBAL::warn = \&Sepia::Debug::warn;
1754     my @sigs = qw(INT TERM PIPE ALRM);
1755     local @SIG{@sigs};
1756     $SIG{$_} = $nextrepl for @sigs;
1757  repl: while (defined(my $in = $READLINE->())) {
1758             if ($SIGGED) {
1759                 $buf = '';
1760                 $SIGGED = 0;
1761                 print "\n";
1762                 next repl;
1763             }
1764             $buf .= $in;
1765             $buf =~ s/^\s*//;
1766             local $ISEVAL;
1767             if ($buf =~ /^<<(\d+)\n(.*)/) {
1768                 $ISEVAL = 1;
1769                 my $len = $1;
1770                 my $tmp;
1771                 $buf = $2;
1772                 while ($len && defined($tmp = read STDIN, $buf, $len, length $buf)) {
1773                     $len -= $tmp;
1774                 }
1775             }
1776             ## Only install a magic handler if no one else is playing.
1777             local $SIG{__WARN__} = $SIG{__WARN__};
1778             @warn = ();
1779             unless ($SIG{__WARN__}) {
1780                 $SIG{__WARN__} = 'Sepia::sig_warn';
1781             }
1782             if (!$ISEVAL) {
1783                 if ($buf eq '') {
1784                     # repeat last interactive command
1785                     $buf = $LAST_INPUT;
1786                 } else {
1787                     $LAST_INPUT = $buf;
1788                 }
1789             }
1790             if ($buf =~ /^,(\S+)\s*(.*)/s) {
1791                 ## Inspector shortcuts
1792                 my $short = $1;
1793                 if (exists $Sepia::RK{$short}) {
1794                     my $ret;
1795                     my $arg = $2;
1796                     chomp $arg;
1797                     $Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
1798                 } else {
1799                     if (grep /^$short/, keys %Sepia::REPL) {
1800                         print "Ambiguous shortcut '$short': ",
1801                             join(', ', sort grep /^$short/, keys %Sepia::REPL),
1802                                 "\n";
1803                     } else {
1804                         print "Unrecognized shortcut '$short'\n";
1805                     }
1806                     $buf = '';
1807                     next repl;
1808                 }
1809             } else {
1810                 ## Ordinary eval
1811                 run_hook @PRE_EVAL;
1812                 @res = $REPL{eval}->($buf);
1813                 run_hook @POST_EVAL;
1814                 if ($@) {
1815                     if ($ISEVAL) {
1816                         ## Always return results for an eval request
1817                         Sepia::printer \@res, wantarray;
1818                         Sepia::printer [$@], wantarray;
1819                         # print_warnings $ISEVAL;
1820                         $buf = '';
1821                     } elsif ($@ =~ /(?:at|before) EOF(?:$| at)/m) {
1822                         ## Possibly-incomplete line
1823                         if ($in eq "\n") {
1824                             print "Error:\n$@\n*** cancel ***\n";
1825                             $buf = '';
1826                         } else {
1827                             print ">> ";
1828                         }
1829                     } else {
1830                         print_warnings;
1831                         # $@ =~ s/(.*) at eval .*/$1/;
1832                         # don't complain if we're abandoning execution
1833                         # from the debugger.
1834                         unless (ref $@ eq 'Sepia::Debug') {
1835                             print "error: $@";
1836                             print "\n" unless $@ =~ /\n\z/;
1837                         }
1838                         $buf = '';
1839                     }
1840                     next repl;
1841                 }
1842             }
1843             if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1844                 ## Be quiet if it ends with a semicolon, or if we
1845                 ## executed a shortcut.
1846                 Sepia::printer \@res, wantarray;
1847             }
1848             $buf = '';
1849             print_warnings;
1850         }
1851     exit if $REPL_QUIT;
1852     wantarray ? @res : $res[0]
1853 }
1854
1855 sub perl_eval
1856 {
1857     tolisp($REPL{eval}->(shift));
1858 }
1859
1860 =head2 Module browsing
1861
1862 =over
1863
1864 =item C<$status = html_module_list([$file [, $prefix]])>
1865
1866 Generate an HTML list of installed modules, looking inside of
1867 packages.  If C<$prefix> is missing, uses "about://perldoc/".  If
1868 $file is given, write the result to $file; otherwise, return it as a
1869 string.
1870
1871 =item C<$status = html_package_list([$file [, $prefix]])>
1872
1873 Generate an HTML list of installed top-level modules, without looking
1874 inside of packages.  If C<$prefix> is missing, uses
1875 "about://perldoc/".  $file is the same as for C<html_module_list>.
1876
1877 =back
1878
1879 =cut
1880
1881 sub html_module_list
1882 {
1883     my ($file, $base) = @_;
1884     $base ||= 'about://perldoc/';
1885     my $inst = inst();
1886     return unless $inst;
1887     my $out;
1888     open OUT, ">", $file || \$out or return;
1889     print OUT "<html><body>";
1890     my $pfx = '';
1891     my %ns;
1892     for (package_list) {
1893         push @{$ns{$1}}, $_ if /^([^:]+)/;
1894     }
1895     # Handle core modules.
1896     my %fs;
1897     undef $fs{$_} for map {
1898         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1899     } grep {
1900         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ # && !/^(?:\/|perl)/
1901     } $inst->files('Perl');
1902     my @fs = sort keys %fs;
1903     print OUT qq{<h2>Core Modules</h2><ul>};
1904     for (@fs) {
1905         print OUT qq{<li><a href="$base$_">$_</a>};
1906     }
1907     print OUT '</ul><h2>Installed Modules</h2><ul>';
1908
1909     # handle the rest
1910     for (sort keys %ns) {
1911         next if $_ eq 'Perl';   # skip Perl core.
1912         print OUT qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
1913         for (sort @{$ns{$_}}) {
1914             my %fs;
1915             undef $fs{$_} for map {
1916                 s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1917             } grep {
1918                 /\.\d(?:pm)?$/ && !/man1/
1919             } $inst->files($_);
1920             my @fs = sort keys %fs;
1921             next unless @fs > 0;
1922             if (@fs == 1) {
1923                 print OUT qq{<li><a href="$base$fs[0]">$fs[0]</a>};
1924             } else {
1925                 print OUT qq{<li>$_<ul>};
1926                 for (@fs) {
1927                     print OUT qq{<li><a href="$base$_">$_</a>};
1928                 }
1929                 print OUT '</ul>';
1930             }
1931         }
1932         print OUT qq{</ul>} if @{$ns{$_}} > 1;
1933     }
1934
1935     print OUT "</ul></body></html>\n";
1936     close OUT;
1937     $file ? 1 : $out;
1938 }
1939
1940 sub html_package_list
1941 {
1942     my ($file, $base) = @_;
1943     return unless inst();
1944     my %ns;
1945     for (package_list) {
1946         push @{$ns{$1}}, $_ if /^([^:]+)/;
1947     }
1948     $base ||= 'about://perldoc/';
1949     my $out;
1950     open OUT, ">", $file || \$out or return;
1951     print OUT "<html><body><ul>";
1952     my $pfx = '';
1953     for (sort keys %ns) {
1954         if (@{$ns{$_}} == 1) {
1955             print OUT
1956                 qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
1957         } else {
1958             print OUT qq{<li><b>$_</b><ul>};
1959             print OUT qq{<li><a href="$base$_">$_</a>}
1960                 for sort @{$ns{$_}};
1961             print OUT qq{</ul>};
1962         }
1963     }
1964     print OUT "</ul></body></html>\n";
1965     close OUT;
1966     $file ? 1 : $out;
1967 }
1968
1969 sub apropos_module
1970 {
1971     my $re = _apropos_re $_[0], 1;
1972     my $inst = inst();
1973     my %ret;
1974     my $incre = inc_re;
1975     for ($inst->files('Perl', 'prog'), package_list) {
1976         if (/\.\d?(?:pm)?$/ && !/man1/ && !/usr\/bin/ && /$re/) {
1977             s/$incre//;
1978             s/.*man.\///;
1979             s|/|::|g;
1980             s/^:+//;
1981             s/\.\d?(?:p[lm])?$//;
1982             undef $ret{$_}
1983         }
1984     }
1985     sort keys %ret;
1986 }
1987
1988 sub requires
1989 {
1990     my $mod = shift;
1991     my @q = $REQUIRES{$mod};
1992     my @done;
1993     while (@q) {
1994         my $m = shift @q;
1995         push @done, $m;
1996         push @q, @{$REQUIRES{$m}};
1997     }
1998     @done;
1999 }
2000
2001 sub users
2002 {
2003     my $mod = shift;
2004     @{$REQUIRED_BY{$mod}}
2005 }
2006
2007 1;
2008 __END__
2009
2010 =head1 TODO
2011
2012 See the README file included with the distribution.
2013
2014 =head1 SEE ALSO
2015
2016 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
2017
2018 There are several modules for Perl development in Emacs on CPAN,
2019 including L<Devel::PerlySense> and L<PDE>.  For a complete list, see
2020 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
2021
2022 =head1 AUTHOR
2023
2024 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
2025
2026 Bug reports welcome, patches even more welcome.
2027
2028 =head1 COPYRIGHT
2029
2030 Copyright (C) 2005-2010 Sean O'Rourke.  All rights reserved, some
2031 wrongs reversed.  This module is distributed under the same terms as
2032 Perl itself.
2033
2034 =cut