File Coverage

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, this module
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 output will look like this:
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 exports the C function if you ask it to:
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), Plover Systems co.
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