File Coverage

blib/lib/Apache/Voodoo/Debug/Log4perl.pm

Criterion	Covered	Total	%
statement	28	145	19.3
branch	4	24	16.6
condition	0	8	0.0
subroutine	7	32	21.8
pod	0	18	0.0
total	39	227	17.1

package Apache::Voodoo::Debug::Log4perl;

$VERSION = "3.0200";

use strict;
use warnings;

use base("Apache::Voodoo::Debug::Common");

use File::Spec;
use Log::Log4perl;
use Data::Dumper; $Data::Dumper::Terse = 1; $Data::Dumper::Indent = 1;

$Log::Log4perl::caller_depth = 3;

#
# Since log4perl wants to use one config file for the whole running perl program (one
# call to init), and # ApacheVoodo lets you define logging per application (multiple inits).
# We're using a singleton to get around that.  We append each config block to a hash and
# then init log4perl after the all the apps are loaded.  Kinda ugly, but until log4perl supports
# multiple configs, then it's what we're stuck with.
#
our $self;

sub new {
	my $class = shift;
	my $id    = shift;
	my $conf  = shift;

	unless (ref($self)) {
		$self = {};
		$self->{conf} = {};
		bless($self,$class);
	}

	if (ref($conf) eq "HASH") {
		foreach (keys %{$conf}) {
			$self->{conf}->{$_} = $conf->{$_};
		}
	}
	elsif (!ref($conf)) {
		$self->{v_file} = $conf;
	}

	return $self;
}

sub bootstrapped {
	my $self = shift;

	unless (Log::Log4perl->initialized()) {
		my $conf;
		if ($self->{v_file}) {
			if (open(F,$self->{v_file})) {
				local $/ = undef;
				$conf = ;
				$conf .= "\n";
				close(F);
			}
			else {
				warn $!
			}
		}
		foreach (keys %{$self->{conf}}) {
			$conf .= $_ .' = '.$self->{conf}->{$_}."\n";
		}

		Log::Log4perl->init_once(\$conf);
	}
}

sub enabled {
	return 1;
}


sub debug     { my $self = shift; $self->_get_logger->debug($self->_dumper(@_)); }
sub info      { my $self = shift; $self->_get_logger->info( $self->_dumper(@_)); }
sub warn      { my $self = shift; $self->_get_logger->warn( $self->_dumper(@_)); }
sub error     { my $self = shift; $self->_get_logger->error($self->_dumper(@_)); }
sub exception { my $self = shift; $self->_get_logger->fatal($self->_dumper(@_)); }

sub trace     { my $self = shift; $self->_get_logger->trace($self->_dump_trace(@_)); }
sub table     { my $self = shift; $self->_get_logger->debug($self->_dump_table(@_)); }

sub return_data   { my $self = shift; $self->_get_logger('ReturnData'  )->trace($self->_dumper(@_)); }
sub url           { my $self = shift; $self->_get_logger('Url'         )->trace($self->_dumper(@_)); }
sub status        { my $self = shift; $self->_get_logger('Status'      )->trace($self->_dumper(@_)); }
sub params        { my $self = shift; $self->_get_logger('Params'      )->trace($self->_dumper(@_)); }
sub template_conf { my $self = shift; $self->_get_logger('TemplateConf')->trace($self->_dumper(@_)); }
sub session       { my $self = shift; $self->_get_logger('Session'     )->trace($self->_dumper(@_)); }

sub mark {
	my $self = shift;

	push(@{$self->{profile}},[@_]);
}

sub shutdown {
	my $self = shift;

	my @d = @{$self->{profile}};
	my $last = $#d;
	if ($last > 0) {
		my $total_time = $d[$last]->[0] - $d[0]->[0];

		my @return = map {
			[
				sprintf("%.5f",    $d[$_]->[0] - $d[$_-1]->[0]),
				sprintf("%5.2f%%",($d[$_]->[0] - $d[$_-1]->[0])/$total_time*100),
				$d[$_]->[1]
			]
		} (1 .. $last);

		unshift(@return, [
			sprintf("%.5f",$total_time),
			'percent',
			'message'
		]);

		my $logger = $self->_get_logger("Profile");
		$logger->debug($self->_dump_table("Profile",\@return));
	}

	delete $self->{profile};
}

sub _dumper {
	my $self = shift;
	my @data = @_;
	return sub {
		if (scalar(@data) > 1 || ref($data[0])) {
			# if there's more than one item, or the item we have is a reference
			# then we need to serialize it.
			return Dumper \@data;
		}
		else {
			return $data[0];
		}
	};
}

sub _get_logger {
	my $self    = shift;
	my $section = shift;

	if ($section) {
		return Log::Log4perl->get_logger("Apache::Voodoo::".$section);
	}
	else {
		my @stack = $self->stack_trace();
		if (scalar(@stack)) {
			return Log::Log4perl->get_logger($stack[-1]->{class});
		}
		else {
			return Log::Log4perl->get_logger("Apache::Voodoo");
		}
	}
}

sub _dump_table {
	my $s = shift;
	my @data = @_;

	return sub {
		my $self = $s;
		my $name = "Table";
		if (scalar(@data) > 1) {
			$name = shift @data;
		}

		return "\n$name\n" . $self->_mk_table(@{$data[0]});
	};
}

sub _dump_trace {
	my $s = shift;
	my $n = shift;
	my $t = [$s->stack_trace()];

	return sub {
		my $self  = $s;
		my $trace = $t;

		my $name = ($n || "Trace");
		my @data = map {
			[
				$_->{class},
				$_->{function},
				$_->{line},
			]
		} @{$trace};

		unshift(@data,['Class','Subroutine','Line']);
		return "\n$name\n".$self->_mk_table(@data);
	};
}

sub _mk_table {
	my $self = shift;
	my @data = @_;

	my @col;
	# find the widest element in each column
	foreach my $row (@data) {
		for (my $i=0; $i < scalar(@{$row}); $i++) {
			if (!defined($col[$i]) || length($row->[$i]) > $col[$i]) {
				$col[$i] = length($row->[$i]);
			}
		}
	}

	my $t_width = 2;	    # "| "
	foreach (@col) {
		$t_width += $_ + 3; # " | "
	}
	$t_width -= 1;          # "| " -> "|"

	my @return;
	push(@return,'-' x $t_width);
	foreach my $row (@data) {
		my $line = "| ";
		for (my $i=0; $i < scalar(@{$row}); $i++) {
			$line .= sprintf("%-".$col[$i]."s",$row->[$i]) . " | ";
		}
		$line =~ s/ $//;
		push (@return,$line);
		push(@return,'-' x $t_width);
	}
	return join("\n",@return);
}

1;

################################################################################
# Copyright (c) 2005-2010 Steven Edwards ([e-mail]).
# All rights reserved.
#
# You may use and distribute Apache::Voodoo under the terms described in the
# LICENSE file include in this package. The summary is it's a legalese version
# of the Artistic License :)
#
################################################################################