5 Sepia - Simple Emacs-Perl Interface
15 use Scalar
::Util
'looks_like_number';
17 use PadWalker
qw(peek_my peek_our peek_sub closed_over);
23 =item C<@compls = completions($string [, $type])>
25 Find a list of completions for C<$string> with glob type $type.
26 Completion operates on word subparts separated by [:_], so
27 e.g. "S:m_w" completes to "Sepia::my_walksymtable".
33 # Do that crazy multi-word identifier completion thing:
37 s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
39 } split /:+/, $re, -1;
41 if ($re !~ /[^\w\d_^:]/) {
42 $re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
55 } grep /$_[0]/, keys %$stash;
59 _completions1
("$stash$_", @_);
60 } grep /$re.*::$/, keys %$stash;
66 _completions1
'::', _apropos_re
($_[0]);
71 %sigil = qw(ARRAY @ SCALAR $ HASH %);
77 my ($str, $type, $infunc) = @_;
78 my @ret = map { s/^:://; $_ } ($type ?
do {
79 (grep { defined *{$_}{$type} } _completions
$str),
80 (defined $infunc && defined *{$infunc}{CODE
}) ?
do {
81 my ($apre) = _apropos_re
($str);
82 my $st = $sigil{$type};
84 (my $tmp = $_) =~ s/^\Q$st//;
90 defined *{$_}{CODE
} || defined *{$_}{IO
}
91 || (/::$/ && defined *{$_}{HASH
});
94 if (!@ret && $str !~ /[^\w\d]/) {
95 ## Complete "simple" sequences as abbreviations, e.g.:
96 ## wtci -> Want_To_Complete_It, NOT
98 my $broad = join '.*', map "\\b$_", split '', $str;
99 @ret = map { s/^:://; $_ } ($type ?
do {
100 (grep { defined *{$_}{$type} } _completions1
'::', qr/$broad/),
101 (defined $infunc && defined *{$infunc}{CODE
}) ?
do {
102 my ($apre) = _apropos_re
($str);
103 my $st = $sigil{$type};
105 (my $tmp = $_) =~ s/^\Q$st//;
111 defined *{$_}{CODE
} || defined *{$_}{IO
}
112 || (/::$/ && defined *{$_}{HASH
});
113 } _completions1
'::', qr/$broad/;
119 =item C<@locs = location(@names)>
121 Return a list of [file, line, name] triples, one for each function
131 if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
133 warn "Sorry -- can't lookup variables.";
136 # XXX: svref_2object only seems to work with a package
137 # tacked on, but that should probably be done
139 $name = 'main::'.$name unless $name =~ /::/;
140 my $cv = B
::svref_2object
(\
&{$name});
141 if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
142 my ($file, $line) = ($cv->file, $cv->line);
143 if ($file !~ /^\//) {
151 my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
152 [Cwd
::abs_path
($file), $line, $shortname || $name]
154 # warn "Bad CV for $name: $cv";
165 =item C<@matches = apropos($name [, $is_regex])>
167 Search for function C<$name>, either in all packages or, if C<$name>
168 is qualified, only in one package. If C<$is_regex> is true, the
169 non-package part of C<$name> is a regular expression.
173 sub my_walksymtable
(&*)
179 &$f for keys %$stash;
180 _walk
("$stash$_") for grep /(?<!main)::$/, keys %$stash;
187 my ($it, $re, @types) = @_;
190 $stashp = grep /STASH/, @types;
191 @types = grep !/STASH/, @types;
196 if ($it =~ /^(.*::)([^:]+)$/) {
197 my ($stash, $name) = ($1, $2);
198 if (!defined %$stash) {
202 my $name = qr/^$name/;
207 my $stashnm = "$stash$_";
210 || scalar grep { defined *{$stashnm}{$_} } @types)
213 defined &$it ?
$it : ();
217 my $findre = $re ?
qr/$it/ : qr/^\Q$it\E$/;
219 push @ret, "$stash$_" if /$findre/;
221 map { s/^:*(?:main:+)*//;$_ } @ret;
225 =item C<@names = mod_subs($pack)>
227 Find subs in package C<$pack>.
235 my $stash = \
%{"$p\::"};
236 if (defined $stash) {
237 grep { defined &{"$p\::$_"} } keys %$stash;
241 =item C<@decls = mod_decls($pack)>
243 Generate a list of declarations for all subroutines in package
254 my $proto = prototype(\
&{"$pack\::$sn"});
255 $proto = defined($proto) ?
"($proto)" : '';
258 return wantarray ?
@ret : join '', @ret;
261 =item C<$info = module_info($module, $type)>
263 Emacs-called function to get module information.
272 $info = Module
::Info
->new_from_file($m);
274 (my $file = $m) =~ s
|::|/|g
;
276 if (exists $INC{$file}) {
277 $info = Module
::Info
->new_from_loaded($m);
279 $info = Module
::Info
->new_from_module($m);
287 =item C<$file = mod_file($mod)>
289 Find the likely file owner for module C<$mod>.
297 while ($m && !exists $INC{"$m.pm"}) {
298 $m =~ s
#(?:^|/)[^/]+$##;
300 $m ?
$INC{"$m.pm"} : undef;
303 =item C<@mods = package_list>
305 Gather a list of all distributions on the system. XXX UNUSED
313 eval 'require ExtUtils::Installed';
314 $INST = new ExtUtils
::Installed
;
324 =item C<@mods = module_list>
326 Gather a list of all packages (.pm files, really) installed on the
327 system, grouped by distribution. XXX UNUSED
333 @_ = package_list
unless @_;
334 my $incre = join '|', map quotemeta, @INC;
335 $incre = qr
|(?
:$incre)/|;
339 s/$incre//; s
|/|::|g
;$_
340 } grep /\.pm$/, $inst->files($_)]
344 =item C<@mods = doc_list>
346 Gather a list of all documented packages (.?pm files, really)
347 installed on the system, grouped by distribution. XXX UNUSED
353 @_ = package_list
unless @_;
357 s/.*man.\///; s|/|::|g
;s/\..?pm//; $_
358 } grep /\..pm$/, $inst->files($_)]
362 =item C<lexicals($subname)>
364 Return a list of C<$subname>'s lexical variables. Note that this
365 includes all nested scopes -- I don't know if or how Perl
366 distinguishes inner blocks.
372 my $cv = B
::svref_2object
(\
&{+shift});
373 return unless $cv && ($cv = $cv->PADLIST);
374 my ($names, $vals) = $cv->ARRAY;
376 my $name = $_->PV; $name =~ s/\0.*$//; $name
377 } grep B
::class($_) ne 'SPECIAL', $names->ARRAY;
380 =item C<$lisp = tolisp($perl)>
382 Convert a Perl scalar to some ELisp equivalent.
388 my $thing = @_ == 1 ?
shift : \
@_;
391 if (!defined $thing) {
393 } elsif (looks_like_number
$thing) {
398 } elsif ($t eq 'GLOB') {
399 (my $name = $$thing) =~ s/\*main:://;
401 } elsif ($t eq 'ARRAY') {
402 '(' . join(' ', map { tolisp
($_) } @
$thing).')'
403 } elsif ($t eq 'HASH') {
404 '(' . join(' ', map {
405 '(' . tolisp
($_) . " . " . tolisp
($thing->{$_}) . ')'
407 } elsif ($t eq 'Regexp') {
408 "'(regexp . \"" . quotemeta($thing) . '")';
409 # } elsif ($t eq 'IO') {
415 =item C<printer(\@res [, $iseval])>
417 Print C<@res> appropriately on the current filehandle. If C<$iseval>
418 is true, use terse format. Otherwise, use human-readable format.
424 local $Data::Dumper
::Deparse
= 1;
425 local $Data::Dumper
::Indent
= 0;
428 local $_ = Data
::Dumper
::Dumper
(@res > 1 ? \
@res : $res[0]);
444 eval { require YAML
};
455 eval { require Data
::Dump
};
467 my ($iseval, $wantarray) = @_;
472 } elsif (@res == 1 && (ref $res[0]) =~ /^PDL/) {
478 print ';;;', length $__, "\n$__\n";
486 Execute a command interpreter on FH. The prompt has a few bells and
489 * Obviously-incomplete lines are treated as multiline input.
491 * C<die> is overridden to enter a recursive interpreter at the point
492 C<die> is called. From within this interpreter, you can examine a
493 backtrace by calling "bt", return from C<die> with "r EXPR", or
494 go ahead and die by pressing Control-c.
496 Behavior is controlled in part through the following package-globals:
500 =item C<$PS1> -- the default prompt
502 =item C<$STOPDIE> -- true to enter the inspector on C<die()>
504 =item C<$STOPWARN> -- true to enter the inspector on C<warn()>
506 =item C<%REPL> -- maps shortcut names to handlers
508 =item C<$PACKAGE> -- evaluation package
510 =item C<$WANTARRAY> -- evaluation context
512 =item C<$PRINTER> -- result printer (default: print_dumper)
516 use vars
qw($PS1 $dies $STOPDIE $STOPWARN %REPL %RK
517 $PACKAGE $WANTARRAY $PRINTER);
526 $PRINTER = \&Sepia::print_dumper;
527 %REPL = (help => \&Sepia::repl_help,
528 cd => \&Sepia::repl_chdir,
529 package => \&Sepia::repl_package,
530 who => \&Sepia::repl_who,
531 wantarray => \&Sepia::repl_wantarray,
532 format => \&Sepia::repl_format,
534 %RK = abbrev keys %REPL;
539 "$PACKAGE ".($WANTARRAY ? '@' : '$').$PS1
544 Data::Dumper->Dump([$_[0]], [$_[1]]);
552 my ($fn, @args) = @_;
554 uplevel $FRAMES, $fn, @args
560 my ($expr, $env) = @_;
564 next unless /^([\$\@%])(.+)/;
565 $str .= "local *$2 = \$::ENV->{'$_'}; ";
567 eval "do { no strict; $str $expr }";
572 my ($lev, $exp) = $_[0] =~ /^\s*(\d+)\s+(.*)/;
574 (0, eval_in_env($exp, PadWalker::peek_my(0+$lev)));
581 my $sub = (caller $i)[3];
583 my $h = PadWalker::peek_my($i);
584 print "[$i] $sub:\n";
585 for (sort keys %$h) {
586 print "\t", Sepia::Dump($h->{$_}, $_);
595 REPL commands (prefixed with ','):
596 cd DIR Change directory to DIR
598 format [dumper|dump|yaml|plain]
599 Set output formatter (default: dumper)
600 help Display this message
601 package PACKAGE Set evaluation package to PACKAGE
602 wantarray [0|1] Set or toggle evaluation context
603 who PACKAGE List variables and subs in PACKAGE
612 $t = 'dumper' if $t eq '';
613 my %formats = abbrev
qw(dumper dump yaml plain);
614 if (exists $formats{$t}) {
616 $PRINTER = \
&{'print_'.$formats{$t}};
618 warn "No such format '$t' (dumper, dump, yaml, plain).\n";
625 chomp(my $dir = shift);
626 $dir =~ s/^~\//$ENV{HOME
}\
//;
627 $dir =~ s/\$HOME/$ENV{HOME}/;
631 my $ecmd = '(cd "'.Cwd
::getcwd
().'")';
632 print ";;;###".length($ecmd)."\n$ecmd\n";
634 warn "Can't chdir\n";
641 my $pack = shift || '';
644 (defined %{$pack.'::'.$_} ?
'%'.$_ : (),
645 defined ${$pack.'::'.$_} ?
'$'.$_ : (), # ?
646 defined @
{$pack.'::'.$_} ?
'@'.$_ : (),
647 defined &{$pack.'::'.$_} ?
$_ : (),
649 } grep !/::$/ && !/^(?:_<|[^\w])/, keys %{$pack.'::'};
655 Sepia
::printer
(\
@who);
662 $WANTARRAY = defined $x ?
$x : !$WANTARRAY;
668 chomp(my $p = shift);
670 if (defined %{$p.'::'}) {
672 # my $ecmd = '(setq sepia-eval-package "'.$p.'")';
673 # print ";;;###".length($ecmd)."\n$ecmd\n";
675 warn "Can't go to package $p -- doesn't exist!\n";
683 Inspector commands (prefixed with ','):
684 \\C-c Pop one debugger level
685 backtrace show backtrace
686 inspect N ... inspect lexicals in frame(s) N ...
687 eval N EXPR evaluate EXPR in lexical environment of frame N
688 return EXPR return EXPR
689 die/warn keep on dying/warning
706 my ($buf, $wantarray, $pkg) = @_;
708 local $PACKAGE = $pkg || $PACKAGE;
709 $buf = "do { package $PACKAGE; no strict; $buf }";
712 $wa = wantarray ?
'ARRAY' : 'SCALAR';
723 my ($fh, $level) = @_;
724 select((select($fh), $|=1)[0]);
729 my $nextrepl = sub { $sigged = 1; };
732 my $MSG = "('\\C-c' to exit, ',h' for help)";
734 backtrace
=> \
&Sepia
::debug_backtrace
,
735 inspect
=> \
&Sepia
::debug_inspect
,
736 eval => \
&Sepia
::debug_upeval
,
737 return => \
&Sepia
::debug_return
,
738 help
=> \
&Sepia
::debug_help
,
740 local *CORE
::GLOBAL
::die = sub {
743 local $dies = $dies+1;
744 local $PS1 = "*$dies*> ";
746 local %Sepia::REPL
= (
747 %dhooks, die => sub { local $Sepia::STOPDIE
=0; die @dieargs });
748 local %Sepia::RK
= abbrev
keys %Sepia::REPL
;
749 print "@_\nDied $MSG\n";
750 return Sepia
::repl
($fh, 1);
755 local *CORE
::GLOBAL
::warn = sub {
757 local $dies = $dies+1;
758 local $PS1 = "*$dies*> ";
760 local %Sepia::REPL
= (
761 %dhooks, warn => sub { local $Sepia::STOPWARN
=0; warn @dieargs });
762 local %Sepia::RK
= abbrev
keys %Sepia::REPL
;
763 print "@_\nWarned $MSG\n";
764 return Sepia
::repl
($fh, 1);
770 my @sigs = qw(INT TERM PIPE ALRM);
772 $SIG{$_} = $nextrepl for @sigs;
773 repl
: while (my $in = <$fh>) {
782 if ($buf =~ /^<<(\d+)\n(.*)/) {
787 while ($len && defined($tmp = read $fh, $buf, $len, length $buf)) {
792 local $SIG{__WARN__
} = sub {
795 if ($buf =~ /^,(\S+)\s*(.*)/s) {
796 ## Inspector shortcuts
797 if (exists $Sepia::RK
{$1}) {
801 ($ret, @res) = $Sepia::REPL
{$Sepia::RK
{$1}}->($arg, wantarray);
803 return wantarray ?
@res : $res[0];
806 print "Unrecignized shortcut '$1'\n";
813 @res = repl_eval
$buf, wantarray;
816 if ($@
=~ /at EOF$/m) {
817 ## Possibly-incomplete line
819 print "*** cancel ***\n", prompt
;
828 Sepia
::printer \
@res, $iseval, wantarray if $iseval;
833 ## Be quiet if it ends with a semicolon.
834 Sepia
::printer \
@res, $iseval, wantarray;
840 print ';;;'.length($tmp)."\n$tmp\n";
851 tolisp
(repl_eval
(shift));