File Coverage

blib/lib/Medusa.pm

Criterion	Covered	Total	%
statement	111	118	94.0
branch	33	56	58.9
condition	4	9	44.4
subroutine	16	16	100.0
pod	0	1	0.0
total	164	200	82.0

package Medusa;

use 5.008003;
use strict;
use warnings;
use Time::HiRes qw/time/;
use B;
use Data::Dumper;
use POSIX qw(strftime);
use Data::GUID;

our %LOG;

our $VERSION = '0.05';

BEGIN {
	%LOG = (
		LOGGER => 'Medusa::Logger',
		LOG_LEVEL => 'debug',
		LOG_FILE  => 'audit.log',
		LOG_INIT => sub {
			(my $module = $LOG{LOGGER}) =~ s/::/\//g;
			require $module . '.pm';
			$LOG{LOGGER}->new(
				file => $LOG{LOG_FILE},
			);
		},
		TIME => 'gmtime',
		TIME_FORMAT => 'default', # example '%Y%m%dT%H:%M:%S.%ms',
		LOG => undef,
		LOG_FUNCTIONS => {
			error => 'error',
			info  => 'info',
			debug => 'debug',
		},
		QUOTE => '†',
		OPTIONS => {
			date => 1,
			guid => 1,
			level => 1,
			elapsed_call => 1,
			caller => 1,
		},
		FORMAT_MESSAGE => sub {
			my %params = @_;
			my $log_message = $params{message};
			my $log_meth = $params{level} || $LOG{LOG_FUNCTIONS}{$LOG{LOG_LEVEL}};
			my $options = $LOG{OPTIONS};
			my $time = ! $options->{date}
				? 0
				: $LOG{TIME_FORMAT} eq 'default'
					? $LOG{TIME} eq 'gmtime'
						? gmtime
						: localtime
					: do {
						my @now = $LOG{TIME} eq 'gmtime'
							? gmtime
							: localtime;
						my ($format, $ms) = $LOG{TIME_FORMAT};
						if ($format =~ s/\.\%ms$//) {
							my $time = Time::HiRes::time;
							$time =~ m/(\.\d+)/;
							$ms = $1;
						}
						strftime($format, @now) . "$ms";
					};
			my $sprintf = "";
			my @sprintf_params;
			if ($time) {
				$sprintf .= "%s ";
				push @sprintf_params, $time;
			}
			if ($options->{guid} && $params{guid}) {
				$sprintf .= "%s ";
				push @sprintf_params, $params{guid};
			}
			if ($options->{level}) {
				$sprintf .= "%s";
				push @sprintf_params, uc $log_meth;
			}
			$sprintf =~ s/\s$//;
			my $message = sprintf($sprintf, @sprintf_params);
			for my $key (sort keys %params) {
				next if $key =~ m/^prefix|level|guid$/;
				if (ref $params{$key}) {
					my $ref = ref $params{$key};
					my $len = $ref eq 'ARRAY' ? scalar @{$params{$key} || []} - 1 : 1;
					for my $i (0 .. $len) {
						my $data = Dumper($ref eq 'HASH' ? $params{$key} : $params{params}->[$i]);
						$data =~ s/\$VAR1\s=\s//;
						$data =~ s/(\s+)(['"][^"]+['"])*/defined $2 ? $2 : ""/gem;
						$data =~ s/;$//;
						$message = sprintf("%s %s%s=%s%s%s",
							$message,
							$params{prefix},
							$i,
							$LOG{QUOTE},
							$data,
							$LOG{QUOTE},
						);
					}
				} else {
					$message = sprintf("%s %s=%s%s%s", $message, $key, $LOG{QUOTE}, $params{$key}, $LOG{QUOTE});
				}
			}
			return $message;
		}
	);
}

sub import {
	my ($pkg, @import) = @_;
	if (scalar @import % 2) {
		die "odd number of params passed in import";
	}
	my $caller = caller();
	{
		no strict 'refs';
		push @{"${caller}::ISA"}, $pkg;
	}
	while (@import) {
		my ($key, $val) = (shift @import, shift @import);
		$LOG{$key} = $val;
	}
}

sub MODIFY_CODE_ATTRIBUTES {
	my ($class,$code,@attrs) = @_;

	unless (ref $LOG{LOG}) {
		$LOG{LOG} = $LOG{LOG_INIT}->();
	}

	my ($att) = grep { $_ =~ m/Audit/ && $_ } @attrs;
	if ($att) {
		$att =~ m/Audit(?:\((.*)\))/;
		$att = $1;
		my $meta = B::svref_2object($code);
		my $meth = $meta->GV->NAME;
		my $caller = caller(1);
		no strict 'refs';
		no warnings 'redefine';
		*{"${caller}::$meth"} = sub {
			my $options = $LOG{OPTIONS};
			my ($n, $caller) = (0, "");
			if ($options->{caller}) {
				while (my @l = (caller($n))) {
					$caller .= "->" if $caller;
					$caller = sprintf "%s%s:%s", $caller, $l[0], $l[2];
					$n++;
				}
			}
			my $guid = !$options->{guid} ? 0 : Data::GUID->new->as_string;
			my ($now, $after) = (0, 0);
			log_message(
				($caller ? ( caller => $caller ) : ()),
				guid => $guid,
				message => sprintf(
					"subroutine %s called with args:",
					$meth
				),
				params => [@_],
				prefix => 'arg'
			);
			$now = time if $options->{elapsed_call};
			my @out = $code->(@_);
			$after = time if $options->{elapsed_call};
			log_message(
				($caller ? ( caller => $caller ) : ()),
				guid => $guid,
				message => sprintf(
					"subroutine %s returned:",
					$meth
				),
				params => [@out],
				($options->{elapsed_call} ? (elapsed_call => $after == $now ? 0 : $after - $now) : ()),
				prefix => 'return'
			);
			return wantarray ? @out : shift @out;
		};
		return;
	}

}

sub log_message {
	my (%params) = @_;
	my $log_meth = $params{level} || $LOG{LOG_FUNCTIONS}{$LOG{LOG_LEVEL}};
	$LOG{LOG}->$log_meth(
		$LOG{FORMAT_MESSAGE}->(
			%params,
			level => $log_meth
		)
	);
}

1;

__END__