File Coverage

blib/lib/Devel/REPL/Plugin/InProcess.pm
Criterion Covered Total %
statement 55 62 88.7
branch 9 16 56.2
condition 2 6 33.3
subroutine 7 7 100.0
pod 0 1 0.0
total 73 92 79.3


line stmt bran cond sub pod time code
1             package Devel::REPL::Plugin::InProcess;
2              
3 2     2   10608 use Devel::REPL::Plugin;
  2         305731  
  2         7  
4 2     2   8119 use PadWalker ();
  2         1008  
  2         51  
5 2     2   9 use namespace::clean -except => [ 'meta' ];
  2         3  
  2         13  
6              
7             has '_caller_depth' => (
8             isa => 'Int',
9             is => 'rw',
10             );
11              
12             has '_package' => (
13             isa => 'Str',
14             is => 'rw',
15             );
16              
17             has '_my_scalars' => (
18             isa => 'HashRef',
19             is => 'rw',
20             );
21              
22             has '_our_scalars' => (
23             isa => 'HashRef',
24             is => 'rw',
25             );
26              
27             has '_lexical_hints' => (
28             isa => "ArrayRef",
29             is => "rw",
30             );
31              
32             has 'skip_levels' => (
33             isa => "Int",
34             is => "rw",
35             default => 0,
36             );
37              
38             sub BEFORE_PLUGIN {
39 1     1 0 334 my $self = shift;
40 1         4 $self->load_plugin('LexEnv');
41             }
42              
43             around 'execute' => sub {
44             my ($orig, $_REPL, @args) = @_;
45             $_REPL->_sync_to_lexenv;
46             my @res = $_REPL->$orig(@args);
47             $_REPL->_sync_from_lexenv;
48             return @res;
49             };
50              
51             # stolen from Devel::REPL::Plugin::Package
52             around 'wrap_as_sub' => sub {
53             my ($orig, $_REPL, @args) = @_;
54             $_REPL->_find_level_and_initialize unless $_REPL->_caller_depth;
55             my $line = $_REPL->$orig(@args);
56             return sprintf "package %s;\n%s", $_REPL->_package, $line;
57             };
58              
59             sub _sync_to_lexenv {
60 2     2   2 my ($self) = @_;
61 2         53 my $cxt = $self->lexical_environment->get_context('_');
62 2         66 my $my = $self->_my_scalars;
63 2         51 my $our = $self->_our_scalars;
64              
65 2         6 $cxt->{$_} = ${$my->{$_}} for keys %$my;
  6         9  
66 2         3 $cxt->{$_} = ${$our->{$_}} for keys %$our;
  0         0  
67             }
68              
69             sub _sync_from_lexenv {
70 2     2   3 my ($self) = @_;
71 2         49 my $cxt = $self->lexical_environment->get_context('_');
72 2         63 my $my = $self->_my_scalars;
73 2         67 my $our = $self->_our_scalars;
74              
75 2         7 ${$my->{$_}} = $cxt->{$_} for keys %$my;
  6         8  
76 2         3 ${$our->{$_}} = $cxt->{$_} for keys %$our;
  0         0  
77             }
78              
79             sub _find_level_and_initialize {
80 1     1   2 my ($self) = @_;
81 1         2 my ($level, $evals, @found_level, @found_eval) = (0, 0);
82 1         27 my $skip = $self->skip_levels;
83              
84 1         1 for (;; ++$level) {
85 7         25 my ($package, $filename, $line, $subroutine, $hasargs,
86             $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) =
87             caller $level;
88 7 100       12 last if !defined $package;
89 6 50 33     22 ++$evals if $subroutine && $subroutine eq '(eval)';
90 6 100       14 if ($package =~ /^Devel::REPL\b/) {
    50          
91 3         5 @found_level = @found_eval = ();
92             } elsif ($package =~ /^DB\b/) {
93             # just ignore DB frames
94             } else {
95 3         4 push @found_level, $level;
96 3         2 push @found_eval, $evals;
97             }
98             }
99              
100 1 50       2 die "Could not find package outside REPL/debugger" unless @found_level;
101 1 50 33     6 die "Asked to skip more packages than have been forund"
102             if $skip && $skip >= @found_level;
103 1         2 my ($found_level, $found_eval) = ($found_level[$skip], $found_eval[$skip]);
104              
105 1         4 my ($package, $filename, $line, $subroutine, $hasargs,
106             $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) =
107             caller $found_level;
108              
109             # (+ 1) because caller(0) is the caller package while peek_my(0) are
110             # the lexicals in the current scope, (- $found_evals) because peek_my
111             # skips eval frames but caller counts them
112 1         8 my $my = PadWalker::peek_my($found_level + 1 - $found_eval);
113 1         4 my $our = PadWalker::peek_our($found_level + 1 - $found_eval);
114 1         32 my $lexenv = $self->lexical_environment;
115 1         54 my $cxt;
116              
117 1         3 for my $key (keys %$my) {
118 3 50       6 if ($key =~ /^\$/) {
119 3         14 $cxt->{$key} = ${$my->{$key}};
  3         7  
120             } else {
121 0         0 $cxt->{$key} = $my->{$key};
122             }
123             }
124 1         2 for my $key (keys %$our) {
125 0 0       0 if ($key =~ /^\$/) {
126 0         0 $cxt->{$key} = ${$our->{$key}};
  0         0  
127             } else {
128 0         0 $cxt->{$key} = $our->{$key};
129             }
130             }
131              
132 1         3 $lexenv->set_context('_' => $cxt);
133              
134 1         32 $self->_caller_depth($found_level);
135 1         26 $self->_package($package);
136 1         31 $self->_lexical_hints([$hints, $hinthash]);
137             $self->_my_scalars({
138 1         33 map +($_ => $my->{$_}), grep /^\$/, keys %$my
139             });
140             $self->_our_scalars({
141 1         28 map +($_ => $our->{$_}), grep /^\$/, keys %$our
142             });
143             }
144              
145             1;