File Coverage

blib/lib/Net/Inspect/Debug.pm
Criterion Covered Total %
statement 16 71 22.5
branch 6 50 12.0
condition 0 7 0.0
subroutine 5 9 55.5
pod 4 4 100.0
total 31 141 21.9


line stmt bran cond sub pod time code
1 1     1   4 use strict;
  1         1  
  1         21  
2 1     1   3 use warnings;
  1         1  
  1         24  
3             package Net::Inspect::Debug;
4              
5 1     1   3 use base 'Exporter';
  1         1  
  1         260  
6             our @EXPORT = qw(debug trace);
7             our @EXPORT_OK = qw($DEBUG $DEBUG_RX %TRACE xdebug xtrace);
8              
9             our $DEBUG = 0; # is debugging enabled at all
10             our $DEBUG_RX = undef; # debug only packages matching given regex
11             my $DEBUG_SUB = undef; # external debug function to call instead of internal
12             my $OUTPUT_SUB = undef; # external output function to call instead of internal
13              
14             # import exported stuff, special case var => \$debug, func => \$code
15             sub import {
16             # on default import go immediately to Exporter
17 1 50   1   2 goto &Exporter::import if @_ == 1;
18              
19             # extract var => \$var from import and alias it to DEBUG
20             # extract sub => \$code and set $DEBUG_SUB
21 1         3 for(my $i=1;$i<@_;$i++) {
22 3 50       19 if ( $_[$i] eq 'var' ) {
    50          
    50          
    50          
23 0         0 *DEBUG = $_[$i+1];
24 0         0 splice(@_,$i,2);
25 0         0 $i-=2;
26             } elsif ( $_[$i] eq 'sub' ) {
27 0         0 $DEBUG_SUB = $_[$i+1];
28 0         0 splice(@_,$i,2);
29 0         0 $i-=2;
30             } elsif ( $_[$i] eq 'output' ) {
31 0         0 $OUTPUT_SUB = $_[$i+1];
32 0         0 splice(@_,$i,2);
33 0         0 $i-=2;
34             } elsif ( $_[$i] =~m{^(?:debug)?(\d+)$} ) {
35 0         0 $DEBUG = $1;
36 0         0 splice(@_,$i,1);
37 0         0 $i--;
38             }
39             }
40              
41             # call Exporter only if we have remaining args, because we don't
42             # want to trigger the default export if user gave args (e.g. var,sub)
43 1 50       114 goto &Exporter::import if @_>1;
44             }
45              
46             # print out debug message or forward to external debug func
47             sub debug {
48 0 0   0 1   $DEBUG or return;
49 0           my $msg = shift;
50 1 0   1   3 $msg = do { no warnings; sprintf($msg,@_) } if @_;
  1         1  
  1         506  
  0            
  0            
51 0 0         if ( $DEBUG_SUB ) {
52 0           @_ = ($msg);
53             # goto foreign debug sub
54             # if DEBUG_RX is set this will be done later
55 0 0         goto &$DEBUG_SUB if ! $DEBUG_RX;
56             }
57              
58 0           my ($pkg,$line) = (caller(0))[0,2];
59 0 0         if ( $DEBUG_RX ) {
60 0   0       $pkg ||= 'main';
61             # does not match wanted package
62 0 0         return if $pkg !~ $DEBUG_RX;
63             # goto foreign debug sub
64 0 0         goto &$DEBUG_SUB if $DEBUG_SUB;
65             }
66              
67 0           my $sub = (caller(1))[3];
68 0 0         $sub =~s{^main::}{} if $sub;
69 0   0       $sub ||= 'Main';
70 0           $msg =~ s{
71             (\\)
72             | (\r)
73             | (\n)
74             | (\t)
75             | ([\x00-\x1f\x7f-\xff])
76             }{
77 0 0         $1 ? "\\\\" :
    0          
    0          
    0          
78             $2 ? "\\r" :
79             $3 ? "\\n" :
80             $4 ? "\\t" :
81             sprintf("\\x%02x",ord($5))
82             }xesg;
83 0           $msg = "${sub}[$line]: ".$msg;
84              
85 0 0         if ( $OUTPUT_SUB ) {
86 0           $OUTPUT_SUB->( DEBUG => $msg );
87             } else {
88 0           $msg =~s{^}{DEBUG: }mg;
89 0           print STDERR $msg,"\n";
90             }
91             }
92              
93             sub xdebug {
94 0 0   0 1   $DEBUG or return;
95 0           my $obj = shift;
96 0           my $msg = shift;
97 0           unshift @_,"[$obj] $msg";
98 0           goto &debug;
99             }
100              
101             our %TRACE;
102             sub trace {
103 0 0   0 1   %TRACE or return;
104 0           my $pkg = lc((caller(0))[0]);
105 0           $pkg =~s/.*:://;
106 0 0 0       $TRACE{$pkg} or $TRACE{'*'} or return;
107              
108 0           my $msg = shift;
109 0 0         $msg = sprintf($msg,@_) if @_;
110              
111 0 0         if ( $OUTPUT_SUB ) {
112 0           $OUTPUT_SUB->( "TRACE[$pkg]" => $msg );
113             } else {
114 0           $msg =~s{\n}{\n * }g;
115 0           $msg =~s{\A}{[$pkg]: };
116 0           print STDERR $msg,"\n";
117             }
118             }
119              
120             sub xtrace {
121 0 0   0 1   %TRACE or return;
122 0           my $obj = shift;
123 0           my $msg = shift;
124 0           unshift @_, "[$obj] $msg";
125 0           goto &trace;
126             }
127              
128              
129             1;
130             __END__