File Coverage

lib/Log/Log4perl/AutoCategorize.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


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__