line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
package Log::Log4perl::AutoCategorize; |
3
|
5
|
|
|
5
|
|
82415
|
use strict; |
|
5
|
|
|
|
|
14
|
|
|
5
|
|
|
|
|
327
|
|
4
|
|
|
|
|
|
|
our $VERSION = "0.03"; |
5
|
|
|
|
|
|
|
|
6
|
5
|
|
|
5
|
|
35
|
use Carp; |
|
5
|
|
|
|
|
14
|
|
|
5
|
|
|
|
|
462
|
|
7
|
5
|
|
|
5
|
|
5266
|
use IO::File; |
|
5
|
|
|
|
|
56312
|
|
|
5
|
|
|
|
|
912
|
|
8
|
|
|
|
|
|
|
|
9
|
5
|
|
|
5
|
|
5857
|
use Log::Log4perl; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
use Log::Dispatch::Screen; |
11
|
|
|
|
|
|
|
use Log::Dispatch::File; |
12
|
|
|
|
|
|
|
use Log::Log4perl::Appender; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
#use YAML; |
15
|
|
|
|
|
|
|
use Data::Dumper; |
16
|
|
|
|
|
|
|
$Data::Dumper::Indent = 1; |
17
|
|
|
|
|
|
|
$Data::Dumper::Sortkeys = 1; |
18
|
|
|
|
|
|
|
$Data::Dumper::Terse = 1; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
################### |
21
|
|
|
|
|
|
|
my $MyPkg = __PACKAGE__; |
22
|
|
|
|
|
|
|
my $Alias = $MyPkg; # this is changed if you use aliasing feature |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
use vars qw($AUTOLOAD); |
25
|
|
|
|
|
|
|
our( # my complicates debug |
26
|
|
|
|
|
|
|
%SeenCat, # collect categories seen |
27
|
|
|
|
|
|
|
%UnSeenCat,# filled at compile by optimizer, cleared at END |
28
|
|
|
|
|
|
|
%cat2data, # category => [ logger-handle, level, munged-name, enablement ] |
29
|
|
|
|
|
|
|
%fn2cat, # munged-name => category. used for init-and-watch handling |
30
|
|
|
|
|
|
|
@usrPkgs, # collect list of user packages. |
31
|
|
|
|
|
|
|
); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $dumper; # bound to Data::Dumper() or YAML::Dump by first call of AUTOLOAD |
34
|
|
|
|
|
|
|
my $defConf; # default logger config. |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# silence redefine errs (no warnings wont do it, cuz theyre const); |
37
|
|
|
|
|
|
|
#BEGIN { local $SIG{__WARN__} = sub { return if /redefined/; carp(@_) }}; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my $opt; # hashref of debug option flags, initialized in begin |
40
|
|
|
|
|
|
|
BEGIN { |
41
|
|
|
|
|
|
|
# cuz Logger is used at import time (ie early) by many other |
42
|
|
|
|
|
|
|
# modules, it must load its own config at compile-time. |
43
|
|
|
|
|
|
|
# use Logger ($conffile) might be possible with import routine. |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# allow notify, do before init(); |
46
|
|
|
|
|
|
|
Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN"); |
47
|
|
|
|
|
|
|
Log::Log4perl::Logger::create_custom_level("NOTICE", "WARN"); |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
$opt = { |
50
|
|
|
|
|
|
|
# flags checked in optimization phase |
51
|
|
|
|
|
|
|
v => 0, # generic verbosity |
52
|
|
|
|
|
|
|
f => 0, # found op-chains (starting with pushmark) |
53
|
|
|
|
|
|
|
#F => 0, # found op-chains op-dump |
54
|
|
|
|
|
|
|
m => 0, # matched op-chains (found & end with method-named) |
55
|
|
|
|
|
|
|
M => 0, # matched op-chains op-dump |
56
|
|
|
|
|
|
|
j => 0, # junk op-chains (subset of found) |
57
|
|
|
|
|
|
|
J => 0, # junk op-chains op-dump |
58
|
|
|
|
|
|
|
d => 0, # $op->dump() while examining opcodes |
59
|
|
|
|
|
|
|
s => 0, # print opstack while scanning for ending method_named op |
60
|
|
|
|
|
|
|
x => 0, # extreme debug |
61
|
|
|
|
|
|
|
r => 0, # function renaming (munging) |
62
|
|
|
|
|
|
|
#z => 0, # $op->dump when done optimizing |
63
|
|
|
|
|
|
|
w => 0, # log wrong ops in chain that matched |
64
|
|
|
|
|
|
|
D => 0, # break in optimizer if debugging |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
# flags checked in AUTOLOAD, at runtime |
67
|
|
|
|
|
|
|
i => 0, # AUTOLOAD invoked |
68
|
|
|
|
|
|
|
A => 0, # AUTOLOAD args |
69
|
|
|
|
|
|
|
a => 0, # AUTOLOAD use of caller() |
70
|
|
|
|
|
|
|
b => 0, # anon-sub build |
71
|
|
|
|
|
|
|
c => 0, # logging category creation |
72
|
|
|
|
|
|
|
n => 0, # no optimize (dont stash the method) |
73
|
|
|
|
|
|
|
y => 0, # use YAML::Dump (default is Data::Dumper, TBD) |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
e => 0, # print END results to stdout |
76
|
|
|
|
|
|
|
z => 0, # print size of stuff at END |
77
|
|
|
|
|
|
|
Z => 0, # print more size stuff at END |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# these 2 are 'inverted', so that default is 'on' |
80
|
|
|
|
|
|
|
l => 0, # dont add level to category, ie: pkg.sub.level.line |
81
|
|
|
|
|
|
|
C => 0, # dont add 'log4perl.category.' prefix to END results |
82
|
|
|
|
|
|
|
}; |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# default Log4per config writes to stdout, and creates a coverage log |
85
|
|
|
|
|
|
|
$defConf = q{ |
86
|
|
|
|
|
|
|
log4perl.rootLogger = DEBUG, A1 |
87
|
|
|
|
|
|
|
log4perl.appender.A1 = Log::Dispatch::Screen |
88
|
|
|
|
|
|
|
log4perl.appender.A1.layout = PatternLayout |
89
|
|
|
|
|
|
|
log4perl.appender.A1.layout.ConversionPattern = %d %c: %m%n |
90
|
|
|
|
|
|
|
# create COVERAGE log |
91
|
|
|
|
|
|
|
log4perl.appender.COVERAGE = Log::Dispatch::File |
92
|
|
|
|
|
|
|
log4perl.appender.COVERAGE.filename = sub { \ |
93
|
|
|
|
|
|
|
my $n = $0; \ |
94
|
|
|
|
|
|
|
$n =~ s|.*/||; \ |
95
|
|
|
|
|
|
|
$n =~ s/(\.(t|pl))?$//; \ |
96
|
|
|
|
|
|
|
return "./out.$n.cover";\ |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
log4perl.appender.COVERAGE.mode = write |
99
|
|
|
|
|
|
|
log4perl.appender.COVERAGE.layout = org.apache.log4j.PatternLayout |
100
|
|
|
|
|
|
|
log4perl.appender.COVERAGE.layout.ConversionPattern = \ |
101
|
|
|
|
|
|
|
(%d{HH:mm:ss.SSS}) %c: %m%n |
102
|
|
|
|
|
|
|
# now that Coverage file has been set up, |
103
|
|
|
|
|
|
|
# send the END-block output there |
104
|
|
|
|
|
|
|
log4perl.logger.Log.Log4perl.AutoCategorize.END = INFO, COVERAGE |
105
|
|
|
|
|
|
|
}; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
######## |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub import { |
111
|
|
|
|
|
|
|
my $pkg = shift; |
112
|
|
|
|
|
|
|
my (%args) = @_; |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
my ($cpkg) = (caller(0))[0]; |
115
|
|
|
|
|
|
|
push @usrPkgs, $cpkg; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
local $" = ","; |
118
|
|
|
|
|
|
|
set_debug($args{debug}) if $args{debug}; |
119
|
|
|
|
|
|
|
print "importing: $pkg into $cpkg, users: @usrPkgs\n";# if $opt->{v}; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
if ($args{alias}) { |
122
|
|
|
|
|
|
|
if ($opt->{v}) { |
123
|
|
|
|
|
|
|
print "aliasing $pkg as $args{alias}\n"; |
124
|
|
|
|
|
|
|
my @caller = (caller(0))[0..2]; |
125
|
|
|
|
|
|
|
print "importer is: @caller\n"; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
no strict 'refs'; |
128
|
|
|
|
|
|
|
*{$args{alias}} = *{$pkg}; |
129
|
|
|
|
|
|
|
*{$args{alias}.'::AUTOLOAD'} = *{$pkg.'::AUTOLOAD'}; |
130
|
|
|
|
|
|
|
# *{$cpkg.'::'.$args{alias}} = *{$pkg}; |
131
|
|
|
|
|
|
|
# *{$cpkg.'::'.$args{alias}.'::AUTOLOAD'} = *{$pkg.'::AUTOLOAD'}; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
$Alias = delete $args{alias}; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Logger initialization: init*-directives may override default, |
137
|
|
|
|
|
|
|
# but not vice-versa. Interface is subject to change, esp wrt |
138
|
|
|
|
|
|
|
# additional configuration items (currently just replaces previous) |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
if ($args{initfile}) { |
141
|
|
|
|
|
|
|
print "initialize with file: $args{initfile}\n" if $opt->{v}; |
142
|
|
|
|
|
|
|
Log::Log4perl->init_and_watch($args{initfile}, 10); |
143
|
|
|
|
|
|
|
delete $args{initfile}; |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
# someday, doing both might work. right now, now its either or. |
146
|
|
|
|
|
|
|
elsif ($args{initstr}) { |
147
|
|
|
|
|
|
|
print "initialize with string\n" if $opt->{v}; |
148
|
|
|
|
|
|
|
Log::Log4perl->init(\$args{initstr}); |
149
|
|
|
|
|
|
|
delete $args{initstr}; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
else { |
152
|
|
|
|
|
|
|
return if $opt->{initd}; |
153
|
|
|
|
|
|
|
print "initializing Logger with default\n" if $opt->{v}; |
154
|
|
|
|
|
|
|
Log::Log4perl->init(\$defConf); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
$opt->{initd} = 1; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
sub set_debug { |
160
|
|
|
|
|
|
|
my ($arg) = pop @_; |
161
|
|
|
|
|
|
|
my $allowed = join '', sort keys %$opt; |
162
|
|
|
|
|
|
|
my $bad; |
163
|
|
|
|
|
|
|
foreach my $letter (split //, $arg) { |
164
|
|
|
|
|
|
|
if (defined $opt->{$letter}) { |
165
|
|
|
|
|
|
|
$opt->{$letter} = 1; |
166
|
|
|
|
|
|
|
} else { |
167
|
|
|
|
|
|
|
$bad .= $letter; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
die "illegal debug option(s): $bad - allowed: $allowed\n" if $bad; |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
if ($opt->{z}) { |
173
|
|
|
|
|
|
|
eval { |
174
|
|
|
|
|
|
|
require Devel::Size; |
175
|
|
|
|
|
|
|
Devel::Size->import qw(size total_size); |
176
|
|
|
|
|
|
|
}; |
177
|
|
|
|
|
|
|
die "$@: -z option requires Devel::Size\n" if $@; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
sub get_loglevel { |
182
|
|
|
|
|
|
|
# returns the level-string, should really query base for complete set |
183
|
|
|
|
|
|
|
return $1 if $_[0] =~ m/^(?:log_)?(debug|info|warn|error|fatal|notice)/; |
184
|
|
|
|
|
|
|
return 0; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
################### |
188
|
|
|
|
|
|
|
sub AUTOLOAD { |
189
|
|
|
|
|
|
|
print "args: ", Dumper \@_ if $opt->{A}; |
190
|
|
|
|
|
|
|
my $cpkg = $_[0]; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
(my $meth = $AUTOLOAD) =~ s/.*:://; |
193
|
|
|
|
|
|
|
return if $meth eq 'DESTROY'; |
194
|
|
|
|
|
|
|
print "\ncalled_as = $cpkg.$meth\n" if $opt->{i}; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# test if meth is a legitimate logging level |
197
|
|
|
|
|
|
|
my $level = get_loglevel($meth); |
198
|
|
|
|
|
|
|
unless ($level) { |
199
|
|
|
|
|
|
|
# delegate if possible (this is why u subclass) |
200
|
|
|
|
|
|
|
if (Log::Log4perl->can($meth)) { |
201
|
|
|
|
|
|
|
print "delegating to Log::Log4perl->$meth()\n" if $opt->{v}; |
202
|
|
|
|
|
|
|
shift @_; |
203
|
|
|
|
|
|
|
Log::Log4perl->$meth(@_); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
elsif (Log::Log4perl::AutoCategorize->can($meth)) { |
206
|
|
|
|
|
|
|
print "delegating to Log::Log4perl::AutoCategorize->$meth()\n" |
207
|
|
|
|
|
|
|
if $opt->{v}; |
208
|
|
|
|
|
|
|
shift @_; |
209
|
|
|
|
|
|
|
Log::Log4perl::AutoCategorize->$meth(@_); |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
else { carp "$meth is not a legitimate log-level\n" } |
212
|
|
|
|
|
|
|
return; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
# $meth = $level; |
215
|
|
|
|
|
|
|
print "meth: $meth\n" if $opt->{i}; |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
# use FQ name as category |
218
|
|
|
|
|
|
|
my ($pkg,$file,$ln0,$ln1,$sub0,$sub1); |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
if (($pkg,$file,$ln1,$sub1) = caller(1)) { |
221
|
|
|
|
|
|
|
print "1: $pkg,$file,$ln1,$sub1\n" if $opt->{a}; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
($pkg,$file,$ln0,$sub0) = caller(0); |
224
|
|
|
|
|
|
|
print "0: $pkg,$file,$ln0,$sub0\n" if $opt->{a}; |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
# construct category, avoid AUTOLOAD sub-name |
227
|
|
|
|
|
|
|
my $cat = $sub1 || 'main.main'; |
228
|
|
|
|
|
|
|
$cat .= ".$level" unless $opt->{l}; |
229
|
|
|
|
|
|
|
$cat .= ".$ln0"; |
230
|
|
|
|
|
|
|
$cat =~ s/::/./g; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
if ($cat2data{$cat}) { |
233
|
|
|
|
|
|
|
my $catinc = 'a'; |
234
|
|
|
|
|
|
|
$catinc++ while $cat2data{$cat.$catinc}; |
235
|
|
|
|
|
|
|
$cat .= $catinc; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
print "cat: $cat\n" if $opt->{c}; |
238
|
|
|
|
|
|
|
delete $UnSeenCat{$meth}; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
my $log = Log::Log4perl->get_logger($cat); |
241
|
|
|
|
|
|
|
my $predicate = "is_$level"; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
# is it runnable ? |
244
|
|
|
|
|
|
|
my $runnable; |
245
|
|
|
|
|
|
|
eval { $runnable = $log->$predicate() }; |
246
|
|
|
|
|
|
|
if ($@) { |
247
|
|
|
|
|
|
|
die("logger: cant $predicate on $cat: $@"); |
248
|
|
|
|
|
|
|
return; |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
# record everything we might need in delegate |
251
|
|
|
|
|
|
|
$cat2data{$cat} = [ $log, $level, $meth, $runnable ]; |
252
|
|
|
|
|
|
|
# $fn2cat{$meth} = $cat; # needed to expire stale routines. |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
unless ($dumper) { |
255
|
|
|
|
|
|
|
$dumper = \&Data::Dumper::Dump; |
256
|
|
|
|
|
|
|
#$dumper = \&YAML::Dump if $opt->{y}; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
# make the right anonymous sub, depending on runability |
259
|
|
|
|
|
|
|
# avoid closure on $cat; make it string literal ?? |
260
|
|
|
|
|
|
|
my $code; |
261
|
|
|
|
|
|
|
if (not $runnable) { |
262
|
|
|
|
|
|
|
print "building disabled sub: $cpkg.$meth\n" if $opt->{b}; |
263
|
|
|
|
|
|
|
$code = sub { $SeenCat{"$cat"}-- }; |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
else { |
266
|
|
|
|
|
|
|
print "building enabled sub: $cpkg.$meth\n" if $opt->{b}; |
267
|
|
|
|
|
|
|
$code = sub { logitDumper ("$cat", @_) }; |
268
|
|
|
|
|
|
|
#$code = sub { logitYAML ("$cat", @_) } if $opt->{y}; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
# stash it |
271
|
|
|
|
|
|
|
unless ($opt->{n}) { |
272
|
|
|
|
|
|
|
no strict 'refs'; |
273
|
|
|
|
|
|
|
#*{__PACKAGE__.'::'.$meth} = $code; |
274
|
|
|
|
|
|
|
#*{$Alias.'::'.$meth} = $code; |
275
|
|
|
|
|
|
|
*{$cpkg.'::'.$meth} = $code; |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
#printf "code size for $meth: %d\n", total_size($code) if $opt->{z}; |
278
|
|
|
|
|
|
|
goto &$code; |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
sub logitDumper { |
282
|
|
|
|
|
|
|
# log the message to base logger, using Data::Dumper to handle refs |
283
|
|
|
|
|
|
|
my ($cat, $cls, @args) = @_; |
284
|
|
|
|
|
|
|
my @scalars; |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
$SeenCat{"$cat"}++; |
287
|
|
|
|
|
|
|
my ($logger, $level) = @{$cat2data{$cat}}; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
eval { |
290
|
|
|
|
|
|
|
# pull leading scalars from @args to @scalars |
291
|
|
|
|
|
|
|
push @scalars, shift @args while @args and not ref $args[0]; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# stringify @scalars, and Dump refs |
294
|
|
|
|
|
|
|
$logger->$level( !@scalars ? () : "@scalars, ", |
295
|
|
|
|
|
|
|
!@args ? () : Dumper((@args==1) ? @args : [@args])); |
296
|
|
|
|
|
|
|
}; |
297
|
|
|
|
|
|
|
if ($@) { carp("logger dump problem on $cat: $@") } |
298
|
|
|
|
|
|
|
return "logged"; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
sub logitYAML {} |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
####### |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub myDump { |
306
|
|
|
|
|
|
|
print "# observed logging categories:\n", Dumper(\%SeenCat); |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
END { |
310
|
|
|
|
|
|
|
my %cat2munged; |
311
|
|
|
|
|
|
|
$cat2munged{$_} = $cat2data{$_}[2] foreach keys %cat2data; |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
unless ($opt->{C}) { |
314
|
|
|
|
|
|
|
# add prefix so its easy to edit coverage report into a config-file |
315
|
|
|
|
|
|
|
$SeenCat{"log4perl.category.$_"} = delete $SeenCat{$_} foreach keys %SeenCat; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# I eat my own dog-food. Note: this doesnt get munged, cuz the |
319
|
|
|
|
|
|
|
# optimizer munge criteria are 'tight'. This is fine, cuz |
320
|
|
|
|
|
|
|
# mycaller() reports it well. |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
$Alias->info("Seen Log Events:", \%SeenCat); |
323
|
|
|
|
|
|
|
$Alias->info("UnSeen Log Events:", \%UnSeenCat); |
324
|
|
|
|
|
|
|
$Alias->info("cat2data:", \%cat2munged); |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
if ($opt->{e}) { |
327
|
|
|
|
|
|
|
print "Seen Log Events:" => Dumper \%SeenCat; |
328
|
|
|
|
|
|
|
print "un-Seen methods:" => Dumper \%UnSeenCat; |
329
|
|
|
|
|
|
|
print "cat2info:" => Dumper \%cat2munged; |
330
|
|
|
|
|
|
|
} |
331
|
|
|
|
|
|
|
if ($opt->{y}) { |
332
|
|
|
|
|
|
|
print "Seen Log Events:" => Dump(%SeenCat); |
333
|
|
|
|
|
|
|
print "un-Seen methods:" => Dump(%UnSeenCat); |
334
|
|
|
|
|
|
|
print "cat2data:" => Dump(%cat2munged); |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
if ($opt->{z}) { |
337
|
|
|
|
|
|
|
eval { |
338
|
|
|
|
|
|
|
require Devel::Size; |
339
|
|
|
|
|
|
|
Devel::Size->import qw(size total_size); |
340
|
|
|
|
|
|
|
{ |
341
|
|
|
|
|
|
|
# attempt to control msg: 'CV not complete' |
342
|
|
|
|
|
|
|
package Devel::Size; |
343
|
|
|
|
|
|
|
use warnings::register; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
}; |
346
|
|
|
|
|
|
|
die "-z option requires Devel::Size\n" if $@; |
347
|
|
|
|
|
|
|
|
348
|
|
|
|
|
|
|
# print size info. Devel::Size does an incomplete job on CVs, |
349
|
|
|
|
|
|
|
# so theres insufficient value to these numbers to base |
350
|
|
|
|
|
|
|
# decisions upon. |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
my (%fnsizes, %hashsizes, %stashsizes, $total); |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
foreach my $fn (values %cat2munged) { |
355
|
|
|
|
|
|
|
$total += $fnsizes{$fn} |
356
|
|
|
|
|
|
|
= total_size(\&{"Log::Log4perl::AutoCategorize::".$fn}); |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
printf "total size of stashed subs: %d\n", $total; |
359
|
|
|
|
|
|
|
print "function size breakdown: ", Dumper \%fnsizes; |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
no strict 'refs'; |
362
|
|
|
|
|
|
|
$total = 0; |
363
|
|
|
|
|
|
|
foreach my $hashname (qw(SeenCat UnSeenCat cat2data)) { |
364
|
|
|
|
|
|
|
$total += $hashsizes{$hashname} = total_size(\%{$hashname}); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
printf "total size of my hashs: %d\n", $total; |
367
|
|
|
|
|
|
|
print "my hash size breakdown: ", Dumper \%hashsizes; |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
if ($opt->{Z}) { |
370
|
|
|
|
|
|
|
$total = 0; |
371
|
|
|
|
|
|
|
foreach my $stashitem (values %Log::Log4perl::AutoCategorize::) { |
372
|
|
|
|
|
|
|
$total += $stashsizes{$stashitem} = total_size($stashitem); |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
printf "total size of stash items: %d\n", $total; |
375
|
|
|
|
|
|
|
printf "total size, all at once: %d\n" |
376
|
|
|
|
|
|
|
, total_size(\%Log::Log4perl::AutoCategorize::); |
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
print "stash size breakdown: ", Dumper \%stashsizes; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
################### |
384
|
|
|
|
|
|
|
# optimizer stuff, only for 5.8 |
385
|
|
|
|
|
|
|
# __END__ # uncomment __END__ to use in 5.6.x, and accept slowdown |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# silence 'Subroutine redefined' warnings due to B::Generate |
388
|
|
|
|
|
|
|
local $SIG{__WARN__}; # localize outside BEGIN block |
389
|
|
|
|
|
|
|
BEGIN { |
390
|
|
|
|
|
|
|
$SIG{__WARN__} = sub { |
391
|
|
|
|
|
|
|
return if $_[0] =~ /Subroutine B(::\w+)+ redefined/; |
392
|
|
|
|
|
|
|
warn $_[0]; |
393
|
|
|
|
|
|
|
}; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
my $munged = '00000'; |
397
|
|
|
|
|
|
|
#INIT { $munged = '00000' }; |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
# sub method_munger |
401
|
|
|
|
|
|
|
use optimizer 'extend-c' => sub { |
402
|
|
|
|
|
|
|
my $opp = shift; |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# look for op-chains which start with pushmark & const == __PACKAGE__ |
405
|
|
|
|
|
|
|
# Scan until method_named is reached, while keeping track of inner |
406
|
|
|
|
|
|
|
# stack manipulations (iow monitor balance of push, pop on @opstack) |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
my $n1 = $opp->name(); |
409
|
|
|
|
|
|
|
$opp = $opp->next(); |
410
|
|
|
|
|
|
|
return if ref $opp eq 'B::NULL'; |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
my $n2 = $opp->name(); |
413
|
|
|
|
|
|
|
# by Policy, use Class method invocation only, hence const |
414
|
|
|
|
|
|
|
return unless $n1 eq "pushmark" and $n2 eq "const"; |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
# Class method allows code to expect the const opcodes value to be |
417
|
|
|
|
|
|
|
# Log::Log4perl::AutoCategorize or $Alias. All others end the chain. |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
my $class = ''; |
420
|
|
|
|
|
|
|
eval { $class = $opp->sv->PV }; # sets $class unless $@ |
421
|
|
|
|
|
|
|
return unless $class and $Alias and $MyPkg; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
return unless $class eq $Alias or $class =~/^$MyPkg/; |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
$DB::single = 1 if $opt->{D}; |
426
|
|
|
|
|
|
|
$opp->dump if $opt->{d}; |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
# OK: weve seen 2 required ops; pushmark, const='Logger'. Now we |
429
|
|
|
|
|
|
|
# track stack activity, so that nested meth_named ops dont |
430
|
|
|
|
|
|
|
# prematurely end the scan which guards the munge. |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
my (@opchain, @opstack, $name); |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
while (@opstack or $opp->name ne 'method_named') { |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
return if ref $opp eq 'B::NULL'; |
437
|
|
|
|
|
|
|
$opp = $opp->next(); |
438
|
|
|
|
|
|
|
return if ref $opp eq 'B::NULL'; |
439
|
|
|
|
|
|
|
|
440
|
|
|
|
|
|
|
push @opchain, $opp; |
441
|
|
|
|
|
|
|
$name = $opp->name; |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
if ($name eq 'pushmark') { |
444
|
|
|
|
|
|
|
push @opstack, $opp; |
445
|
|
|
|
|
|
|
printf "pushed: %s\n", opNames(\@opchain) if $opt->{s}; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
if ($name =~ /refgen|entersub/) { |
448
|
|
|
|
|
|
|
printf "popping: %s\n", opNames(\@opchain) if $opt->{s}; |
449
|
|
|
|
|
|
|
pop @opstack; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
} |
452
|
|
|
|
|
|
|
printf "found op-chain: $class => %s\n", opNames(\@opchain) if $opt->{f}; |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# this should be proper end of chain |
455
|
|
|
|
|
|
|
my ($meth) = $opchain[-1]; |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
unless ($meth->name eq 'method_named') { |
458
|
|
|
|
|
|
|
# this is a sign of problems. |
459
|
|
|
|
|
|
|
printf "junk op-chain: $class => %s\n", opNames(\@opchain) if $opt->{j}; |
460
|
|
|
|
|
|
|
dumpchain(\@opchain) if $opt->{J}; |
461
|
|
|
|
|
|
|
return; |
462
|
|
|
|
|
|
|
} |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
printf "matched op-chain: $class => %s\n", opNames(\@opchain) if $opt->{m}; |
465
|
|
|
|
|
|
|
dumpchain(\@opchain) if $opt->{M}; |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
my $fnname = $meth->sv->PV; |
468
|
|
|
|
|
|
|
unless (get_loglevel($fnname)) { |
469
|
|
|
|
|
|
|
print "$fnname is ineligible for munging\n" if $opt->{v}; |
470
|
|
|
|
|
|
|
return; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
# now do the munge |
473
|
|
|
|
|
|
|
#print "func: $fnname\n" if $opt->{r}; |
474
|
|
|
|
|
|
|
$munged++; |
475
|
|
|
|
|
|
|
$meth->sv->PV("${fnname}_$munged"); |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# record munged fnname, and where its called (to aid test-coverage review) |
478
|
|
|
|
|
|
|
my $cllr = join(',', (caller(0))[0..2]); |
479
|
|
|
|
|
|
|
$UnSeenCat{"${fnname}_$munged"} = $cllr; |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
print "munged func name: ${fnname}_$munged, caller: $cllr\n" |
482
|
|
|
|
|
|
|
if $opt->{r}; |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
#$meth->dump if $opt->{z}; |
485
|
|
|
|
|
|
|
}; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub opNames { |
488
|
|
|
|
|
|
|
# given ref to opchain, prints names |
489
|
|
|
|
|
|
|
my ($opchain, $extra) = @_; |
490
|
|
|
|
|
|
|
return join ' ', map $_->name(), @$opchain unless $extra; |
491
|
|
|
|
|
|
|
return join ' ', map {$_->name(), $_->$extra()} @$opchain; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
sub dumpchain { |
495
|
|
|
|
|
|
|
# annotates $op->dump with stuff, to stdout |
496
|
|
|
|
|
|
|
my ($opchain, @msg) = @_; |
497
|
|
|
|
|
|
|
foreach (@$opchain) { |
498
|
|
|
|
|
|
|
printf STDERR @msg; |
499
|
|
|
|
|
|
|
$_->dump; |
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
1; |
504
|
|
|
|
|
|
|
__END__ |