File Coverage

blib/lib/Devel/REPL/Plugin/Carp/REPL.pm

Criterion	Covered	Total	%
statement	14	17	82.3
branch	0	2	0.0
condition			n/a
subroutine	5	6	83.3
pod	0	2	0.0
total	19	27	70.3

package Devel::REPL::Plugin::Carp::REPL;
use Devel::REPL::Plugin;
#use namespace::clean -except => [ 'meta' ];
use Devel::LexAlias;
use Devel::StackTrace::WithLexicals;
use Data::Dump::Streamer;

sub BEFORE_PLUGIN {
    my $self = shift;
    $self->load_plugin('LexEnv');
}

has stacktrace => (
    is      => 'ro',
    isa     => 'Devel::StackTrace::WithLexicals',
    handles => [qw/frame_count/],
    default => sub {
        my $stacktrace = Devel::StackTrace::WithLexicals->new(
            ignore_class => ['Carp::REPL', __PACKAGE__],
            unsafe_ref_capture => 1,
        );

        # skip all the Moose metaclass frames
        shift @{ $stacktrace->{raw} }
            until @{ $stacktrace->{raw} } == 0
               || $stacktrace->{raw}[0]{caller}[3] eq 'Carp::REPL::repl';

        # get out of Carp::
        shift @{ $stacktrace->{raw} }
            until @{ $stacktrace->{raw} } == 0
               || $stacktrace->{raw}[0]{caller}[0] !~ /^Carp(?:::|$)/;

        shift @{ $stacktrace->{raw} }
            until @{ $stacktrace->{raw} } == 0
               || $Carp::REPL::bottom_frame-- <= 0;

        return $stacktrace;
    },
);

has frame_index => (
    is      => 'rw',
    isa     => 'Int',
    default => 0,
);

sub frame {
    my $self = shift;
    my $i = @_ ? shift : $self->frame_index;

    return $self->stacktrace->frame($i);
}

around 'frame_index' => sub {
    my $orig = shift;
    my ($self, $index) = @_;

    return $orig->(@_) if !defined($index);

    if ($index < 0) {
        warn "You're already at the bottom frame.\n";
    }
    elsif ($index >= $self->frame_count) {
        warn "You're already at the top frame.\n";
    }
    else {
        $orig->(@_);
        my $frame = $self->frame;
        my ($file, $line) = ($frame->filename, $frame->line);
        $self->print("Now at $file:$line (frame $index).");
    }
};

# this is totally the wrong spot for this. oh well.
around 'read' => sub {
    my $orig = shift;
    my ($self, @rest) = @_;
    my $line = $self->$orig(@rest);

    return if !defined($line) || $line =~ /^\s*:q\s*/;

    if ($line =~ /^\s*:b?t\b/) {
        $self->print($self->stacktrace);
        return '';
    }

    if ($line =~ /^\s*:top\b/) {
        $self->frame_index($self->frame_count - 1);
        return '';
    }

    if ($line =~ /^\s*:b(?:ot(?:tom)?)?\b/) {
        $self->frame_index(0);
        return '';
    }

    if ($line =~ /^\s*:up?\b/) {
        $self->frame_index($self->frame_index + 1);
        return '';
    }

    if ($line =~ /^\s*:d(?:own)?\b/) {
        $self->frame_index($self->frame_index - 1);
        return '';
    }

    if ($line =~ /^\s*:l(?:ist)?\b/) {
        my $frame = $self->frame;
        my ($file, $num) = ($frame->filename, $frame->line);
        open my $handle, '<', $file or do {
            warn "Unable to open $file for reading: $!\n";
            return '';
        };
        my @code = <$handle>;
        chomp @code;

        my $min = $num - 6;
        my $max = $num + 4;
        $min = 0 if $min < 0;
        $max = $#code if $max > $#code;

        my @lines;
        $self->print("File $file:\n");
        for my $cur ($min .. $max) {
            next if !defined($code[$cur]);

            push @lines, sprintf "%s%*d: %s",
                            $cur + 1 == $num ? '*' : ' ',
                            length($max),
                            $cur + 1,
                            $code[$cur];
        }

        $self->print(join "\n", @lines);

        return '';
    }

    if ($line =~ /^\s*:e(?:nv)?\s*/) {
        $self->print(Dump($self->frame->lexicals)->Names('Env')->Out);
        return '';
    }

    return $line;
};

# Provide an alias for each lexical in the current stack frame
around 'mangle_line' => sub {
    my $orig = shift;
    my ($self, @rest) = @_;
    my $line = $self->$orig(@rest);

    my $frame = $self->frame;
    my $package = $frame->package;
    my $lexicals = $frame->lexicals;

    my $declarations = join "\n",
                       map {"my $_;"}
                       keys %$lexicals;

    my $aliases = << '    ALIASES';
    while (my ($k, $v) = each %{ $_REPL->frame->lexicals }) {
        Devel::LexAlias::lexalias 0, $k, $v;
    }
    my $_a; Devel::LexAlias::lexalias 0, '$_a', \$_REPL->frame->{args};
    ALIASES

    return << "    CODE";
    package $package;
    no warnings 'misc'; # declaration in same scope masks earlier instance
    no strict 'vars';   # so we get all the global variables in our package
    $declarations
    $aliases
    $line
    CODE
};

1;

__END__

=head1 NAME

Devel::REPL::Plugin::Carp::REPL - Devel::REPL plugin for Carp::REPL

=head1 SYNOPSIS

This sets up the environment captured by L<Carp::REPL>. This plugin
isn't intended for use by anything else. There are plans to move some features
from this into a generic L<Devel::REPL> plugin.

This plugin also adds a few extra commands like :up and :down to move up and
down the stack.

=head1 AUTHOR

Shawn M Moore, C<< <sartak at gmail.com> >>

=head1 BUGS

Please report any bugs to a medium given by Carp::REPL.

=head1 COPYRIGHT & LICENSE

Copyright 2007-2008 Best Practical Solutions, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut