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 =cut
  22
  23 $VERSION = '0.97';
  24 use strict;
  25 use B;
  26 use Sepia::Debug;               # THIS TURNS ON DEBUGGING INFORMATION!
  27 use Cwd 'abs_path';
  28 use Scalar::Util 'looks_like_number';
  29 use Text::Abbrev;
  30
  31 use vars qw($PS1 %REPL %RK %REPL_DOC %REPL_SHORT %PRINTER
  32             @REPL_RESULT @res
  33             $REPL_LEVEL $PACKAGE $WANTARRAY $PRINTER $STRICT $PRINT_PRETTY
  34             $ISEVAL);
  35
  36 sub repl_strict
  37 {
  38     eval { require Lexical::Persistence; import Lexical::Persistence };
  39     if ($@) {
  40         print "Strict mode requires Lexical::Persistence.\n";
  41     } else {
  42         *repl_strict = sub {
  43             my $x = as_boolean(shift, $STRICT);
  44             if ($x && !$STRICT) {
  45                 $STRICT = new Lexical::Persistence;
  46             } elsif (!$x) {
  47                 undef $STRICT;
  48             }
  49         };
  50         goto &repl_strict;
  51     }
  52 }
  53
  54 sub core_version
  55 {
  56     eval { require Module::CoreList };
  57     if ($@) {
  58         '???';
  59     } else {
  60         *core_version = sub { Module::CoreList->first_release(@_) };
  61         goto &core_version;
  62     }
  63 }
  64
  65 BEGIN {
  66     eval { use List::Util 'max' };
  67     if ($@) {
  68         *Sepia::max = sub {
  69             my $ret = shift;
  70             for (@_) {
  71                 $ret = $_ if $_ > $ret;
  72             }
  73             $ret;
  74         };
  75     }
  76 }
  77
  78 sub repl_size
  79 {
  80     eval { require Devel::Size };
  81     if ($@) {
  82         print "Size requires Devel::Size.\n";
  83     } else {
  84         *Sepia::repl_size = sub {
  85             no strict 'refs';
  86             ## XXX: C&P from repl_who:
  87             my ($pkg, $re) = split ' ', shift || '';
  88             if ($pkg =~ /^\/(.*)\/?$/) {
  89                 $pkg = $PACKAGE;
  90                 $re = $1;
  91             } elsif (!$re && !%{$pkg.'::'}) {
  92                 $re = $pkg;
  93                 $pkg = $PACKAGE;
  94             } else {
  95                 $re = '';
  96                 $pkg = $PACKAGE;
  97             }
  98             my @who = who($pkg, $re);
  99             my $len = max(3, map { length } @who) + 4;
 100             my $fmt = '%-'.$len."s%10d\n";
 101             print 'Var', ' ' x ($len + 2), "Bytes\n";
 102             print '-' x ($len-4), ' ' x 9, '-' x 5, "\n";
 103             for (@who) {
 104                 next unless /^[\$\@\%\&]/; # skip subs.
 105                 next if $_ eq '%SIG';
 106                 my $res = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
 107                 print "aiee: $@\n" if $@;
 108                 printf $fmt, $_, $res;
 109             }
 110         };
 111         goto &repl_size;
 112     }
 113 }
 114
 115 =head1 DESCRIPTION
 116
 117 Sepia is a set of features to make Emacs a better tool for Perl
 118 development.  This package contains the Perl side of the
 119 implementation, including all user-serviceable parts (for the
 120 cross-referencing facility see L<Sepia::Xref>).  This document is
 121 aimed as Sepia developers; for user documentation, see
 122 L<sepia/index.html>.
 123
 124 Though not intended to be used independent of the Emacs interface, the
 125 Sepia module's functionality can be used through a rough procedural
 126 interface.
 127
 128 =head2 C<@compls = completions($string [, $type])>
 129
 130 Find a list of completions for C<$string> with glob type C<$type>,
 131 which may be "SCALAR", "HASH", "ARRAY", "CODE", "IO", or the special
 132 value "VARIABLE", which means either scalar, hash, or array.
 133 Completion operates on word subparts separated by [:_], so
 134 e.g. "S:m_w" completes to "Sepia::my_walksymtable".
 135
 136 =head2 C<@compls = method_completions($expr, $string [,$eval])>
 137
 138 Complete among methods on the object returned by C<$expr>.  The
 139 C<$eval> argument, if present, is a function used to do the
 140 evaluation; the default is C<eval>, but for example the Sepia REPL
 141 uses C<Sepia::repl_eval>.  B<Warning>: Since it has to evaluate
 142 C<$expr>, method completion can be extremely problematic.  Use with
 143 care.
 144
 145 =cut
 146
 147 sub _apropos_re($)
 148 {
 149     # Do that crazy multi-word identifier completion thing:
 150     my $re = shift;
 151     return qr/.*/ if $re eq '';
 152     if (wantarray) {
 153         map {
 154             s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
 155             qr/^$_/
 156         } split /:+/, $re, -1;
 157     } else {
 158         if ($re !~ /[^\w\d_^:]/) {
 159             $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
 160         }
 161         qr/$re/;
 162     }
 163 }
 164
 165 my %sigil;
 166 BEGIN {
 167     %sigil = qw(ARRAY @ SCALAR $ HASH %);
 168 }
 169
 170 sub filter_untyped
 171 {
 172     no strict;
 173     local $_ = /^::/ ? $_ : "::$_";
 174     defined *{$_}{CODE} || defined *{$_}{IO} || (/::$/ && %$_);
 175 }
 176
 177 ## XXX: Careful about autovivification here!  Specifically:
 178 ##     defined *FOO{HASH} # => ''
 179 ##     defined %FOO       # => ''
 180 ##     defined *FOO{HASH} # => 1
 181 sub filter_typed
 182 {
 183     no strict;
 184     my $type = shift;
 185     local $_ = /^::/ ? $_ : "::$_";
 186     if ($type eq 'SCALAR') {
 187         defined $$_;
 188     } elsif ($type eq 'VARIABLE') {
 189         defined $$_ || defined *{$_}{HASH} || defined *{$_}{ARRAY};
 190     } else {
 191         defined *{$_}{$type}
 192     }
 193 }
 194
 195 sub maybe_icase
 196 {
 197     my $ch = shift;
 198     $ch =~ /[A-Z]/ ? $ch : '['.uc($ch).$ch.']';
 199 }
 200
 201 sub all_abbrev_completions
 202 {
 203     use vars '&_completions';
 204     local *_completions = sub {
 205         no strict;
 206         my ($stash, @e) = @_;
 207         my $ch = '[A-Za-z0-9]*';
 208         my $re1 = "^".maybe_icase($e[0]).$ch.join('', map {
 209             '_'.maybe_icase($_).$ch
 210         } @e[1..$#e]);
 211         $re1 = qr/$re1/;
 212         my $re2 = maybe_icase $e[0];
 213         $re2 = qr/^$re2.*::$/;
 214         my @ret = grep !/::$/ && /$re1/, keys %{$stash};
 215         my @pkgs = grep /$re2/, keys %{$stash};
 216         (map("$stash$_", @ret),
 217          @e > 1 ? map { _completions "$stash$_", @e[1..$#e] } @pkgs :
 218              map { "$stash$_" } @pkgs)
 219     };
 220     map { s/^:://; $_ } _completions('::', split //, shift);
 221 }
 222
 223 sub apropos_re
 224 {
 225     my ($icase, $re) = @_;
 226     $re =~ s/_/[^_]*_/g;
 227     $icase ? qr/^$re.*$/i : qr/^$re.*$/;
 228 }
 229
 230 sub all_completions
 231 {
 232     my $icase = $_[0] !~ /[A-Z]/;
 233     my @parts = split /:+/, shift, -1;
 234     my $re = apropos_re $icase, pop @parts;
 235     use vars '&_completions';
 236     local *_completions = sub {
 237         no strict;
 238         my $stash = shift;
 239         if (@_ == 0) {
 240             map { "$stash$_" } grep /$re/, keys %{$stash};
 241         } else {
 242             my $re2 = $icase ? qr/^$_[0].*::$/i : qr/^$_[0].*::$/;
 243             my @pkgs = grep /$re2/, keys %{$stash};
 244             map { _completions "$stash$_", @_[1..$#_] } @pkgs
 245         }
 246     };
 247     map { s/^:://; $_ } _completions('::', @parts);
 248 }
 249
 250 sub completions
 251 {
 252     my ($type, $str, $t);
 253     my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
 254     my %rh;
 255     @rh{values %h} = keys %h;
 256     if (@_ == 1) {
 257         ($type, $str) = $_[0] =~ /^([\%\$\@\&]?)(.*)/;
 258         $t = $type || '';
 259     $type = $h{$type} if $type;
 260     } else {
 261         ($str, $type) = @_;
 262         $type ||= '';
 263         $t = $rh{$type} if $type;
 264     }
 265     my @ret = grep {
 266         $type ? filter_typed $type : filter_untyped
 267     } all_completions $str;
 268     if (!@ret && $str !~ /:/) {
 269         @ret = grep {
 270             $type ? filter_typed $type : filter_untyped
 271         } all_abbrev_completions $str;
 272     }
 273     @ret = map { s/^:://; "$t$_" } @ret;
 274 #     ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
 275 #     ## remove them.
 276     grep {
 277         length > 0 && !looks_like_number $_ && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
 278     } @ret;
 279 }
 280
 281 sub method_completions
 282 {
 283     my ($x, $fn, $eval) = @_;
 284     $x =~ s/^\s+//;
 285     $x =~ s/\s+$//;
 286     $eval ||= 'CORE::eval';
 287     no strict;
 288     return unless ($x =~ /^\$/ && ($x = $eval->("ref($x)")))
 289         || $eval->('%'.$x.'::');
 290     unless ($@) {
 291         my $re = _apropos_re $fn;
 292         ## Filter out overload methods "(..."
 293         return sort { $a cmp $b } map { s/.*:://; $_ }
 294             grep { defined *{$_}{CODE} && /::$re/ && !/\(/ }
 295                 methods($x, 1);
 296     }
 297 }
 298
 299 =head2 C<@locs = location(@names)>
 300
 301 Return a list of [file, line, name] triples, one for each function
 302 name in C<@names>.
 303
 304 =cut
 305
 306 sub location
 307 {
 308     no strict;
 309     my @x= map {
 310         my $str = $_;
 311         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
 312             if ($pfx) {
 313                 warn "Sorry -- can't lookup variables.";
 314                 [];
 315             } else {
 316                 # XXX: svref_2object only seems to work with a package
 317                 # tacked on, but that should probably be done
 318                 # elsewhere...
 319                 $name = 'main::'.$name unless $name =~ /::/;
 320                 my $cv = B::svref_2object(\&{$name});
 321                 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
 322                     my ($file, $line) = ($cv->file, $cv->line);
 323                     if ($file !~ /^\//) {
 324                         for (@INC) {
 325                             if (-f "$_/$file") {
 326                                 $file = "$_/$file";
 327                                 last;
 328                             }
 329                         }
 330                     }
 331                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
 332                     [Cwd::abs_path($file), $line, $shortname || $name]
 333                 } else {
 334 #                    warn "Bad CV for $name: $cv";
 335                     [];
 336                 }
 337             }
 338         } else {
 339             []
 340         }
 341     } @_;
 342     return @x;
 343 }
 344
 345 =head2 C<@matches = apropos($name [, $is_regex])>
 346
 347 Search for function C<$name>, either in all packages or, if C<$name>
 348 is qualified, only in one package.  If C<$is_regex> is true, the
 349 non-package part of C<$name> is a regular expression.
 350
 351 =cut
 352
 353 sub my_walksymtable(&*)
 354 {
 355     no strict;
 356     my ($f, $st) = @_;
 357     local *_walk = sub {
 358         local ($stash) = @_;
 359         &$f for keys %$stash;
 360         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 361     };
 362     _walk($st);
 363 }
 364
 365 sub apropos
 366 {
 367     my ($it, $re, @types) = @_;
 368     my $stashp;
 369     if (@types) {
 370         $stashp = grep /STASH/, @types;
 371         @types = grep !/STASH/, @types;
 372     } else {
 373         @types = qw(CODE);
 374     }
 375     no strict;
 376     if ($it =~ /^(.*::)([^:]+)$/) {
 377         my ($stash, $name) = ($1, $2);
 378         if (!%$stash) {
 379             return;
 380         }
 381         if ($re) {
 382             my $name = qr/^$name/;
 383             map {
 384                 "$stash$_"
 385             }
 386             grep {
 387                 my $stashnm = "$stash$_";
 388                 /$name/ &&
 389                     (($stashp && /::$/)
 390                      || scalar grep {
 391                          defined($_ eq 'SCALAR' ? $$stashnm : *{$stashnm}{$_})
 392                      } @types)
 393             } keys %$stash;
 394         } else {
 395             defined &$it ? $it : ();
 396         }
 397     } else {
 398         my @ret;
 399         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 400         my_walksymtable {
 401             push @ret, "$stash$_" if /$findre/;
 402         } '::';
 403         map { s/^:*(?:main:+)*//;$_ } @ret;
 404     }
 405 }
 406
 407 =head2 C<@names = mod_subs($pack)>
 408
 409 Find subs in package C<$pack>.
 410
 411 =cut
 412
 413 sub mod_subs
 414 {
 415     no strict;
 416     my $p = shift;
 417     my $stash = \%{"$p\::"};
 418     if (%$stash) {
 419         grep { defined &{"$p\::$_"} } keys %$stash;
 420     }
 421 }
 422
 423 =head2 C<@decls = mod_decls($pack)>
 424
 425 Generate a list of declarations for all subroutines in package
 426 C<$pack>.
 427
 428 =cut
 429
 430 sub mod_decls
 431 {
 432     my $pack = shift;
 433     no strict 'refs';
 434     my @ret = map {
 435         my $sn = $_;
 436         my $proto = prototype(\&{"$pack\::$sn"});
 437         $proto = defined($proto) ? "($proto)" : '';
 438         "sub $sn $proto;";
 439     } mod_subs($pack);
 440     return wantarray ? @ret : join '', @ret;
 441 }
 442
 443 =head2 C<$info = module_info($module, $type)>
 444
 445 Emacs-called function to get module information.
 446
 447 =cut
 448
 449 sub module_info
 450 {
 451     eval { require Module::Info; import Module::Info };
 452     if ($@) {
 453         undef;
 454     } else {
 455         *module_info = sub {
 456             my ($m, $func) = @_;
 457             my $info;
 458             if (-f $m) {
 459                 $info = Module::Info->new_from_file($m);
 460             } else {
 461                 (my $file = $m) =~ s|::|/|g;
 462                 $file .= '.pm';
 463                 if (exists $INC{$file}) {
 464                     $info = Module::Info->new_from_loaded($m);
 465                 } else {
 466                     $info = Module::Info->new_from_module($m);
 467                 }
 468             }
 469             if ($info) {
 470                 return $info->$func;
 471             }
 472         };
 473         goto &module_info;
 474     }
 475 }
 476
 477 =head2 C<$file = mod_file($mod)>
 478
 479 Find the likely file owner for module C<$mod>.
 480
 481 =cut
 482
 483 sub mod_file
 484 {
 485     my $m = shift;
 486     $m =~ s/::/\//g;
 487     while ($m && !exists $INC{"$m.pm"}) {
 488         $m =~ s#(?:^|/)[^/]+$##;
 489     }
 490     $m ? $INC{"$m.pm"} : undef;
 491 }
 492
 493 =head2 C<@mods = package_list>
 494
 495 Gather a list of all distributions on the system. XXX UNUSED
 496
 497 =cut
 498
 499 our $INST;
 500 sub inst()
 501 {
 502     unless ($INST) {
 503         eval 'require ExtUtils::Installed';
 504         $INST = new ExtUtils::Installed;
 505     }
 506     $INST;
 507 }
 508
 509 sub package_list
 510 {
 511     sort { $a cmp $b } inst()->modules;
 512 }
 513
 514 =head2 C<@mods = module_list>
 515
 516 Gather a list of all packages (.pm files, really) installed on the
 517 system, grouped by distribution. XXX UNUSED
 518
 519 =cut
 520
 521 sub module_list
 522 {
 523     @_ = package_list unless @_;
 524     my $incre = join '|', map quotemeta, @INC;
 525     $incre = qr|(?:$incre)/|;
 526     my $inst = inst;
 527     map {
 528         [$_, sort map {
 529             s/$incre//; s|/|::|g;$_
 530         } grep /\.pm$/, $inst->files($_)]
 531     } @_;
 532 }
 533
 534 =head2 C<@mods = doc_list>
 535
 536 Gather a list of all documented packages (.?pm files, really)
 537 installed on the system, grouped by distribution. XXX UNUSED
 538
 539 =cut
 540
 541 sub doc_list
 542 {
 543     @_ = package_list unless @_;
 544     my $inst = inst;
 545     map {
 546         [$_, sort map {
 547             s/.*man.\///; s|/|::|g;s/\..?pm//; $_
 548         } grep /\..pm$/, $inst->files($_)]
 549     } @_;
 550 }
 551
 552 =head2 C<lexicals($subname)>
 553
 554 Return a list of C<$subname>'s lexical variables.  Note that this
 555 includes all nested scopes -- I don't know if or how Perl
 556 distinguishes inner blocks.
 557
 558 =cut
 559
 560 sub lexicals
 561 {
 562     my $cv = B::svref_2object(\&{+shift});
 563     return unless $cv && ($cv = $cv->PADLIST);
 564     my ($names, $vals) = $cv->ARRAY;
 565     map {
 566         my $name = $_->PV; $name =~ s/\0.*$//; $name
 567     } grep B::class($_) ne 'SPECIAL', $names->ARRAY;
 568 }
 569
 570 =head2 C<$lisp = tolisp($perl)>
 571
 572 Convert a Perl scalar to some ELisp equivalent.
 573
 574 =cut
 575
 576 sub tolisp($)
 577 {
 578     my $thing = @_ == 1 ? shift : \@_;
 579     my $t = ref $thing;
 580     if (!$t) {
 581         if (!defined $thing) {
 582             'nil'
 583         } elsif (looks_like_number $thing) {
 584             ''.(0+$thing);
 585         } else {
 586             ## XXX Elisp and perl have slightly different
 587             ## escaping conventions, so we do this crap instead.
 588             $thing =~ s/["\\]/\\$1/g;
 589             qq{"$thing"};
 590         }
 591     } elsif ($t eq 'GLOB') {
 592         (my $name = $$thing) =~ s/\*main:://;
 593         $name;
 594     } elsif ($t eq 'ARRAY') {
 595         '(' . join(' ', map { tolisp($_) } @$thing).')'
 596     } elsif ($t eq 'HASH') {
 597         '(' . join(' ', map {
 598             '(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
 599         } keys %$thing).')'
 600     } elsif ($t eq 'Regexp') {
 601         "'(regexp . \"" . quotemeta($thing) . '")';
 602 #     } elsif ($t eq 'IO') {
 603     } else {
 604         qq{"$thing"};
 605     }
 606 }
 607
 608 =head2 C<printer(\@res, $wantarray)>
 609
 610 Print C<@res> appropriately on the current filehandle.  If C<$ISEVAL>
 611 is true, use terse format.  Otherwise, use human-readable format,
 612 which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
 613
 614 =cut
 615
 616 %PRINTER = (
 617     dumper => sub {
 618         eval { require Data::Dumper };
 619         local $Data::Dumper::Deparse = 1;
 620         local $Data::Dumper::Indent = 0;
 621         local $_;
 622         my $thing = @res > 1 ? \@res : $res[0];
 623         eval {
 624             $_ = Data::Dumper::Dumper($thing);
 625             s/^\$VAR1 = //;
 626             s/;$//;
 627         };
 628         if (length $_ > ($ENV{COLUMNS} || 80)) {
 629             $Data::Dumper::Indent = 1;
 630             eval {
 631                 $_ = Data::Dumper::Dumper($thing);
 632                 s/\A\$VAR1 = //;
 633                 s/;\Z//;
 634             };
 635             s/\A\$VAR1 = //;
 636             s/;\Z//;
 637         }
 638         $_;
 639     },
 640     plain => sub {
 641         "@res";
 642     },
 643     yaml => sub {
 644         eval { require YAML };
 645         if ($@) {
 646             $PRINTER{dumper}->();
 647         } else {
 648             YAML::Dump(\@res);
 649         }
 650     },
 651     dump => sub {
 652         eval { require Data::Dump };
 653         if ($@) {
 654             $PRINTER{dumper}->();
 655         } else {
 656             Data::Dump::dump(\@res);
 657         }
 658     }
 659 );
 660
 661 sub printer
 662 {
 663     local *res = shift;
 664     my ($wantarray) = @_;
 665     my $res;
 666     @::__ = @res;
 667     $::__ = @res == 1 ? $res[0] : [@res];
 668     my $str;
 669     if ($ISEVAL) {
 670         $res = "@res";
 671     } elsif (@res == 1 && UNIVERSAL::can($res[0], '()')) {
 672         # overloaded?
 673         $res = $res[0];
 674     } elsif (!$ISEVAL && $PRINT_PRETTY && @res > 1 && !grep ref, @res) {
 675         $res = columnate(@res);
 676         print $res;
 677         return;
 678     } else {
 679         $res = $PRINTER{$PRINTER}->();
 680     }
 681     if ($ISEVAL) {
 682         print ';;;', length $res, "\n$res\n";
 683     } else {
 684         print "$res\n";
 685     }
 686 }
 687
 688 BEGIN {
 689     $PS1 = "> ";
 690     $PACKAGE = 'main';
 691     $WANTARRAY = 1;
 692     $PRINTER = 'dumper';
 693     $PRINT_PRETTY = 1;
 694 }
 695
 696 sub prompt()
 697 {
 698     "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
 699 }
 700
 701 sub Dump
 702 {
 703     eval {
 704         Data::Dumper->Dump([$_[0]], [$_[1]]);
 705     };
 706 }
 707
 708 sub flow
 709 {
 710     my $n = shift;
 711     my $n1 = int(2*$n/3);
 712     local $_ = shift;
 713     s/(.{$n1,$n}) /$1\n/g;
 714     $_
 715 }
 716
 717 =head2 C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
 718
 719 Define $name as a shortcut for function $sub.
 720
 721 =cut
 722
 723     sub define_shortcut
 724 {
 725     my ($name, $doc, $short, $fn);
 726     if (@_ == 2) {
 727         ($name, $fn) = @_;
 728         $short = $name;
 729         $doc = '';
 730     } elsif (@_ == 3) {
 731         ($name, $fn, $doc) = @_;
 732         $short = $name;
 733     } else {
 734         ($name, $fn, $short, $doc) = @_;
 735     }
 736     $REPL{$name} = $fn;
 737     $REPL_DOC{$name} = $doc;
 738     $REPL_SHORT{$name} = $short;
 739 }
 740
 741 sub define_shortcuts
 742 {
 743     define_shortcut 'help', \&Sepia::repl_help,
 744         'help [CMD]',
 745             'Display help on all commands, or just CMD.';
 746     define_shortcut 'cd', \&Sepia::repl_chdir,
 747         'cd DIR', 'Change directory to DIR';
 748     define_shortcut 'pwd', \&Sepia::repl_pwd,
 749         'Show current working directory';
 750     define_shortcut 'methods', \&Sepia::repl_methods,
 751         'methods X [RE]',
 752             'List methods for reference or package X, matching optional pattern RE';
 753     define_shortcut 'package', \&Sepia::repl_package,
 754         'package PKG', 'Set evaluation package to PKG';
 755     define_shortcut 'who', \&Sepia::repl_who,
 756         'who PKG [RE]',
 757             'List variables and subs in PKG matching optional pattern RE.';
 758     define_shortcut 'wantarray', \&Sepia::repl_wantarray,
 759         'wantarray [0|1]', 'Set or toggle evaluation context';
 760     define_shortcut 'format', \&Sepia::repl_format,
 761         'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
 762     define_shortcut 'strict', \&Sepia::repl_strict,
 763         'strict [0|1]', 'Turn \'use strict\' mode on or off';
 764     define_shortcut 'quit', \&Sepia::repl_quit,
 765         'Quit the REPL';
 766     define_shortcut 'reload', \&Sepia::repl_reload,
 767         'Reload Sepia.pm and relaunch the REPL.';
 768     define_shortcut 'shell', \&Sepia::repl_shell,
 769         'shell CMD ...', 'Run CMD in the shell';
 770     define_shortcut 'eval', \&Sepia::repl_eval,
 771         'eval EXP', '(internal)';
 772     define_shortcut 'size', \&Sepia::repl_size,
 773         'size PKG [RE]',
 774             'List total sizes of objects in PKG matching optional pattern RE.';
 775     define_shortcut define => \&Sepia::repl_define,
 776         'define NAME [\'doc\'] BODY',
 777             'Define NAME as a shortcut executing BODY';
 778     define_shortcut undef => \&Sepia::repl_undef,
 779         'undef NAME', 'Undefine shortcut NAME';
 780 }
 781
 782 sub repl_help
 783 {
 784     my $width = $ENV{COLUMNS} || 80;
 785     my $args = shift;
 786     if ($args =~ /\S/) {
 787         $args =~ s/^\s+//;
 788         $args =~ s/\s+$//;
 789         my $full = $RK{$args};
 790         if ($full) {
 791             print "$RK{$full}    ",
 792                 flow($width - length $RK{$full} - 4, $REPL_DOC{$full}), "\n";
 793         } else {
 794             print "$args: no such command\n";
 795         }
 796     } else {
 797         my $left = 1 + max map length, values %REPL_SHORT;
 798         print "REPL commands (prefixed with ','):\n";
 799
 800         for (sort keys %REPL) {
 801             my $flow = flow($width - $left, $REPL_DOC{$_});
 802             $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
 803             printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
 804         }
 805     }
 806 }
 807
 808 sub repl_define
 809 {
 810     local $_ = shift;
 811     my ($name, $doc, $body);
 812     if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
 813         ($name, $doc, $body) = ($1, $2, $3);
 814     } elsif (/^\s*(\S+)\s+(\S.*)/) {
 815         ($name, $doc, $body) = ($1, $2, $2);
 816     } else {
 817         print "usage: define NAME ['doc'] BODY...\n";
 818         return;
 819     }
 820     my $sub = eval "sub { do { $body } }";
 821     if ($@) {
 822         print "usage: define NAME ['doc'] BODY...\n\t$@\n";
 823         return;
 824     }
 825     define_shortcut $name, $sub, $doc;
 826     %RK = abbrev keys %REPL;
 827 }
 828
 829 sub repl_undef
 830 {
 831     my $name = shift;
 832     $name =~ s/^\s*//;
 833     $name =~ s/\s*$//;
 834     my $full = $RK{$name};
 835     if ($full) {
 836         delete $REPL{$full};
 837         delete $REPL_SHORT{$full};
 838         delete $REPL_DOC{$full};
 839         %RK = abbrev keys %REPL;
 840     } else {
 841         print "$name: no such shortcut.\n";
 842     }
 843 }
 844
 845 sub repl_format
 846 {
 847     my $t = shift;
 848     chomp $t;
 849     if ($t eq '') {
 850         print "printer = $PRINTER, pretty = @{[$PRINT_PRETTY ? 1 : 0]}\n";
 851     } else {
 852         my %formats = abbrev keys %PRINTER;
 853         if (exists $formats{$t}) {
 854             $PRINTER = $formats{$t};
 855         } else {
 856             warn "No such format '$t' (dumper, dump, yaml, plain).\n";
 857         }
 858     }
 859 }
 860
 861 sub repl_chdir
 862 {
 863     chomp(my $dir = shift);
 864     $dir =~ s/^~\//$ENV{HOME}\//;
 865     $dir =~ s/\$HOME/$ENV{HOME}/;
 866     if (-d $dir) {
 867         chdir $dir;
 868         my $ecmd = '(cd "'.Cwd::getcwd().'")';
 869         print ";;;###".length($ecmd)."\n$ecmd\n";
 870     } else {
 871         warn "Can't chdir\n";
 872     }
 873 }
 874
 875 sub repl_pwd
 876 {
 877     print Cwd::getcwd(), "\n";
 878 }
 879
 880 sub who
 881 {
 882     my ($pack, $re_str) = @_;
 883     $re_str ||= '.?';
 884     my $re = qr/$re_str/;
 885     no strict;
 886     if ($re_str =~ /^[\$\@\%\&]/) {
 887         ## sigil given -- match it
 888         sort grep /$re/, map {
 889             my $name = $pack.'::'.$_;
 890             (defined *{$name}{HASH} ? '%'.$_ : (),
 891              defined *{$name}{ARRAY} ? '@'.$_ : (),
 892              defined *{$name}{CODE} ? $_ : (),
 893              defined ${$name} ? '$'.$_ : (), # ?
 894          )
 895         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
 896     } else {
 897         ## no sigil -- don't match it
 898         sort map {
 899             my $name = $pack.'::'.$_;
 900             (defined *{$name}{HASH} ? '%'.$_ : (),
 901              defined *{$name}{ARRAY} ? '@'.$_ : (),
 902              defined *{$name}{CODE} ? $_ : (),
 903              defined ${$name} ? '$'.$_ : (), # ?
 904          )
 905         } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
 906     }
 907 }
 908
 909
 910 sub columnate
 911 {
 912     my $len = 0;
 913     my $width = $ENV{COLUMNS} || 80;
 914     for (@_) {
 915         $len = length if $len < length;
 916     }
 917     my $nc = int($width / ($len+1)) || 1;
 918     my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
 919     my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
 920     my @incs = map { $_ * $nr } 0..$nc-1;
 921     my $str = '';
 922     for my $r (0..$nr-1) {
 923         $str .= sprintf $fmt, map { defined($_) ? $_ : '' }
 924             @_[map { $r + $_ } @incs];
 925     }
 926     $str =~ s/ +$//m;
 927     $str
 928 }
 929
 930 sub repl_who
 931 {
 932     my ($pkg, $re) = split ' ', shift;
 933     no strict;
 934     if ($pkg =~ /^\/(.*)\/?$/) {
 935         $pkg = $PACKAGE;
 936         $re = $1;
 937     } elsif (!$re && !%{$pkg.'::'}) {
 938         $re = $pkg;
 939         $pkg = $PACKAGE;
 940     }
 941     print columnate who($pkg || $PACKAGE, $re);
 942 }
 943
 944 sub methods
 945 {
 946     my ($pack, $qualified) = @_;
 947     no strict;
 948     my @own = $qualified ? grep {
 949         defined *{$_}{CODE}
 950     } map { "$pack\::$_" } keys %{$pack.'::'}
 951         : grep {
 952             defined *{"$pack\::$_"}{CODE}
 953         } keys %{$pack.'::'};
 954     (@own, defined *{$pack.'::ISA'}{ARRAY}
 955          ? (map methods($_, $qualified), @{$pack.'::ISA'}) : ());
 956 }
 957
 958 sub repl_methods
 959 {
 960     my ($x, $re) = split ' ', shift;
 961     $x =~ s/^\s+//;
 962     $x =~ s/\s+$//;
 963     if ($x =~ /^\$/) {
 964         $x = $REPL{eval}->("ref $x");
 965         return 0 if $@;
 966     }
 967     $re ||= '.?';
 968     $re = qr/$re/;
 969     print columnate sort { $a cmp $b } grep /$re/, methods $x;
 970 }
 971
 972 sub as_boolean
 973 {
 974     my ($val, $cur) = @_;
 975     $val =~ s/\s+//g;
 976     length($val) ? $val : !$cur;
 977 }
 978
 979 sub repl_wantarray
 980 {
 981     $WANTARRAY = as_boolean shift, $WANTARRAY;
 982 }
 983
 984 sub repl_package
 985 {
 986     chomp(my $p = shift);
 987     no strict;
 988     if (%{$p.'::'}) {
 989         $PACKAGE = $p;
 990 #         my $ecmd = '(setq sepia-eval-package "'.$p.'")';
 991 #         print ";;;###".length($ecmd)."\n$ecmd\n";
 992     } else {
 993         warn "Can't go to package $p -- doesn't exist!\n";
 994     }
 995 }
 996
 997 sub repl_quit
 998 {
 999     last repl;
1000 }
1001
1002 sub repl_reload
1003 {
1004     do $INC{'Sepia.pm'};
1005     if ($@) {
1006         print "Reload failed:\n$@\n";
1007     } else {
1008         $REPL_LEVEL = 0;        # ok?
1009         goto &Sepia::repl;
1010     }
1011 }
1012
1013 sub repl_shell
1014 {
1015     my $cmd = shift;
1016     print `$cmd 2>& 1`;
1017 }
1018
1019 sub repl_eval
1020 {
1021     my ($buf) = @_;
1022     no strict;
1023     # local $PACKAGE = $pkg || $PACKAGE;
1024     if ($STRICT) {
1025         if (!$WANTARRAY) {
1026             $buf = 'scalar($buf)';
1027         }
1028         my $ctx = join(',', keys %{$STRICT->get_context('_')});
1029         $ctx = $ctx ? "my ($ctx);" : '';
1030         $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1031         if ($@) {
1032             print "ERROR\n$@\n";
1033             return;
1034         }
1035         $STRICT->call($buf);
1036     } else {
1037         $buf = "do { package $PACKAGE; no strict; $buf }";
1038         if ($WANTARRAY) {
1039             eval $buf;
1040         } else {
1041             scalar eval $buf;
1042         }
1043     }
1044 }
1045
1046 ## Collects warnings for REPL
1047 my @warn;
1048
1049 sub sig_warn
1050 {
1051     push @warn, shift
1052 }
1053
1054 sub print_warnings
1055 {
1056     if (@warn) {
1057         if ($ISEVAL) {
1058             my $tmp = "@warn";
1059             print ';;;'.length($tmp)."\n$tmp\n";
1060         } else {
1061             for (@warn) {
1062                 # s/(.*) at .*/$1/;
1063                 print "warning: $_\n";
1064             }
1065         }
1066     }
1067 }
1068
1069 sub repl_banner
1070 {
1071     print <<EOS;
1072 I need user feedback!  Please send questions or comments to seano\@cpan.org.
1073 Sepia version $Sepia::VERSION.
1074 Type ",h" for help, or ",q" to quit.
1075 EOS
1076 }
1077
1078 =head2 C<repl()>
1079
1080 Execute a command interpreter on standard input and standard output.
1081 If you want to use different descriptors, localize them before
1082 calling C<repl()>.  The prompt has a few bells and whistles, including:
1083
1084 =over 4
1085
1086 =item Obviously-incomplete lines are treated as multiline input (press
1087 'return' twice or 'C-c' to discard).
1088
1089 =item C<die> is overridden to enter a debugging repl at the point
1090 C<die> is called.
1091
1092 =back
1093
1094 Behavior is controlled in part through the following package-globals:
1095
1096 =over 4
1097
1098 =item C<$PACKAGE> -- evaluation package
1099
1100 =item C<$PRINTER> -- result printer (default: dumper)
1101
1102 =item C<$PS1> -- the default prompt
1103
1104 =item C<$STRICT> -- whether 'use strict' is applied to input
1105
1106 =item C<$WANTARRAY> -- evaluation context
1107
1108 =item C<$PRINT_PRETTY> -- format some output nicely (default = 1)
1109
1110 Format some values nicely, independent of $PRINTER.  Currently, this
1111 displays arrays of scalars as columns.
1112
1113 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1114
1115 If zero, then initialization takes place.
1116
1117 =item C<%REPL> -- maps shortcut names to handlers
1118
1119 =item C<%REPL_DOC> -- maps shortcut names to documentation
1120
1121 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1122
1123 =back
1124
1125 =cut
1126
1127 sub repl
1128 {
1129     $| = 1;
1130     if ($REPL_LEVEL == 0) {
1131         define_shortcuts;
1132         -f "$ENV{HOME}/.sepiarc" and do "$ENV{HOME}/.sepiarc";
1133         warn ".sepiarc: $@\n" if $@;
1134     }
1135     local $REPL_LEVEL = $REPL_LEVEL + 1;
1136
1137     my $in;
1138     my $buf = '';
1139     my $sigged = 0;
1140
1141     my $nextrepl = sub { $sigged = 1; };
1142
1143     local *__;
1144     local *CORE::GLOBAL::die = \&Sepia::Debug::die;
1145     local *CORE::GLOBAL::warn = \&Sepia::Debug::warn;
1146     local @REPL_RESULT;
1147     Sepia::Debug::add_repl_commands;
1148     repl_banner if $REPL_LEVEL == 1;
1149     print prompt;
1150     my @sigs = qw(INT TERM PIPE ALRM);
1151     local @SIG{@sigs};
1152     $SIG{$_} = $nextrepl for @sigs;
1153  repl: while (defined(my $in = <STDIN>)) {
1154             if ($sigged) {
1155                 $buf = '';
1156                 $sigged = 0;
1157                 print "\n", prompt;
1158                 next repl;
1159             }
1160             $buf .= $in;
1161             $buf =~ s/^\s*//;
1162             local $ISEVAL;
1163             if ($buf =~ /^<<(\d+)\n(.*)/) {
1164                 $ISEVAL = 1;
1165                 my $len = $1;
1166                 my $tmp;
1167                 $buf = $2;
1168                 while ($len && defined($tmp = read STDIN, $buf, $len, length $buf)) {
1169                     $len -= $tmp;
1170                 }
1171             }
1172             my (@res);
1173             ## Only install a magic handler if no one else is playing.
1174             local $SIG{__WARN__} = $SIG{__WARN__};
1175             @warn = ();
1176             unless ($SIG{__WARN__}) {
1177                 $SIG{__WARN__} = 'Sepia::sig_warn';
1178             }
1179             if ($buf =~ /^,(\S+)\s*(.*)/s) {
1180                 ## Inspector shortcuts
1181                 my $short = $1;
1182                 if (exists $Sepia::RK{$short}) {
1183                     my $ret;
1184                     my $arg = $2;
1185                     chomp $arg;
1186                     $Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
1187                 } else {
1188                     if (grep /^$short/, keys %Sepia::REPL) {
1189                         print "Ambiguous shortcut '$short': ",
1190                             join(', ', sort grep /^$short/, keys %Sepia::REPL),
1191                                 "\n";
1192                     } else {
1193                         print "Unrecognized shortcut '$short'\n";
1194                     }
1195                     $buf = '';
1196                     print prompt;
1197                     next repl;
1198                 }
1199             } else {
1200                 ## Ordinary eval
1201                 @res = $REPL{eval}->($buf);
1202                 if ($@) {
1203                     if ($ISEVAL) {
1204                         ## Always return results for an eval request
1205                         Sepia::printer \@res, wantarray;
1206                         Sepia::printer [$@], wantarray;
1207                         # print_warnings $ISEVAL;
1208                         $buf = '';
1209                         print prompt;
1210                     } elsif ($@ =~ /(?:at|before) EOF(?:$| at)/m) {
1211                         ## Possibly-incomplete line
1212                         if ($in eq "\n") {
1213                             print "Error:\n$@\n*** cancel ***\n", prompt;
1214                             $buf = '';
1215                         } else {
1216                             print ">> ";
1217                         }
1218                     } else {
1219                         print_warnings;
1220                         # $@ =~ s/(.*) at eval .*/$1/;
1221                         # don't complain if we're abandoning execution
1222                         # from the debugger.
1223                         unless (ref $@ eq 'Sepia::Debug') {
1224                             print "error: $@";
1225                             print "\n" unless $@ =~ /\n\z/;
1226                         }
1227                         print prompt;
1228                         $buf = '';
1229                     }
1230                     next repl;
1231                 }
1232             }
1233             if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1234                 ## Be quiet if it ends with a semicolon, or if we
1235                 ## executed a shortcut.
1236                 Sepia::printer \@res, wantarray;
1237             }
1238             $buf = '';
1239             print_warnings;
1240             print prompt;
1241         }
1242     wantarray ? @REPL_RESULT : $REPL_RESULT[0]
1243 }
1244
1245 sub perl_eval
1246 {
1247     tolisp($REPL{eval}->(shift));
1248 }
1249
1250 =head2 C<$status = html_module_list([$file [, $prefix]])>
1251
1252 Generate an HTML list of installed modules, looking inside of
1253 packages.  If C<$prefix> is missing, uses "about://perldoc/".  If
1254 $file is given, write the result to $file; otherwise, return it as a
1255 string.
1256
1257 =head2 C<$status = html_package_list([$file [, $prefix]])>
1258
1259 Generate an HTML list of installed top-level modules, without looking
1260 inside of packages.  If C<$prefix> is missing, uses
1261 "about://perldoc/".  $file is the same as for C<html_module_list>.
1262
1263 =cut
1264
1265 sub html_module_list
1266 {
1267     my ($file, $base) = @_;
1268     $base ||= 'about://perldoc/';
1269     my $inst = inst();
1270     return unless $inst;
1271     my $out;
1272     open OUT, ">", $file || \$out or return;
1273     print OUT "<html><body>";
1274     my $pfx = '';
1275     my %ns;
1276     for (package_list) {
1277         push @{$ns{$1}}, $_ if /^([^:]+)/;
1278     }
1279     # Handle core modules.
1280     my %fs;
1281     undef $fs{$_} for map {
1282         s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1283     } grep {
1284         /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ # && !/^(?:\/|perl)/
1285     } $inst->files('Perl');
1286     my @fs = sort keys %fs;
1287     print OUT qq{<h2>Core Modules</h2><ul>};
1288     for (@fs) {
1289         print OUT qq{<li><a href="$base$_">$_</a>};
1290     }
1291     print OUT '</ul><h2>Installed Modules</h2><ul>';
1292
1293     # handle the rest
1294     for (sort keys %ns) {
1295         next if $_ eq 'Perl';   # skip Perl core.
1296         print OUT qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
1297         for (sort @{$ns{$_}}) {
1298             my %fs;
1299             undef $fs{$_} for map {
1300                 s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
1301             } grep {
1302                 /\.\d(?:pm)?$/ && !/man1/
1303             } $inst->files($_);
1304             my @fs = sort keys %fs;
1305             next unless @fs > 0;
1306             if (@fs == 1) {
1307                 print OUT qq{<li><a href="$base$fs[0]">$fs[0]</a>};
1308             } else {
1309                 print OUT qq{<li>$_<ul>};
1310                 for (@fs) {
1311                     print OUT qq{<li><a href="$base$_">$_</a>};
1312                 }
1313                 print OUT '</ul>';
1314             }
1315         }
1316         print OUT qq{</ul>} if @{$ns{$_}} > 1;
1317     }
1318
1319     print OUT "</ul></body></html>\n";
1320     close OUT;
1321     $file ? 1 : $out;
1322 }
1323
1324 sub html_package_list
1325 {
1326     my ($file, $base) = @_;
1327     return unless inst();
1328     $base ||= 'about://perldoc/';
1329     my $out;
1330     open OUT, ">", $file || \$out or return;
1331     print OUT "<html><body><ul>";
1332     my $pfx = '';
1333     my %ns;
1334     for (package_list) {
1335         push @{$ns{$1}}, $_ if /^([^:]+)/;
1336     }
1337     for (sort keys %ns) {
1338         if (@{$ns{$_}} == 1) {
1339             print OUT
1340                 qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
1341         } else {
1342             print OUT qq{<li><b>$_</b><ul>};
1343             print OUT qq{<li><a href="$base$_">$_</a>}
1344                 for sort @{$ns{$_}};
1345             print OUT qq{</ul>};
1346         }
1347     }
1348     print OUT "</ul></body></html>\n";
1349     close OUT;
1350     $file ? 1 : $out;
1351 }
1352
1353 1;
1354 __END__
1355
1356 =head1 TODO
1357
1358 See the README file included with the distribution.
1359
1360 =head1 SEE ALSO
1361
1362 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
1363
1364 There are several modules for Perl development in Emacs on CPAN,
1365 including L<Devel::PerlySense> and L<PDE>.  For a complete list, see
1366 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
1367
1368 =head1 AUTHOR
1369
1370 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
1371
1372 Bug reports welcome, patches even more welcome.
1373
1374 =head1 COPYRIGHT
1375
1376 Copyright (C) 2005-2008 Sean O'Rourke.  All rights reserved, some
1377 wrongs reversed.  This module is distributed under the same terms as
1378 Perl itself.
1379
1380 =cut