package Sepia;
=head1 NAME
Sepia - Simple Emacs-Perl Interface
=head1 SYNOPSIS
From inside Emacs:
M-x load-library RET sepia RET
M-x sepia-repl RET
At the prompt in the C<*sepia-repl*> buffer:
main @> ,help
For more information, please see F<Sepia.html> or F<sepia.info>, which
come with the distribution.
=head1 DESCRIPTION
Sepia is a set of features to make Emacs a better tool for Perl
development. This package contains the Perl side of the
implementation, including all user-serviceable parts (for the
cross-referencing facility see L<Sepia::Xref>). This document is
aimed as Sepia developers; for user documentation, see
L<Sepia.html> or L<sepia.info>.
Though not intended to be used independent of the Emacs interface, the
Sepia module's functionality can be used through a rough procedural
interface.
=cut
$VERSION = '0.992_01';
BEGIN {
if ($] >= 5.012) {
eval 'no warnings "deprecated"'; # undo some of the 5.12 suck.
}
# Not as useful as I had hoped...
sub track_requires
{
my $parent = caller;
(my $child = $_[1]) =~ s!/!::!g;
$child =~ s/\.pm$//;
push @{$REQUIRED_BY{$child}}, $parent;
push @{$REQUIRES{$parent}}, $child;
}
BEGIN { sub TRACK_REQUIRES () { $ENV{TRACK_REQUIRES}||0 } };
unshift @INC, \&Sepia::track_requires if TRACK_REQUIRES;
}
use strict;
use B;
use Sepia::Debug; # THIS TURNS ON DEBUGGING INFORMATION!
use Cwd 'abs_path';
use Scalar::Util 'looks_like_number';
use Text::Abbrev;
use File::Find;
use Storable qw(store retrieve);
use vars qw($PS1 %REPL %RK %REPL_DOC %REPL_SHORT %PRINTER
@res $REPL_LEVEL $REPL_QUIT $PACKAGE $SIGGED
$WANTARRAY $PRINTER $STRICT $COLUMNATE $ISEVAL $STRINGIFY
$LAST_INPUT $READLINE @PRE_EVAL @POST_EVAL @PRE_PROMPT
%REQUIRED_BY %REQUIRES);
BEGIN {
eval q{ use List::Util 'max' };
if ($@) {
*Sepia::max = sub {
my $ret = shift;
for (@_) {
$ret = $_ if $_ > $ret;
}
$ret;
};
}
}
=head2 Hooks
Like Emacs, Sepia's behavior can be modified by placing functions on
various hooks (arrays). Hooks can be manipulated by the following
functions:
=over
=item C<add_hook(@hook, @functions)> -- Add C<@functions> to C<@hook>.
=item C<remove_hook(@hook, @functions)> -- Remove named C<@functions> from C<@hook>.
=item C<run_hook(@hook)> -- Run the functions on the named hook.
Each function is called with no arguments in an eval {} block, and
its return value is ignored.
=back
Sepia currently defines the following hooks:
=over
=item C<@PRE_PROMPT> -- Called immediately before the prompt is printed.
=item C<@PRE_EVAL> -- Called immediately before evaluating user input.
=item C<@POST_EVAL> -- Called immediately after evaluating user input.
=back
=cut
sub run_hook(\@)
{
my $hook = shift;
no strict 'refs';
for (@$hook) {
eval { $_->() };
}
}
sub add_hook(\@@)
{
my $hook = shift;
for my $h (@_) {
push @$hook, $h unless grep $h eq $_, @$hook;
}
}
sub remove_hook(\@@)
{
my $hook = shift;
@$hook = grep { my $x = $_; !grep $_ eq $x, @$hook } @$hook;
}
=head2 Completion
Sepia tries hard to come up with a list of completions.
=over
=item C<$re = _apropos_re($pat)>
Create a completion expression from user input.
=cut
sub _apropos_re($;$)
{
# Do that crazy multi-word identifier completion thing:
my $re = shift;
my $hat = shift() ? '' : '^';
return qr/.*/ if $re eq '';
if (wantarray) {
map {
s/(?:^|(?<=[A-Za-z\d]))(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
qr/$hat$_/;
} split /:+/, $re, -1;
} else {
if ($re !~ /[^\w\d_^:]/) {
$re =~ s/(?<=[A-Za-z\d])(([^A-Za-z\d])\2*)/[A-Za-z\\d]*$2+/g;
}
qr/$re/;
}
}
my %sigil;
BEGIN {
%sigil = qw(ARRAY @ SCALAR $ HASH %);
}
=item C<$val = filter_untyped>
Return true if C<$_> is the name of a sub, file handle, or package.
=item C<$val = filter_typed $type>
Return true if C<$_> is the name of something of C<$type>, which
should be either a glob slot name (e.g. SCALAR) or the special value
"VARIABLE", meaning an array, hash, or scalar.
=cut
sub filter_untyped
{
no strict;
local $_ = /^::/ ? $_ : "::$_";
defined *{$_}{CODE} || defined *{$_}{IO} || (/::$/ && %$_);
}
## XXX: Careful about autovivification here! Specifically:
## defined *FOO{HASH} # => ''
## defined %FOO # => ''
## defined *FOO{HASH} # => 1
sub filter_typed
{
no strict;
my $type = shift;
local $_ = /^::/ ? $_ : "::$_";
if ($type eq 'SCALAR') {
defined $$_;
} elsif ($type eq 'VARIABLE') {
defined $$_ || defined *{$_}{HASH} || defined *{$_}{ARRAY};
} else {
defined *{$_}{$type}
}
}
=item C<$re_out = maybe_icase $re_in>
Make C<$re_in> case-insensitive if it looks like it should be.
=cut
sub maybe_icase
{
my $ch = shift;
return '' if $ch eq '';
$ch =~ /[A-Z]/ ? $ch : '['.uc($ch).$ch.']';
}
=item C<@res = all_abbrev_completions $pattern>
Find all "abbreviated completions" for $pattern.
=cut
sub all_abbrev_completions
{
use vars '&_completions';
local *_completions = sub {
no strict;
my ($stash, @e) = @_;
my $ch = '[A-Za-z0-9]*';
my $re1 = "^".maybe_icase($e[0]).$ch.join('', map {
'_'.maybe_icase($_).$ch
} @e[1..$#e]);
$re1 = qr/$re1/;
my $re2 = maybe_icase $e[0];
$re2 = qr/^$re2.*::$/;
my @ret = grep !/::$/ && /$re1/, keys %{$stash};
my @pkgs = grep /$re2/, keys %{$stash};
(map("$stash$_", @ret),
@e > 1 ? map { _completions "$stash$_", @e[1..$#e] } @pkgs :
map { "$stash$_" } @pkgs)
};
map { s/^:://; $_ } _completions('::', split //, shift);
}
sub apropos_re
{
my ($icase, $re) = @_;
$re =~ s/_/[^_]*_/g;
$icase ? qr/^$re.*$/i : qr/^$re.*$/;
}
sub all_completions
{
my $icase = $_[0] !~ /[A-Z]/;
my @parts = split /:+/, shift, -1;
my $re = apropos_re $icase, pop @parts;
use vars '&_completions';
local *_completions = sub {
no strict;
my $stash = shift;
if (@_ == 0) {
map { "$stash$_" } grep /$re/, keys %{$stash};
} else {
my $re2 = $icase ? qr/^$_[0].*::$/i : qr/^$_[0].*::$/;
my @pkgs = grep /$re2/, keys %{$stash};
map { _completions "$stash$_", @_[1..$#_] } @pkgs
}
};
map { s/^:://; $_ } _completions('::', @parts);
}
=item C<@res = filter_exact_prefix @names>
Filter exact matches so that e.g. "A::x" completes to "A::xx" when
both "Ay::xx" and "A::xx" exist.
=cut
sub filter_exact_prefix
{
my @parts = split /:+/, shift, -1;
my @res = @_;
my @tmp;
my $pre = shift @parts;
while (@parts && (@tmp = grep /^\Q$pre\E(?:::|$)/, @res)) {
@res = @tmp;
$pre .= '::'.shift @parts;
}
@res;
}
=item C<@res = lexical_completions $type, $str, $sub>
Find lexicals of C<$sub> (or a parent lexical environment) of type
C<$type> matching C<$str>.
=cut
sub lexical_completions
{
eval q{ use PadWalker 'peek_sub' };
# "internal" function, so don't warn on failure
return if $@;
*lexical_completions = sub {
my ($type, $str, $sub) = @_;
$sub = "$PACKAGE\::$sub" unless $sub =~ /::/;
# warn "Completing $str of type $type in $sub\n";
no strict;
return unless defined *{$sub}{CODE};
my $pad = peek_sub(\&$sub);
if ($type) {
map { s/^[\$\@&\%]//;$_ } grep /^\Q$type$str\E/, keys %$pad;
} else {
map { s/^[\$\@&\%]//;$_ } grep /^.\Q$str\E/, keys %$pad;
}
};
goto &lexical_completions;
}
=item C<@compls = completions($string [, $type [, $sub ] ])>
Find a list of completions for C<$string> with glob type C<$type>,
which may be "SCALAR", "HASH", "ARRAY", "CODE", "IO", or the special
value "VARIABLE", which means either scalar, hash, or array.
Completion operates on word subparts separated by [:_], so
e.g. "S:m_w" completes to "Sepia::my_walksymtable". If C<$sub> is
given, also consider its lexical variables.
=item C<@compls = method_completions($expr, $string [,$eval])>
Complete among methods on the object returned by C<$expr>. The
C<$eval> argument, if present, is a function used to do the
evaluation; the default is C<eval>, but for example the Sepia REPL
uses C<Sepia::repl_eval>. B<Warning>: Since it has to evaluate
C<$expr>, method completion can be extremely problematic. Use with
care.
=cut
sub completions
{
my ($type, $str, $sub) = @_;
my $t;
my %h = qw(@ ARRAY % HASH & CODE * IO $ SCALAR);
my %rh;
@rh{values %h} = keys %h;
$type ||= '';
$t = $type ? $rh{$type} : '';
my @ret;
if ($sub && $type ne '') {
@ret = lexical_completions $t, $str, $sub;
}
if (!@ret) {
@ret = grep {
$type ? filter_typed $type : filter_untyped
} all_completions $str;
}
if (!@ret && $str !~ /:/) {
@ret = grep {
$type ? filter_typed $type : filter_untyped
} all_abbrev_completions $str;
}
@ret = map { s/^:://; "$t$_" } filter_exact_prefix $str, @ret;
# ## XXX: Control characters, $", and $1, etc. confuse Emacs, so
# ## remove them.
grep {
length $_ > 0 && !/^\d+$/ && !/^[^\w\d_]$/ && !/^_</ && !/^[[:cntrl:]]/
} @ret;
}
sub method_completions
{
my ($x, $fn, $eval) = @_;
$x =~ s/^\s+//;
$x =~ s/\s+$//;
$eval ||= 'CORE::eval';
no strict;
return unless ($x =~ /^\$/ && ($x = $eval->("ref($x)")))
|| $eval->('%'.$x.'::');
unless ($@) {
my $re = _apropos_re $fn;
## Filter out overload methods "(..."
return sort { $a cmp $b } map { s/.*:://; $_ }
grep { defined *{$_}{CODE} && /::$re/ && !/\(/ }
methods($x, 1);
}
}
=item C<@matches = apropos($name [, $is_regex])>
Search for function C<$name>, either in all packages or, if C<$name>
is qualified, only in one package. If C<$is_regex> is true, the
non-package part of C<$name> is a regular expression.
=cut
sub my_walksymtable(&*)
{
no strict;
my ($f, $st) = @_;
local *_walk = sub {
local ($stash) = @_;
&$f for keys %$stash;
_walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
};
_walk($st);
}
sub apropos
{
my ($it, $re, @types) = @_;
my $stashp;
if (@types) {
$stashp = grep /STASH/, @types;
@types = grep !/STASH/, @types;
} else {
@types = qw(CODE);
}
no strict;
if ($it =~ /^(.*::)([^:]+)$/) {
my ($stash, $name) = ($1, $2);
if (!%$stash) {
return;
}
if ($re) {
my $name = qr/^$name/;
map {
"$stash$_"
}
grep {
my $stashnm = "$stash$_";
/$name/ &&
(($stashp && /::$/)
|| scalar grep {
defined($_ eq 'SCALAR' ? $$stashnm : *{$stashnm}{$_})
} @types)
} keys %$stash;
} else {
defined &$it ? $it : ();
}
} else {
my @ret;
my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
my_walksymtable {
push @ret, "$stash$_" if /$findre/;
} '::';
map { s/^:*(?:main:+)*//;$_ } @ret;
}
}
=back
=head2 Module information
=over
=item C<@names = mod_subs($pack)>
Find subs in package C<$pack>.
=cut
sub mod_subs
{
no strict;
my $p = shift;
my $stash = \%{"$p\::"};
if (%$stash) {
grep { defined &{"$p\::$_"} } keys %$stash;
}
}
=item C<@decls = mod_decls($pack)>
Generate a list of declarations for all subroutines in package
C<$pack>.
=cut
sub mod_decls
{
my $pack = shift;
no strict 'refs';
my @ret = map {
my $sn = $_;
my $proto = prototype(\&{"$pack\::$sn"});
$proto = defined($proto) ? "($proto)" : '';
"sub $sn $proto;";
} mod_subs($pack);
return wantarray ? @ret : join '', @ret;
}
=item C<$info = module_info($module, $type)>
Emacs-called function to get module information.
=cut
sub module_info
{
eval q{ require Module::Info; import Module::Info };
if ($@) {
undef;
} else {
no warnings;
*module_info = sub {
my ($m, $func) = @_;
my $info;
if (-f $m) {
$info = Module::Info->new_from_file($m);
} else {
(my $file = $m) =~ s|::|/|g;
$file .= '.pm';
if (exists $INC{$file}) {
$info = Module::Info->new_from_loaded($m);
} else {
$info = Module::Info->new_from_module($m);
}
}
if ($info) {
return $info->$func;
}
};
goto &module_info;
}
}
=item C<$file = mod_file($mod)>
Find the likely file owner for module C<$mod>.
=cut
sub mod_file
{
my $m = shift;
$m =~ s/::/\//g;
while ($m && !exists $INC{"$m.pm"}) {
$m =~ s#(?:^|/)[^/]+$##;
}
$m ? $INC{"$m.pm"} : undef;
}
=item C<@mods = package_list>
Gather a list of all distributions on the system.
=cut
our $INST;
sub inst()
{
unless ($INST) {
require ExtUtils::Installed;
$INST = new ExtUtils::Installed;
}
$INST;
}
sub package_list
{
sort { $a cmp $b } inst()->modules;
}
=item C<@mods = module_list>
Gather a list of all packages (.pm files, really) installed on the
system, grouped by distribution. XXX UNUSED
=cut
sub inc_re
{
join '|', map quotemeta, sort { length $b <=> length $a } @INC;
}
sub module_list
{
@_ = package_list unless @_;
my $incre = inc_re;
$incre = qr|(?:$incre)/|;
my $inst = inst;
map {
[$_, sort map {
s/$incre\///; s|/|::|g;$_
} grep /\.pm$/, $inst->files($_)]
} @_;
}
=item C<@paths = file_list $module>
List the absolute paths of all files (except man pages) installed by
C<$module>.
=cut
sub file_list
{
my @ret = eval { grep /\.p(l|m|od)$/, inst->files(shift) };
@ret ? @ret : ();
}
=item C<@mods = doc_list>
Gather a list of all documented packages (.?pm files, really)
installed on the system, grouped by distribution. XXX UNUSED
=back
=cut
sub doc_list
{
@_ = package_list unless @_;
my $inst = inst;
map {
[$_, sort map {
s/.*man.\///; s|/|::|g;s/\..?pm//; $_
} grep /\..pm$/, $inst->files($_)]
} @_;
}
=head2 Miscellaneous functions
=over
=item C<$v = core_version($module)>
=cut
sub core_version
{
eval q{ require Module::CoreList };
if ($@) {
'???';
} else {
*core_version = sub { Module::CoreList->first_release(@_) };
goto &core_version;
}
}
=item C<[$file, $line, $name] = location($name)>
Return a [file, line, name] triple for function C<$name>.
=cut
sub location
{
no strict;
map {
if (my ($pfx, $name) = /^([\%\$\@]?)(.+)/) {
if ($pfx) {
warn "Sorry -- can't lookup variables.";
} else {
# XXX: svref_2object only seems to work with a package
# tacked on, but that should probably be done elsewhere...
$name = 'main::'.$name unless $name =~ /::/;
my $cv = B::svref_2object(\&{$name});
if ($cv && defined($cv = $cv->START) && !$cv->isa('B::NULL')) {
my ($file, $line) = ($cv->file, $cv->line);
if ($file !~ /^\//) {
for (@INC) {
if (!ref $_ && -f "$_/$file") {
$file = "$_/$file";
last;
}
}
}
my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
return [Cwd::abs_path($file), $line, $shortname || $name]
}
}
}
[]
} @_;
}
=item C<lexicals($subname)>
Return a list of C<$subname>'s lexical variables. Note that this
includes all nested scopes -- I don't know if or how Perl
distinguishes inner blocks.
=cut
sub lexicals
{
my $cv = B::svref_2object(\&{+shift});
return unless $cv && ($cv = $cv->PADLIST);
my ($names, $vals) = $cv->ARRAY;
map {
my $name = $_->PV; $name =~ s/\0.*$//; $name
} grep B::class($_) ne 'SPECIAL', $names->ARRAY;
}
=item C<$lisp = tolisp($perl)>
Convert a Perl scalar to some ELisp equivalent.
=cut
sub tolisp($)
{
my $thing = @_ == 1 ? shift : \@_;
my $t = ref $thing;
if (!$t) {
if (!defined $thing) {
'nil'
} elsif (looks_like_number $thing) {
''.(0+$thing);
} else {
## XXX Elisp and perl have slightly different
## escaping conventions, so we do this crap instead.
$thing =~ s/["\\]/\\$1/g;
qq{"$thing"};
}
} elsif ($t eq 'GLOB') {
(my $name = $$thing) =~ s/\*main:://;
$name;
} elsif ($t eq 'ARRAY') {
'(' . join(' ', map { tolisp($_) } @$thing).')'
} elsif ($t eq 'HASH') {
'(' . join(' ', map {
'(' . tolisp($_) . " . " . tolisp($thing->{$_}) . ')'
} keys %$thing).')'
} elsif ($t eq 'Regexp') {
"'(regexp . \"" . quotemeta($thing) . '")';
# } elsif ($t eq 'IO') {
} else {
qq{"$thing"};
}
}
=item C<printer(\@res)>
Print C<@res> appropriately on the current filehandle. If C<$ISEVAL>
is true, use terse format. Otherwise, use human-readable format,
which can use either L<Data::Dumper>, L<YAML>, or L<Data::Dump>.
=cut
%PRINTER = (
dumper => sub {
eval q{ require Data::Dumper };
local $Data::Dumper::Deparse = 1;
local $Data::Dumper::Indent = 0;
local $_;
my $thing = @res > 1 ? \@res : $res[0];
eval {
$_ = Data::Dumper::Dumper($thing);
};
if (length $_ > ($ENV{COLUMNS} || 80)) {
$Data::Dumper::Indent = 1;
eval {
$_ = Data::Dumper::Dumper($thing);
};
}
s/\A\$VAR1 = //;
s/;\Z//;
$_;
},
plain => sub {
"@res";
},
dumpvar => sub {
if (eval q{require 'dumpvar.pl';1}) {
dumpvar::veryCompact(1);
$PRINTER{dumpvar} = sub { dumpValue(\@res) };
goto &{$PRINTER{dumpvar}};
}
},
yaml => sub {
eval q{ require YAML };
if ($@) {
$PRINTER{dumper}->();
} else {
YAML::Dump(\@res);
}
},
dump => sub {
eval q{ require Data::Dump };
if ($@) {
$PRINTER{dumper}->();
} else {
Data::Dump::dump(\@res);
}
},
peek => sub {
eval q{
require Devel::Peek;
require IO::Scalar;
};
if ($@) {
$PRINTER{dumper}->();
} else {
my $ret = new IO::Scalar;
my $out = select $ret;
Devel::Peek::Dump(@res == 1 ? $res[0] : \@res);
select $out;
$ret;
}
}
);
sub ::_()
{
if (wantarray) {
@res
} else {
$_
}
}
sub printer
{
local *res = shift;
my $res;
@_ = @res;
$_ = @res == 1 ? $res[0] : @res == 0 ? undef : [@res];
my $str;
if ($ISEVAL) {
$res = "@res";
} elsif (@res == 1 && !$ISEVAL && $STRINGIFY
&& UNIVERSAL::can($res[0], '()')) {
# overloaded?
$res = "$res[0]";
} elsif (!$ISEVAL && $COLUMNATE && @res > 1 && !grep ref, @res) {
$res = columnate(@res);
print $res;
return;
} else {
$res = $PRINTER{$PRINTER}->();
}
if ($ISEVAL) {
print ';;;', length $res, "\n$res\n";
} else {
print "$res\n";
}
}
BEGIN {
$PS1 = "> ";
$PACKAGE = 'main';
$WANTARRAY = '@';
$PRINTER = 'dumper';
$COLUMNATE = 1;
$STRINGIFY = 1;
}
=item C<prompt()> -- Print the REPL prompt.
=cut
sub prompt()
{
run_hook @PRE_PROMPT;
"$PACKAGE $WANTARRAY$PS1"
}
sub Dump
{
eval {
Data::Dumper->Dump([$_[0]], [$_[1]]);
};
}
=item C<$flowed = flow($width, $text)> -- Flow C<$text> to at most C<$width> columns.
=cut
sub flow
{
my $n = shift;
my $n1 = int(2*$n/3);
local $_ = shift;
s/(.{$n1,$n}) /$1\n/g;
$_
}
=back
=head2 Persistence
=over
=item C<load \@keyvals> -- Load persisted data in C<@keyvals>.
=item C<$ok = saveable $name> -- Return whether C<$name> is saveable.
Saving certain magic variables leads to badness, so we avoid them.
=item C<\@kvs = save $re> -- Return a list of name/value pairs to save.
=back
=cut
sub load
{
my $a = shift;
no strict;
for (@$a) {
*{$_->[0]} = $_->[1];
}
}
my %BADVARS;
undef @BADVARS{qw(%INC @INC %SIG @ISA %ENV @ARGV)};
# magic variables
sub saveable
{
local $_ = shift;
return !/^.[^c-zA-Z]$/ # single-letter stuff (match vars, $_, etc.)
&& !/^.[\0-\060]/ # magic weirdness.
&& !/^._</ # debugger info
&& !exists $BADVARS{$_}; # others.
}
sub save
{
my ($re) = @_;
my @save;
$re = qr/(?:^|::)$re/;
no strict; # no kidding...
my_walksymtable {
return if /::$/
|| $stash =~ /^(?:::)?(?:warnings|Config|strict|B)\b/;
if (/$re/) {
my $name = "$stash$_";
if (defined ${$name} and saveable '$'.$_) {
push @save, [$name, \$$name];
}
if (defined *{$name}{HASH} and saveable '%'.$_) {
push @save, [$name, \%{$name}];
}
if (defined *{$name}{ARRAY} and saveable '@'.$_) {
push @save, [$name, \@{$name}];
}
}
} '::';
print STDERR "$_->[0] " for @save;
print STDERR "\n";
\@save;
}
=head2 REPL shortcuts
The function implementing built-in REPL shortcut ",X" is named C<repl_X>.
=over
=item C<define_shortcut $name, $sub [, $doc [, $shortdoc]]>
Define $name as a shortcut for function $sub.
=cut
sub define_shortcut
{
my ($name, $doc, $short, $fn);
if (@_ == 2) {
($name, $fn) = @_;
$short = $name;
$doc = '';
} elsif (@_ == 3) {
($name, $fn, $doc) = @_;
$short = $name;
} else {
($name, $fn, $short, $doc) = @_;
}
$REPL{$name} = $fn;
$REPL_DOC{$name} = $doc;
$REPL_SHORT{$name} = $short;
abbrev \%RK, keys %REPL;
}
=item C<alias_shortcut $new, $old>
Alias $new to do the same as $old.
=cut
sub alias_shortcut
{
my ($new, $old) = @_;
$REPL{$new} = $REPL{$old};
$REPL_DOC{$new} = $REPL_DOC{$old};
($REPL_SHORT{$new} = $REPL_SHORT{$old}) =~ s/^\Q$old\E/$new/;
abbrev %RK, keys %REPL;
}
=item C<define_shortcuts()>
Define the default REPL shortcuts.
=cut
sub define_shortcuts
{
define_shortcut 'help', \&Sepia::repl_help,
'help [CMD]',
'Display help on all commands, or just CMD.';
define_shortcut 'cd', \&Sepia::repl_chdir,
'cd DIR', 'Change directory to DIR';
define_shortcut 'pwd', \&Sepia::repl_pwd,
'Show current working directory';
define_shortcut 'methods', \&Sepia::repl_methods,
'methods X [RE]',
'List methods for reference or package X, matching optional pattern RE';
define_shortcut 'package', \&Sepia::repl_package,
'package PKG', 'Set evaluation package to PKG';
define_shortcut 'who', \&Sepia::repl_who,
'who PKG [RE]',
'List variables and subs in PKG matching optional pattern RE.';
define_shortcut 'wantarray', \&Sepia::repl_wantarray,
'wantarray [0|1]', 'Set or toggle evaluation context';
define_shortcut 'format', \&Sepia::repl_format,
'format [TYPE]', "Set output formatter to TYPE (one of 'dumper', 'dump', 'yaml', 'plain'; default: 'dumper'), or show current type.";
define_shortcut 'strict', \&Sepia::repl_strict,
'strict [0|1]', 'Turn \'use strict\' mode on or off';
define_shortcut 'quit', \&Sepia::repl_quit,
'Quit the REPL';
alias_shortcut 'exit', 'quit';
define_shortcut 'restart', \&Sepia::repl_restart,
'Reload Sepia.pm and relaunch the REPL.';
define_shortcut 'shell', \&Sepia::repl_shell,
'shell CMD ...', 'Run CMD in the shell';
define_shortcut 'eval', \&Sepia::repl_eval,
'eval EXP', '(internal)';
define_shortcut 'size', \&Sepia::repl_size,
'size PKG [RE]',
'List total sizes of objects in PKG matching optional pattern RE.';
define_shortcut define => \&Sepia::repl_define,
'define NAME [\'DOC\'] BODY',
'Define NAME as a shortcut executing BODY';
define_shortcut undef => \&Sepia::repl_undef,
'undef NAME', 'Undefine shortcut NAME';
define_shortcut test => \&Sepia::repl_test,
'test FILE...', 'Run tests interactively.';
define_shortcut load => \&Sepia::repl_load,
'load [FILE]', 'Load state from FILE.';
define_shortcut save => \&Sepia::repl_save,
'save [PATTERN [FILE]]', 'Save variables matching PATTERN to FILE.';
define_shortcut reload => \&Sepia::repl_reload,
'reload [MODULE | /RE/]', 'Reload MODULE, or all modules matching RE.';
define_shortcut freload => \&Sepia::repl_full_reload,
'freload MODULE', 'Reload MODULE and all its dependencies.';
define_shortcut time => \&Sepia::repl_time,
'time [0|1]', 'Print timing information for each command.';
define_shortcut lsmod => \&Sepia::repl_lsmod,
'lsmod [PATTERN]', 'List loaded modules matching PATTERN.';
}
=item C<repl_strict([$value])>
Toggle strict mode. Requires L<PadWalker> and L<Devel::LexAlias>.
=cut
sub repl_strict
{
eval q{ use PadWalker qw(peek_sub set_closed_over);
use Devel::LexAlias 'lexalias';
};
if ($@) {
print "Strict mode requires PadWalker and Devel::LexAlias.\n";
} else {
*repl_strict = sub {
my $x = as_boolean(shift, $STRICT);
if ($x && !$STRICT) {
$STRICT = {};
} elsif (!$x) {
undef $STRICT;
}
};
goto &repl_strict;
}
}
sub repl_size
{
eval q{ require Devel::Size };
if ($@) {
print "Size requires Devel::Size.\n";
} else {
*Sepia::repl_size = sub {
my ($pkg, $re) = split ' ', shift, 2;
if ($re) {
$re =~ s!^/|/$!!g;
} elsif (!$re && $pkg =~ /^\/(.*?)\/?$/) {
$re = $1;
undef $pkg;
} elsif (!$pkg) {
$re = '.';
}
my (@who, %res);
if ($STRICT && !$pkg) {
@who = grep /$re/, keys %$STRICT;
for (@who) {
$res{$_} = Devel::Size::total_size($Sepia::STRICT->{$_});
}
} else {
no strict 'refs';
$pkg ||= 'main';
@who = who($pkg, $re);
for (@who) {
next unless /^[\$\@\%\&]/; # skip subs.
next if $_ eq '%SIG';
$res{$_} = eval "no strict; package $pkg; Devel::Size::total_size \\$_;";
}
}
my $len = max(3, map { length } @who) + 4;
my $fmt = '%-'.$len."s%10d\n";
# print "$pkg\::/$re/\n";
print 'Var', ' ' x ($len + 2), "Bytes\n";
print '-' x ($len-4), ' ' x 9, '-' x 5, "\n";
for (sort { $res{$b} <=> $res{$a} } keys %res) {
printf $fmt, $_, $res{$_};
}
};
goto &repl_size;
}
}
=item C<repl_time([$value])>
Toggle command timing.
=cut
my ($time_res, $TIME);
sub time_pre_prompt_bsd
{
printf "(%.2gr, %.2gu, %.2gs) ", @{$time_res} if defined $time_res;
};
sub time_pre_prompt_plain
{
printf "(%.2gs) ", $time_res if defined $time_res;
}
sub repl_time
{
$TIME = as_boolean(shift, $TIME);
if (!$TIME) {
print STDERR "Removing time hook.\n";
remove_hook @PRE_PROMPT, 'Sepia::time_pre_prompt';
remove_hook @PRE_EVAL, 'Sepia::time_pre_eval';
remove_hook @POST_EVAL, 'Sepia::time_post_eval';
return;
}
print STDERR "Adding time hook.\n";
add_hook @PRE_PROMPT, 'Sepia::time_pre_prompt';
add_hook @PRE_EVAL, 'Sepia::time_pre_eval';
add_hook @POST_EVAL, 'Sepia::time_post_eval';
my $has_bsd = eval q{ use BSD::Resource 'getrusage';1 };
my $has_hires = eval q{ use Time::HiRes qw(gettimeofday tv_interval);1 };
my ($t0);
if ($has_bsd) { # sweet! getrusage!
my ($user, $sys, $real);
*time_pre_eval = sub {
undef $time_res;
($user, $sys) = getrusage();
$real = $has_hires ? [gettimeofday()] : $user+$sys;
};
*time_post_eval = sub {
my ($u2, $s2) = getrusage();
$time_res = [$has_hires ? tv_interval($real, [gettimeofday()])
: $s2 + $u2 - $real,
($u2 - $user), ($s2 - $sys)];
};
*time_pre_prompt = *time_pre_prompt_bsd;
} elsif ($has_hires) { # at least we have msec...
*time_pre_eval = sub {
undef $time_res;
$t0 = [gettimeofday()];
};
*time_post_eval = sub {
$time_res = tv_interval($t0, [gettimeofday()]);
};
*time_pre_prompt = *time_pre_prompt_plain;
} else {
*time_pre_eval = sub {
undef $time_res;
$t0 = time;
};
*time_post_eval = sub {
$time_res = (time - $t0);
};
*time_pre_prompt = *time_pre_prompt_plain;
}
}
sub repl_help
{
my $width = $ENV{COLUMNS} || 80;
my $args = shift;
if ($args =~ /\S/) {
$args =~ s/^\s+//;
$args =~ s/\s+$//;
my $full = $RK{$args};
if ($full) {
my $short = $REPL_SHORT{$full};
my $flow = flow($width - length $short - 4, $REPL_DOC{$full});
$flow =~ s/(.)\n/"$1\n".(' 'x (4 + length $short))/eg;
print "$short $flow\n";
} else {
print "$args: no such command\n";
}
} else {
my $left = 1 + max map length, values %REPL_SHORT;
print "REPL commands (prefixed with ','):\n";
for (sort keys %REPL) {
my $flow = flow($width - $left, $REPL_DOC{$_});
$flow =~ s/(.)\n/"$1\n".(' ' x $left)/eg;
printf "%-${left}s%s\n", $REPL_SHORT{$_}, $flow;
}
}
}
sub repl_define
{
local $_ = shift;
my ($name, $doc, $body);
if (/^\s*(\S+)\s+'((?:[^'\\]|\\.)*)'\s+(.+)/) {
($name, $doc, $body) = ($1, $2, $3);
} elsif (/^\s*(\S+)\s+(\S.*)/) {
($name, $doc, $body) = ($1, $2, $2);
} else {
print "usage: define NAME ['doc'] BODY...\n";
return;
}
my $sub = eval "sub { do { $body } }";
if ($@) {
print "usage: define NAME ['doc'] BODY...\n\t$@\n";
return;
}
define_shortcut $name, $sub, $doc;
# %RK = abbrev keys %REPL;
}
sub repl_undef
{
my $name = shift;
$name =~ s/^\s*//;
$name =~ s/\s*$//;
my $full = $RK{$name};
if ($full) {
delete $REPL{$full};
delete $REPL_SHORT{$full};
delete $REPL_DOC{$full};
abbrev \%RK, keys %REPL;
} else {
print "$name: no such shortcut.\n";
}
}
sub repl_format
{
my $t = shift;
chomp $t;
if ($t eq '') {
print "printer = $PRINTER, columnate = @{[$COLUMNATE ? 1 : 0]}\n";
} else {
my %formats = abbrev keys %PRINTER;
if (exists $formats{$t}) {
$PRINTER = $formats{$t};
} else {
warn "No such format '$t' (dumper, dump, yaml, plain).\n";
}
}
}
sub repl_chdir
{
chomp(my $dir = shift);
$dir =~ s/^~\//$ENV{HOME}\//;
$dir =~ s/\$HOME/$ENV{HOME}/;
if (-d $dir) {
chdir $dir;
my $ecmd = '(cd "'.Cwd::getcwd().'")';
print ";;;###".length($ecmd)."\n$ecmd\n";
} else {
warn "Can't chdir\n";
}
}
sub repl_pwd
{
print Cwd::getcwd(), "\n";
}
=item C<who($package [, $re])>
List variables and functions in C<$package> matching C<$re>, or all
variables if C<$re> is absent.
=cut
sub who
{
my ($pack, $re_str) = @_;
$re_str ||= '.?';
my $re = qr/$re_str/;
no strict;
if ($re_str =~ /^[\$\@\%\&]/) {
## sigil given -- match it
sort grep /$re/, map {
my $name = $pack.'::'.$_;
(defined *{$name}{HASH} ? '%'.$_ : (),
defined *{$name}{ARRAY} ? '@'.$_ : (),
defined *{$name}{CODE} ? $_ : (),
defined ${$name} ? '$'.$_ : (), # ?
)
} grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
} else {
## no sigil -- don't match it
sort map {
my $name = $pack.'::'.$_;
(defined *{$name}{HASH} ? '%'.$_ : (),
defined *{$name}{ARRAY} ? '@'.$_ : (),
defined *{$name}{CODE} ? $_ : (),
defined ${$name} ? '$'.$_ : (), # ?
)
} grep !/::$/ && !/^(?:_<|[^\w])/ && /$re/, keys %{$pack.'::'};
}
}
=item C<$text = columnate(@items)>
Format C<@items> in columns such that they fit within C<$ENV{COLUMNS}>
columns.
=cut
sub columnate
{
my $len = 0;
my $width = $ENV{COLUMNS} || 80;
for (@_) {
$len = length if $len < length;
}
my $nc = int($width / ($len+1)) || 1;
my $nr = int(@_ / $nc) + (@_ % $nc ? 1 : 0);
my $fmt = ('%-'.($len+1).'s') x ($nc-1) . "%s\n";
my @incs = map { $_ * $nr } 0..$nc-1;
my $str = '';
for my $r (0..$nr-1) {
$str .= sprintf $fmt, map { defined($_) ? $_ : '' }
@_[map { $r + $_ } @incs];
}
$str =~ s/ +$//m;
$str
}
sub repl_who
{
my ($pkg, $re) = split ' ', shift, 2;
if ($re) {
$re =~ s!^/|/$!!g;
} elsif (!$re && $pkg =~ /^\/(.*?)\/?$/) {
$re = $1;
undef $pkg;
} elsif (!$pkg) {
$re = '.';
}
my @x;
if ($STRICT && !$pkg) {
@x = grep /$re/, keys %$STRICT;
$pkg = '(lexical)';
} else {
$pkg ||= $PACKAGE;
@x = who($pkg, $re);
}
print($pkg, "::/$re/\n", columnate @x) if @x;
}
=item C<@m = methods($package [, $qualified])>
List method names in C<$package> and its parents. If C<$qualified>,
return full "CLASS::NAME" rather than just "NAME."
=cut
sub methods
{
my ($pack, $qualified) = @_;
no strict;
my @own = $qualified ? grep {
defined *{$_}{CODE}
} map { "$pack\::$_" } keys %{$pack.'::'}
: grep {
defined &{"$pack\::$_"}
} keys %{$pack.'::'};
if (exists ${$pack.'::'}{ISA} && *{$pack.'::ISA'}{ARRAY}) {
my %m;
undef @m{@own, map methods($_, $qualified), @{$pack.'::ISA'}};
@own = keys %m;
}
@own;
}
sub repl_methods
{
my ($x, $re) = split ' ', shift;
$x =~ s/^\s+//;
$x =~ s/\s+$//;
if ($x =~ /^\$/) {
$x = $REPL{eval}->("ref $x");
return 0 if $@;
}
$re ||= '.?';
$re = qr/$re/;
print columnate sort { $a cmp $b } grep /$re/, methods $x;
}
sub as_boolean
{
my ($val, $cur) = @_;
$val =~ s/\s+//g;
length($val) ? $val : !$cur;
}
sub repl_wantarray
{
$WANTARRAY = shift || $WANTARRAY;
$WANTARRAY = '' unless $WANTARRAY eq '@' || $WANTARRAY eq '$';
}
sub repl_package
{
chomp(my $p = shift);
$PACKAGE = $p;
}
sub repl_quit
{
$REPL_QUIT = 1;
last repl;
}
sub repl_restart
{
do $INC{'Sepia.pm'};
if ($@) {
print "Restart failed:\n$@\n";
} else {
$REPL_LEVEL = 0; # ok?
goto &Sepia::repl;
}
}
sub repl_shell
{
my $cmd = shift;
print `$cmd 2>& 1`;
}
# Stolen from Lexical::Persistence, then simplified.
sub call_strict
{
my ($sub) = @_;
# steal any new "my" variables
my $pad = peek_sub($sub);
for my $k (keys %$pad) {
unless (exists $STRICT->{$k}) {
if ($k =~ /^\$/) {
$STRICT->{$k} = \(my $x);
} elsif ($k =~ /^\@/) {
$STRICT->{$k} = []
} elsif ($k =~ /^\%/) {
$STRICT->{$k} = +{};
}
}
}
# Grab its lexials
lexalias($sub, $_, $STRICT->{$_}) for keys %$STRICT;
$sub->();
}
sub repl_eval
{
my ($buf) = @_;
no strict;
# local $PACKAGE = $pkg || $PACKAGE;
if ($STRICT) {
my $ctx = join(',', keys %$STRICT);
$ctx = $ctx ? "my ($ctx);" : '';
if ($WANTARRAY eq '$') {
$buf = 'scalar($buf)';
} elsif ($WANTARRAY ne '@') {
$buf = '$buf;1';
}
$buf = eval "sub { package $PACKAGE; use strict; $ctx $buf }";
if ($@) {
print "ERROR\n$@\n";
return;
}
call_strict($buf);
} else {
$buf = "do { package $PACKAGE; no strict; $buf }";
if ($WANTARRAY eq '@') {
eval $buf;
} elsif ($WANTARRAY eq '$') {
scalar eval $buf;
} else {
eval $buf; undef
}
}
}
sub repl_test
{
my ($buf) = @_;
my @files;
if ($buf =~ /\S/) {
$buf =~ s/^\s+//;
$buf =~ s/\s+$//;
if (-f $buf) {
push @files, $buf;
} elsif (-f "t/$buf") {
push @files, $buf;
}
} else {
find({ no_chdir => 1,
wanted => sub {
push @files, $_ if /\.t$/;
}}, Cwd::getcwd() =~ /t\/?$/ ? '.' : './t');
}
if (@files) {
# XXX: this is cribbed from an EU::MM-generated Makefile.
system $^X, qw(-MExtUtils::Command::MM -e),
"test_harness(0, 'blib/lib', 'blib/arch')", @files;
} else {
print "No test files for '$buf' in ", Cwd::getcwd, "\n";
}
}
sub repl_load
{
my ($file) = split ' ', shift;
$file ||= "$ENV{HOME}/.sepia-save";
load(retrieve $file);
}
sub repl_save
{
my ($re, $file) = split ' ', shift;
$re ||= '.';
$file ||= "$ENV{HOME}/.sepia-save";
store save($re), $file;
}
sub modules_matching
{
my $pat = shift;
if ($pat =~ /^\/(.*)\/?$/) {
$pat = $1;
$pat =~ s#::#/#g;
$pat = qr/$pat/;
grep /$pat/, keys %INC;
} else {
my $mod = $pat;
$pat =~ s#::#/#g;
exists $INC{"$pat.pm"} ? "$pat.pm" : ();
}
}
sub full_reload
{
my %save_inc = %INC;
local %INC;
for my $name (modules_matching $_[0]) {
print STDERR "full reload $name\n";
require $name;
}
my @ret = keys %INC;
while (my ($k, $v) = each %save_inc) {
$INC{$k} ||= $v;
}
@ret;
}
sub repl_full_reload
{
chomp (my $pat = shift);
my @x = full_reload $pat;
print "Reloaded: @x\n";
}
sub repl_reload
{
chomp (my $pat = shift);
# for my $name (modules_matching $pat) {
# delete $INC{$PAT};
# eval "require $name";
# if (!$@) {
# (my $mod = $name) =~ s/
if ($pat =~ /^\/(.*)\/?$/) {
$pat = $1;
$pat =~ s#::#/#g;
$pat = qr/$pat/;
my @rel;
for (keys %INC) {
next unless /$pat/;
if (!do $_) {
print "$_: $@\n";
}
s#/#::#g;
s/\.pm$//;
push @rel, $_;
}
} else {
my $mod = $pat;
$pat =~ s#::#/#g;
$pat .= '.pm';
if (exists $INC{$pat}) {
delete $INC{$pat};
eval 'require $mod';
import $mod unless $@;
print "Reloaded $mod.\n"
} else {
print "$mod not loaded.\n"
}
}
}
sub repl_lsmod
{
chomp (my $pat = shift);
$pat ||= '.';
$pat = qr/$pat/;
my $first = 1;
my $fmt = "%-20s%8s %s\n";
# my $shorten = join '|', sort { length($a) <=> length($b) } @INC;
# my $ss = sub {
# s/^(?:$shorten)\/?//; $_
# };
for (sort keys %INC) {
my $file = $_;
s!/!::!g;
s/\.p[lm]$//;
next if /^::/ || !/$pat/;
if ($first) {
printf $fmt, qw(Module Version File);
printf $fmt, qw(------ ------- ----);
$first = 0;
}
printf $fmt, $_, (UNIVERSAL::VERSION($_)||'???'), $INC{$file};
}
if ($first) {
print "No modules found.\n";
}
}
=item C<sig_warn($warning)>
Collect C<$warning> for later printing.
=item C<print_warnings()>
Print and clear accumulated warnings.
=cut
my @warn;
sub sig_warn
{
push @warn, shift
}
sub print_warnings
{
if (@warn) {
if ($ISEVAL) {
my $tmp = "@warn";
print ';;;'.length($tmp)."\n$tmp\n";
} else {
for (@warn) {
# s/(.*) at .*/$1/;
print "warning: $_\n";
}
}
}
}
sub repl_banner
{
print <<EOS;
I need user feedback! Please send questions or comments to seano\@cpan.org.
Sepia version $Sepia::VERSION.
Type ",h" for help, or ",q" to quit.
EOS
}
=item C<repl()>
Execute a command interpreter on standard input and standard output.
If you want to use different descriptors, localize them before
calling C<repl()>. The prompt has a few bells and whistles, including:
=over 4
=item Obviously-incomplete lines are treated as multiline input (press
'return' twice or 'C-c' to discard).
=item C<die> is overridden to enter a debugging repl at the point
C<die> is called.
=back
Behavior is controlled in part through the following package-globals:
=over 4
=item C<$PACKAGE> -- evaluation package
=item C<$PRINTER> -- result printer (default: dumper)
=item C<$PS1> -- the default prompt
=item C<$STRICT> -- whether 'use strict' is applied to input
=item C<$WANTARRAY> -- evaluation context
=item C<$COLUMNATE> -- format some output nicely (default = 1)
Format some values nicely, independent of $PRINTER. Currently, this
displays arrays of scalars as columns.
=item C<$REPL_LEVEL> -- level of recursive repl() calls
If zero, then initialization takes place.
=item C<%REPL> -- maps shortcut names to handlers
=item C<%REPL_DOC> -- maps shortcut names to documentation
=item C<%REPL_SHORT> -- maps shortcut names to brief usage
=back
=back
=cut
sub repl_setup
{
$| = 1;
if ($REPL_LEVEL == 0) {
define_shortcuts;
-f "$ENV{HOME}/.sepiarc" and eval qq#package $Sepia::PACKAGE; do "$ENV{HOME}/.sepiarc"#;
warn ".sepiarc: $@\n" if $@;
}
Sepia::Debug::add_repl_commands;
repl_banner if $REPL_LEVEL == 0;
}
$READLINE = sub { print prompt(); <STDIN> };
sub repl
{
repl_setup;
local $REPL_LEVEL = $REPL_LEVEL + 1;
my $in;
my $buf = '';
$SIGGED = 0;
my $nextrepl = sub { $SIGGED++; };
local (@_, $_);
local *CORE::GLOBAL::die = \&Sepia::Debug::die;
local *CORE::GLOBAL::warn = \&Sepia::Debug::warn;
my @sigs = qw(INT TERM PIPE ALRM);
local @SIG{@sigs};
$SIG{$_} = $nextrepl for @sigs;
repl: while (defined(my $in = $READLINE->())) {
if ($SIGGED) {
$buf = '';
$SIGGED = 0;
print "\n";
next repl;
}
$buf .= $in;
$buf =~ s/^\s*//;
local $ISEVAL;
if ($buf =~ /^<<(\d+)\n(.*)/) {
$ISEVAL = 1;
my $len = $1;
my $tmp;
$buf = $2;
while ($len && defined($tmp = read STDIN, $buf, $len, length $buf)) {
$len -= $tmp;
}
}
## Only install a magic handler if no one else is playing.
local $SIG{__WARN__} = $SIG{__WARN__};
@warn = ();
unless ($SIG{__WARN__}) {
$SIG{__WARN__} = 'Sepia::sig_warn';
}
if (!$ISEVAL) {
if ($buf eq '') {
# repeat last interactive command
$buf = $LAST_INPUT;
} else {
$LAST_INPUT = $buf;
}
}
if ($buf =~ /^,(\S+)\s*(.*)/s) {
## Inspector shortcuts
my $short = $1;
if (exists $Sepia::RK{$short}) {
my $ret;
my $arg = $2;
chomp $arg;
$Sepia::REPL{$Sepia::RK{$short}}->($arg, wantarray);
} else {
if (grep /^$short/, keys %Sepia::REPL) {
print "Ambiguous shortcut '$short': ",
join(', ', sort grep /^$short/, keys %Sepia::REPL),
"\n";
} else {
print "Unrecognized shortcut '$short'\n";
}
$buf = '';
next repl;
}
} else {
## Ordinary eval
run_hook @PRE_EVAL;
@res = $REPL{eval}->($buf);
run_hook @POST_EVAL;
if ($@) {
if ($ISEVAL) {
## Always return results for an eval request
Sepia::printer \@res, wantarray;
Sepia::printer [$@], wantarray;
# print_warnings $ISEVAL;
$buf = '';
} elsif ($@ =~ /(?:at|before) EOF(?:$| at)/m) {
## Possibly-incomplete line
if ($in eq "\n") {
print "Error:\n$@\n*** cancel ***\n";
$buf = '';
} else {
print ">> ";
}
} else {
print_warnings;
# $@ =~ s/(.*) at eval .*/$1/;
# don't complain if we're abandoning execution
# from the debugger.
unless (ref $@ eq 'Sepia::Debug') {
print "error: $@";
print "\n" unless $@ =~ /\n\z/;
}
$buf = '';
}
next repl;
}
}
if ($buf !~ /;\s*$/ && $buf !~ /^,/) {
## Be quiet if it ends with a semicolon, or if we
## executed a shortcut.
Sepia::printer \@res, wantarray;
}
$buf = '';
print_warnings;
}
exit if $REPL_QUIT;
wantarray ? @res : $res[0]
}
sub perl_eval
{
tolisp($REPL{eval}->(shift));
}
=head2 Module browsing
=over
=item C<$status = html_module_list([$file [, $prefix]])>
Generate an HTML list of installed modules, looking inside of
packages. If C<$prefix> is missing, uses "about://perldoc/". If
$file is given, write the result to $file; otherwise, return it as a
string.
=item C<$status = html_package_list([$file [, $prefix]])>
Generate an HTML list of installed top-level modules, without looking
inside of packages. If C<$prefix> is missing, uses
"about://perldoc/". $file is the same as for C<html_module_list>.
=back
=cut
sub html_module_list
{
my ($file, $base) = @_;
$base ||= 'about://perldoc/';
my $inst = inst();
return unless $inst;
my $out;
open OUT, ">", $file || \$out or return;
print OUT "<html><body>";
my $pfx = '';
my %ns;
for (package_list) {
push @{$ns{$1}}, $_ if /^([^:]+)/;
}
# Handle core modules.
my %fs;
undef $fs{$_} for map {
s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
} grep {
/\.\d(?:pm)?$/ && !/man1/ && !/usr\/bin/ # && !/^(?:\/|perl)/
} $inst->files('Perl');
my @fs = sort keys %fs;
print OUT qq{<h2>Core Modules</h2><ul>};
for (@fs) {
print OUT qq{<li><a href="$base$_">$_</a>};
}
print OUT '</ul><h2>Installed Modules</h2><ul>';
# handle the rest
for (sort keys %ns) {
next if $_ eq 'Perl'; # skip Perl core.
print OUT qq{<li><b>$_</b><ul>} if @{$ns{$_}} > 1;
for (sort @{$ns{$_}}) {
my %fs;
undef $fs{$_} for map {
s/.*man.\///; s|/|::|g; s/\.\d(?:pm)?$//; $_
} grep {
/\.\d(?:pm)?$/ && !/man1/
} $inst->files($_);
my @fs = sort keys %fs;
next unless @fs > 0;
if (@fs == 1) {
print OUT qq{<li><a href="$base$fs[0]">$fs[0]</a>};
} else {
print OUT qq{<li>$_<ul>};
for (@fs) {
print OUT qq{<li><a href="$base$_">$_</a>};
}
print OUT '</ul>';
}
}
print OUT qq{</ul>} if @{$ns{$_}} > 1;
}
print OUT "</ul></body></html>\n";
close OUT;
$file ? 1 : $out;
}
sub html_package_list
{
my ($file, $base) = @_;
return unless inst();
my %ns;
for (package_list) {
push @{$ns{$1}}, $_ if /^([^:]+)/;
}
$base ||= 'about://perldoc/';
my $out;
open OUT, ">", $file || \$out or return;
print OUT "<html><body><ul>";
my $pfx = '';
for (sort keys %ns) {
if (@{$ns{$_}} == 1) {
print OUT
qq{<li><a href="$base$ns{$_}[0]">$ns{$_}[0]</a>};
} else {
print OUT qq{<li><b>$_</b><ul>};
print OUT qq{<li><a href="$base$_">$_</a>}
for sort @{$ns{$_}};
print OUT qq{</ul>};
}
}
print OUT "</ul></body></html>\n";
close OUT;
$file ? 1 : $out;
}
sub apropos_module
{
my $re = _apropos_re $_[0], 1;
my $inst = inst();
my %ret;
my $incre = inc_re;
for ($inst->files('Perl', 'prog'), package_list) {
if (/\.\d?(?:pm)?$/ && !/man1/ && !/usr\/bin/ && /$re/) {
s/$incre//;
s/.*man.\///;
s|/|::|g;
s/^:+//;
s/\.\d?(?:p[lm])?$//;
undef $ret{$_}
}
}
sort keys %ret;
}
sub requires
{
my $mod = shift;
my @q = $REQUIRES{$mod};
my @done;
while (@q) {
my $m = shift @q;
push @done, $m;
push @q, @{$REQUIRES{$m}};
}
@done;
}
sub users
{
my $mod = shift;
@{$REQUIRED_BY{$mod}}
}
1;
__END__
=head1 TODO
See the README file included with the distribution.
=head1 SEE ALSO
Sepia's public GIT repository is located at L<http://repo.or.cz/w/sepia.git>.
There are several modules for Perl development in Emacs on CPAN,
including L<Devel::PerlySense> and L<PDE>. For a complete list, see
L<http://emacswiki.org/cgi-bin/wiki/PerlLanguage>.
=head1 AUTHOR
Sean O'Rourke, E<lt>seano@cpan.orgE<gt>
Bug reports welcome, patches even more welcome.
=head1 COPYRIGHT
Copyright (C) 2005-2011 Sean O'Rourke. All rights reserved, some
wrongs reversed. This module is distributed under the same terms as
Perl itself.
=cut