line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# Paranoid::Debug -- Debug support for paranoid programs |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# $Id: lib/Paranoid/Debug.pm, 2.09 2021/12/28 15:46:49 acorliss Exp $ |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This software is free software. Similar to Perl, you can redistribute it |
6
|
|
|
|
|
|
|
# and/or modify it under the terms of either: |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# a) the GNU General Public License |
9
|
|
|
|
|
|
|
# as published by the |
10
|
|
|
|
|
|
|
# Free Software Foundation ; either version 1 |
11
|
|
|
|
|
|
|
# , or any later version |
12
|
|
|
|
|
|
|
# , or |
13
|
|
|
|
|
|
|
# b) the Artistic License 2.0 |
14
|
|
|
|
|
|
|
# , |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# subject to the following additional term: No trademark rights to |
17
|
|
|
|
|
|
|
# "Paranoid" have been or are conveyed under any of the above licenses. |
18
|
|
|
|
|
|
|
# However, "Paranoid" may be used fairly to describe this unmodified |
19
|
|
|
|
|
|
|
# software, in good faith, but not as a trademark. |
20
|
|
|
|
|
|
|
# |
21
|
|
|
|
|
|
|
# (c) 2005 - 2020, Arthur Corliss (corliss@digitalmages.com) |
22
|
|
|
|
|
|
|
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com) |
23
|
|
|
|
|
|
|
# |
24
|
|
|
|
|
|
|
##################################################################### |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
##################################################################### |
27
|
|
|
|
|
|
|
# |
28
|
|
|
|
|
|
|
# Environment definitions |
29
|
|
|
|
|
|
|
# |
30
|
|
|
|
|
|
|
##################################################################### |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
package Paranoid::Debug; |
33
|
|
|
|
|
|
|
|
34
|
70
|
|
|
70
|
|
7970
|
use strict; |
|
70
|
|
|
|
|
151
|
|
|
70
|
|
|
|
|
2084
|
|
35
|
70
|
|
|
70
|
|
334
|
use warnings; |
|
70
|
|
|
|
|
139
|
|
|
70
|
|
|
|
|
2012
|
|
36
|
70
|
|
|
70
|
|
335
|
use vars qw($VERSION @EXPORT @EXPORT_OK %EXPORT_TAGS); |
|
70
|
|
|
|
|
136
|
|
|
70
|
|
|
|
|
4128
|
|
37
|
70
|
|
|
70
|
|
382
|
use base qw(Exporter); |
|
70
|
|
|
|
|
121
|
|
|
70
|
|
|
|
|
5067
|
|
38
|
70
|
|
|
70
|
|
528
|
use Paranoid; |
|
70
|
|
|
|
|
253
|
|
|
70
|
|
|
|
|
10954
|
|
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
($VERSION) = ( q$Revision: 2.09 $ =~ /(\d+(?:\.\d+)+)/sm ); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
@EXPORT = qw(PDEBUG pdebug pIn pOut |
43
|
|
|
|
|
|
|
PDEBUG1 PDEBUG2 PDEBUG3 PDEBUG4 PDEBUG5 PDEBUG6 PDEBUG7 PDEBUG8); |
44
|
|
|
|
|
|
|
@EXPORT_OK = ( |
45
|
|
|
|
|
|
|
@EXPORT, |
46
|
|
|
|
|
|
|
qw(pderror PDPREFIX PDLEVEL1 PDLEVEL2 PDLEVEL3 PDLEVEL4 PDMAXINDENT), |
47
|
|
|
|
|
|
|
); |
48
|
|
|
|
|
|
|
%EXPORT_TAGS = ( |
49
|
|
|
|
|
|
|
all => [@EXPORT_OK], |
50
|
|
|
|
|
|
|
constants => [ |
51
|
|
|
|
|
|
|
qw(PDEBUG1 PDEBUG2 PDEBUG3 PDEBUG4 PDEBUG5 PDEBUG6 |
52
|
|
|
|
|
|
|
PDEBUG7 PDEBUG8) |
53
|
|
|
|
|
|
|
], |
54
|
|
|
|
|
|
|
); |
55
|
|
|
|
|
|
|
|
56
|
70
|
|
|
70
|
|
755
|
use constant PDLEVEL1 => 9; |
|
70
|
|
|
|
|
140
|
|
|
70
|
|
|
|
|
5487
|
|
57
|
70
|
|
|
70
|
|
469
|
use constant PDLEVEL2 => 10; |
|
70
|
|
|
|
|
144
|
|
|
70
|
|
|
|
|
3711
|
|
58
|
70
|
|
|
70
|
|
882
|
use constant PDLEVEL3 => 11; |
|
70
|
|
|
|
|
145
|
|
|
70
|
|
|
|
|
3691
|
|
59
|
70
|
|
|
70
|
|
743
|
use constant PDLEVEL4 => 12; |
|
70
|
|
|
|
|
162
|
|
|
70
|
|
|
|
|
3286
|
|
60
|
|
|
|
|
|
|
|
61
|
70
|
|
|
70
|
|
699
|
use constant PDMAXIND => 60; |
|
70
|
|
|
|
|
195
|
|
|
70
|
|
|
|
|
3693
|
|
62
|
|
|
|
|
|
|
|
63
|
70
|
|
|
70
|
|
456
|
use constant PDEBUG1 => 1; |
|
70
|
|
|
|
|
197
|
|
|
70
|
|
|
|
|
4037
|
|
64
|
70
|
|
|
70
|
|
445
|
use constant PDEBUG2 => 2; |
|
70
|
|
|
|
|
160
|
|
|
70
|
|
|
|
|
3816
|
|
65
|
70
|
|
|
70
|
|
443
|
use constant PDEBUG3 => 3; |
|
70
|
|
|
|
|
120
|
|
|
70
|
|
|
|
|
3548
|
|
66
|
70
|
|
|
70
|
|
428
|
use constant PDEBUG4 => 4; |
|
70
|
|
|
|
|
436
|
|
|
70
|
|
|
|
|
4425
|
|
67
|
70
|
|
|
70
|
|
490
|
use constant PDEBUG5 => 5; |
|
70
|
|
|
|
|
119
|
|
|
70
|
|
|
|
|
3047
|
|
68
|
70
|
|
|
70
|
|
370
|
use constant PDEBUG6 => 6; |
|
70
|
|
|
|
|
114
|
|
|
70
|
|
|
|
|
3878
|
|
69
|
70
|
|
|
70
|
|
447
|
use constant PDEBUG7 => 7; |
|
70
|
|
|
|
|
132
|
|
|
70
|
|
|
|
|
3952
|
|
70
|
70
|
|
|
70
|
|
667
|
use constant PDEBUG8 => 8; |
|
70
|
|
|
|
|
445
|
|
|
70
|
|
|
|
|
44807
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
##################################################################### |
73
|
|
|
|
|
|
|
# |
74
|
|
|
|
|
|
|
# Module code follows |
75
|
|
|
|
|
|
|
# |
76
|
|
|
|
|
|
|
##################################################################### |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
{ |
79
|
|
|
|
|
|
|
my $dlevel = 0; # Start with no debug level |
80
|
|
|
|
|
|
|
my $ilevel = 0; # Start with no identation |
81
|
|
|
|
|
|
|
my $pdebug = 0; # Start with debug output disabled |
82
|
|
|
|
|
|
|
my $maxLevel = PDMAXIND; # Start with normal max indentation |
83
|
|
|
|
|
|
|
my $indIgnored = 0; # Start without ignoring indentation |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
my $defprefix = sub { |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# Default Prefix to use with debug messages looks like: |
88
|
|
|
|
|
|
|
# |
89
|
|
|
|
|
|
|
# [PID - $dlevel] Subroutine: |
90
|
|
|
|
|
|
|
# |
91
|
|
|
|
|
|
|
my $caller = shift; |
92
|
|
|
|
|
|
|
my $prefix = ' ' x $ilevel . "[$$-$dlevel] $caller: "; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
return $prefix; |
95
|
|
|
|
|
|
|
}; |
96
|
|
|
|
|
|
|
my $pdprefix = $defprefix; |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub PDEBUG : lvalue { |
99
|
529859
|
|
|
529859
|
1
|
1840278
|
$pdebug; |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub PDPREFIX : lvalue { |
103
|
529859
|
|
|
529859
|
1
|
667515
|
$pdprefix; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub PDMAXINDENT : lvalue { |
107
|
196943
|
|
|
196943
|
1
|
318732
|
$maxLevel; |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub pderror ($) { |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
# Purpose: Print passed string to STDERR |
113
|
|
|
|
|
|
|
# Returns: Return value from print function |
114
|
|
|
|
|
|
|
# Usage: $rv = pderror("Foo!"); |
115
|
|
|
|
|
|
|
|
116
|
1
|
|
|
1
|
1
|
82
|
my $msg = shift; |
117
|
|
|
|
|
|
|
|
118
|
1
|
|
|
|
|
18
|
$@ = $msg; |
119
|
|
|
|
|
|
|
|
120
|
1
|
|
|
|
|
27
|
return print STDERR "$msg\n"; |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
sub pdebug ($;$@) { |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# Purpose: Calls pderror() if the message level is less than or equal |
126
|
|
|
|
|
|
|
# to the value of PDBEBUG, after prepending the string |
127
|
|
|
|
|
|
|
# returned by the PDPREFIX routine, if defined |
128
|
|
|
|
|
|
|
# Returns: Always returns the passed message, regardless of PDEBUG's |
129
|
|
|
|
|
|
|
# value |
130
|
|
|
|
|
|
|
# Usage: pdebug($message, $level); |
131
|
|
|
|
|
|
|
|
132
|
529859
|
|
|
529859
|
1
|
788053
|
my $msg = shift; |
133
|
529859
|
|
100
|
|
|
883759
|
my $level = shift || 1; |
134
|
529859
|
|
|
|
|
886626
|
my @pfargs = @_; |
135
|
529859
|
|
|
|
|
734332
|
my $prefix = PDPREFIX; |
136
|
529859
|
|
|
|
|
675112
|
my ( $ci, @crec, $caller, $n, $np ); |
137
|
|
|
|
|
|
|
|
138
|
529859
|
50
|
|
|
|
843500
|
$msg = '' unless defined $msg; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# If called with a negative level it merely means we |
141
|
|
|
|
|
|
|
# need to go a little bit deeper in the call stack to find the |
142
|
|
|
|
|
|
|
# true initiator of the message. This provides the mechanism for |
143
|
|
|
|
|
|
|
# Paranoid::Log::plog to pass indirect debug messages |
144
|
529859
|
100
|
|
|
|
810018
|
$ci = $level < 0 ? 2 : 1; |
145
|
529859
|
100
|
|
|
|
823198
|
$level *= -1 if $level < 0; |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Get the call stack info |
148
|
529859
|
|
|
|
|
2284804
|
@crec = caller $ci; |
149
|
529859
|
50
|
|
|
|
1034198
|
$caller = |
|
|
100
|
|
|
|
|
|
150
|
|
|
|
|
|
|
defined $crec[3] ? $crec[3] |
151
|
|
|
|
|
|
|
: defined $crec[1] ? "$crec[1]/$crec[2]" |
152
|
|
|
|
|
|
|
: 'undef'; |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
# Filter message through sprintf if args were passed |
155
|
529859
|
|
|
|
|
2143413
|
$n = [ $msg =~ m#(%[\w.]+)#sg ]; |
156
|
529859
|
|
|
|
|
1008721
|
$np = $n = scalar @$n; |
157
|
529859
|
100
|
|
|
|
877012
|
if ($n) { |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
# Adjust n upwards if we were given more list items than |
160
|
|
|
|
|
|
|
# we see placeholders for in the messsage string |
161
|
454436
|
100
|
|
|
|
783141
|
$n = scalar @pfargs if @pfargs > $n; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# Make sure the requisite number of args are translated for undefs |
164
|
454436
|
|
|
|
|
761514
|
while ( $n > 0 ) { |
165
|
763940
|
|
|
|
|
841754
|
$n--; |
166
|
763940
|
100
|
|
|
|
1761189
|
$pfargs[$n] = 'undef' unless defined $pfargs[$n]; |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# Consolidate extra args into the last placeholder's spot |
170
|
454436
|
100
|
|
|
|
734623
|
if ( scalar @pfargs > $np ) { |
171
|
876
|
|
|
|
|
1435
|
$n = $np - 1; |
172
|
876
|
|
|
|
|
5936
|
@pfargs = |
173
|
|
|
|
|
|
|
( @pfargs[ 0 .. ( $n - 1 ) ], "@pfargs[$n .. $#pfargs]" ); |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# Filter through sprintf |
177
|
|
|
|
|
|
|
{ |
178
|
70
|
|
|
70
|
|
634
|
no warnings; |
|
70
|
|
|
|
|
132
|
|
|
70
|
|
|
|
|
7771
|
|
|
454436
|
|
|
|
|
539808
|
|
179
|
454436
|
|
|
|
|
1510612
|
$msg = sprintf( $msg, @pfargs ); |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
|
183
|
529859
|
50
|
|
|
|
972892
|
return $msg if $level > PDEBUG; |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
# Execute the code block, if that's what it is |
186
|
0
|
0
|
|
|
|
0
|
$prefix = &$prefix($caller) if ref($prefix) eq 'CODE'; |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
{ |
189
|
70
|
|
|
70
|
|
484
|
no warnings; |
|
70
|
|
|
|
|
133
|
|
|
70
|
|
|
|
|
15006
|
|
|
0
|
|
|
|
|
0
|
|
190
|
0
|
|
|
|
|
0
|
pderror("$prefix$msg"); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
|
|
0
|
return $msg; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub pIn () { |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# Purpose: Increases indentation level |
199
|
|
|
|
|
|
|
# Returns: Always True (1) |
200
|
|
|
|
|
|
|
# Usage: pIn(); |
201
|
|
|
|
|
|
|
|
202
|
196943
|
50
|
|
196943
|
1
|
268044
|
if ( $ilevel < PDMAXINDENT ) { |
203
|
196943
|
|
|
|
|
233006
|
$ilevel++; |
204
|
|
|
|
|
|
|
} else { |
205
|
0
|
|
|
|
|
0
|
$indIgnored = 1; |
206
|
|
|
|
|
|
|
} |
207
|
196943
|
|
|
|
|
225395
|
$dlevel++; |
208
|
|
|
|
|
|
|
|
209
|
196943
|
|
|
|
|
306113
|
return 1; |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
sub pOut () { |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# Purpose: Decreases indentation level |
215
|
|
|
|
|
|
|
# Returns: Always True (1) |
216
|
|
|
|
|
|
|
# Usage: pOut(); |
217
|
|
|
|
|
|
|
|
218
|
196943
|
50
|
|
196943
|
1
|
330957
|
if ($indIgnored) { |
219
|
0
|
|
|
|
|
0
|
$indIgnored = 0; |
220
|
|
|
|
|
|
|
} else { |
221
|
196943
|
50
|
|
|
|
341710
|
$ilevel-- if $ilevel > 0; |
222
|
|
|
|
|
|
|
} |
223
|
196943
|
|
|
|
|
229476
|
$dlevel--; |
224
|
|
|
|
|
|
|
|
225
|
196943
|
|
|
|
|
294309
|
return 1; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
1; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
__END__ |