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

package Log::Log4perl::AutoCategorize;
use strict;
our $VERSION = "0.03";

use Carp;
use IO::File;

use Log::Log4perl;
use Log::Dispatch::Screen;
use Log::Dispatch::File;
use Log::Log4perl::Appender;

#use YAML;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Terse = 1;

###################
my $MyPkg = __PACKAGE__;
my $Alias = $MyPkg; # this is changed if you use aliasing feature

use vars qw($AUTOLOAD);
our( # my complicates debug
     %SeenCat,	# collect categories seen
     %UnSeenCat,# filled at compile by optimizer, cleared at END
     %cat2data,	# category => [ logger-handle, level, munged-name, enablement ]
     %fn2cat,	# munged-name => category.  used for init-and-watch handling
     @usrPkgs,	# collect list of user packages.
);

my $dumper;	# bound to Data::Dumper() or YAML::Dump by first call of AUTOLOAD
my $defConf;	# default logger config.

# silence redefine errs (no warnings wont do it, cuz theyre const);
#BEGIN { local $SIG{__WARN__} = sub { return if /redefined/; carp(@_) }};

my $opt; # hashref of debug option flags, initialized in begin
BEGIN {
    # cuz Logger is used at import time (ie early) by many other
    # modules, it must load its own config at compile-time.
    # use Logger ($conffile) might be possible with import routine.

    # allow notify, do before init();
  Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN");
  Log::Log4perl::Logger::create_custom_level("NOTICE", "WARN");

    $opt = {
	# flags checked in optimization phase
	v => 0,		# generic verbosity
	f => 0,		# found op-chains (starting with pushmark)
	#F => 0,		# found op-chains op-dump
	m => 0,		# matched op-chains (found & end with method-named)
	M => 0,		# matched op-chains op-dump
	j => 0,		# junk op-chains (subset of found)
	J => 0,		# junk op-chains op-dump
	d => 0,		# $op->dump() while examining opcodes
	s => 0,		# print opstack while scanning for ending method_named op
	x => 0,		# extreme debug
	r => 0,		# function renaming (munging)
	#z => 0,		# $op->dump when done optimizing
	w => 0,		# log wrong ops in chain that matched
	D => 0,		# break in optimizer if debugging

	# flags checked in AUTOLOAD, at runtime
	i => 0,		# AUTOLOAD invoked
	A => 0,		# AUTOLOAD args
	a => 0,		# AUTOLOAD use of caller()
	b => 0,		# anon-sub build
	c => 0,		# logging category creation
	n => 0,		# no optimize (dont stash the method)
	y => 0,		# use YAML::Dump (default is Data::Dumper, TBD)

	e => 0,		# print END results to stdout
	z => 0,		# print size of stuff at END
	Z => 0,		# print more size stuff at END

	# these 2 are 'inverted', so that default is 'on'
	l => 0,		# dont add level to category, ie: pkg.sub.level.line
	C => 0,		# dont add 'log4perl.category.' prefix to END results
    };

    # default Log4per config writes to stdout, and creates a coverage log
    $defConf = q{
	 log4perl.rootLogger = DEBUG, A1
	 log4perl.appender.A1 = Log::Dispatch::Screen
	 log4perl.appender.A1.layout = PatternLayout
	 log4perl.appender.A1.layout.ConversionPattern = %d %c: %m%n
	 # create COVERAGE log
	 log4perl.appender.COVERAGE = Log::Dispatch::File
	 log4perl.appender.COVERAGE.filename = sub { \
		my $n = $0;		\
		$n =~ s|.*/||;		\
		$n =~ s/(\.(t|pl))?$//;	\
		return "./out.$n.cover";\
	 }
         log4perl.appender.COVERAGE.mode = write
	 log4perl.appender.COVERAGE.layout = org.apache.log4j.PatternLayout
	 log4perl.appender.COVERAGE.layout.ConversionPattern = \
	     (%d{HH:mm:ss.SSS}) %c: %m%n
	 # now that Coverage file has been set up,
	 # send the END-block output there
	 log4perl.logger.Log.Log4perl.AutoCategorize.END = INFO, COVERAGE
    };
}

########

sub import {
    my $pkg = shift;
    my (%args) = @_;

    my ($cpkg) = (caller(0))[0];
    push @usrPkgs, $cpkg;

    local $" = ",";
    set_debug($args{debug}) if $args{debug};
    print "importing: $pkg into $cpkg, users: @usrPkgs\n";# if $opt->{v};

    if ($args{alias}) {
	if ($opt->{v}) {
	    print "aliasing $pkg as $args{alias}\n";
	    my @caller = (caller(0))[0..2];
	    print "importer is: @caller\n";
	}
	no strict 'refs';
	*{$args{alias}} = *{$pkg};
	*{$args{alias}.'::AUTOLOAD'} = *{$pkg.'::AUTOLOAD'};
	# *{$cpkg.'::'.$args{alias}} = *{$pkg};
	# *{$cpkg.'::'.$args{alias}.'::AUTOLOAD'} = *{$pkg.'::AUTOLOAD'};

	$Alias = delete $args{alias};
    }

    # Logger initialization: init*-directives may override default,
    # but not vice-versa.  Interface is subject to change, esp wrt
    # additional configuration items (currently just replaces previous)

    if ($args{initfile}) {
	print "initialize with file: $args{initfile}\n" if $opt->{v};
        Log::Log4perl->init_and_watch($args{initfile}, 10);
	delete $args{initfile};
    }
    # someday, doing both might work.  right now, now its either or.
    elsif ($args{initstr}) {
	print "initialize with string\n" if $opt->{v};
        Log::Log4perl->init(\$args{initstr});
	delete $args{initstr};
    }
    else {
	return if $opt->{initd};
	print "initializing Logger with default\n" if $opt->{v};
        Log::Log4perl->init(\$defConf);
    }
    $opt->{initd} = 1;
}

sub set_debug {
    my ($arg) = pop @_;
    my $allowed = join '', sort keys %$opt;
    my $bad;
    foreach my $letter (split //, $arg) {
	if (defined $opt->{$letter}) {
	    $opt->{$letter} = 1;
	} else {
	    $bad .= $letter;
	}
    }
    die "illegal debug option(s): $bad - allowed: $allowed\n" if $bad;

    if ($opt->{z}) {
	eval {
	    require Devel::Size;
	    Devel::Size->import qw(size total_size);
	};
	die "$@: -z option requires Devel::Size\n" if $@;
    }
}

sub get_loglevel {
    # returns the level-string, should really query base for complete set
    return $1 if $_[0] =~ m/^(?:log_)?(debug|info|warn|error|fatal|notice)/;
    return 0;
}

###################
sub AUTOLOAD {
    print "args: ", Dumper \@_ if $opt->{A};
    my $cpkg = $_[0];

    (my $meth = $AUTOLOAD) =~ s/.*:://;
    return if $meth eq 'DESTROY';
    print "\ncalled_as = $cpkg.$meth\n" if $opt->{i};

    # test if meth is a legitimate logging level
    my $level = get_loglevel($meth);
    unless ($level) {
	# delegate if possible (this is why u subclass)
	if (Log::Log4perl->can($meth)) {
	    print "delegating to Log::Log4perl->$meth()\n" if $opt->{v};
	    shift @_;
	    Log::Log4perl->$meth(@_);
	}
	elsif (Log::Log4perl::AutoCategorize->can($meth)) {
	    print "delegating to Log::Log4perl::AutoCategorize->$meth()\n"
		if $opt->{v};
	    shift @_;
	    Log::Log4perl::AutoCategorize->$meth(@_);
	}
	else { carp "$meth is not a legitimate log-level\n" }
	return;
    }
    # $meth = $level;
    print "meth: $meth\n" if $opt->{i};

    # use FQ name as category
    my ($pkg,$file,$ln0,$ln1,$sub0,$sub1);

    if (($pkg,$file,$ln1,$sub1) = caller(1)) {
	print "1: $pkg,$file,$ln1,$sub1\n" if $opt->{a};
    }
    ($pkg,$file,$ln0,$sub0) = caller(0);
    print "0: $pkg,$file,$ln0,$sub0\n" if $opt->{a};

    # construct category, avoid AUTOLOAD sub-name
    my $cat = $sub1 || 'main.main';
    $cat .= ".$level" unless $opt->{l};
    $cat .= ".$ln0";
    $cat =~ s/::/./g;

    if ($cat2data{$cat}) {
	my $catinc = 'a';
	$catinc++ while $cat2data{$cat.$catinc};
	$cat .= $catinc;
    }
    print "cat: $cat\n" if $opt->{c};
    delete $UnSeenCat{$meth};

    my $log = Log::Log4perl->get_logger($cat);
    my $predicate = "is_$level";

    # is it runnable ?
    my $runnable;
    eval { $runnable = $log->$predicate() };
    if ($@) {
	die("logger: cant $predicate on $cat: $@");
	return;
    }
    # record everything we might need in delegate
    $cat2data{$cat} = [ $log, $level, $meth, $runnable ];
    # $fn2cat{$meth} = $cat; # needed to expire stale routines.

    unless ($dumper) {
	$dumper = \&Data::Dumper::Dump;
	#$dumper = \&YAML::Dump if $opt->{y};
    }
    # make the right anonymous sub, depending on runability
    # avoid closure on $cat; make it string literal ??
    my $code;
    if (not $runnable) {
	print "building disabled sub: $cpkg.$meth\n" if $opt->{b};
	$code = sub { $SeenCat{"$cat"}-- };
    }
    else {
	print "building enabled sub: $cpkg.$meth\n" if $opt->{b};
	$code = sub { logitDumper ("$cat", @_) };
	#$code = sub { logitYAML   ("$cat", @_) } if $opt->{y};
    }
    # stash it
    unless ($opt->{n}) {
	no strict 'refs';
	#*{__PACKAGE__.'::'.$meth} = $code;
	#*{$Alias.'::'.$meth} = $code;
	*{$cpkg.'::'.$meth} = $code;
    }
    #printf "code size for $meth: %d\n", total_size($code) if $opt->{z};
    goto &$code;
}

sub logitDumper {
    # log the message to base logger, using Data::Dumper to handle refs
    my ($cat, $cls, @args) = @_;
    my @scalars;

    $SeenCat{"$cat"}++;
    my ($logger, $level) = @{$cat2data{$cat}};

    eval {
	# pull leading scalars from @args to @scalars
	push @scalars, shift @args while @args and not ref $args[0];

	# stringify @scalars, and Dump refs
	$logger->$level( !@scalars ? () : "@scalars, ",
			 !@args    ? () : Dumper((@args==1) ? @args : [@args]));
    };
    if ($@) { carp("logger dump problem on $cat: $@") }
    return "logged";
}

sub logitYAML {}

#######

sub myDump {
    print "# observed logging categories:\n", Dumper(\%SeenCat);
}

END {
    my %cat2munged;
    $cat2munged{$_} = $cat2data{$_}[2] foreach keys %cat2data;

    unless ($opt->{C}) {
	# add prefix so its easy to edit coverage report into a config-file
	$SeenCat{"log4perl.category.$_"} = delete $SeenCat{$_} foreach keys %SeenCat;
    }

    # I eat my own dog-food.  Note: this doesnt get munged, cuz the
    # optimizer munge criteria are 'tight'.  This is fine, cuz
    # mycaller() reports it well.

    $Alias->info("Seen Log Events:", \%SeenCat);
    $Alias->info("UnSeen Log Events:", \%UnSeenCat);
    $Alias->info("cat2data:", \%cat2munged);

    if ($opt->{e}) {
	print "Seen Log Events:"	=> Dumper \%SeenCat;
	print "un-Seen methods:"	=> Dumper \%UnSeenCat;
	print "cat2info:"		=> Dumper \%cat2munged;
    }
    if ($opt->{y}) {
	print "Seen Log Events:"	=> Dump(%SeenCat);
	print "un-Seen methods:"	=> Dump(%UnSeenCat);
	print "cat2data:"		=> Dump(%cat2munged);
    }
    if ($opt->{z}) {
	eval {
	    require Devel::Size;
	    Devel::Size->import qw(size total_size);
	    {
		# attempt to control msg: 'CV not complete'
		package Devel::Size;
		use warnings::register;
	    }
	};
	die "-z option requires Devel::Size\n" if $@;

	# print size info.  Devel::Size does an incomplete job on CVs,
	# so theres insufficient value to these numbers to base
	# decisions upon.

	my (%fnsizes, %hashsizes, %stashsizes, $total);

	foreach my $fn (values %cat2munged) {
	    $total += $fnsizes{$fn}
		= total_size(\&{"Log::Log4perl::AutoCategorize::".$fn});
	}
	printf "total size of stashed subs: %d\n", $total;
	print "function size breakdown: ", Dumper \%fnsizes;

	no strict 'refs';
	$total = 0;
	foreach my $hashname (qw(SeenCat UnSeenCat cat2data)) {
	    $total += $hashsizes{$hashname} = total_size(\%{$hashname});
	}
	printf "total size of my hashs: %d\n", $total;
	print "my hash size breakdown: ", Dumper \%hashsizes;

	if ($opt->{Z}) {
	    $total = 0;
	    foreach my $stashitem (values %Log::Log4perl::AutoCategorize::) {
		$total += $stashsizes{$stashitem} = total_size($stashitem);
	    }
	    printf "total size of stash items: %d\n", $total;
	    printf "total size, all at once: %d\n"
		, total_size(\%Log::Log4perl::AutoCategorize::);

	}
	print "stash size breakdown: ", Dumper \%stashsizes;
    }
}

###################
# optimizer stuff, only for 5.8
# __END__ # uncomment __END__ to use in 5.6.x, and accept slowdown

# silence 'Subroutine redefined' warnings due to B::Generate
local $SIG{__WARN__};	# localize outside BEGIN block
BEGIN {
    $SIG{__WARN__} = sub {
	return if $_[0] =~ /Subroutine B(::\w+)+ redefined/;
	warn $_[0];
    };
}

my $munged = '00000';
#INIT { $munged = '00000' };


# sub method_munger
use optimizer 'extend-c' => sub {
    my $opp = shift;

    # look for op-chains which start with pushmark & const == __PACKAGE__
    # Scan until method_named is reached, while keeping track of inner
    # stack manipulations (iow monitor balance of push, pop on @opstack)

    my $n1 = $opp->name();
    $opp = $opp->next();
    return if ref $opp eq 'B::NULL';

    my $n2 = $opp->name();
    # by Policy, use Class method invocation only, hence const
    return unless $n1 eq "pushmark" and $n2 eq "const";

    # Class method allows code to expect the const opcodes value to be
    # Log::Log4perl::AutoCategorize or $Alias.  All others end the chain.

    my $class = '';
    eval { $class = $opp->sv->PV };	# sets $class unless $@
    return unless $class and $Alias and $MyPkg;

    return unless $class eq $Alias or $class =~/^$MyPkg/;

    $DB::single = 1 if $opt->{D};
    $opp->dump if $opt->{d};

    # OK: weve seen 2 required ops; pushmark, const='Logger'.  Now we
    # track stack activity, so that nested meth_named ops dont
    # prematurely end the scan which guards the munge.

    my (@opchain, @opstack, $name);

    while (@opstack or $opp->name ne 'method_named') {

	return if ref $opp eq 'B::NULL';
	$opp = $opp->next();
	return if ref $opp eq 'B::NULL';

	push @opchain, $opp;
	$name = $opp->name;

	if ($name eq 'pushmark') {
	    push @opstack, $opp;
	    printf "pushed: %s\n", opNames(\@opchain) if $opt->{s};
	}
	if ($name =~ /refgen|entersub/) {
	    printf "popping: %s\n", opNames(\@opchain) if $opt->{s};
	    pop @opstack;
	}
    }
    printf "found op-chain: $class => %s\n", opNames(\@opchain) if $opt->{f};

    # this should be proper end of chain
    my ($meth) = $opchain[-1];

    unless ($meth->name eq 'method_named') {
	# this is a sign of problems.
	printf "junk op-chain: $class => %s\n", opNames(\@opchain) if $opt->{j};
	dumpchain(\@opchain) if $opt->{J};
	return;
    }

    printf "matched op-chain: $class => %s\n", opNames(\@opchain) if $opt->{m};
    dumpchain(\@opchain) if $opt->{M};

    my $fnname = $meth->sv->PV;
    unless (get_loglevel($fnname)) {
	print "$fnname is ineligible for munging\n" if $opt->{v};
	return;
    }
    # now do the munge
    #print "func: $fnname\n" if $opt->{r};
    $munged++;
    $meth->sv->PV("${fnname}_$munged");

    # record munged fnname, and where its called (to aid test-coverage review)
    my $cllr = join(',', (caller(0))[0..2]);
    $UnSeenCat{"${fnname}_$munged"} = $cllr;

    print "munged func name: ${fnname}_$munged, caller: $cllr\n"
	if $opt->{r};

    #$meth->dump if $opt->{z};
};

sub opNames {
    # given ref to opchain, prints names
    my ($opchain, $extra) = @_;
    return join ' ', map $_->name(), @$opchain unless $extra;
    return join ' ', map {$_->name(), $_->$extra()} @$opchain;
}

sub dumpchain {
    # annotates $op->dump with stuff, to stdout
    my ($opchain, @msg) = @_;
    foreach (@$opchain) {
	printf STDERR @msg;
	$_->dump;
    }
}

1;
__END__