76ac49dd6356527ba333a93bd41ee16c7676ea51
5 Sepia - Simple Emacs-Perl Interface
11 M-x load-library RET sepia RET
14 At the prompt in the C<*sepia-repl*> buffer:
18 For more information, please see F<Sepia.html> or F<sepia.info>, which
19 come with the distribution.
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>.
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
36 use 5.008; # try to defend against "Modern"
37 $VERSION = '0.992_01';
40 eval 'no warnings "deprecated"'; # undo some of the 5.12 suck.
44 Perl $] (newer than 5.12.3) may break Sepia. Please let the author
45 (seano\@cpan.org) know what happens.
48 # Not as useful as I had hoped...
52 (my $child = $_[1]) =~ s!/!::!g;
54 push @
{$REQUIRED_BY{$child}}, $parent;
55 push @
{$REQUIRES{$parent}}, $child;
57 BEGIN { sub TRACK_REQUIRES
() { $ENV{TRACK_REQUIRES
}||0 } };
58 unshift @INC, \
&Sepia
::track_requires
if TRACK_REQUIRES
;
61 use Sepia
::Debug
; # THIS TURNS ON DEBUGGING INFORMATION!
63 use Scalar
::Util
'looks_like_number';
66 use Storable
qw(store retrieve);
68 # uncomment for development:
70 # use vars qw($PS1 %REPL %RK %REPL_DOC %REPL_SHORT %PRINTER
71 # @res $REPL_LEVEL $REPL_QUIT $PACKAGE $SIGGED
72 # $WANTARRAY $PRINTER $STRICT $COLUMNATE $ISEVAL $STRINGIFY
73 # $LAST_INPUT $READLINE @PRE_EVAL @POST_EVAL @PRE_PROMPT
74 # %REQUIRED_BY %REQUIRES);
77 eval q{ use List::Util 'max' };
82 $ret = $_ if $_ > $ret;
91 Like Emacs, Sepia's behavior can be modified by placing functions on
92 various hooks (arrays). Hooks can be manipulated by the following
97 =item C<add_hook(@hook, @functions)> -- Add C<@functions> to C<@hook>.
99 =item C<remove_hook(@hook, @functions)> -- Remove named C<@functions> from C<@hook>.
101 =item C<run_hook(@hook)> -- Run the functions on the named hook.
103 Each function is called with no arguments in an eval {} block, and
104 its return value is ignored.
108 Sepia currently defines the following hooks:
112 =item C<@PRE_PROMPT> -- Called immediately before the prompt is printed.
114 =item C<@PRE_EVAL> -- Called immediately before evaluating user input.
116 =item C<@POST_EVAL> -- Called immediately after evaluating user input.
135 push @
$hook, $h unless grep $h eq $_, @
$hook;
142 @
$hook = grep { my $x = $_; !grep $_ eq $x, @
$hook } @
$hook;
147 Sepia tries hard to come up with a list of completions.
151 =item C<$re = _apropos_re($pat)>
153 Create a completion expression from user input.
159 # Do that crazy multi-word identifier completion thing:
161 my $hat = shift() ?
'' : '^';
162 return qr/.*/ if $re eq '';
165 s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
167 } split /:+/, $re, -1;
169 if ($re !~ /[^\w\d_^:]/) {
170 $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
178 %sigil = qw(ARRAY @ SCALAR $ HASH %);
181 =item C<$val = filter_untyped>
183 Return true if C<$_> is the name of a sub, file handle, or package.
185 =item C<$val = filter_typed $type>
187 Return true if C<$_> is the name of something of C<$type>, which
188 should be either a glob slot name (e.g. SCALAR) or the special value
189 "VARIABLE", meaning an array, hash, or scalar.
197 local $_ = /^::/ ?
$_ : "::$_";
198 defined *{$_}{CODE
} || defined *{$_}{IO
} || (/::$/ && %$_);
201 ## XXX: Careful about autovivification here! Specifically:
202 ## defined *FOO{HASH} # => ''
203 ## defined %FOO # => ''
204 ## defined *FOO{HASH} # => 1
209 local $_ = /^::/ ?
$_ : "::$_";
210 if ($type eq 'SCALAR') {
212 } elsif ($type eq 'VARIABLE') {
213 defined $$_ || defined *{$_}{HASH
} || defined *{$_}{ARRAY
};
219 =item C<$re_out = maybe_icase $re_in>
221 Make C<$re_in> case-insensitive if it looks like it should be.
228 return '' if $ch eq '';
229 $ch =~ /[A-Z]/ ?
$ch : '['.uc($ch).$ch.']';
232 =item C<@res = all_abbrev_completions $pattern>
234 Find all "abbreviated completions" for $pattern.
238 sub all_abbrev_completions
240 use vars
'&_completions';
241 local *_completions
= sub {
243 my ($stash, @e) = @_;
244 my $ch = '[A-Za-z0-9]*';
245 my $re1 = "^".maybe_icase
($e[0]).$ch.join('', map {
246 '_'.maybe_icase
($_).$ch
249 my $re2 = maybe_icase
$e[0];
250 $re2 = qr/^$re2.*::$/;
251 my @ret = grep !/::$/ && /$re1/, keys %{$stash};
252 my @pkgs = grep /$re2/, keys %{$stash};
253 (map("$stash$_", @ret),
254 @e > 1 ?
map { _completions
"$stash$_", @e[1..$#e] } @pkgs :
255 map { "$stash$_" } @pkgs)
257 map { s/^:://; $_ } _completions
('::', split //, shift);
262 my ($icase, $re) = @_;
264 $icase ?
qr/^$re.*$/i : qr/^$re.*$/;
269 my $icase = $_[0] !~ /[A-Z]/;
270 my @parts = split /:+/, shift, -1;
271 my $re = apropos_re
$icase, pop @parts;
272 use vars
'&_completions';
273 local *_completions
= sub {
277 map { "$stash$_" } grep /$re/, keys %{$stash};
279 my $re2 = $icase ?
qr/^$_[0].*::$/i : qr/^$_[0].*::$/;
280 my @pkgs = grep /$re2/, keys %{$stash};
281 map { _completions
"$stash$_", @_[1..$#_] } @pkgs
284 map { s/^:://; $_ } _completions
('::', @parts);
287 =item C<@res = filter_exact_prefix @names>
289 Filter exact matches so that e.g. "A::x" completes to "A::xx" when
290 both "Ay::xx" and "A::xx" exist.
294 sub filter_exact_prefix
296 my @parts = split /:+/, shift, -1;
299 my $pre = shift @parts;
300 while (@parts && (@tmp = grep /^\Q$pre\E(?:::|$)/, @res)) {
302 $pre .= '::'.shift @parts;
307 =item C<@res = lexical_completions $type, $str, $sub>
309 Find lexicals of C<$sub> (or a parent lexical environment) of type
310 C<$type> matching C<$str>.
314 sub lexical_completions
316 eval q{ use PadWalker 'peek_sub' };
317 # "internal" function, so don't warn on failure
319 *lexical_completions
= sub {
320 my ($type, $str, $sub) = @_;
321 $sub = "$PACKAGE\::$sub" unless $sub =~ /::/;
322 # warn "Completing $str of type $type in $sub\n";
324 return unless defined *{$sub}{CODE
};
325 my $pad = peek_sub
(\
&$sub);
327 map { s/^[\$\@&\%]//;$_ } grep /^\Q$type$str\E/, keys %$pad;
329 map { s/^[\$\@&\%]//;$_ } grep /^.\Q$str\E/, keys %$pad;
332 goto &lexical_completions
;
335 =item C<@compls = completions($string [, $type [, $sub ] ])>
337 Find a list of completions for C<$string> with glob type C<$type>,
338 which may be "SCALAR", "HASH", "ARRAY", "CODE", "IO", or the special
339 value "VARIABLE", which means either scalar, hash, or array.
340 Completion operates on word subparts separated by [:_], so
341 e.g. "S:m_w" completes to "Sepia::my_walksymtable". If C<$sub> is
342 given, also consider its lexical variables.
344 =item C<@compls = method_completions($expr, $string [,$eval])>
346 Complete among methods on the object returned by C<$expr>. The
347 C<$eval> argument, if present, is a function used to do the
348 evaluation; the default is C<eval>, but for example the Sepia REPL
349 uses C<Sepia::repl_eval>. B<Warning>: Since it has to evaluate
350 C<$expr>, method completion can be extremely problematic. Use with
357 my ($type, $str, $sub) = @_;
359 my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
362 $t = $type ?
$rh{$type} : '';
364 if ($sub && $type ne '') {
365 @ret = lexical_completions
$t, $str, $sub;
369 $type ? filter_typed
$type : filter_untyped
370 } all_completions
$str;
372 if (!@ret && $str !~ /:/) {
374 $type ? filter_typed
$type : filter_untyped
375 } all_abbrev_completions
$str;
377 @ret = map { s/^:://; "$t$_" } filter_exact_prefix
$str, @ret;
378 # ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
381 length $_ > 0 && !/^\d+$/ && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
385 sub method_completions
387 my ($x, $fn, $eval) = @_;
390 $eval ||= 'CORE::eval';
392 return unless ($x =~ /^\$/ && ($x = $eval->("ref($x)")))
393 || $eval->('%'.$x.'::');
395 my $re = _apropos_re
$fn;
396 ## Filter out overload methods "(..."
397 return sort { $a cmp $b } map { s/.*:://; $_ }
398 grep { defined *{$_}{CODE
} && /::$re/ && !/\(/ }
403 =item C<@matches = apropos($name [, $is_regex])>
405 Search for function C<$name>, either in all packages or, if C<$name>
406 is qualified, only in one package. If C<$is_regex> is true, the
407 non-package part of C<$name> is a regular expression.
411 sub my_walksymtable
(&*)
417 &$f for keys %$stash;
418 _walk
("$stash$_") for grep /(?<!main)::$/, keys %$stash;
425 my ($it, $re, @types) = @_;
428 $stashp = grep /STASH/, @types;
429 @types = grep !/STASH/, @types;
434 if ($it =~ /^(.*::)([^:]+)$/) {
435 my ($stash, $name) = ($1, $2);
440 my $name = qr/^$name/;
445 my $stashnm = "$stash$_";
449 defined($_ eq 'SCALAR' ?
$$stashnm : *{$stashnm}{$_})
453 defined &$it ?
$it : ();
457 my $findre = $re ?
qr/$it/ : qr/^\Q$it\E$/;
459 push @ret, "$stash$_" if /$findre/;
461 map { s/^:*(?:main:+)*//;$_ } @ret;
467 =head2 Module information
471 =item C<@names = mod_subs($pack)>
473 Find subs in package C<$pack>.
481 my $stash = \
%{"$p\::"};
483 grep { defined &{"$p\::$_"} } keys %$stash;
487 =item C<@decls = mod_decls($pack)>
489 Generate a list of declarations for all subroutines in package
500 my $proto = prototype(\
&{"$pack\::$sn"});
501 $proto = defined($proto) ?
"($proto)" : '';
504 return wantarray ?
@ret : join '', @ret;
507 =item C<$info = module_info($module, $type)>
509 Emacs-called function to get module information.
515 eval q{ require Module::Info; import Module::Info };
524 $info = Module
::Info
->new_from_file($m);
526 (my $file = $m) =~ s
|::|/|g
;
528 if (exists $INC{$file}) {
529 $info = Module
::Info
->new_from_loaded($m);
531 $info = Module
::Info
->new_from_module($m);
542 =item C<$file = mod_file($mod)>
544 Find the likely file owner for module C<$mod>.
552 while ($m && !exists $INC{"$m.pm"}) {
553 $m =~ s
#(?:^|/)[^/]+$##;
555 $m ?
$INC{"$m.pm"} : undef;
558 =item C<@mods = package_list>
560 Gather a list of all distributions on the system.
568 require ExtUtils
::Installed
;
569 $INST = new ExtUtils
::Installed
;
576 sort { $a cmp $b } inst
()->modules;
579 =item C<@mods = module_list>
581 Gather a list of all packages (.pm files, really) installed on the
582 system, grouped by distribution. XXX UNUSED
588 join '|', map quotemeta, sort { length $b <=> length $a } @INC;
593 @_ = package_list
unless @_;
595 $incre = qr
|(?
:$incre)/|;
599 s/$incre\///; s|/|::|g
;$_
600 } grep /\.pm$/, $inst->files($_)]
604 =item C<@paths = file_list $module>
606 List the absolute paths of all files (except man pages) installed by
613 my @ret = eval { grep /\.p(l|m|od)$/, inst
->files(shift) };
617 =item C<@mods = doc_list>
619 Gather a list of all documented packages (.?pm files, really)
620 installed on the system, grouped by distribution. XXX UNUSED
628 @_ = package_list
unless @_;
632 s/.*man.\///; s|/|::|g
;s/\..?pm//; $_
633 } grep /\..pm$/, $inst->files($_)]
637 =head2 Miscellaneous functions
641 =item C<$v = core_version($module)>
647 eval q{ require Module::CoreList };
651 *core_version
= sub { Module
::CoreList
->first_release(@_) };
656 =item C<[$file, $line, $name] = location($name)>
658 Return a [file, line, name] triple for function C<$name>.
666 if (my ($pfx, $name) = /^([\%\$\@]?)(.+)/) {
668 warn "Sorry -- can't lookup variables.";
670 # XXX: svref_2object only seems to work with a package
671 # tacked on, but that should probably be done elsewhere...
672 $name = 'main::'.$name unless $name =~ /::/;
673 my $cv = B
::svref_2object
(\
&{$name});
674 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
675 my ($file, $line) = ($cv->file, $cv->line);
676 if ($file !~ /^\//) {
678 if (!ref $_ && -f
"$_/$file") {
684 my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
685 return [Cwd
::abs_path
($file), $line, $shortname || $name]
693 =item C<lexicals($subname)>
695 Return a list of C<$subname>'s lexical variables. Note that this
696 includes all nested scopes -- I don't know if or how Perl
697 distinguishes inner blocks.
703 my $cv = B
::svref_2object
(\
&{+shift});
704 return unless $cv && ($cv = $cv->PADLIST);
705 my ($names, $vals) = $cv->ARRAY;
707 my $name = $_->PV; $name =~ s/\0.*$//; $name
708 } grep B
::class($_) ne 'SPECIAL', $names->ARRAY;
711 =item C<$lisp = tolisp($perl)>
713 Convert a Perl scalar to some ELisp equivalent.
719 my $thing = @_ == 1 ?
shift : \
@_;
722 if (!defined $thing) {
724 } elsif (looks_like_number
$thing) {
727 ## XXX Elisp and perl have slightly different
728 ## escaping conventions, so we do this crap instead.
729 $thing =~ s/["\\]/\\$1/g;
732 } elsif ($t eq 'GLOB') {
733 (my $name = $$thing) =~ s/\*main:://;
735 } elsif ($t eq 'ARRAY') {
736 '(' . join(' ', map { tolisp
($_) } @
$thing).')'
737 } elsif ($t eq 'HASH') {
738 '(' . join(' ', map {
739 '(' . tolisp
($_) . " . " . tolisp
($thing->{$_}) . ')'
741 } elsif ($t eq 'Regexp') {
742 "'(regexp . \"" . quotemeta($thing) . '")';
743 # } elsif ($t eq 'IO') {
749 =item C<printer(\@res)>
751 Print C<@res> appropriately on the current filehandle. If C<$ISEVAL>
752 is true, use terse format. Otherwise, use human-readable format,
753 which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
759 eval q{ require Data::Dumper };
760 local $Data::Dumper
::Deparse
= 1;
761 local $Data::Dumper
::Indent
= 0;
763 my $thing = @res > 1 ? \
@res : $res[0];
765 $_ = Data
::Dumper
::Dumper
($thing);
767 if (length $_ > ($ENV{COLUMNS
} || 80)) {
768 $Data::Dumper
::Indent
= 1;
770 $_ = Data
::Dumper
::Dumper
($thing);
781 if (eval q{require 'dumpvar.pl';1}) {
782 dumpvar
::veryCompact
(1);
783 $PRINTER{dumpvar
} = sub { dumpValue
(\
@res) };
784 goto &{$PRINTER{dumpvar
}};
788 eval q{ require YAML };
790 $PRINTER{dumper
}->();
796 eval q{ require Data::Dump };
798 $PRINTER{dumper
}->();
800 Data
::Dump
::dump(\
@res);
809 $PRINTER{dumper
}->();
811 my $ret = new IO
::Scalar
;
812 my $out = select $ret;
813 Devel
::Peek
::Dump
(@res == 1 ?
$res[0] : \
@res);
834 $_ = @res == 1 ?
$res[0] : @res == 0 ?
undef : [@res];
838 } elsif (@res == 1 && !$ISEVAL && $STRINGIFY
839 && UNIVERSAL
::can
($res[0], '()')) {
842 } elsif (!$ISEVAL && $COLUMNATE && @res > 1 && !grep ref, @res) {
843 $res = columnate
(@res);
847 $res = $PRINTER{$PRINTER}->();
850 print ';;;', length $res, "\n$res\n";
865 =item C<prompt()> -- Print the REPL prompt.
871 run_hook
@PRE_PROMPT;
872 "$PACKAGE $WANTARRAY$PS1"
878 Data
::Dumper
->Dump([$_[0]], [$_[1]]);
882 =item C<$flowed = flow($width, $text)> -- Flow C<$text> to at most C<$width> columns.
888 my $width = shift()-2;
889 my $format = "^" . ('<' x
$width) . "~~\n";
891 formline($format, @_);
901 =item C<load \@keyvals> -- Load persisted data in C<@keyvals>.
903 =item C<$ok = saveable $name> -- Return whether C<$name> is saveable.
905 Saving certain magic variables leads to badness, so we avoid them.
907 =item C<\@kvs = save $re> -- Return a list of name/value pairs to save.
918 *{$_->[0]} = $_->[1];
923 undef @BADVARS{qw(%INC @INC %SIG @ISA %ENV @ARGV)};
929 return !/^.[^c-zA-Z]$/ # single-letter stuff (match vars, $_, etc.)
930 && !/^.[\0-\060]/ # magic weirdness.
931 && !/^._</ # debugger info
932 && !exists $BADVARS{$_}; # others.
939 $re = qr/(?:^|::)$re/;
940 no strict; # no kidding...
943 || $stash =~ /^(?:::)?(?:warnings|Config|strict|B)\b/;
945 my $name = "$stash$_";
946 if (defined ${$name} and saveable '$'.$_) {
947 push @save, [$name, \$$name];
949 if (defined *{$name}{HASH} and saveable '%'.$_) {
950 push @save, [$name, \%{$name}];
952 if (defined *{$name}{ARRAY} and saveable '@'.$_) {
953 push @save, [$name, \@{$name}];
957 print STDERR "$_->[0] " for @save;
962 =head2 REPL shortcuts
964 The function implementing built-in REPL shortcut ",X" is named C<repl_X>.
968 =item C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
970 Define $name as a shortcut for function $sub.
976 my ($name, $doc, $short, $fn);
982 ($name, $fn, $doc) = @_;
985 ($name, $fn, $short, $doc) = @_;
988 $REPL_DOC{$name} = $doc;
989 $REPL_SHORT{$name} = $short;
990 abbrev \%RK, keys %REPL;
993 =item C<alias_shortcut $new, $old>
995 Alias $new to do the same as $old.
1001 my ($new, $old) = @_;
1002 $REPL{$new} = $REPL{$old};
1003 $REPL_DOC{$new} = $REPL_DOC{$old};
1004 ($REPL_SHORT{$new} = $REPL_SHORT{$old}) =~ s/^\Q$old\E/$new/;
1005 abbrev %RK, keys %REPL;
1008 =item C<define_shortcuts()>
1010 Define the default REPL shortcuts.
1014 sub define_shortcuts
1016 define_shortcut 'help', \&Sepia::repl_help,
1018 'Display help on all commands or CMD.';
1019 define_shortcut 'cd', \&Sepia::repl_chdir,
1020 'cd DIR', 'Change directory to DIR';
1021 define_shortcut 'pwd', \&Sepia::repl_pwd,
1022 'Show current working directory';
1023 define_shortcut 'methods', \&Sepia::repl_methods,
1025 'List methods for reference or package X, matching optional pattern RE';
1026 define_shortcut 'package', \&Sepia::repl_package,
1027 'package PKG', 'Set evaluation package to PKG';
1028 define_shortcut 'who', \&Sepia::repl_who,
1030 'List variables and subs in PKG matching optional pattern RE.';
1031 define_shortcut 'wantarray', \&Sepia::repl_wantarray,
1032 'wantarray [0|1]', 'Set or toggle evaluation context';
1033 define_shortcut 'format', \&Sepia::repl_format,
1034 'format [TYPE]', "Set output format to TYPE ('dumper', 'dump', 'yaml', or 'plain'; default: 'dumper') or show current type.";
1035 define_shortcut 'strict', \&Sepia::repl_strict,
1036 'strict [0|1]', 'Turn \'use strict\' mode on or off';
1037 define_shortcut 'quit', \&Sepia::repl_quit,
1039 alias_shortcut 'exit', 'quit';
1040 define_shortcut 'restart', \&Sepia::repl_restart,
1041 'Reload Sepia.pm and relaunch the REPL.';
1042 define_shortcut 'shell', \&Sepia::repl_shell,
1043 'shell CMD ...', 'Run CMD in the shell';
1044 define_shortcut 'eval', \&Sepia::repl_eval,
1045 'eval EXP', '(internal)';
1046 define_shortcut 'size', \&Sepia::repl_size,
1048 'List total sizes of objects in PKG matching optional pattern RE.';
1049 define_shortcut define => \&Sepia::repl_define,
1050 'define NAME [\'DOC\'] BODY',
1051 'Define NAME as a shortcut executing BODY';
1052 define_shortcut undef => \&Sepia::repl_undef,
1053 'undef NAME', 'Undefine shortcut NAME';
1054 define_shortcut test => \&Sepia::repl_test,
1055 'test FILE...', 'Run tests interactively.';
1056 define_shortcut load => \&Sepia::repl_load,
1057 'load [FILE]', 'Load state from FILE.';
1058 define_shortcut save => \&Sepia::repl_save,
1059 'save [PATTERN [FILE]]', 'Save variables matching PATTERN to FILE.';
1060 define_shortcut reload => \&Sepia::repl_reload,
1061 'reload [MODULE | /RE/]', 'Reload MODULE or all modules matching RE.';
1062 define_shortcut freload => \&Sepia::repl_full_reload,
1063 'freload MODULE', 'Reload MODULE and all its dependencies.';
1064 define_shortcut time => \&Sepia::repl_time,
1065 'time [0|1]', 'Print timing information for each command.';
1066 define_shortcut lsmod => \&Sepia::repl_lsmod,
1067 'lsmod [PATTERN]', 'List loaded modules matching PATTERN.';
1070 =item C<repl_strict([$value])>
1072 Toggle strict mode. Requires L<PadWalker> and L<Devel::LexAlias>.
1078 eval q{ use PadWalker qw(peek_sub set_closed_over);
1079 use Devel
::LexAlias
'lexalias';
1082 print "Strict mode requires PadWalker and Devel::LexAlias.\n";
1084 *repl_strict
= sub {
1085 my $x = as_boolean
(shift, $STRICT);
1086 if ($x && !$STRICT) {
1098 eval q{ require Devel::Size };
1100 print "Size requires Devel::Size.\n";
1102 *Sepia
::repl_size
= sub {
1103 my ($pkg, $re) = split ' ', shift, 2;
1106 } elsif (!$re && $pkg =~ /^\/(.*?
)\
/?$/) {
1113 if ($STRICT && !$pkg) {
1114 @who = grep /$re/, keys %$STRICT;
1116 $res{$_} = Devel
::Size
::total_size
($Sepia::STRICT
->{$_});
1121 @who = who
($pkg, $re);
1123 next unless /^[\$\@\%\&]/; # skip subs.
1124 next if $_ eq '%SIG';
1125 $res{$_} = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
1128 my $len = max
(3, map { length } @who) + 4;
1129 my $fmt = '%-'.$len."s%10d\n";
1130 # print "$pkg\::/$re/\n";
1131 print 'Var', ' ' x
($len + 2), "Bytes\n";
1132 print '-' x
($len-4), ' ' x
9, '-' x
5, "\n";
1133 for (sort { $res{$b} <=> $res{$a} } keys %res) {
1134 printf $fmt, $_, $res{$_};
1141 =item C<repl_time([$value])>
1143 Toggle command timing.
1147 my ($time_res, $TIME);
1148 sub time_pre_prompt_bsd
1150 printf "(%.2gr, %.2gu, %.2gs) ", @
{$time_res} if defined $time_res;
1153 sub time_pre_prompt_plain
1155 printf "(%.2gs) ", $time_res if defined $time_res;
1160 $TIME = as_boolean
(shift, $TIME);
1162 print STDERR
"Removing time hook.\n";
1163 remove_hook
@PRE_PROMPT, 'Sepia::time_pre_prompt';
1164 remove_hook
@PRE_EVAL, 'Sepia::time_pre_eval';
1165 remove_hook
@POST_EVAL, 'Sepia::time_post_eval';
1168 print STDERR
"Adding time hook.\n";
1169 add_hook
@PRE_PROMPT, 'Sepia::time_pre_prompt';
1170 add_hook
@PRE_EVAL, 'Sepia::time_pre_eval';
1171 add_hook
@POST_EVAL, 'Sepia::time_post_eval';
1172 my $has_bsd = eval q{ use BSD::Resource 'getrusage';1 };
1173 my $has_hires = eval q{ use Time::HiRes qw(gettimeofday tv_interval);1 };
1175 if ($has_bsd) { # sweet! getrusage!
1176 my ($user, $sys, $real);
1177 *time_pre_eval
= sub {
1179 ($user, $sys) = getrusage
();
1180 $real = $has_hires ?
[gettimeofday
()] : $user+$sys;
1182 *time_post_eval
= sub {
1183 my ($u2, $s2) = getrusage
();
1184 $time_res = [$has_hires ? tv_interval
($real, [gettimeofday
()])
1185 : $s2 + $u2 - $real,
1186 ($u2 - $user), ($s2 - $sys)];
1188 *time_pre_prompt
= *time_pre_prompt_bsd
;
1189 } elsif ($has_hires) { # at least we have msec...
1190 *time_pre_eval
= sub {
1192 $t0 = [gettimeofday
()];
1194 *time_post_eval
= sub {
1195 $time_res = tv_interval
($t0, [gettimeofday
()]);
1197 *time_pre_prompt
= *time_pre_prompt_plain
;
1199 *time_pre_eval
= sub {
1203 *time_post_eval
= sub {
1204 $time_res = (time - $t0);
1206 *time_pre_prompt
= *time_pre_prompt_plain
;
1212 my $width = $ENV{COLUMNS
} || 80;
1214 if ($args =~ /\S/) {
1217 my $full = $RK{$args};
1219 my $short = $REPL_SHORT{$full};
1220 my $flow = flow
($width - length($short) - 4, $REPL_DOC{$full});
1222 $flow =~ s/(.)\n/"$1\n".(' 'x (4 + length $short))/eg;
1223 print "$short $flow\n";
1225 print "$args: no such command\n";
1228 my $left = 1 + max
map length, values %REPL_SHORT;
1229 print "REPL commands (prefixed with ','):\n";
1231 for (sort keys %REPL) {
1232 my $flow = flow
($width - $left, $REPL_DOC{$_});
1234 $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
1235 printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
1243 my ($name, $doc, $body);
1244 if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
1245 ($name, $doc, $body) = ($1, $2, $3);
1246 } elsif (/^\s*(\S+)\s+(\S.*)/) {
1247 ($name, $doc, $body) = ($1, $2, $2);
1249 print "usage: define NAME ['doc'] BODY...\n";
1252 my $sub = eval "sub { do { $body } }";
1254 print "usage: define NAME ['doc'] BODY...\n\t$@\n";
1257 define_shortcut
$name, $sub, $doc;
1258 # %RK = abbrev keys %REPL;
1266 my $full = $RK{$name};
1268 delete $REPL{$full};
1269 delete $REPL_SHORT{$full};
1270 delete $REPL_DOC{$full};
1271 abbrev \
%RK, keys %REPL;
1273 print "$name: no such shortcut.\n";
1282 print "printer = $PRINTER, columnate = @{[$COLUMNATE ? 1 : 0]}\n";
1284 my %formats = abbrev
keys %PRINTER;
1285 if (exists $formats{$t}) {
1286 $PRINTER = $formats{$t};
1288 warn "No such format '$t' (dumper, dump, yaml, plain).\n";
1295 chomp(my $dir = shift);
1296 $dir =~ s/^~\//$ENV{HOME
}\
//;
1297 $dir =~ s/\$HOME/$ENV{HOME}/;
1300 my $ecmd = '(cd "'.Cwd
::getcwd
().'")';
1301 print ";;;###".length($ecmd)."\n$ecmd\n";
1303 warn "Can't chdir\n";
1309 print Cwd
::getcwd
(), "\n";
1312 =item C<who($package [, $re])>
1314 List variables and functions in C<$package> matching C<$re>, or all
1315 variables if C<$re> is absent.
1321 my ($pack, $re_str) = @_;
1323 my $re = qr/$re_str/;
1325 if ($re_str =~ /^[\$\@\%\&]/) {
1326 ## sigil given -- match it
1327 sort grep /$re/, map {
1328 my $name = $pack.'::'.$_;
1329 (defined *{$name}{HASH
} ?
'%'.$_ : (),
1330 defined *{$name}{ARRAY
} ?
'@'.$_ : (),
1331 defined *{$name}{CODE
} ?
$_ : (),
1332 defined ${$name} ?
'$'.$_ : (), # ?
1334 } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1336 ## no sigil -- don't match it
1338 my $name = $pack.'::'.$_;
1339 (defined *{$name}{HASH
} ?
'%'.$_ : (),
1340 defined *{$name}{ARRAY
} ?
'@'.$_ : (),
1341 defined *{$name}{CODE
} ?
$_ : (),
1342 defined ${$name} ?
'$'.$_ : (), # ?
1344 } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
1348 =item C<$text = columnate(@items)>
1350 Format C<@items> in columns such that they fit within C<$ENV{COLUMNS}>
1358 my $width = $ENV{COLUMNS
} || 80;
1360 $len = length if $len < length;
1362 my $nc = int($width / ($len+1)) || 1;
1363 my $nr = int(@_ / $nc) + (@_ % $nc ?
1 : 0);
1364 my $fmt = ('%-'.($len+1).'s') x
($nc-1) . "%s\n";
1365 my @incs = map { $_ * $nr } 0..$nc-1;
1367 for my $r (0..$nr-1) {
1368 $str .= sprintf $fmt, map { defined($_) ?
$_ : '' }
1369 @_[map { $r + $_ } @incs];
1377 my ($pkg, $re) = split ' ', shift, 2;
1380 } elsif (!$re && $pkg =~ /^\/(.*?
)\
/?$/) {
1387 if ($STRICT && !$pkg) {
1388 @x = grep /$re/, keys %$STRICT;
1392 @x = who
($pkg, $re);
1394 print($pkg, "::/$re/\n", columnate
@x) if @x;
1397 =item C<@m = methods($package [, $qualified])>
1399 List method names in C<$package> and its parents. If C<$qualified>,
1400 return full "CLASS::NAME" rather than just "NAME."
1406 my ($pack, $qualified) = @_;
1408 my @own = $qualified ?
grep {
1410 } map { "$pack\::$_" } keys %{$pack.'::'}
1412 defined &{"$pack\::$_"}
1413 } keys %{$pack.'::'};
1414 if (exists ${$pack.'::'}{ISA
} && *{$pack.'::ISA'}{ARRAY
}) {
1416 undef @m{@own, map methods
($_, $qualified), @
{$pack.'::ISA'}};
1424 my ($x, $re) = split ' ', shift;
1428 $x = $REPL{eval}->("ref $x");
1433 print columnate
sort { $a cmp $b } grep /$re/, methods
$x;
1438 my ($val, $cur) = @_;
1440 length($val) ?
$val : !$cur;
1445 (my $val = $_[0]) =~ s/\s+//g;
1447 $WANTARRAY = ($WANTARRAY eq '@' ?
'$' : '@');
1449 $WANTARRAY = $val ?
'@' : '$';
1455 chomp(my $p = shift);
1467 do $INC{'Sepia.pm'};
1469 print "Restart failed:\n$@\n";
1471 $REPL_LEVEL = 0; # ok?
1482 # Stolen from Lexical::Persistence, then simplified.
1487 # steal any new "my" variables
1488 my $pad = peek_sub
($sub);
1489 for my $k (keys %$pad) {
1490 unless (exists $STRICT->{$k}) {
1492 $STRICT->{$k} = \
(my $x);
1493 } elsif ($k =~ /^\@/) {
1495 } elsif ($k =~ /^\%/) {
1496 $STRICT->{$k} = +{};
1502 lexalias
($sub, $_, $STRICT->{$_}) for keys %$STRICT;
1510 # local $PACKAGE = $pkg || $PACKAGE;
1512 my $ctx = join(',', keys %$STRICT);
1513 $ctx = $ctx ?
"my ($ctx);" : '';
1514 if ($WANTARRAY eq '$') {
1515 $buf = 'scalar($buf)';
1516 } elsif ($WANTARRAY ne '@') {
1519 $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1521 print "ERROR\n$@\n";
1526 $buf = "do { package $PACKAGE; no strict; $buf }";
1527 if ($WANTARRAY eq '@') {
1529 } elsif ($WANTARRAY eq '$') {
1546 } elsif (-f
"t/$buf") {
1550 find
({ no_chdir
=> 1,
1552 push @files, $_ if /\.t$/;
1553 }}, Cwd
::getcwd
() =~ /t\/?
$/ ? '.' : './t
');
1556 # XXX: this is cribbed from an EU::MM-generated Makefile.
1557 system $^X, qw(-MExtUtils::Command::MM -e),
1558 "test_harness(0, 'blib/lib', 'blib/arch')", @files;
1560 print "No test files for '$buf' in ", Cwd
::getcwd
, "\n";
1566 my ($file) = split ' ', shift;
1567 $file ||= "$ENV{HOME}/.sepia-save";
1568 load
(retrieve
$file);
1573 my ($re, $file) = split ' ', shift;
1575 $file ||= "$ENV{HOME}/.sepia-save";
1576 store save
($re), $file;
1579 sub modules_matching
1582 if ($pat =~ /^\/(.*)\
/?$/) {
1586 grep /$pat/, keys %INC;
1590 exists $INC{"$pat.pm"} ?
"$pat.pm" : ();
1596 my %save_inc = %INC;
1598 for my $name (modules_matching
$_[0]) {
1599 print STDERR
"full reload $name\n";
1602 my @ret = keys %INC;
1603 while (my ($k, $v) = each %save_inc) {
1609 sub repl_full_reload
1611 chomp (my $pat = shift);
1612 my @x = full_reload
$pat;
1613 print "Reloaded: @x\n";
1618 chomp (my $pat = shift);
1619 # for my $name (modules_matching $pat) {
1620 # delete $INC{$PAT};
1621 # eval "require $name";
1623 # (my $mod = $name) =~ s/
1624 if ($pat =~ /^\/(.*)\
/?$/) {
1642 if (exists $INC{$pat}) {
1644 eval 'require $mod';
1645 import
$mod unless $@
;
1646 print "Reloaded $mod.\n"
1648 print "$mod not loaded.\n"
1655 chomp (my $pat = shift);
1659 my $fmt = "%-20s%8s %s\n";
1660 # my $shorten = join '|', sort { length($a) <=> length($b) } @INC;
1662 # s/^(?:$shorten)\/?//; $_
1664 for (sort keys %INC) {
1668 next if /^::/ || !/$pat/;
1670 printf $fmt, qw(Module Version File);
1671 printf $fmt, qw(------ ------- ----);
1674 printf $fmt, $_, (UNIVERSAL
::VERSION
($_)||'???'), $INC{$file};
1677 print "No modules found.\n";
1681 =item C<sig_warn($warning)>
1683 Collect C<$warning> for later printing.
1685 =item C<print_warnings()>
1687 Print and clear accumulated warnings.
1703 print ';;;'.length($tmp)."\n$tmp\n";
1707 print "warning: $_\n";
1716 I need user feedback! Please send questions or comments to seano\@cpan.org.
1717 Sepia version $Sepia::VERSION.
1718 Type ",h" for help, or ",q" to quit.
1724 Execute a command interpreter on standard input and standard output.
1725 If you want to use different descriptors, localize them before
1726 calling C<repl()>. The prompt has a few bells and whistles, including:
1730 =item Obviously-incomplete lines are treated as multiline input (press
1731 'return' twice or 'C-c' to discard).
1733 =item C<die> is overridden to enter a debugging repl at the point
1738 Behavior is controlled in part through the following package-globals:
1742 =item C<$PACKAGE> -- evaluation package
1744 =item C<$PRINTER> -- result printer (default: dumper)
1746 =item C<$PS1> -- the default prompt
1748 =item C<$STRICT> -- whether 'use strict' is applied to input
1750 =item C<$WANTARRAY> -- evaluation context
1752 =item C<$COLUMNATE> -- format some output nicely (default = 1)
1754 Format some values nicely, independent of $PRINTER. Currently, this
1755 displays arrays of scalars as columns.
1757 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1759 If zero, then initialization takes place.
1761 =item C<%REPL> -- maps shortcut names to handlers
1763 =item C<%REPL_DOC> -- maps shortcut names to documentation
1765 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1776 if ($REPL_LEVEL == 0) {
1778 -f
"$ENV{HOME}/.sepiarc" and eval qq#package $Sepia::PACKAGE; do "$ENV{HOME}/.sepiarc"#;
1779 warn ".sepiarc: $@\n" if $@
;
1781 Sepia
::Debug
::add_repl_commands
;
1782 repl_banner
if $REPL_LEVEL == 0;
1785 $READLINE = sub { print prompt
(); <STDIN
> };
1790 local $REPL_LEVEL = $REPL_LEVEL + 1;
1796 my $nextrepl = sub { $SIGGED++; };
1799 local *CORE
::GLOBAL
::die = \
&Sepia
::Debug
::die;
1800 local *CORE
::GLOBAL
::warn = \
&Sepia
::Debug
::warn;
1801 my @sigs = qw(INT TERM PIPE ALRM);
1803 $SIG{$_} = $nextrepl for @sigs;
1804 repl
: while (defined(my $in = $READLINE->())) {
1814 if ($buf =~ /^<<(\d+)\n(.*)/) {
1819 while ($len && defined($tmp = read STDIN
, $buf, $len, length $buf)) {
1823 ## Only install a magic handler if no one else is playing.
1824 local $SIG{__WARN__
} = $SIG{__WARN__
};
1826 unless ($SIG{__WARN__
}) {
1827 $SIG{__WARN__
} = 'Sepia::sig_warn';
1831 # repeat last interactive command
1837 if ($buf =~ /^,(\S+)\s*(.*)/s) {
1838 ## Inspector shortcuts
1840 if (exists $Sepia::RK
{$short}) {
1844 $Sepia::REPL
{$Sepia::RK
{$short}}->($arg, wantarray);
1846 if (grep /^$short/, keys %Sepia::REPL
) {
1847 print "Ambiguous shortcut '$short': ",
1848 join(', ', sort grep /^$short/, keys %Sepia::REPL
),
1851 print "Unrecognized shortcut '$short'\n";
1859 @res = $REPL{eval}->($buf);
1860 run_hook
@POST_EVAL;
1863 ## Always return results for an eval request
1864 Sepia
::printer \
@res, wantarray;
1865 Sepia
::printer
[$@
], wantarray;
1866 # print_warnings $ISEVAL;
1868 } elsif ($@
=~ /(?:at|before) EOF(?:$| at)/m) {
1869 ## Possibly-incomplete line
1871 print "Error:\n$@\n*** cancel ***\n";
1878 # $@ =~ s/(.*) at eval .*/$1/;
1879 # don't complain if we're abandoning execution
1880 # from the debugger.
1881 unless (ref $@
eq 'Sepia::Debug') {
1883 print "\n" unless $@
=~ /\n\z/;
1890 if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1891 ## Be quiet if it ends with a semicolon, or if we
1892 ## executed a shortcut.
1893 Sepia
::printer \
@res, wantarray;
1899 wantarray ?
@res : $res[0]
1904 tolisp
($REPL{eval}->(shift));
1907 =head2 Module browsing
1911 =item C<$status = html_module_list([$file [, $prefix]])>
1913 Generate an HTML list of installed modules, looking inside of
1914 packages. If C<$prefix> is missing, uses "about://perldoc/". If
1915 $file is given, write the result to $file; otherwise, return it as a
1918 =item C<$status = html_package_list([$file [, $prefix]])>
1920 Generate an HTML list of installed top-level modules, without looking
1921 inside of packages. If C<$prefix> is missing, uses
1922 "about://perldoc/". $file is the same as for C<html_module_list>.
1928 sub html_module_list
1930 my ($file, $base) = @_;
1931 $base ||= 'about://perldoc/';
1933 return unless $inst;
1935 open OUT
, ">", $file || \
$out or return;
1936 print OUT
"<html><body>";
1939 for (package_list
) {
1940 push @
{$ns{$1}}, $_ if /^([^:]+)/;
1942 # Handle core modules.
1944 undef $fs{$_} for map {
1945 s/.*man.\///; s|/|::|g
; s/\.\d(?:pm)?$//; $_
1947 /\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin
/ # && !/^(?
:\
/|perl)/
1948 } $inst->files('Perl');
1949 my @fs = sort keys %fs;
1950 print OUT
qq{<h2
>Core Modules
</h2
><ul
>};
1952 print OUT
qq{<li
><a href
="$base$_">$_</a
>};
1954 print OUT
'</ul><h2>Installed Modules</h2><ul>';
1957 for (sort keys %ns) {
1958 next if $_ eq 'Perl'; # skip Perl core.
1959 print OUT
qq{<li
><b
>$_</b
><ul
>} if @
{$ns{$_}} > 1;
1960 for (sort @
{$ns{$_}}) {
1962 undef $fs{$_} for map {
1963 s/.*man.\///; s|/|::|g
; s/\.\d(?:pm)?$//; $_
1965 /\.\d(?:pm)?$/ && !/man1/
1967 my @fs = sort keys %fs;
1968 next unless @fs > 0;
1970 print OUT
qq{<li
><a href
="$base$fs[0]">$fs[0]</a
>};
1972 print OUT
qq{<li
>$_<ul
>};
1974 print OUT
qq{<li
><a href
="$base$_">$_</a
>};
1979 print OUT
qq{</ul
>} if @
{$ns{$_}} > 1;
1982 print OUT
"</ul></body></html>\n";
1987 sub html_package_list
1989 my ($file, $base) = @_;
1990 return unless inst
();
1992 for (package_list
) {
1993 push @
{$ns{$1}}, $_ if /^([^:]+)/;
1995 $base ||= 'about://perldoc/';
1997 open OUT
, ">", $file || \
$out or return;
1998 print OUT
"<html><body><ul>";
2000 for (sort keys %ns) {
2001 if (@
{$ns{$_}} == 1) {
2003 qq{<li
><a href
="$base$ns{$_}[0]">$ns{$_}[0]</a
>};
2005 print OUT
qq{<li
><b
>$_</b
><ul
>};
2006 print OUT
qq{<li
><a href
="$base$_">$_</a
>}
2007 for sort @
{$ns{$_}};
2008 print OUT
qq{</ul
>};
2011 print OUT
"</ul></body></html>\n";
2018 my $re = _apropos_re
$_[0], 1;
2022 for ($inst->files('Perl', 'prog'), package_list
) {
2023 if (/\.\d?(?:pm)?$/ && !/man1/ && !/usr\/bin
/ && /$re/) {
2028 s/\.\d?(?:p[lm])?$//;
2038 my @q = $REQUIRES{$mod};
2043 push @q, @
{$REQUIRES{$m}};
2051 @
{$REQUIRED_BY{$mod}}
2059 See the README file included with the distribution.
2063 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
2065 There are several modules for Perl development in Emacs on CPAN,
2066 including L<Devel::PerlySense> and L<PDE>. For a complete list, see
2067 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
2071 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
2073 Bug reports welcome, patches even more welcome.
2077 Copyright (C) 2005-2011 Sean O'Rourke. All rights reserved, some
2078 wrongs reversed. This module is distributed under the same terms as