File Coverage

blib/lib/Devel/Chitin/Eval.pm
Criterion Covered Total %
statement 6 36 16.6
branch 0 8 0.0
condition n/a
subroutine 2 5 40.0
pod n/a
total 8 49 16.3


line stmt bran cond sub pod time code
1             package Devel::Chitin::Eval;
2              
3 34     34   187 use strict;
  34         53  
  34         857  
4 34     34   187 use warnings;
  34         52  
  34         10885  
5              
6             our $VERSION = '0.12'; # TRIAL
7              
8             # Count how many stack frames we should discard when we're
9             # interested in the debugged program's stack frames
10             sub _first_program_frame {
11 0     0     for(my $level = 1;
12             my ($package, $filename, $line, $subroutine) = caller($level);
13             $level++
14             ) {
15 0 0         if ($subroutine eq 'DB::DB') {
16 0           return $level;
17             }
18             }
19 0           return;
20             }
21              
22              
23             package DB;
24              
25             our($single, $trace, $usercontext, @saved);
26              
27             # Needs to live in package DB because of the way eval works.
28             # when run on package DB, it searches back for the first stack
29             # frame that's _not_ package DB, and evaluates the expr there.
30              
31             sub _eval_in_program_context {
32 0     0     my($eval_string, $wantarray, $cb) = @_;
33              
34 0           local($^W) = 0; # no warnings
35              
36 0           my $eval_result;
37             {
38             # Try to keep the user code from messing with us. Save these so that
39             # even if the eval'ed code changes them, we can put them back again.
40             # Needed because the user could refer directly to the debugger's
41             # package globals (and any 'my' variables in this containing scope)
42             # inside the eval(), and we want to try to stay safe.
43 0           my $orig_trace = $trace;
  0            
44 0           my $orig_single = $single;
45 0           my $orig_cd = $^D;
46              
47             # Untaint the incoming eval() argument.
48 0           { ($eval_string) = $eval_string =~ /(.*)/s; }
  0            
49              
50             # Fill in the appropriate @_
51 0           () = caller(Devel::Chitin::Eval::_first_program_frame() );
52             #@_ = @DB::args;
53 0     0     my $do_eval = sub { eval "$usercontext $eval_string;\n" };
  0            
54              
55 0 0         if ($wantarray) {
    0          
56             #my @eval_result = eval "$usercontext $eval_string;\n";
57 0           my @eval_result = $do_eval->(@DB::args);
58 0           $eval_result = \@eval_result;
59             } elsif (defined $wantarray) {
60             #$eval_result = eval "$usercontext $eval_string;\n";
61 0           $eval_result = $do_eval->(@DB::args);
62             } else {
63             #eval "$usercontext $eval_string;\n";
64 0           $do_eval->(@DB::args);
65             }
66              
67             # restore old values
68 0           $trace = $orig_trace;
69 0           $single = $orig_single;
70 0           $^D = $orig_cd;
71             }
72              
73 0           my $exception = $@; # exception from the eval
74             # Since we're only saving $@, we only have to localize the array element
75             # that it will be stored in.
76 0           local $saved[0]; # Preserve the old value of $@
77 0           eval { &DB::save };
  0            
78              
79 0 0         $cb->($eval_result, $exception) if $cb;
80 0           return ($eval_result, $exception);
81             }
82              
83             1;
84              
85             __END__