view release on metacpan or  search on metacpan

lib/Sepia.pm  view on Meta::CPAN

    };
    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;

lib/Sepia.pm  view on Meta::CPAN

=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])>