blib/lib/Devel/EdTrace.pm | |||
---|---|---|---|
Criterion | Covered | Total | % |
statement | 7 | 9 | 77.7 |
branch | n/a | ||
condition | n/a | ||
subroutine | 3 | 3 | 100.0 |
pod | n/a | ||
total | 10 | 12 | 83.3 |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | # -*- perl -*- | ||||||
2 | |||||||
3 | package Devel::EdTrace; | ||||||
4 | 1 | 1 | 954 | no warnings; | |||
1 | 2 | ||||||
1 | 48 | ||||||
5 | 1 | 1 | 4 | use strict; | |||
1 | 1 | ||||||
1 | 31 | ||||||
6 | 1 | 1 | 1642 | use Data::Diff; | |||
0 | |||||||
0 | |||||||
7 | use Data::Grep; | ||||||
8 | use Data::Dumper; | ||||||
9 | use Data::DeepCopy; | ||||||
10 | use Config; | ||||||
11 | |||||||
12 | use vars qw($_brackets $_simple_parens); | ||||||
13 | |||||||
14 | my $_quotables = [ '@', '#', '%', '^', '&', '*', ':', '"', "'", '', '', '' ]; | ||||||
15 | |||||||
16 | BEGIN | ||||||
17 | { | ||||||
18 | eval "use PadWalker qw(peek_my peek_our);\n"; | ||||||
19 | eval "use Devel::LexAlias qw(lexalias);\n"; | ||||||
20 | ($_brackets , $_simple_parens) = ___brackets_parens(); | ||||||
21 | # eval "use Regex::Token qw(\$_brackets \$_simple_parens);\n"; | ||||||
22 | |||||||
23 | # if ($@) { print STDERR "HERE :$@:\n"; } | ||||||
24 | # | ||||||
25 | # print STDERR "HERE: $_brackets\n"; | ||||||
26 | # die; | ||||||
27 | if (!defined(&peek_my)) { print STDERR "SYSTEM WARNING: PadWalker not found!\n"; } | ||||||
28 | if (!defined(&lexalias)) { print STDERR "SYSTEM WARNING: Devel::LexAlias not found!\n"; } | ||||||
29 | |||||||
30 | # print STDERR ":$_simple_parens:\n"; | ||||||
31 | *lexalias = sub { {} } if (!defined(&lexalias)); | ||||||
32 | *peek_my = sub { {} } if (!defined(&peek_my)); | ||||||
33 | *peek_our = sub { {} } if (!defined(&peek_our)); | ||||||
34 | |||||||
35 | sub ___brackets_parens | ||||||
36 | { | ||||||
37 | my $_cpp_comment = q$(? | ||||||
38 | my $_perl_comment = q,(?>\#[^\n]+(?:\n|\Z)),; | ||||||
39 | my $_doublestring = q$(?>\"(?>[^\\\"]+|\\\.)*\")$; #" | ||||||
40 | my $_singlestring = q$(?>\'(?>[^\\\']+|\\\.)*\')$; #' | ||||||
41 | my $_simple_brackets; | ||||||
42 | |||||||
43 | my $_simple_parens; | ||||||
44 | |||||||
45 | my $_sub_simple_brackets = "\{(?>[^{}]+)\}"; | ||||||
46 | my $_sub_simple_parens = "(?>\\((?>[^()]+)\\))"; | ||||||
47 | |||||||
48 | my $_subbrackets = | ||||||
49 | q$ | ||||||
50 | \{ | ||||||
51 | (?> | ||||||
52 | $ . | ||||||
53 | $_perl_comment . '|' . | ||||||
54 | $_cpp_comment . '|' . | ||||||
55 | $_doublestring . '|' . | ||||||
56 | $_singlestring . '|' . | ||||||
57 | q$ | ||||||
58 | |||||||
59 | (?>[""''/\#]) | | ||||||
60 | (?>[^{}""''/\#]+) | ||||||
61 | )* | ||||||
62 | \} | ||||||
63 | $; | ||||||
64 | |||||||
65 | my $xx; | ||||||
66 | for ($xx = 0; $xx < 20; $xx++) | ||||||
67 | { | ||||||
68 | |||||||
69 | $_simple_brackets = "(?>\\s*\{(?>[^{}]+|$_sub_simple_brackets)*\})"; | ||||||
70 | $_sub_simple_brackets = $_simple_brackets; | ||||||
71 | |||||||
72 | $_brackets = | ||||||
73 | q$ | ||||||
74 | (?>\s* | ||||||
75 | \{ | ||||||
76 | (?> | ||||||
77 | $ . $_cpp_comment . '|' . | ||||||
78 | $_doublestring .'|'. | ||||||
79 | $_singlestring . '|' . | ||||||
80 | $_perl_comment . '|' . | ||||||
81 | q$ | ||||||
82 | (?>[""''/\#]) | | ||||||
83 | (?>[^{}""''/\#]+) | | ||||||
84 | $ . | ||||||
85 | $_subbrackets . | ||||||
86 | q$ | ||||||
87 | )* | ||||||
88 | \} | ||||||
89 | )$ | ||||||
90 | ; | ||||||
91 | |||||||
92 | $_subbrackets = $_brackets; | ||||||
93 | } | ||||||
94 | |||||||
95 | for ($xx = 0; $xx < 20; $xx++) | ||||||
96 | { | ||||||
97 | $_simple_parens = "(?>\\s*\\((?>[^()]+|$_sub_simple_parens)*\\))"; | ||||||
98 | $_sub_simple_parens = $_simple_parens; | ||||||
99 | } | ||||||
100 | |||||||
101 | $_brackets =~ s"\s""sg; | ||||||
102 | $_simple_parens =~ s"\s""sg; | ||||||
103 | return($_brackets, $_simple_parens); | ||||||
104 | } | ||||||
105 | } | ||||||
106 | |||||||
107 | use FileHandle; | ||||||
108 | use Time::HiRes qw(usleep); | ||||||
109 | use vars qw($_cached); | ||||||
110 | |||||||
111 | our $_tb_code; | ||||||
112 | our $_tb_delay; | ||||||
113 | our $_setme; | ||||||
114 | our $_destroy_lines = {}; | ||||||
115 | |||||||
116 | |||||||
117 | use vars (qw ($VERSION $TRACE)); | ||||||
118 | $VERSION = '0.10'; | ||||||
119 | BEGIN { $TRACE = 1; } | ||||||
120 | |||||||
121 | $_cached = {}; | ||||||
122 | |||||||
123 | use vars qw($tlfh); | ||||||
124 | |||||||
125 | $Devel::EdTrace::PrintEval = ($ENV{TRACEEVAL})? 1 : 0; | ||||||
126 | $Devel::EdTrace::PrintLevel = ($ENV{TRACELEVEL})? $ENV{TRACELEVEL} : 1; | ||||||
127 | $Devel::EdTrace::ExpandBuiltin = ($ENV{TRACEBUILTIN} == 1)? 'keys|values|map' : ($ENV{TRACEBUILTIN})? $ENV{TRACEBUILTIN} : 0; | ||||||
128 | $Devel::EdTrace::NoExpandArray = ($ENV{TRACENOARRAY})? 1 : 0; | ||||||
129 | $Devel::EdTrace::SafeGuard = ($ENV{TRACESAFE} eq 'none')? undef : ($ENV{TRACESAFE})? $ENV{TRACESAFE} : "hashref|functions|autovivify"; | ||||||
130 | $Devel::EdTrace::GrepRegex = ($ENV{TRACEGREP})? $ENV{TRACEGREP} : undef; | ||||||
131 | $Devel::EdTrace::TraceSys = ($ENV{TRACESYS})? $ENV{TRACESYS} : undef; | ||||||
132 | |||||||
133 | |||||||
134 | # This is the important part. The rest is just fluff. | ||||||
135 | |||||||
136 | #sub NEWDB::DB | ||||||
137 | sub DB::DB | ||||||
138 | { | ||||||
139 | return unless $TRACE; | ||||||
140 | my ($p, $f, $l) = caller; | ||||||
141 | my $oldeval; | ||||||
142 | |||||||
143 | no strict 'refs'; | ||||||
144 | # DB::eval(); | ||||||
145 | |||||||
146 | local($Data::DeepCopy::RefLevel) = (defined($ENV{TRACELEVEL}))? | ||||||
147 | $ENV{TRACELEVEL} : 1; | ||||||
148 | local($Data::Diff::RefLevel) = (defined($ENV{TRACELEVEL}))? | ||||||
149 | $ENV{TRACELEVEL} : 1; | ||||||
150 | local($Data::Grep::RefLevel) = (defined($ENV{TRACELEVEL}))? | ||||||
151 | $ENV{TRACELEVEL} : 1; | ||||||
152 | |||||||
153 | ___printwatchpoints(); | ||||||
154 | ___printreversewatchpoints(); | ||||||
155 | |||||||
156 | # $ENV{TRACEDELAY} = 1000000; | ||||||
157 | # $ENV{TRACECB} = "sub { \$ENV{PERL5SHELL} = 'C:\\cygwin\\bin\\sh.exe -cf' if (!\$_setme++); system(\"/bin/ls.exe\"); }"; | ||||||
158 | |||||||
159 | if ($ENV{TRACEDELAY}) { usleep($ENV{TRACEDELAY}); } | ||||||
160 | |||||||
161 | if ($ENV{TRACECB}) | ||||||
162 | { | ||||||
163 | if ($_tb_code) | ||||||
164 | { | ||||||
165 | &{$_tb_code}(); | ||||||
166 | } | ||||||
167 | else | ||||||
168 | { | ||||||
169 | $oldeval = $@; | ||||||
170 | eval("\$_tb_code = $ENV{TRACECB}"); | ||||||
171 | $@ = $oldeval; | ||||||
172 | } | ||||||
173 | } | ||||||
174 | |||||||
175 | ___print(___prompt($f, $l)); | ||||||
176 | } | ||||||
177 | |||||||
178 | my @oldopt; | ||||||
179 | sub CommonOn | ||||||
180 | { | ||||||
181 | push(@oldopt, [ $Devel::EdTrace::PrintEval, $Devel::EdTrace::PrintLevel, $Devel::EdTrace::TRACE ]); | ||||||
182 | |||||||
183 | $Devel::EdTrace::PrintEval = 1; | ||||||
184 | $Devel::EdTrace::PrintLevel = 2; | ||||||
185 | $Devel::EdTrace::TRACE = 1; | ||||||
186 | } | ||||||
187 | |||||||
188 | sub CommonOff | ||||||
189 | { | ||||||
190 | if (@oldopt) | ||||||
191 | { | ||||||
192 | my ($opt) = pop(@oldopt); | ||||||
193 | |||||||
194 | $Devel::EdTrace::PrintEval = $opt->[0]; | ||||||
195 | $Devel::EdTrace::PrintLevel = $opt->[1]; | ||||||
196 | $Devel::EdTrace::TRACE = $opt->[2]; | ||||||
197 | } | ||||||
198 | else | ||||||
199 | { | ||||||
200 | $Devel::EdTrace::TRACE = 0; | ||||||
201 | } | ||||||
202 | } | ||||||
203 | |||||||
204 | sub ___prompt | ||||||
205 | { | ||||||
206 | my ($f, $l) = @_; | ||||||
207 | |||||||
208 | no strict; | ||||||
209 | |||||||
210 | my $code = \@{"::_<$f"}; | ||||||
211 | |||||||
212 | my $toprint; | ||||||
213 | if ($Devel::EdTrace::PrintEval) | ||||||
214 | { | ||||||
215 | my $cd = ___getstatement($code, $l); | ||||||
216 | chomp($cd); | ||||||
217 | |||||||
218 | # print STDERR ":$cd:\n"; | ||||||
219 | $toprint = ___eval_in_callers_scope($cd, $code); | ||||||
220 | # print STDERR "HERE1 => :$toprint:\n"; | ||||||
221 | # $toprint = $code->[$l]; | ||||||
222 | |||||||
223 | } | ||||||
224 | else | ||||||
225 | { | ||||||
226 | $toprint = ___getstatement($code, $l); | ||||||
227 | $toprint = "\n$toprint"; | ||||||
228 | } | ||||||
229 | |||||||
230 | if ($Devel::EdTrace::PrintLevel == 1) | ||||||
231 | { | ||||||
232 | return(">> $f :$l: $toprint"); | ||||||
233 | } | ||||||
234 | elsif ($Devel::EdTrace::PrintLevel == 2) | ||||||
235 | { | ||||||
236 | my @stack; | ||||||
237 | my $stack = 0; | ||||||
238 | while (@stack = caller($stack)) | ||||||
239 | { | ||||||
240 | $stack++; | ||||||
241 | } | ||||||
242 | return(("\t" x $stack) . ">> $f :$l: $toprint"); | ||||||
243 | } | ||||||
244 | elsif ($Devel::EdTrace::PrintLevel == 3) | ||||||
245 | { | ||||||
246 | my $text; | ||||||
247 | |||||||
248 | my @stack; | ||||||
249 | my $stack = 0; | ||||||
250 | |||||||
251 | while (@stack = caller($stack)) | ||||||
252 | { | ||||||
253 | $stack++; | ||||||
254 | } | ||||||
255 | |||||||
256 | $stack--; | ||||||
257 | my $join; | ||||||
258 | while ($stack >= 1) | ||||||
259 | { | ||||||
260 | my @stack = caller($stack); | ||||||
261 | $join .= "$stack[1] :$stack[2]: $code->[$stack[2]] "; | ||||||
262 | $stack--; | ||||||
263 | } | ||||||
264 | |||||||
265 | $join =~ s"\n" -- "sg; | ||||||
266 | return( "$join\n"); | ||||||
267 | } | ||||||
268 | } | ||||||
269 | |||||||
270 | sub ___getstatement | ||||||
271 | { | ||||||
272 | my ($code, $l) = @_; | ||||||
273 | |||||||
274 | my $open_here; | ||||||
275 | my $ret; | ||||||
276 | while (length($code->[$l])) | ||||||
277 | { | ||||||
278 | |||||||
279 | if ($open_here && $code->[$l] =~ m"^$open_here") | ||||||
280 | { | ||||||
281 | $ret .= $code->[$l]; | ||||||
282 | last; | ||||||
283 | } | ||||||
284 | elsif ($code->[$l] =~ m/.*<<["']?([_A-Z0-9!]+)["'\s;\),;]/ && !$open_here) | ||||||
285 | { | ||||||
286 | $open_here = $1; | ||||||
287 | $ret .= $code->[$l]; | ||||||
288 | } | ||||||
289 | else | ||||||
290 | { | ||||||
291 | $ret .= $code->[$l]; | ||||||
292 | last if (!$open_here && $code->[$l] =~ m";"); | ||||||
293 | } | ||||||
294 | $l++; | ||||||
295 | } | ||||||
296 | return($ret); | ||||||
297 | } | ||||||
298 | |||||||
299 | sub ___eval_in_callers_scope | ||||||
300 | { | ||||||
301 | my ($input_line, $code_lines) = @_; | ||||||
302 | |||||||
303 | |||||||
304 | my $_specials = { '@ARGV' => 1 }; | ||||||
305 | |||||||
306 | no strict; | ||||||
307 | my $return; | ||||||
308 | |||||||
309 | chomp($input_line); | ||||||
310 | |||||||
311 | my $callers_lexicals = peek_my(3); | ||||||
312 | |||||||
313 | my $line; | ||||||
314 | # foreach $line (keys(%$callers_lexicals)) | ||||||
315 | # { | ||||||
316 | # print STDERR "LEXICAL => $line\n"; | ||||||
317 | # sleep(1); | ||||||
318 | # } | ||||||
319 | |||||||
320 | # print STDERR "HERE :$input_line: $@\n"; | ||||||
321 | # return($return); | ||||||
322 | |||||||
323 | my $preamble = ""; | ||||||
324 | use Data::Dumper; | ||||||
325 | |||||||
326 | my @full; | ||||||
327 | my @stack; | ||||||
328 | my $stack = 0; | ||||||
329 | |||||||
330 | my (@stack) = caller(2); | ||||||
331 | |||||||
332 | my $in_destroy_flag = ___in_destroy_flag($stack[1], $stack[2], $code_lines); | ||||||
333 | |||||||
334 | # print STDERR Dumper(\@stack) if ($in_destroy_flag); | ||||||
335 | # sleep(10) if ($in_destroy_flag); | ||||||
336 | |||||||
337 | my $preamble = "dummy(); sub dummy {\n"; | ||||||
338 | for my $variable_name (keys(%$callers_lexicals)) | ||||||
339 | { | ||||||
340 | my $val = $callers_lexicals->{$variable_name}; | ||||||
341 | my $repl; | ||||||
342 | my $code_lines; | ||||||
343 | |||||||
344 | if (!$in_destroy_flag) | ||||||
345 | { | ||||||
346 | $preamble .= "my $variable_name; Devel::EdTrace::lexalias(0, '$variable_name', \$callers_lexicals->{'$variable_name'}) if (Devel::EdTrace::___defined(\$callers_lexicals->{'$variable_name'}));\n"; | ||||||
347 | # $preamble .= "my $variable_name; lexalias(0, '$variable_name', \$callers_lexicals->{'$variable_name'});\n"; | ||||||
348 | } | ||||||
349 | } | ||||||
350 | # if (ref($val) eq 'SCALAR') | ||||||
351 | # { | ||||||
352 | # $repl = $$val; | ||||||
353 | # $code_lines = "$variable_name = $repl;\n"; | ||||||
354 | # } | ||||||
355 | # else | ||||||
356 | # { | ||||||
357 | # $code_lines = "_alias(\\$variable_name, $repl);\n"; | ||||||
358 | # | ||||||
359 | # print STDERR "VARB $variable_name => $repl\n"; | ||||||
360 | # $preamble .= "my $variable_name; $code_lines;"; | ||||||
361 | # } | ||||||
362 | |||||||
363 | my $caller = [ caller(2) ]; | ||||||
364 | # print STDERR ":@$caller:\n"; | ||||||
365 | # sleep(4); | ||||||
366 | |||||||
367 | # print STDERR " FFFF => :$_brackets:\n"; | ||||||
368 | # my $tag = "AABBCCDDEEFF"; | ||||||
369 | |||||||
370 | chomp($input_line); | ||||||
371 | my $eval_input_line = $input_line; | ||||||
372 | |||||||
373 | my @bad_lines; | ||||||
374 | push(@bad_liens, "BEF1 :$eval_input_line:\n"); | ||||||
375 | |||||||
376 | if ($Devel::EdTrace::NoExpandArray) | ||||||
377 | { | ||||||
378 | $eval_input_line =~ s"\@"\\\@"sg; | ||||||
379 | } | ||||||
380 | push(@bad_lines, "BEF2 :$eval_input_line:\n"); | ||||||
381 | |||||||
382 | if ($_brackets) | ||||||
383 | { | ||||||
384 | $eval_input_line =~ s/(\@(?:\w+))/"\@AOPBRACK [ $1 ] CLSBRACK"/sge; | ||||||
385 | push(@bad_lines, "BEF3 :$eval_input_line:\n"); | ||||||
386 | |||||||
387 | while ($eval_input_line =~ s/\@(\s*$_brackets)/"\@AOPBRACK [ " . ___bracket_surgery($1, $eval_input_line, 'quotemeta' , $found_so_far) . " ] CLSBRACK "/sge) { }; | ||||||
388 | push(@bad_lines, "BEF3b :$eval_input_line:\n"); | ||||||
389 | |||||||
390 | if ($Devel::EdTrace::ExpandBuiltin) | ||||||
391 | { | ||||||
392 | my $found_so_far = {}; | ||||||
393 | |||||||
394 | $eval_input_line =~ s/(\b(?:$Devel::EdTrace::ExpandBuiltin)\b\s*$_simple_parens)/"\@AOPBRACK [ $1 ] CLSBRACK"/sge; | ||||||
395 | push(@bad_lines, "BEF4 :$eval_input_line:\n"); | ||||||
396 | } | ||||||
397 | |||||||
398 | # print STDERR "HERE :$Devel::EdTrace::SafeGuard:\n"; | ||||||
399 | if ($Devel::EdTrace::SafeGuard =~ m"hashref") | ||||||
400 | { | ||||||
401 | # print STDERR "BEFORE :$eval_input_line:\n"; | ||||||
402 | while ($eval_input_line =~ s"(\$\w+(?:\->\s*)?)($_brackets)" $1 . ___bracket_surgery($2, $eval_input_line, undef, $found_so_far )"sge) { } | ||||||
403 | push(@bad_lines, "BEF5 :$eval_input_line:\n"); | ||||||
404 | |||||||
405 | while ($eval_input_line =~ s"(\@)($_brackets)" $1 . ___bracket_surgery($2, $eval_input_line, 'func_call', $found_so_far)"sge) { } | ||||||
406 | push(@bad_lines, "BEF6 :$eval_input_line:\n"); | ||||||
407 | |||||||
408 | # print STDERR "AFTER :$eval_input_line:\n"; | ||||||
409 | } | ||||||
410 | } | ||||||
411 | elsif ($Devel::EdTrace::ExpandBuiltin) | ||||||
412 | { | ||||||
413 | die "SYSTEM ERROR: ExpandBuiltin not supported without Regex::Token\n"; | ||||||
414 | } | ||||||
415 | |||||||
416 | $eval_input_line =~ s"\+\+(\s*\$)"1 + $1"sg; | ||||||
417 | push(@bad_lines, "BEF7 :$eval_input_line:\n"); | ||||||
418 | $eval_input_line =~ s"\+\+""sg; | ||||||
419 | |||||||
420 | push(@bad_lines, "BEF8 :$eval_input_line:\n"); | ||||||
421 | $eval_input_line =~ s"\-\-(\s*\$)"$1 - 1"sg; | ||||||
422 | |||||||
423 | push(@bad_lines, "BEF9 :$eval_input_line:\n"); | ||||||
424 | $eval_input_line =~ s"\-\-""sg; | ||||||
425 | |||||||
426 | push(@bad_lines, "BEF10 :$eval_input_line:\n"); | ||||||
427 | |||||||
428 | ___unbracket_surgery($eval_input_line); | ||||||
429 | |||||||
430 | push(@bad_lines, "BEF10a :$eval_input_line:\n"); | ||||||
431 | |||||||
432 | # my $tags = join('|', keys(%$rephash)); | ||||||
433 | # $eval_input_line =~ s"($tags)"$rephash->{$1}"sg; | ||||||
434 | |||||||
435 | $eval_input_line =~ s,\\*?(([\$\@\%])(\w+))(?=(\s*\[|\s*{|\b)), | ||||||
436 | |||||||
437 | my $cl = $1; | ||||||
438 | my $sign = $2; | ||||||
439 | my $val = $3; | ||||||
440 | my $post = $4; | ||||||
441 | # print STDERR ":$cl: :$sign: :$val: :$post:\n"; | ||||||
442 | my $transsign = $sign; | ||||||
443 | if ($post =~ m"{" && $sign eq '$') { $transsign = '%'; } | ||||||
444 | if ($post =~ m"\[" && $sign eq '$') { $transsign = '@'; } | ||||||
445 | |||||||
446 | if ( !$callers_lexicals->{"$transsign$val"} && !$_specials->{"$transsign$val"} && !$_protected->{"$transsign$val"}) | ||||||
447 | { | ||||||
448 | if | ||||||
449 | ( | ||||||
450 | ($transsign eq '$' && defined(${"$caller->[0]" . "::" . $val})) || | ||||||
451 | ($transsign eq '@' && defined(@{"$caller->[0]" . "::" . $val})) || | ||||||
452 | ($transsign eq '%' && defined(%{"$caller->[0]" . "::" . $val})) | ||||||
453 | ) | ||||||
454 | { | ||||||
455 | if ($sign ne '@') | ||||||
456 | { | ||||||
457 | $sign . "$caller->[0]" . "::" . $val; | ||||||
458 | } | ||||||
459 | else | ||||||
460 | { | ||||||
461 | if ($sign eq '@' && $Devel::EdTrace::NoExpandArray) | ||||||
462 | { | ||||||
463 | "\\$sign" . "$caller->[0]" . "::" . $val; | ||||||
464 | } | ||||||
465 | else | ||||||
466 | { | ||||||
467 | "$sign" . "$caller->[0]" . "::" . $val; | ||||||
468 | } | ||||||
469 | } | ||||||
470 | } | ||||||
471 | else | ||||||
472 | { | ||||||
473 | if ($Devel::EdTrace::NoExpandArray || $_protected->{$cl}) | ||||||
474 | { | ||||||
475 | "\\$sign$val" | ||||||
476 | } | ||||||
477 | else | ||||||
478 | { | ||||||
479 | "$sign$val"; | ||||||
480 | } | ||||||
481 | } | ||||||
482 | } | ||||||
483 | elsif ($_protected->{$cl} || $sign ne '$') | ||||||
484 | { | ||||||
485 | if ($Devel::EdTrace::NoExpandArray || $_protected->{$cl}) | ||||||
486 | { | ||||||
487 | "\\$sign$val" | ||||||
488 | } | ||||||
489 | else | ||||||
490 | { | ||||||
491 | "$sign$val"; | ||||||
492 | } | ||||||
493 | } | ||||||
494 | else | ||||||
495 | { | ||||||
496 | "$sign$val"; | ||||||
497 | },sge; | ||||||
498 | |||||||
499 | push(@bad_lines, "BEF11 :$eval_input_line:\n"); | ||||||
500 | |||||||
501 | if ($Devel::EdTrace::SafeGuard =~ m"autovivify") | ||||||
502 | { | ||||||
503 | # print STDERR "BEF11b :$eval_input_line:\n"; | ||||||
504 | $eval_input_line =~ s,($_brackets)(((?:->)?$_brackets)),$1\\$2,sg; | ||||||
505 | } | ||||||
506 | push(@bad_lines, "BEF12 :$eval_input_line:\n"); | ||||||
507 | |||||||
508 | # print STDERR "WHOA :$preamble; \$return = q$input_line <=> . qq >>>$eval_input_line<<< . \"\\\n\""; | ||||||
509 | # sleep(4); | ||||||
510 | |||||||
511 | my $width = $ENV{TRACEWIDTH} || 160; #" | ||||||
512 | |||||||
513 | my %symbefore = map { $_ => 1 } keys(%YPAN::Map::Build::); | ||||||
514 | |||||||
515 | my $code; | ||||||
516 | if ($ENV{GOOD}) | ||||||
517 | { | ||||||
518 | $code = "package ___junkit; $preamble \$return = Devel::EdTrace::___split_screen(\$width, q$input_line, q$eval_input_line) . \"\\n\""; | ||||||
519 | } | ||||||
520 | else | ||||||
521 | { | ||||||
522 | $code = "package ___junkit; $preamble \$return = Devel::EdTrace::___split_screen(\$width, q$input_line, qq$eval_input_line) . \"\\n\""; | ||||||
523 | } | ||||||
524 | # my $code = "$preamble"; | ||||||
525 | # my $code = "$preamble \$return = ___split_screen(\$width, q$input_line) . \"\\n\""; | ||||||
526 | $code .= "\n}"; | ||||||
527 | # print STDERR "CODE:\n----\n$code\n----\n"; | ||||||
528 | # sleep(1); | ||||||
529 | package ___junkit; | ||||||
530 | my $oldeval = $@; | ||||||
531 | eval($code); | ||||||
532 | package Devel::EdTrace; | ||||||
533 | # print STDERR ">>>$return<<<"; | ||||||
534 | |||||||
535 | my %symafter = map { $_ => 1 } keys(%YPAN::Map::Build::); | ||||||
536 | |||||||
537 | if (%symafter != %symbefore) | ||||||
538 | { | ||||||
539 | foreach $sym (keys(%symafter)) | ||||||
540 | { | ||||||
541 | if (!$symbefore{$sym}) | ||||||
542 | { | ||||||
543 | print STDERR "SYMBOL :$sym: was introduced\n"; | ||||||
544 | print STDERR "YEEHAW :$code:\n"; | ||||||
545 | } | ||||||
546 | } | ||||||
547 | } | ||||||
548 | |||||||
549 | # print STDERR "CODE:\n\n----\n$code\n----\n$@\n----\n"; | ||||||
550 | |||||||
551 | if ($@) | ||||||
552 | { | ||||||
553 | # print STDERR "^^^^$code^^^^$input_line^^^^ :$@: RRR :$return:\n"; | ||||||
554 | # print STDERR "WHAT THE..:$@: -- :$code:\n"; | ||||||
555 | print STDERR join("\n", @bad_lines) . "\n"; | ||||||
556 | print STDERR "BAD LINE: :$input_line: :$eval_input_line: :$@:\n"; | ||||||
557 | $@ = $oldeval; | ||||||
558 | return("\n" . ___split_screen($width, $input_line, $eval_input_line) . "\n"); | ||||||
559 | } | ||||||
560 | elsif ($input_line =~ m"backpan_mname") | ||||||
561 | { | ||||||
562 | print STDERR "AUTOVIV\n"; | ||||||
563 | print STDERR join("\n", @bad_lines) . "\n"; | ||||||
564 | } | ||||||
565 | |||||||
566 | $@ = $oldeval; | ||||||
567 | |||||||
568 | # sleep(1); | ||||||
569 | |||||||
570 | # print STDERR "HERE4 :$return:\n"; | ||||||
571 | # sleep(4); | ||||||
572 | |||||||
573 | # my $code = "\$return = sub { $preamble; return( q{ $input_line <=> } . qq{ $input_line } . \"\\\n\"; ); }->()"; | ||||||
574 | # print STDERR "$input_line"; | ||||||
575 | # print STDERR $code; | ||||||
576 | # sleep(1); | ||||||
577 | # print STDERR "HERE1\n"; | ||||||
578 | # DB::eval($code); | ||||||
579 | # print STDERR "HERE2: $return\n"; | ||||||
580 | # sleep(1); | ||||||
581 | # $return = "\n$return"; | ||||||
582 | $return = "\n$return"; | ||||||
583 | return($return); | ||||||
584 | } | ||||||
585 | |||||||
586 | |||||||
587 | sub ___unbracket_surgery | ||||||
588 | { | ||||||
589 | my ($eval_input_line) = @_; | ||||||
590 | |||||||
591 | $_[0] =~ s"AOPBRACK"{"sg; | ||||||
592 | $_[0] =~ s"CLSBRACK"}"sg; | ||||||
593 | } | ||||||
594 | |||||||
595 | |||||||
596 | |||||||
597 | sub ___bracket_surgery | ||||||
598 | { | ||||||
599 | my ($brack, $orig, $type, $found_so_far) = @_; | ||||||
600 | |||||||
601 | # if ($brack =~ m"self.*os") | ||||||
602 | # { | ||||||
603 | # print STDERR "YEARGH :$orig: :$brack:\n"; | ||||||
604 | # } | ||||||
605 | return($brack) if ($brack =~ m"^\s*{\s*\["); | ||||||
606 | $brack =~ s"^{""s; | ||||||
607 | $brack =~ s"}\Z""s; | ||||||
608 | |||||||
609 | my $ql = _get_ql($orig, $found_so_far); | ||||||
610 | if ($type eq 'quotemeta') | ||||||
611 | { | ||||||
612 | $brack = "qq${ql}$brack${ql}"; | ||||||
613 | return($brack); | ||||||
614 | } | ||||||
615 | |||||||
616 | if ($type eq 'func_call') | ||||||
617 | { | ||||||
618 | if ($brack =~ m"\s|\(|\)"s) | ||||||
619 | { | ||||||
620 | $brack = "AOPBRACKqq${ql}$brack${ql}CLSBRACK"; | ||||||
621 | } | ||||||
622 | return($brack); | ||||||
623 | } | ||||||
624 | |||||||
625 | $brack = "AOPBRACKqq${ql}$brack${ql}CLSBRACK"; | ||||||
626 | |||||||
627 | return($brack); | ||||||
628 | } | ||||||
629 | |||||||
630 | sub _get_ql | ||||||
631 | { | ||||||
632 | my ($orig, $found_so_far) = @_; | ||||||
633 | |||||||
634 | my $ql; | ||||||
635 | |||||||
636 | my $quot; | ||||||
637 | foreach $quot (@$_quotables) | ||||||
638 | { | ||||||
639 | my $qm = quotemeta($quot); | ||||||
640 | if (!$found_so_far->{$quot}) | ||||||
641 | { | ||||||
642 | if ($orig =~ m"$qm") { $found_so_far->{$quot} = 1; } else { $ql = $quot; $found_so_far->{$quot} = 1; last; } | ||||||
643 | } | ||||||
644 | } | ||||||
645 | |||||||
646 | if (scalar(keys(%$found_so_far)) == @$_quotables) { die "SYSTEM ERROR: Could unparsable piece of code!\n"; } | ||||||
647 | else | ||||||
648 | { | ||||||
649 | # print STDERR scalar(keys(%$found_so_far)) . "," . @$_quotables . "\n"; | ||||||
650 | } | ||||||
651 | return($ql); | ||||||
652 | } | ||||||
653 | |||||||
654 | |||||||
655 | my $_destroy_lines = {}; | ||||||
656 | |||||||
657 | sub ___in_destroy_flag | ||||||
658 | { | ||||||
659 | my ($file, $line, $code_lines) = @_; | ||||||
660 | |||||||
661 | if (!$_destroy_lines->{$file}) | ||||||
662 | { | ||||||
663 | my @range; | ||||||
664 | my $start_destroy = 0; | ||||||
665 | |||||||
666 | my $xx; | ||||||
667 | for ($xx = 1; $xx <= @$code_lines; $xx++) | ||||||
668 | { | ||||||
669 | if ($code_lines->[$xx-1] =~ m"sub\s*DESTROY") | ||||||
670 | { | ||||||
671 | # print STDERR "$file -- $line -- " . join("\n", @$code_lines) . "\n"; | ||||||
672 | # sleep(5); | ||||||
673 | $start_destroy = 1; | ||||||
674 | $range[0] = $xx-1; | ||||||
675 | } | ||||||
676 | elsif ($start_destroy && ($code_lines->[$xx-1] =~ m"sub\s" || $xx == @$code_lines)) | ||||||
677 | { | ||||||
678 | $range[1] = $xx-1; | ||||||
679 | push(@{$_destroy_lines->{$file}}, [ @range ]); | ||||||
680 | # print STDERR Dumper($_destroy_lines); | ||||||
681 | # sleep(5); | ||||||
682 | |||||||
683 | @range = (); | ||||||
684 | $start_destroy = 0; | ||||||
685 | } | ||||||
686 | } | ||||||
687 | } | ||||||
688 | |||||||
689 | my $range; | ||||||
690 | foreach $range (@{$_destroy_lines->{$file}}) | ||||||
691 | { | ||||||
692 | if ($line >= $range->[0] && $line <= $range->[1]) | ||||||
693 | { | ||||||
694 | return(1); | ||||||
695 | } | ||||||
696 | } | ||||||
697 | return(0); | ||||||
698 | } | ||||||
699 | |||||||
700 | sub ___defined | ||||||
701 | { | ||||||
702 | my ($val) = @_; | ||||||
703 | |||||||
704 | if (ref($val) =~ m"SCALAR" && !defined($$val)) { return(0); } | ||||||
705 | if (ref($val) =~ m"ARRAY" && !@$val) { return(0); } | ||||||
706 | if (ref($val) =~ m"HASH" && !scalar(%$val)) { return(0); } | ||||||
707 | |||||||
708 | return(1); | ||||||
709 | } | ||||||
710 | |||||||
711 | |||||||
712 | sub ___split_screen | ||||||
713 | { | ||||||
714 | my ($width, $arg1, $arg2) = @_; | ||||||
715 | |||||||
716 | if ($ENV{DRYRUN}) { $arg2 = $arg1; } | ||||||
717 | # print STDERR "FFFFF\n"; | ||||||
718 | # return($arg1); | ||||||
719 | $arg1 =~ s"\n"\\n"sg; | ||||||
720 | $arg2 =~ s"\n"\\n"sg; | ||||||
721 | |||||||
722 | $arg1 =~ s"\t" "sg; | ||||||
723 | $arg2 =~ s"\t" "sg; | ||||||
724 | |||||||
725 | my $ret; | ||||||
726 | my $totlength = (length($arg1) > length($arg2))? | ||||||
727 | length($arg1) : | ||||||
728 | length($arg2); | ||||||
729 | |||||||
730 | my $noperline = int($width/2) - 3; | ||||||
731 | my $lines = "<" x $noperline; | ||||||
732 | |||||||
733 | my $nolines = int($totlength/(int($width/2) - 3)) + 1; | ||||||
734 | |||||||
735 | |||||||
736 | my (@val1) = ($arg1 =~ m"(.{1,$noperline})"sg); | ||||||
737 | my (@val2) = ($arg2 =~ m"(.{1,$noperline})"sg); | ||||||
738 | |||||||
739 | my $xx; | ||||||
740 | for ($xx = 0; $xx < $nolines; $xx++) | ||||||
741 | { | ||||||
742 | $val1[$xx] ||= ''; | ||||||
743 | $val2[$xx] ||= ''; | ||||||
744 | |||||||
745 | $ret .= " $val1[$xx]" . " " x ($noperline - length($val1[$xx])) . " | "; | ||||||
746 | $ret .= " $val2[$xx]" . " " x ($noperline - length($val2[$xx])) . "\n"; | ||||||
747 | } | ||||||
748 | |||||||
749 | chomp($ret); | ||||||
750 | return($ret); | ||||||
751 | } | ||||||
752 | |||||||
753 | sub ___print | ||||||
754 | { | ||||||
755 | my ($text) = @_; | ||||||
756 | |||||||
757 | if ($Devel::EdTrace::GrepRegex && $text !~ m"$Devel::EdTrace::GrepRegex") { return() }; | ||||||
758 | |||||||
759 | # if ($Devel::EdTrace::PrintLevel == 1) | ||||||
760 | # { | ||||||
761 | if ($tlfh) { print $tlfh $text; } else { print STDERR $text; } | ||||||
762 | # } | ||||||
763 | # else | ||||||
764 | # { | ||||||
765 | # if ($tlfh) { print $tlfh ___traceit($text); } else { print STDERR ___traceit($text); } | ||||||
766 | # } | ||||||
767 | if ($ENV{TRACESYS}) { my $oldsys = $?; system("$ENV{TRACESYS}"); $? = $oldsys; } | ||||||
768 | } | ||||||
769 | |||||||
770 | sub ___traceit | ||||||
771 | { | ||||||
772 | my $caller = [ caller(3) ]; # hack | ||||||
773 | return( join(" -- ", @$caller[0,1,2,3]). "\n\t" . $_[0] ); | ||||||
774 | } | ||||||
775 | |||||||
776 | sub ___printwatchpoints | ||||||
777 | { | ||||||
778 | if ($ENV{TRACEWATCH}) | ||||||
779 | { | ||||||
780 | my @vars = split(m":", $ENV{TRACEWATCH}); | ||||||
781 | my $var; | ||||||
782 | |||||||
783 | my $var; | ||||||
784 | foreach $var (@vars) | ||||||
785 | { | ||||||
786 | if (___diff('my', $var)) { ___printdiff('my', $var); ___set('my', $var); } | ||||||
787 | if (___diff('our', $var)) { ___printdiff('our', $var); ___set('our', $var); } | ||||||
788 | if (___diff('glob', $var)) { ___printdiff('glob', $var); ___set('glob', $var); } | ||||||
789 | } | ||||||
790 | } | ||||||
791 | } | ||||||
792 | |||||||
793 | sub ___printreversewatchpoints | ||||||
794 | { | ||||||
795 | if ($ENV{TRACEREVERSE}) | ||||||
796 | { | ||||||
797 | my @rwatch = split(m"<->", $ENV{TRACEREVERSE}); | ||||||
798 | |||||||
799 | grep(s"<\\->"<->"sg, @rwatch); | ||||||
800 | grep(s"\|"\\|"sg, @rwatch); | ||||||
801 | |||||||
802 | my $rwatch = join('|', @rwatch); | ||||||
803 | |||||||
804 | my $var; | ||||||
805 | foreach $var (___globals(3)) | ||||||
806 | { | ||||||
807 | # print STDERR "WHOA : :$var:\n"; | ||||||
808 | if (___diff('glob', $var) && ___printgrep('glob', $var, $rwatch)) | ||||||
809 | { | ||||||
810 | # print STDERR "AHA1: $var :$rwatch:\n"; | ||||||
811 | ___set('glob', $var); | ||||||
812 | } | ||||||
813 | } | ||||||
814 | |||||||
815 | foreach $var (___ours(3)) | ||||||
816 | { | ||||||
817 | if (___diff('our', $var) && ___printgrep('our', $var, $rwatch)) | ||||||
818 | { | ||||||
819 | # print STDERR "AHA2: $var :$rwatch:\n"; | ||||||
820 | ___set('our', $var); | ||||||
821 | } | ||||||
822 | } | ||||||
823 | |||||||
824 | my @vars = ___mys(3); | ||||||
825 | |||||||
826 | foreach $var (___mys(3)) | ||||||
827 | { | ||||||
828 | # print STDERR "AHAAAA :$var: mydiff: " . ___diff('my', $var) . "\n"; | ||||||
829 | # sleep(2); | ||||||
830 | if (___diff('my', $var) && ___printgrep('my', $var, $rwatch)) | ||||||
831 | { | ||||||
832 | # sleep(10); | ||||||
833 | # print STDERR "AHA3: $var :$rwatch:\n"; | ||||||
834 | ___set('my', $var); | ||||||
835 | } | ||||||
836 | } | ||||||
837 | } | ||||||
838 | } | ||||||
839 | |||||||
840 | sub ___globals | ||||||
841 | { | ||||||
842 | my ($scope) = @_; | ||||||
843 | |||||||
844 | no strict 'refs'; | ||||||
845 | my $package = ___getpkg('glob', undef, $scope); | ||||||
846 | |||||||
847 | my @return; | ||||||
848 | my @varnames = keys(%{"${package}::"}); | ||||||
849 | |||||||
850 | my $var; | ||||||
851 | foreach $var (@varnames) | ||||||
852 | { | ||||||
853 | |||||||
854 | next if ($var !~ m"\w"); | ||||||
855 | next if ($var =~ m"<"); | ||||||
856 | next if ($var =~ m"::"); | ||||||
857 | |||||||
858 | if (defined(%{${"${package}::"}{$var}})) | ||||||
859 | { | ||||||
860 | push(@return, "%$var"); | ||||||
861 | } | ||||||
862 | if (defined(@{${"${package}::"}{$var}})) | ||||||
863 | { | ||||||
864 | push(@return, "\@$var"); | ||||||
865 | } | ||||||
866 | if (defined(${${"${package}::"}{$var}})) | ||||||
867 | { | ||||||
868 | push(@return, "\$$var"); | ||||||
869 | } | ||||||
870 | } | ||||||
871 | |||||||
872 | return(@return); | ||||||
873 | } | ||||||
874 | |||||||
875 | sub ___ours | ||||||
876 | { | ||||||
877 | my ($scope) = @_; | ||||||
878 | |||||||
879 | my $hdl = peek_our($scope); | ||||||
880 | |||||||
881 | return(keys(%$hdl)); | ||||||
882 | } | ||||||
883 | |||||||
884 | sub ___mys | ||||||
885 | { | ||||||
886 | my ($scope) = @_; | ||||||
887 | my $hdl = peek_my($scope); | ||||||
888 | |||||||
889 | return(keys(%$hdl)); | ||||||
890 | } | ||||||
891 | |||||||
892 | sub ___set | ||||||
893 | { | ||||||
894 | my ($type, $variable, $value) = @_; | ||||||
895 | |||||||
896 | my $package = ___getpkg($type, $variable, 3); | ||||||
897 | |||||||
898 | my ($val); | ||||||
899 | if (@_ == 3) | ||||||
900 | { | ||||||
901 | undef($_cached->{$type}{$package}{$variable}); | ||||||
902 | } | ||||||
903 | else | ||||||
904 | { | ||||||
905 | $_cached->{$type}{$package}{$variable} = ___copy($type, $variable); | ||||||
906 | } | ||||||
907 | } | ||||||
908 | |||||||
909 | |||||||
910 | sub ___copy | ||||||
911 | { | ||||||
912 | my ($type, $variable) = @_; | ||||||
913 | |||||||
914 | no strict 'refs'; | ||||||
915 | my ($old, $new) = ___lookup($type, $variable, 5); | ||||||
916 | |||||||
917 | # print STDERR Dumper($old, $new); | ||||||
918 | |||||||
919 | return(deepcopy($new)); | ||||||
920 | } | ||||||
921 | |||||||
922 | sub ___getpkg | ||||||
923 | { | ||||||
924 | my ($type, $variable, $scope) = @_; | ||||||
925 | |||||||
926 | $scope ||= 4; | ||||||
927 | |||||||
928 | return($type) if ($type eq 'our' || $type eq 'my'); | ||||||
929 | my ($p, $f, $l) = caller($scope); | ||||||
930 | return($p); | ||||||
931 | } | ||||||
932 | |||||||
933 | sub ___printgrep | ||||||
934 | { | ||||||
935 | my ($type, $variable, $rwatch) = @_; | ||||||
936 | |||||||
937 | my ($old, $new)= ___lookup($type, $variable, 4); | ||||||
938 | |||||||
939 | # print STDERR "HERE: $variable: " . Dumper($old, $new) if ($variable =~ m"%ary" && $type eq 'our'); | ||||||
940 | |||||||
941 | # print STDERR "AHAME :$old: :$new: :$variable: :$rwatch:\n"; | ||||||
942 | # sleep(2); | ||||||
943 | my $status = _datagrep | ||||||
944 | ( | ||||||
945 | $rwatch, $new, | ||||||
946 | { | ||||||
947 | name => $variable, | ||||||
948 | filter => sub | ||||||
949 | { | ||||||
950 | # print STDERR Dumper($_[1]); | ||||||
951 | # print STDERR "@{$_[1]}"; | ||||||
952 | return(0) if ($_[2]->{name} ne '%ENV'); | ||||||
953 | return(1) if ($_[2]->{name} =~ m"%ENV" && "@{$_[1]}" =~ m"TRACEREVERSE"); | ||||||
954 | return(0); | ||||||
955 | }, | ||||||
956 | grepkey => 1, | ||||||
957 | type => $type | ||||||
958 | } | ||||||
959 | ); | ||||||
960 | return($status); | ||||||
961 | } | ||||||
962 | |||||||
963 | sub ___printdiff | ||||||
964 | { | ||||||
965 | my ($type, $variable) = @_; | ||||||
966 | |||||||
967 | my ($old, $new) = ___lookup($type, $variable,4); | ||||||
968 | |||||||
969 | if (ref($old) eq ref($new)) | ||||||
970 | { | ||||||
971 | ___compare($type, $variable); | ||||||
972 | } | ||||||
973 | elsif | ||||||
974 | ( | ||||||
975 | defined($old) || | ||||||
976 | (!defined($old) && ref($new) eq 'SCALAR' && defined(${$new})) || | ||||||
977 | (!defined($old) && ref($new) ne 'SCALAR') | ||||||
978 | ) | ||||||
979 | { | ||||||
980 | my $package = ___getpkg($type, $variable, 3); | ||||||
981 | my ($sigil, $name) = ( $variable =~ m"(.)(.*)"); | ||||||
982 | |||||||
983 | my $dumpa = ___dump($old, $name); | ||||||
984 | my $dumpb = ___dump($new, $name); | ||||||
985 | |||||||
986 | if ($dumpa =~ m"\n") { $dumpa =~ s"\n\s*"\n\t\t\t"sg; $dumpa = "\n\t\t$dumpa"; } | ||||||
987 | if ($dumpb =~ m"\n") { $dumpb =~ s"\n\s*"\n\t\t\t"sg; $dumpb = "\n\t\t$dumpb"; } | ||||||
988 | |||||||
989 | ___print ( " $type $variable: $dumpa +++> $dumpb" . "\n"); | ||||||
990 | } | ||||||
991 | } | ||||||
992 | |||||||
993 | sub ___ref | ||||||
994 | { | ||||||
995 | my ($var) = @_; | ||||||
996 | |||||||
997 | my $type = (defined($var) && ref($var) eq 'SCALAR' && ref($$var))? ref($$var) : | ||||||
998 | (defined($var) && ref($var) ne 'SCALAR')? ref($var) : | ||||||
999 | (!defined($var))? 'undef' : | ||||||
1000 | 'scalar'; | ||||||
1001 | return($type); | ||||||
1002 | } | ||||||
1003 | |||||||
1004 | sub ___dump | ||||||
1005 | { | ||||||
1006 | my ($var, $name) = @_; | ||||||
1007 | |||||||
1008 | local($Data::Dumper::Varname) = "ZYZYZYZYZYZYZ"; | ||||||
1009 | |||||||
1010 | my $ret = | ||||||
1011 | (defined($var) && ref($var) eq 'SCALAR' && ref($$var))? Dumper($$var) : | ||||||
1012 | (defined($var) && ref($var) ne 'SCALAR')? Dumper($var) : | ||||||
1013 | (!defined($var))? 'undef' : | ||||||
1014 | (ref($var) eq 'SCALAR')? "'$$var'" : | ||||||
1015 | "'$var'"; | ||||||
1016 | |||||||
1017 | $ret =~ s"ZYZYZYZYZYZYZ1"$name"sg; | ||||||
1018 | |||||||
1019 | return($ret); | ||||||
1020 | } | ||||||
1021 | |||||||
1022 | sub ___diff | ||||||
1023 | { | ||||||
1024 | my ($type, $var) = @_; | ||||||
1025 | |||||||
1026 | my ($oldvar, $newvar) = ___lookup($type, $var,4); | ||||||
1027 | # print STDERR ":$oldvar: :$newvar:\n"; | ||||||
1028 | # print STDERR ":$type: :$var: :$oldvar: :$newvar:\n"; | ||||||
1029 | # sleep(1); | ||||||
1030 | |||||||
1031 | return() if (!$oldvar && !$newvar); | ||||||
1032 | |||||||
1033 | my $status = checkEq($oldvar, $newvar); | ||||||
1034 | # print STDERR "STATUS: " . Dumper ($status) . "\n"; | ||||||
1035 | return(!$status) if (!ref($status)); | ||||||
1036 | return(1) if (ref($status)); | ||||||
1037 | |||||||
1038 | # print STDERR Dumper($oldvar, $newvar, $status) if ($var =~m"hash"); | ||||||
1039 | # return(!checkEq($oldvar, $newvar)); | ||||||
1040 | } | ||||||
1041 | |||||||
1042 | my $_die; | ||||||
1043 | sub ___lookup | ||||||
1044 | { | ||||||
1045 | my ($type, $var, $scope) = @_; | ||||||
1046 | |||||||
1047 | $scope ||= 4; | ||||||
1048 | my $package = ___getpkg($type, $var, $scope); | ||||||
1049 | |||||||
1050 | my $oldvar = $_cached->{$type}{$package}{$var}; | ||||||
1051 | my $hdl; | ||||||
1052 | my $newvar; | ||||||
1053 | |||||||
1054 | # print STDERR "HERE!!!!!! :$var: :$hdl->{$var} :$newvar:\n"; | ||||||
1055 | |||||||
1056 | if ($type eq 'my') | ||||||
1057 | { | ||||||
1058 | $hdl = peek_my($scope); | ||||||
1059 | $newvar = (!defined($hdl->{$var}))? undef : | ||||||
1060 | ($var =~ m"^\%")? \%{$hdl->{$var}} : | ||||||
1061 | ($var =~ m"^\@")? \@{$hdl->{$var}} : | ||||||
1062 | ${$hdl->{$var}}; | ||||||
1063 | |||||||
1064 | # print STDERR "DONE :$newvar:\n"; | ||||||
1065 | } | ||||||
1066 | elsif ($type eq 'our') | ||||||
1067 | { | ||||||
1068 | $hdl = peek_our($scope); | ||||||
1069 | $newvar = (!defined($hdl->{$var}))? undef : | ||||||
1070 | ($var =~ m"^\%")? \%{$hdl->{$var}} : | ||||||
1071 | ($var =~ m"^\@")? \@{$hdl->{$var}} : | ||||||
1072 | ${$hdl->{$var}}; | ||||||
1073 | } | ||||||
1074 | else | ||||||
1075 | { | ||||||
1076 | |||||||
1077 | no strict 'refs'; | ||||||
1078 | my ($sigil, $name) = ($var =~ m"(.)(.*)"s); | ||||||
1079 | # print STDERR "YEEHAW :$sigil: :$name:\n"; | ||||||
1080 | my $sym = ${"${package}::"}{$name}; | ||||||
1081 | # print STDERR "DUMB THING\n"; | ||||||
1082 | |||||||
1083 | # print STDERR "WHOA!!!! :$:$sym: \n"; | ||||||
1084 | $newvar = | ||||||
1085 | ($sigil eq '$' && ref(${$sym}))? ${$sym} : | ||||||
1086 | ($sigil eq '$')? \${$sym} : | ||||||
1087 | ($sigil eq '%')? \%{$sym} : | ||||||
1088 | ($sigil eq '@')? \@{$sym} : | ||||||
1089 | print STDERR "SYSTEM ERROR: Unknown Sigil $sigil for variable $name\n"; | ||||||
1090 | } | ||||||
1091 | return($oldvar, $newvar); | ||||||
1092 | } | ||||||
1093 | |||||||
1094 | sub ___compare | ||||||
1095 | { | ||||||
1096 | my ($type, $varname) = @_; | ||||||
1097 | |||||||
1098 | my ($old, $new) = ___lookup($type, $varname, 5); | ||||||
1099 | checkData | ||||||
1100 | ( | ||||||
1101 | $old, $new, | ||||||
1102 | { | ||||||
1103 | check_data_type => $type, | ||||||
1104 | check_data_varname => $varname, | ||||||
1105 | check_data_coderef => | ||||||
1106 | sub | ||||||
1107 | { | ||||||
1108 | my ($a, $b, $config) = @_; | ||||||
1109 | if ($a ne $b) | ||||||
1110 | { | ||||||
1111 | |||||||
1112 | if (!defined($a)) { $a = 'undef' } else { $a = "'$a'"; } | ||||||
1113 | if (!defined($b)) { $b = 'undef' } else { $b = "'$b'"; } | ||||||
1114 | |||||||
1115 | ___print( | ||||||
1116 | " $config->{check_data_type} $config->{check_data_varname} " . | ||||||
1117 | join("", @{$config->{data_path}}) . " : $a => $b\n"); | ||||||
1118 | } | ||||||
1119 | } | ||||||
1120 | } | ||||||
1121 | ); | ||||||
1122 | } | ||||||
1123 | |||||||
1124 | sub ___printheader | ||||||
1125 | { | ||||||
1126 | if ($tlfh) | ||||||
1127 | { | ||||||
1128 | print $tlfh ___header(); | ||||||
1129 | } | ||||||
1130 | else | ||||||
1131 | { | ||||||
1132 | print STDERR ___header(); | ||||||
1133 | } | ||||||
1134 | } | ||||||
1135 | |||||||
1136 | sub ___header | ||||||
1137 | { | ||||||
1138 | my $ret = | ||||||
1139 | "-----\n%ENV = \n\t" . Dumper(\%ENV) . | ||||||
1140 | "\n----\n%INC = \n\t" . Dumper(\%INC) . | ||||||
1141 | "\n----\n\@INC = \n\t" . Dumper(\@INC) . | ||||||
1142 | "\n----\n\@ARGV = \n\t" . Dumper(\@ARGV) . "\n-----\n"; | ||||||
1143 | |||||||
1144 | return($ret); | ||||||
1145 | } | ||||||
1146 | |||||||
1147 | sub ___gettfh | ||||||
1148 | { | ||||||
1149 | fclose($tlfh) if ($tlfh); | ||||||
1150 | |||||||
1151 | my $dir = $0; | ||||||
1152 | $dir =~ s".*/""sg; | ||||||
1153 | |||||||
1154 | my $tfile = | ||||||
1155 | ($ENV{TRACELOG} && $ENV{TRACEPID})? | ||||||
1156 | "$ENV{TRACELOG}.$$" : | ||||||
1157 | ($ENV{TRACELOG} && !$ENV{TRACEPID})? | ||||||
1158 | "$ENV{TRACELOG}" : | ||||||
1159 | ($ENV{TRACEDIR} && $ENV{TRACEPID})? | ||||||
1160 | "$ENV{TRACEDIR}/$dir.$$" : | ||||||
1161 | ($ENV{TRACEDIR} && !$ENV{TRACEPID})? | ||||||
1162 | "$ENV{TRACEDIR}/$dir" : | ||||||
1163 | ""; | ||||||
1164 | |||||||
1165 | my $tlfh2 = ($ENV{TRACERM} && $tfile)? | ||||||
1166 | FileHandle->new("> $tfile") : | ||||||
1167 | ($tfile)? FileHandle->new(">> $tfile") : | ||||||
1168 | undef; | ||||||
1169 | $tlfh = $tlfh2; | ||||||
1170 | return($tlfh2); | ||||||
1171 | } | ||||||
1172 | |||||||
1173 | sub ___setdelay { my ($cb) = @_; $ENV{TRACEDELAY} = $cb; } | ||||||
1174 | sub ___setcb { my ($cb) = @_; $ENV{TRACECB} = $cb; } | ||||||
1175 | |||||||
1176 | BEGIN | ||||||
1177 | { | ||||||
1178 | ___gettfh(); | ||||||
1179 | ___printheader() if ($ENV{TRACEHEADER}); | ||||||
1180 | } | ||||||
1181 | |||||||
1182 | sub import | ||||||
1183 | { | ||||||
1184 | my $package = shift; | ||||||
1185 | foreach (@_) { | ||||||
1186 | if ($_ eq 'trace') { | ||||||
1187 | my $caller = caller; | ||||||
1188 | *{$caller . '::trace'} = \&{$package . '::trace'}; | ||||||
1189 | } else { | ||||||
1190 | use Carp; | ||||||
1191 | croak "Package $package does not export `$_'; aborting"; | ||||||
1192 | } | ||||||
1193 | } | ||||||
1194 | } | ||||||
1195 | |||||||
1196 | my %tracearg = ('on' => 1, 'off' => 0); | ||||||
1197 | sub trace { | ||||||
1198 | my $arg = shift; | ||||||
1199 | $arg = $tracearg{$arg} while exists $tracearg{$arg}; | ||||||
1200 | $TRACE = $arg; | ||||||
1201 | } | ||||||
1202 | |||||||
1203 | sub ___junkit::AUTOLOAD | ||||||
1204 | { | ||||||
1205 | no strict; | ||||||
1206 | my $method = $AUTOLOAD; | ||||||
1207 | $method =~ s".*::""sg; | ||||||
1208 | |||||||
1209 | if ($Devel::EdTrace::SafeGuard) | ||||||
1210 | { | ||||||
1211 | my $args = join(",", @_); | ||||||
1212 | return("$method\($args\)"); | ||||||
1213 | } | ||||||
1214 | else | ||||||
1215 | { | ||||||
1216 | my @stack = caller(3); | ||||||
1217 | &{"$stack[0]"}(@_); | ||||||
1218 | } | ||||||
1219 | } | ||||||
1220 | |||||||
1221 | sub AUTOLOAD | ||||||
1222 | { | ||||||
1223 | no strict; | ||||||
1224 | my $method = $AUTOLOAD; | ||||||
1225 | $method =~ s".*::""sg; | ||||||
1226 | |||||||
1227 | if ($Devel::EdTrace::SafeGuard) | ||||||
1228 | { | ||||||
1229 | my $args = join(",", @_); | ||||||
1230 | return("$method\($args\)"); | ||||||
1231 | } | ||||||
1232 | else | ||||||
1233 | { | ||||||
1234 | my @stack = caller(3); | ||||||
1235 | &{"$stack[0]"}(@_); | ||||||
1236 | } | ||||||
1237 | } | ||||||
1238 | 1; | ||||||
1239 | |||||||
1240 | |||||||
1241 | =head1 NAME | ||||||
1242 | |||||||
1243 | Devel::EdTrace - Print out each line before it is executed (like C |
||||||
1244 | |||||||
1245 | =head1 SYNOPSIS | ||||||
1246 | |||||||
1247 | perl -d:Trace program | ||||||
1248 | |||||||
1249 | =head1 DESCRIPTION | ||||||
1250 | |||||||
1251 | If you run your program with C |
||||||
1252 | will print a message to standard error just before each line is executed. | ||||||
1253 | For example, if your program looks like this: | ||||||
1254 | |||||||
1255 | #!/usr/bin/perl | ||||||
1256 | |||||||
1257 | |||||||
1258 | print "Statement 1 at line 4\n"; | ||||||
1259 | print "Statement 2 at line 5\n"; | ||||||
1260 | print "Call to sub x returns ", &x(), " at line 6.\n"; | ||||||
1261 | |||||||
1262 | exit 0; | ||||||
1263 | |||||||
1264 | |||||||
1265 | sub x { | ||||||
1266 | print "In sub x at line 12.\n"; | ||||||
1267 | return 13; | ||||||
1268 | } | ||||||
1269 | |||||||
1270 | Then the C |
||||||
1271 | |||||||
1272 | >> ./test:4: print "Statement 1 at line 4\n"; | ||||||
1273 | >> ./test:5: print "Statement 2 at line 5\n"; | ||||||
1274 | >> ./test:6: print "Call to sub x returns ", &x(), " at line 6.\n"; | ||||||
1275 | >> ./test:12: print "In sub x at line 12.\n"; | ||||||
1276 | >> ./test:13: return 13; | ||||||
1277 | >> ./test:8: exit 0; | ||||||
1278 | |||||||
1279 | This is something like the shell's C<-x> option. | ||||||
1280 | |||||||
1281 | =head1 DETAILS | ||||||
1282 | |||||||
1283 | Inside your program, you can enable and disable tracing by doing | ||||||
1284 | |||||||
1285 | $Devel::EdTrace::TRACE = 1; # Enable | ||||||
1286 | $Devel::EdTrace::TRACE = 0; # Disable | ||||||
1287 | |||||||
1288 | or | ||||||
1289 | |||||||
1290 | Devel::EdTrace::trace('on'); # Enable | ||||||
1291 | Devel::EdTrace::trace('off'); # Disable | ||||||
1292 | |||||||
1293 | C |
||||||
1294 | |||||||
1295 | import Devel::EdTrace 'trace'; | ||||||
1296 | |||||||
1297 | Then if you want you just say | ||||||
1298 | |||||||
1299 | trace 'on'; # Enable | ||||||
1300 | trace 'off'; # Disable | ||||||
1301 | |||||||
1302 | |||||||
1303 | New features: | ||||||
1304 | |||||||
1305 | $Devel::EdTrace::PrintEval (or environmental variable TRACEEVAL) | ||||||
1306 | - Sets whether or not you want to have 'constant eval set on' This evaluates | ||||||
1307 | and shows the value of the variables evaluated on a left panel of the scrren. | ||||||
1308 | For example: | ||||||
1309 | |||||||
1310 | >> for ($xx = 0; $xx < 10; $xx++) | for ( = 0; < 10; ++) | ||||||
1311 | >> { | { | ||||||
1312 | >> $yy = $xx; | = 0 | ||||||
1313 | >> } | } | ||||||
1314 | |||||||
1315 | Note that the eval happens before the statement, not after. | ||||||
1316 | |||||||
1317 | $Devel::EdTrace::PrintLevel (or environmental variable TRACELEVEL) | ||||||
1318 | |||||||
1319 | - sets whether or not indent is going to be turned on. | ||||||
1320 | |||||||
1321 | If set to one, no indent is done. | ||||||
1322 | |||||||
1323 | If set to 2, all output will be indented to the level | ||||||
1324 | at which the code was called (ie: the number of frames in) | ||||||
1325 | |||||||
1326 | $Devel::EdTrace::ExpandBuiltin (or environmental variable TRACEBUILTIN) | ||||||
1327 | |||||||
1328 | - when set to 1 - and in conjunction with PrintEval, makes the functions | ||||||
1329 | keys, values and map be evaluated in place when evaluated | ||||||
1330 | |||||||
1331 | - when set to a pipe (|) separated list, evaluates all functions in the list | ||||||
1332 | (eg: $ENV{TRACEBUILTIN} = 'keys|values' will evaluate keys and values functions) | ||||||
1333 | |||||||
1334 | $Devel::EdTrace::TraceSys (or environmental variable TRACESYS) | ||||||
1335 | |||||||
1336 | - Causes each statement in the code to be followed by a system call (the one | ||||||
1337 | in TRACESYS). For example | ||||||
1338 | |||||||
1339 | $ENV{TRACESYS} = 'ls' | ||||||
1340 | |||||||
1341 | will do an 'ls' before each perl statement. | ||||||
1342 | |||||||
1343 | Environmental variable TRACELOG | ||||||
1344 | |||||||
1345 | Puts all tracing to a log (named tracelog). | ||||||
1346 | |||||||
1347 | Envionmental variable TRACERM | ||||||
1348 | |||||||
1349 | In conjunction with TRACELOG, removes any previous tracelog before writing to the new tracelog. | ||||||
1350 | |||||||
1351 | =head1 Author | ||||||
1352 | |||||||
1353 | =begin text | ||||||
1354 | |||||||
1355 | Initial module by Mark-Jason Dominus (C |
||||||
1356 | Heavily modified, renamed by Edward Peschko (horos22@yahoo.com) | ||||||
1357 | |||||||
1358 | =end text | ||||||
1359 | |||||||
1360 | =begin man | ||||||
1361 | |||||||
1362 | Edward Peschko (horos22@gmail.com>). | ||||||
1363 | |||||||
1364 | =end man | ||||||
1365 | |||||||
1366 | =begin html | ||||||
1367 | Original module by Mark-Jason Dominus (mjd-perl-trace@plover.com), Plover Systems co. |
||||||
1368 | heavily modified by Edward Peschko (mjd-perl-trace@plover.com), Plover Systems co. |
||||||
1369 | See The Devel::Trace.pm Page for news and upgrades. |
||||||
1370 | |||||||
1371 | =end html | ||||||
1372 | |||||||
1373 | =cut | ||||||
1374 |