line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
8
|
|
|
8
|
|
45
|
use strict; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
175
|
|
2
|
8
|
|
|
8
|
|
32
|
use warnings; |
|
8
|
|
|
|
|
13
|
|
|
8
|
|
|
|
|
212
|
|
3
|
|
|
|
|
|
|
package Net::IMP::Debug; |
4
|
|
|
|
|
|
|
|
5
|
8
|
|
|
8
|
|
32
|
use base 'Exporter'; |
|
8
|
|
|
|
|
15
|
|
|
8
|
|
|
|
|
3522
|
|
6
|
|
|
|
|
|
|
our @EXPORT = qw($DEBUG debug); |
7
|
|
|
|
|
|
|
our @EXPORT_OK = qw($DEBUG_RX set_debug); |
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
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# import exported stuff, special case var => \$debug, func => \$code |
14
|
|
|
|
|
|
|
sub import { |
15
|
|
|
|
|
|
|
# on default import go immediately to Exporter |
16
|
39
|
100
|
|
39
|
|
11775
|
goto &Exporter::import if @_ == 1; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
# extract var => \$var from import and alias it to DEBUG |
19
|
|
|
|
|
|
|
# extract sub => \$code and set $DEBUG_SUB |
20
|
8
|
|
|
|
|
34
|
for(my $i=1;$i<@_-1;$i++) { |
21
|
0
|
0
|
|
|
|
0
|
if ( $_[$i] eq 'var' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
22
|
0
|
|
|
|
|
0
|
*DEBUG = $_[$i+1]; |
23
|
0
|
|
|
|
|
0
|
splice(@_,$i,2); |
24
|
0
|
|
|
|
|
0
|
$i-=2; |
25
|
|
|
|
|
|
|
} elsif ( $_[$i] eq 'rxvar' ) { |
26
|
0
|
|
|
|
|
0
|
*DEBUG_RX = $_[$i+1]; |
27
|
0
|
|
|
|
|
0
|
splice(@_,$i,2); |
28
|
0
|
|
|
|
|
0
|
$i-=2; |
29
|
|
|
|
|
|
|
} elsif ( $_[$i] eq 'sub' ) { |
30
|
0
|
|
|
|
|
0
|
$DEBUG_SUB = $_[$i+1]; |
31
|
0
|
|
|
|
|
0
|
splice(@_,$i,2); |
32
|
0
|
|
|
|
|
0
|
$i-=2; |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# call Exporter only if we have remaining args, because we don't |
37
|
|
|
|
|
|
|
# want to trigger the default export if user gave args (e.g. var,sub) |
38
|
8
|
50
|
|
|
|
361
|
goto &Exporter::import if @_>1; |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# set debugging properties |
42
|
|
|
|
|
|
|
sub set_debug { |
43
|
0
|
0
|
0
|
0
|
1
|
0
|
$DEBUG = $_[1] if @_>1 && defined $_[1]; |
44
|
0
|
0
|
|
|
|
0
|
$DEBUG_RX = $_[2] if @_>2; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# print out debug message or forward to external debug func |
48
|
|
|
|
|
|
|
sub debug { |
49
|
293
|
50
|
|
293
|
1
|
7800
|
$DEBUG or return; |
50
|
0
|
|
|
|
|
|
my $msg = shift; |
51
|
0
|
0
|
|
|
|
|
$msg = sprintf($msg,@_) if @_; |
52
|
0
|
0
|
|
|
|
|
if ( $DEBUG_SUB ) { |
53
|
0
|
|
|
|
|
|
@_ = ($msg); |
54
|
|
|
|
|
|
|
# goto foreign debug sub |
55
|
|
|
|
|
|
|
# if DEBUG_RX is set this ill be done later |
56
|
0
|
0
|
|
|
|
|
goto &$DEBUG_SUB if ! $DEBUG_RX; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
my ($pkg,$line) = (caller(0))[0,2]; |
60
|
0
|
0
|
|
|
|
|
if ( $DEBUG_RX ) { |
61
|
0
|
|
0
|
|
|
|
$pkg ||= 'main'; |
62
|
|
|
|
|
|
|
# does not match wanted package |
63
|
0
|
0
|
|
|
|
|
return if $pkg !~ $DEBUG_RX; |
64
|
|
|
|
|
|
|
# goto foreign debug sub |
65
|
0
|
0
|
|
|
|
|
goto &$DEBUG_SUB if $DEBUG_SUB; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
0
|
|
|
|
|
|
my $sub = (caller(1))[3]; |
69
|
0
|
0
|
|
|
|
|
$sub =~s{^main::}{} if $sub; |
70
|
0
|
|
0
|
|
|
|
$sub ||= 'Main'; |
71
|
0
|
|
|
|
|
|
$msg = "${sub}[$line]: ".$msg; |
72
|
|
|
|
|
|
|
|
73
|
0
|
|
|
|
|
|
$msg =~s{^}{DEBUG: }mg; |
74
|
0
|
|
|
|
|
|
print STDERR $msg,"\n"; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
1; |
79
|
|
|
|
|
|
|
__END__ |