File Coverage

lib/Devel/Trepan/DB/Eval.pm
Criterion Covered Total %
statement 60 92 65.2
branch 11 30 36.6
condition 1 9 11.1
subroutine 12 15 80.0
pod 0 5 0.0
total 84 151 55.6


line stmt bran cond sub pod time code
1             # Eval part of Perl's Core DB.pm library and perl5db.pl with modification.
2              
3             package DB;
4 13     13   18133 use warnings; use strict;
  13     13   37  
  13         411  
  13         71  
  13         34  
  13         282  
5 13     13   474 use English qw( -no_match_vars );
  13         2935  
  13         83  
6              
7             # FIXME: remove these
8 13     13   2979 use vars qw($eval_result @eval_result);
  13         37  
  13         662  
9              
10             # This is the flag that says "a debugger is running, please call
11             # DB::DB and DB::sub". We will turn it on forcibly before we try to
12             # execute anything in the user's context, because we always want to
13             # get control back.
14 13     13   84 use constant db_stop => 1 << 30;
  13         36  
  13         1097  
15              
16             BEGIN {
17             # When we want to evaluate a string in the context of the running
18             # program we use these:
19 13     13   56 $DB::eval_result = undef; # Place for result if scalar;
20 13         38 @DB::eval_result = (); # place for result if array
21 13         2595 %DB::eval_result = (); # place for result if hash
22             }
23              
24             # Like builtin caller but we strip off DB:: routines which are presumably
25             # are calls from inside inside the debugger (package DB).
26             # NOTE: we assume the original builtin caller has been saved inside
27             # local-declared *orig_caller. See below in eval_with_return.
28              
29             # no critic
30              
31             sub caller_levels_skip() {
32 0     0 0 0 my $skip=0;
33 0 0       0 my $db_fn = ($DB::event eq 'post-mortem') ? 'catch' : 'DB';
34              
35 0         0 while (my ($pkg, $file, $line, $fn) = caller($skip++)) {
36             # Note: The function parameter of caller(), $fn, gives the
37             # function that was used rather than the function that the
38             # caller is currently in. Therefore, the implicitly line
39             # calling DB:DB is the one we want to stop at.
40 0 0 0     0 if ("DB::$db_fn" eq $fn or ('DB' eq $pkg && $db_fn eq $fn)) {
      0        
41             ## print("XXX $skip\n");
42 0         0 $skip--;
43 0         0 last ;
44             }
45             }
46 0 0       0 $skip-- if $skip > 0;
47 0         0 return $skip;
48             }
49              
50             # Provide a replacement for built-in CORE::caller
51             sub caller_sans_DB(;$) {
52 0     0 0 0 my $levels = shift;
53 0 0       0 $levels = 0 unless defined($levels);
54 0         0 my $skip = caller_levels_skip();
55 0         0 my @caller = CORE::caller($skip+$levels);
56              
57 0 0       0 return if ! @caller; # empty
58 0 0       0 return $caller[0] if ! wantarray; # scalar context
59 0         0 return @caller[0..2]; # outside of DB, array info just gives 3 itmes
60              
61             }
62              
63             # evaluate $eval_str in the context of $package_namespace (a package name).
64             # @saved contains an ordered list of saved global variables.
65             # $return_type indicates the return context:
66             # @ for array context,
67             # $ for scalar context,
68             # % save result in a hash variable
69             #
70             sub eval_with_return {
71 3     3 0 1358 my ($eval_str, $opts, @saved) = @_;
72 13     13   89 no strict;
  13         33  
  13         554  
73 3         14 ($EVAL_ERROR, $ERRNO, $EXTENDED_OS_ERROR,
74             $OUTPUT_FIELD_SEPARATOR,
75             $INPUT_RECORD_SEPARATOR,
76             $OUTPUT_RECORD_SEPARATOR, $WARNING) = @saved;
77              
78             {
79 13     13   68 no warnings 'once';
  13         35  
  13         4703  
  3         7  
80             # Try to keep the user code from messing with us. Save these so that
81             # even if the eval'ed code changes them, we can put them back again.
82             # Needed because the user could refer directly to the debugger's
83             # package globals (and any 'my' variables in this containing scope)
84             # inside the eval(), and we want to try to stay safe.
85 3         6 local $otrace = $DB::trace;
86 3         7 local $osingle = $DB::single;
87 3         6 local $od = $DEBUGGING;
88              
89             # Set package namespace for running eval's in the namespace
90             # of the debugged program.
91 3   33     9 my $eval_setup = $opts->{namespace_package} || $DB::namespace_package;
92 3         6 $eval_setup .= ";\n\@_ = \@DB::_;";
93              
94             # Make sure __FILE__ and __LINE__ are set correctly
95 3 50       8 if( $opts->{fix_file_and_line}) {
96 0         0 my $position_str = "\n# line $DB::lineno \"$DB::filename\"\n";
97 0         0 $eval_setup .= $position_str ;
98             }
99              
100 3         5 my $return_type = $opts->{return_type};
101              
102             # Override caller inside the eval below. Many thanks to Toby
103             # Inkster and educated_foo via
104             # http://www.perlmonks.org/?node_id=1065502
105              
106 3         11 local *CORE::GLOBAL::caller = \&caller_sans_DB;
107              
108             # Note: our code shouldn't use caller for itself below (or if
109             # it is needed use it by the name CORE::caller, since we've
110             # overwritten it above.
111              
112 3 100       13 if ('$' eq $return_type) {
    100          
    50          
113             # print "+++ eval $return: $eval_setup \$DB::eval_result=$eval_str\n";
114 1         60 eval "$eval_setup \$DB::eval_result=$eval_str\n";
115             } elsif ('@' eq $return_type) {
116             # print "+++ eval @return: $eval_setup \@DB::eval_result=$eval_str\n";
117 1         63 eval "$eval_setup \@DB::eval_result=$eval_str\n";
118             } elsif ('%' eq $return_type) {
119 1         78 eval "$eval_setup \%DB::eval_result=$eval_str\n";
120             # } elsif ('>' eq $return_type) {
121             # ($eval_result, $stderr, @result) = capture {
122             # eval "$eval_setup $eval_str\n";
123             # };
124             # } elsif ('2>&1' eq $return_type) {
125             # $eval_result = capture_merged {
126             # eval "$eval_setup $eval_str\n";
127             } else {
128             # print "+++ eval $eval_setup $eval_str\n";
129 0         0 $eval_result = eval "$eval_setup $eval_str\n";
130             };
131              
132             # Restore those old values.
133 3         11 $DB::trace = $otrace;
134 3         5 $DB::single = $osingle;
135 3         6 $DEBUGGING = $od;
136              
137 3         5 my $msg = $EVAL_ERROR;
138 3 50       9 if ($msg) {
139 0         0 chomp $msg;
140 0 0       0 if ($opts->{hide_position}) {
141 0         0 $msg =~ s/ at .* line \d+[.,]//;
142 0         0 $msg =~ s/ line \d+,//;
143 0         0 $msg =~ s/ at EOF$/ at end of string/;
144             }
145 0         0 _warnall($msg);
146 0         0 $eval_str = '';
147 0         0 return undef;
148             } else {
149 3 100       7 if ('@' eq $return_type) {
150 1         5 return @eval_result;
151             } else {
152 2         8 return $eval_result;
153             }
154             }
155             }
156             }
157              
158             # Evaluate the argument and return 0 if there's no error.
159             # If there is an error we return the error message.
160             sub eval_not_ok ($)
161             {
162 7     7 0 3942 my $code = shift;
163 7         22 my $wrapped = "$DB::namespace_package; sub { $code }";
164 13     13   98 no strict;
  13         34  
  13         2492  
165 7     1   393 eval $wrapped;
  1         19  
166 7 100       45 if ($@) {
167 4         9 my $msg = $@;
168 4         30 $msg =~ s/ at .* line \d+[.,]//g;
169 4         11 $msg =~ s/ at EOF$/ at end of string/;
170 4         13 return $msg;
171             } else {
172 3         10 return 0;
173             }
174             }
175              
176             unless (CORE::caller) {
177             eval {
178             sub doit($) {
179 0     0 0 0 my $code = shift;
180 0         0 my $msg = eval_not_ok($code);
181 0         0 print "code: $code\n";
182 0 0       0 if ($msg) {
183 0         0 print "$msg";
184             } else {
185 0         0 print "code ok\n";
186             }
187             }
188             };
189              
190             $DB::namespace_package = 'package DB;';
191             doit 'doit(1,2,3)';
192             doit "1+";
193             doit '$x+2';
194             doit "foo(";
195             doit '$foo =';
196             doit 'BEGIN { $x = 1; ';
197             doit 'package foo; 1';
198              
199             }
200              
201             # doit '$x = 1; __END__ $y=';
202              
203              
204             1;