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.
26 use Sepia
::Debug
; # THIS TURNS ON DEBUGGING INFORMATION!
28 use Scalar
::Util
'looks_like_number';
31 use vars
qw($PS1 %REPL %RK %REPL_DOC %REPL_SHORT %PRINTER
33 $REPL_LEVEL $PACKAGE $WANTARRAY $PRINTER $STRICT $PRINT_PRETTY
38 eval { require Lexical::Persistence; import Lexical::Persistence };
40 print "Strict mode requires Lexical::Persistence.\n";
43 my $x = as_boolean(shift, $STRICT);
45 $STRICT = new Lexical::Persistence;
56 eval { require Module::CoreList };
60 *core_version = sub { Module::CoreList->first_release(@_) };
66 eval { use List::Util 'max' };
71 $ret = $_ if $_ > $ret;
80 eval { require Devel::Size };
82 print "Size requires Devel::Size.\n";
84 *Sepia::repl_size = sub {
85 ## XXX: C&P from repl_who:
86 my ($pkg, $re) = split ' ', shift || '';
87 if ($pkg =~ /^\/(.*)\/?$/) {
90 } elsif (!$re && !defined %{$pkg.'::'}) {
97 my @who = who($pkg, $re);
98 my $len = max(map { length } @who) + 4;
99 my $fmt = '%-'.$len."s%10d\n";
100 print 'Var', ' ' x ($len + 2), "Bytes\n";
101 print '-' x ($len-4), ' ' x 9, '-' x 5, "\n";
102 local $SIG{__WARN__} = sub {};
104 next unless /^[\$\@\%\&]/; # skip subs.
105 # print STDERR "no strict; package $pkg; Devel::Size::total_size \\$_;";
106 my $res = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
107 print "aiee: $@\n" if $@;
108 printf $fmt, $_, $res;
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
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
128 =head2 C<@compls = completions($string [, $type])>
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".
136 =head2 C<@compls = method_completions($expr, $string [,$eval])>
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
149 # Do that crazy multi-word identifier completion thing:
151 return qr/.*/ if $re eq '';
154 s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
156 } split /:+/, $re, -1;
158 if ($re !~ /[^\w\d_^:]/) {
159 $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
167 %sigil = qw(ARRAY @ SCALAR $ HASH %);
173 local $_ = /^::/ ?
$_ : "::$_";
174 defined *{$_}{CODE
} || defined *{$_}{IO
} || (/::$/ && defined *{$_}{HASH
});
177 ## XXX: Careful about autovivification here! Specifically:
178 ## defined *FOO{HASH} # => ''
179 ## defined %FOO # => ''
180 ## defined *FOO{HASH} # => 1
185 local $_ = /^::/ ?
$_ : "::$_";
186 if ($type eq 'SCALAR') {
188 } elsif ($type eq 'VARIABLE') {
189 defined ${$_} || defined *{$_}{HASH
} || defined *{$_}{ARRAY
};
198 $ch =~ /[A-Z]/ ?
$ch : '['.uc($ch).$ch.']';
201 sub all_abbrev_completions
203 use vars
'&_completions';
204 local *_completions
= sub {
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
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)
220 map { s/^:://; $_ } _completions
('::', split //, shift);
225 my ($icase, $re) = @_;
227 $icase ?
qr/^$re.*$/i : qr/^$re.*$/;
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 {
240 map { "$stash$_" } grep /$re/, keys %{$stash};
242 my $re2 = $icase ?
qr/^$_[0].*::$/i : qr/^$_[0].*::$/;
243 my @pkgs = grep /$re2/, keys %{$stash};
244 map { _completions
"$stash$_", @_[1..$#_] } @pkgs
247 map { s/^:://; $_ } _completions
('::', @parts);
252 my ($type, $str, $t);
253 my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
255 @rh{values %h} = keys %h;
257 ($type, $str) = $_[0] =~ /^([\%\$\@\&]?)(.*)/;
259 $type = $h{$type} if $type;
263 $t = $rh{$type} if $type;
266 $type ? filter_typed
$type : filter_untyped
267 } all_completions
$str;
268 if (!@ret && $str !~ /:/) {
270 $type ? filter_typed
$type : filter_untyped
271 } all_abbrev_completions
$str;
273 @ret = map { s/^:://; "$t$_" } @ret;
274 # ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
277 length > 0 && !looks_like_number
$_ && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
281 sub method_completions
283 my ($x, $fn, $eval) = @_;
286 $eval ||= 'CORE::eval';
288 return unless ($x =~ /^\$/ && ($x = $eval->("ref($x)")))
289 || $eval->('defined(%{'.$x.'::})');
291 my $re = _apropos_re
$fn;
292 ## Filter out overload methods "(..."
293 return sort { $a cmp $b } map { s/.*:://; $_ }
294 grep { defined *{$_}{CODE
} && /::$re/ && !/\(/ }
299 =head2 C<@locs = location(@names)>
301 Return a list of [file, line, name] triples, one for each function
311 if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
313 warn "Sorry -- can't lookup variables.";
316 # XXX: svref_2object only seems to work with a package
317 # tacked on, but that should probably be done
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 !~ /^\//) {
331 my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
332 [Cwd
::abs_path
($file), $line, $shortname || $name]
334 # warn "Bad CV for $name: $cv";
345 =head2 C<@matches = apropos($name [, $is_regex])>
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.
353 sub my_walksymtable
(&*)
359 &$f for keys %$stash;
360 _walk
("$stash$_") for grep /(?<!main)::$/, keys %$stash;
367 my ($it, $re, @types) = @_;
370 $stashp = grep /STASH/, @types;
371 @types = grep !/STASH/, @types;
376 if ($it =~ /^(.*::)([^:]+)$/) {
377 my ($stash, $name) = ($1, $2);
378 if (!defined %$stash) {
382 my $name = qr/^$name/;
387 my $stashnm = "$stash$_";
390 || scalar grep { defined *{$stashnm}{$_} } @types)
393 defined &$it ?
$it : ();
397 my $findre = $re ?
qr/$it/ : qr/^\Q$it\E$/;
399 push @ret, "$stash$_" if /$findre/;
401 map { s/^:*(?:main:+)*//;$_ } @ret;
405 =head2 C<@names = mod_subs($pack)>
407 Find subs in package C<$pack>.
415 my $stash = \
%{"$p\::"};
416 if (defined $stash) {
417 grep { defined &{"$p\::$_"} } keys %$stash;
421 =head2 C<@decls = mod_decls($pack)>
423 Generate a list of declarations for all subroutines in package
434 my $proto = prototype(\
&{"$pack\::$sn"});
435 $proto = defined($proto) ?
"($proto)" : '';
438 return wantarray ?
@ret : join '', @ret;
441 =head2 C<$info = module_info($module, $type)>
443 Emacs-called function to get module information.
449 eval { require Module
::Info
; import Module
::Info
};
457 $info = Module
::Info
->new_from_file($m);
459 (my $file = $m) =~ s
|::|/|g
;
461 if (exists $INC{$file}) {
462 $info = Module
::Info
->new_from_loaded($m);
464 $info = Module
::Info
->new_from_module($m);
475 =head2 C<$file = mod_file($mod)>
477 Find the likely file owner for module C<$mod>.
485 while ($m && !exists $INC{"$m.pm"}) {
486 $m =~ s
#(?:^|/)[^/]+$##;
488 $m ?
$INC{"$m.pm"} : undef;
491 =head2 C<@mods = package_list>
493 Gather a list of all distributions on the system. XXX UNUSED
501 eval 'require ExtUtils::Installed';
502 $INST = new ExtUtils
::Installed
;
509 sort { $a cmp $b } inst
()->modules;
512 =head2 C<@mods = module_list>
514 Gather a list of all packages (.pm files, really) installed on the
515 system, grouped by distribution. XXX UNUSED
521 @_ = package_list
unless @_;
522 my $incre = join '|', map quotemeta, @INC;
523 $incre = qr
|(?
:$incre)/|;
527 s/$incre//; s
|/|::|g
;$_
528 } grep /\.pm$/, $inst->files($_)]
532 =head2 C<@mods = doc_list>
534 Gather a list of all documented packages (.?pm files, really)
535 installed on the system, grouped by distribution. XXX UNUSED
541 @_ = package_list
unless @_;
545 s/.*man.\///; s|/|::|g
;s/\..?pm//; $_
546 } grep /\..pm$/, $inst->files($_)]
550 =head2 C<lexicals($subname)>
552 Return a list of C<$subname>'s lexical variables. Note that this
553 includes all nested scopes -- I don't know if or how Perl
554 distinguishes inner blocks.
560 my $cv = B
::svref_2object
(\
&{+shift});
561 return unless $cv && ($cv = $cv->PADLIST);
562 my ($names, $vals) = $cv->ARRAY;
564 my $name = $_->PV; $name =~ s/\0.*$//; $name
565 } grep B
::class($_) ne 'SPECIAL', $names->ARRAY;
568 =head2 C<$lisp = tolisp($perl)>
570 Convert a Perl scalar to some ELisp equivalent.
576 my $thing = @_ == 1 ?
shift : \
@_;
579 if (!defined $thing) {
581 } elsif (looks_like_number
$thing) {
584 ## XXX Elisp and perl have slightly different
585 ## escaping conventions, so we do this crap instead.
586 $thing =~ s/["\\]/\\$1/g;
589 } elsif ($t eq 'GLOB') {
590 (my $name = $$thing) =~ s/\*main:://;
592 } elsif ($t eq 'ARRAY') {
593 '(' . join(' ', map { tolisp
($_) } @
$thing).')'
594 } elsif ($t eq 'HASH') {
595 '(' . join(' ', map {
596 '(' . tolisp
($_) . " . " . tolisp
($thing->{$_}) . ')'
598 } elsif ($t eq 'Regexp') {
599 "'(regexp . \"" . quotemeta($thing) . '")';
600 # } elsif ($t eq 'IO') {
606 =head2 C<printer(\@res, $wantarray)>
608 Print C<@res> appropriately on the current filehandle. If C<$ISEVAL>
609 is true, use terse format. Otherwise, use human-readable format,
610 which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
616 eval { require Data
::Dumper
};
617 local $Data::Dumper
::Deparse
= 1;
618 local $Data::Dumper
::Indent
= 0;
620 my $thing = @res > 1 ? \
@res : $res[0];
622 $_ = Data
::Dumper
::Dumper
($thing);
626 if (length $_ > ($ENV{COLUMNS
} || 80)) {
627 $Data::Dumper
::Indent
= 1;
629 $_ = Data
::Dumper
::Dumper
($thing);
642 eval { require YAML
};
644 $PRINTER{dumper
}->();
650 eval { require Data
::Dump
};
652 $PRINTER{dumper
}->();
654 Data
::Dump
::dump(\
@res);
662 my ($wantarray) = @_;
665 $::__
= @res == 1 ?
$res[0] : [@res];
669 } elsif (@res == 1 && UNIVERSAL
::can
($res[0], '()')) {
672 } elsif (!$ISEVAL && $PRINT_PRETTY && @res > 1 && !grep ref, @res) {
673 $res = columnate
(@res);
677 $res = $PRINTER{$PRINTER}->();
680 print ';;;', length $res, "\n$res\n";
696 "$PACKAGE ".($WANTARRAY ?
'@' : '$').$PS1
702 Data
::Dumper
->Dump([$_[0]], [$_[1]]);
709 my $n1 = int(2*$n/3);
711 s/(.{$n1,$n}) /$1\n/g;
715 =head2 C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
717 Define $name as a shortcut for function $sub.
723 my ($name, $doc, $short, $fn);
729 ($name, $fn, $doc) = @_;
732 ($name, $fn, $short, $doc) = @_;
735 $REPL_DOC{$name} = $doc;
736 $REPL_SHORT{$name} = $short;
741 define_shortcut
'help', \
&Sepia
::repl_help
,
743 'Display help on all commands, or just CMD.';
744 define_shortcut
'cd', \
&Sepia
::repl_chdir
,
745 'cd DIR', 'Change directory to DIR';
746 define_shortcut
'pwd', \
&Sepia
::repl_pwd
,
747 'Show current working directory';
748 define_shortcut
'methods', \
&Sepia
::repl_methods
,
750 'List methods for reference or package X, matching optional pattern RE';
751 define_shortcut
'package', \
&Sepia
::repl_package
,
752 'package PKG', 'Set evaluation package to PKG';
753 define_shortcut
'who', \
&Sepia
::repl_who
,
755 'List variables and subs in PKG matching optional pattern RE.';
756 define_shortcut
'wantarray', \
&Sepia
::repl_wantarray
,
757 'wantarray [0|1]', 'Set or toggle evaluation context';
758 define_shortcut
'format', \
&Sepia
::repl_format
,
759 'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
760 define_shortcut
'strict', \
&Sepia
::repl_strict
,
761 'strict [0|1]', 'Turn \'use strict\' mode on or off';
762 define_shortcut
'quit', \
&Sepia
::repl_quit
,
764 define_shortcut
'reload', \
&Sepia
::repl_reload
,
765 'Reload Sepia.pm and relaunch the REPL.';
766 define_shortcut
'shell', \
&Sepia
::repl_shell
,
767 'shell CMD ...', 'Run CMD in the shell';
768 define_shortcut
'eval', \
&Sepia
::repl_eval
,
769 'eval EXP', '(internal)';
770 define_shortcut
'size', \
&Sepia
::repl_size
,
772 'List total sizes of objects in PKG matching optional pattern RE.';
773 define_shortcut define
=> \
&Sepia
::repl_define
,
774 'define NAME [\'doc\'] BODY',
775 'Define NAME as a shortcut executing BODY';
776 define_shortcut
undef => \
&Sepia
::repl_undef
,
777 'undef NAME', 'Undefine shortcut NAME';
782 my $width = $ENV{COLUMNS
} || 80;
787 my $full = $RK{$args};
790 flow
($width - length $RK{$full} - 4, $REPL_DOC{$full}), "\n";
792 print "$args: no such command\n";
795 my $left = 1 + max
map length, values %REPL_SHORT;
796 print "REPL commands (prefixed with ','):\n";
798 for (sort keys %REPL) {
799 my $flow = flow
($width - $left, $REPL_DOC{$_});
800 $flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
801 printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
809 my ($name, $doc, $body);
810 if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
811 ($name, $doc, $body) = ($1, $2, $3);
812 } elsif (/^\s*(\S+)\s+(\S.*)/) {
813 ($name, $doc, $body) = ($1, $2, $2);
815 print "usage: define NAME ['doc'] BODY...\n";
818 my $sub = eval "sub { do { $body } }";
820 print "usage: define NAME ['doc'] BODY...\n\t$@\n";
823 define_shortcut
$name, $sub, $doc;
824 %RK = abbrev
keys %REPL;
832 my $full = $RK{$name};
835 delete $REPL_SHORT{$full};
836 delete $REPL_DOC{$full};
837 %RK = abbrev
keys %REPL;
839 print "$name: no such shortcut.\n";
848 print "printer = $PRINTER, pretty = @{[$PRINT_PRETTY ? 1 : 0]}\n";
850 my %formats = abbrev
keys %PRINTER;
851 if (exists $formats{$t}) {
852 $PRINTER = $formats{$t};
854 warn "No such format '$t' (dumper, dump, yaml, plain).\n";
861 chomp(my $dir = shift);
862 $dir =~ s/^~\//$ENV{HOME
}\
//;
863 $dir =~ s/\$HOME/$ENV{HOME}/;
866 my $ecmd = '(cd "'.Cwd
::getcwd
().'")';
867 print ";;;###".length($ecmd)."\n$ecmd\n";
869 warn "Can't chdir\n";
875 print Cwd
::getcwd
(), "\n";
880 my ($pack, $re_str) = @_;
882 my $re = qr/$re_str/;
884 if ($re_str =~ /^[\$\@\%\&]/) {
885 ## sigil given -- match it
886 sort grep /$re/, map {
887 (defined %{$pack.'::'.$_} ?
'%'.$_ : (),
888 defined ${$pack.'::'.$_} ?
'$'.$_ : (), # ?
889 defined @
{$pack.'::'.$_} ?
'@'.$_ : (),
890 defined &{$pack.'::'.$_} ?
'&'.$_ : (),
892 } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
894 ## no sigil -- don't match it
896 (defined %{$pack.'::'.$_} ?
'%'.$_ : (),
897 defined ${$pack.'::'.$_} ?
'$'.$_ : (), # ?
898 defined @
{$pack.'::'.$_} ?
'@'.$_ : (),
899 defined &{$pack.'::'.$_} ?
$_ : (),
901 } grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
909 my $width = $ENV{COLUMNS
} || 80;
911 $len = length if $len < length;
913 my $nc = int($width / ($len+1)) || 1;
914 my $nr = int(@_ / $nc) + (@_ % $nc ?
1 : 0);
915 my $fmt = ('%-'.($len+1).'s') x
($nc-1) . "%s\n";
916 my @incs = map { $_ * $nr } 0..$nc-1;
918 for my $r (0..$nr-1) {
919 $str .= sprintf $fmt, map { defined($_) ?
$_ : '' }
920 @_[map { $r + $_ } @incs];
928 my ($pkg, $re) = split ' ', shift;
929 if ($pkg =~ /^\/(.*)\
/?$/) {
932 } elsif (!$re && !defined %{$pkg.'::'}) {
936 print columnate who
($pkg || $PACKAGE, $re);
941 my ($pack, $qualified) = @_;
943 my @own = $qualified ?
grep {
945 } map { "$pack\::$_" } keys %{$pack.'::'}
947 defined *{"$pack\::$_"}{CODE
}
948 } keys %{$pack.'::'};
949 (@own, defined @
{$pack.'::ISA'}
950 ?
(map methods
($_, $qualified), @
{$pack.'::ISA'}) : ());
955 my ($x, $re) = split ' ', shift;
959 $x = $REPL{eval}->("ref $x");
964 print columnate
sort { $a cmp $b } grep /$re/, methods
$x;
969 my ($val, $cur) = @_;
971 length($val) ?
$val : !$cur;
976 $WANTARRAY = as_boolean
shift, $WANTARRAY;
981 chomp(my $p = shift);
983 if (defined %{$p.'::'}) {
985 # my $ecmd = '(setq sepia-eval-package "'.$p.'")';
986 # print ";;;###".length($ecmd)."\n$ecmd\n";
988 warn "Can't go to package $p -- doesn't exist!\n";
1001 print "Reload failed:\n$@\n";
1003 $REPL_LEVEL = 0; # ok?
1018 # local $PACKAGE = $pkg || $PACKAGE;
1021 $buf = 'scalar($buf)';
1023 my $ctx = join(',', keys %{$STRICT->get_context('_')});
1024 $ctx = $ctx ?
"my ($ctx);" : '';
1025 $buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
1027 print "ERROR\n$@\n";
1030 $STRICT->call($buf);
1032 $buf = "do { package $PACKAGE; no strict; $buf }";
1041 ## Collects warnings for REPL
1054 print ';;;'.length($tmp)."\n$tmp\n";
1058 print "warning: $_\n";
1067 I need user feedback! Please send questions or comments to seano\@cpan.org.
1068 Sepia version $Sepia::VERSION.
1069 Type ",h" for help, or ",q" to quit.
1075 Execute a command interpreter on standard input and standard output.
1076 If you want to use different descriptors, localize them before
1077 calling C<repl()>. The prompt has a few bells and whistles, including:
1081 =item Obviously-incomplete lines are treated as multiline input (press
1082 'return' twice or 'C-c' to discard).
1084 =item C<die> is overridden to enter a debugging repl at the point
1089 Behavior is controlled in part through the following package-globals:
1093 =item C<$PACKAGE> -- evaluation package
1095 =item C<$PRINTER> -- result printer (default: dumper)
1097 =item C<$PS1> -- the default prompt
1099 =item C<$STRICT> -- whether 'use strict' is applied to input
1101 =item C<$WANTARRAY> -- evaluation context
1103 =item C<$PRINT_PRETTY> -- format some output nicely (default = 1)
1105 Format some values nicely, independent of $PRINTER. Currently, this
1106 displays arrays of scalars as columns.
1108 =item C<$REPL_LEVEL> -- level of recursive repl() calls
1110 If zero, then initialization takes place.
1112 =item C<%REPL> -- maps shortcut names to handlers
1114 =item C<%REPL_DOC> -- maps shortcut names to documentation
1116 =item C<%REPL_SHORT> -- maps shortcut names to brief usage
1125 if ($REPL_LEVEL == 0) {
1127 -f
"$ENV{HOME}/.sepiarc" and do "$ENV{HOME}/.sepiarc";
1128 warn ".sepiarc: $@\n" if $@
;
1130 local $REPL_LEVEL = $REPL_LEVEL + 1;
1136 my $nextrepl = sub { $sigged = 1; };
1139 local *CORE
::GLOBAL
::die = \
&Sepia
::Debug
::die;
1140 local *CORE
::GLOBAL
::warn = \
&Sepia
::Debug
::warn;
1142 Sepia
::Debug
::add_repl_commands
;
1143 repl_banner
if $REPL_LEVEL == 1;
1145 my @sigs = qw(INT TERM PIPE ALRM);
1147 $SIG{$_} = $nextrepl for @sigs;
1148 repl
: while (defined(my $in = <STDIN
>)) {
1158 if ($buf =~ /^<<(\d+)\n(.*)/) {
1163 while ($len && defined($tmp = read STDIN
, $buf, $len, length $buf)) {
1168 ## Only install a magic handler if no one else is playing.
1169 local $SIG{__WARN__
} = $SIG{__WARN__
};
1171 unless ($SIG{__WARN__
}) {
1172 $SIG{__WARN__
} = 'Sepia::sig_warn';
1174 if ($buf =~ /^,(\S+)\s*(.*)/s) {
1175 ## Inspector shortcuts
1177 if (exists $Sepia::RK
{$short}) {
1181 $Sepia::REPL
{$Sepia::RK
{$short}}->($arg, wantarray);
1183 if (grep /^$short/, keys %Sepia::REPL
) {
1184 print "Ambiguous shortcut '$short': ",
1185 join(', ', sort grep /^$short/, keys %Sepia::REPL
),
1188 print "Unrecognized shortcut '$short'\n";
1196 @res = $REPL{eval}->($buf);
1199 ## Always return results for an eval request
1200 Sepia
::printer \
@res, wantarray;
1201 Sepia
::printer
[$@
], wantarray;
1202 # print_warnings $ISEVAL;
1205 } elsif ($@
=~ /(?:at|before) EOF(?:$| at)/m) {
1206 ## Possibly-incomplete line
1208 print "Error:\n$@\n*** cancel ***\n", prompt
;
1215 # $@ =~ s/(.*) at eval .*/$1/;
1216 # don't complain if we're abandoning execution
1217 # from the debugger.
1218 unless (ref $@
eq 'Sepia::Debug') {
1220 print "\n" unless $@
=~ /\n\z/;
1228 if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
1229 ## Be quiet if it ends with a semicolon, or if we
1230 ## executed a shortcut.
1231 Sepia
::printer \
@res, wantarray;
1237 wantarray ?
@REPL_RESULT : $REPL_RESULT[0]
1242 tolisp
($REPL{eval}->(shift));
1245 =head2 C<$status = html_module_list([$file [, $prefix]])>
1247 Generate an HTML list of installed modules, looking inside of
1248 packages. If C<$prefix> is missing, uses "about://perldoc/". If
1249 $file is given, write the result to $file; otherwise, return it as a
1252 =head2 C<$status = html_package_list([$file [, $prefix]])>
1254 Generate an HTML list of installed top-level modules, without looking
1255 inside of packages. If C<$prefix> is missing, uses
1256 "about://perldoc/". $file is the same as for C<html_module_list>.
1260 sub html_module_list
1262 my ($file, $base) = @_;
1263 $base ||= 'about://perldoc/';
1265 return unless $inst;
1267 open OUT
, ">", $file || \
$out or return;
1268 print OUT
"<html><body><ul>";
1271 for (package_list
) {
1272 push @
{$ns{$1}}, $_ if /^([^:]+)/;
1274 for (sort keys %ns) {
1275 print OUT
qq{<li
><b
>$_</b
><ul
>} if @
{$ns{$_}} > 1;
1276 for (sort @
{$ns{$_}}) {
1278 s/.*man.\///; s|/|::|g
; s/\.\d(?:pm)?$//; $_
1279 } grep /\.\d(?:pm)?$/, sort $inst->files($_);
1281 print OUT
qq{<li
><a href
="$base$fs[0]">$fs[0]</a
>};
1283 print OUT
qq{<li
>$_<ul
>};
1285 print OUT
qq{<li
><a href
="$base$_">$_</a
>};
1290 print OUT
qq{</ul
>} if @
{$ns{$_}} > 1;
1292 print OUT
"</ul></body></html>\n";
1297 sub html_package_list
1299 my ($file, $base) = @_;
1300 return unless inst
();
1301 $base ||= 'about://perldoc/';
1303 open OUT
, ">", $file || \
$out or return;
1304 print OUT
"<html><body><ul>";
1307 for (package_list
) {
1308 push @
{$ns{$1}}, $_ if /^([^:]+)/;
1310 for (sort keys %ns) {
1311 if (@
{$ns{$_}} == 1) {
1313 qq{<li
><a href
="$base$ns{$_}[0]">$ns{$_}[0]</a
>};
1315 print OUT
qq{<li
><b
>$_</b
><ul
>};
1316 print OUT
qq{<li
><a href
="$base$_">$_</a
>}
1317 for sort @
{$ns{$_}};
1318 print OUT
qq{</ul
>};
1321 print OUT
"</ul></body></html>\n";
1331 See the README file included with the distribution.
1335 Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
1337 There are several modules for Perl development in Emacs on CPAN,
1338 including L<Devel::PerlySense> and L<PDE>. For a complete list, see
1339 L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
1343 Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
1345 Bug reports welcome, patches even more welcome.
1349 Copyright (C) 2005-2008 Sean O'Rourke. All rights reserved, some
1350 wrongs reversed. This module is distributed under the same terms as