File Coverage

blib/lib/Log/Dynamic.pm

Criterion	Covered	Total	%
statement	82	89	92.1
branch	19	28	67.8
condition	21	30	70.0
subroutine	19	20	95.0
pod	5	6	83.3
total	146	173	84.3

package Log::Dynamic;

$VERSION = 0.04;

use strict;
use warnings;

use Carp;
use Data::Dumper;

my $PKG   = __PACKAGE__;
my $MODE  = '>>';  # By default we append
my $UCASE = 1;     # By default we force types to upper case
my $TYPES = undef;

# Constructor
sub open {
	my $class = shift;

	# Catch an object call
	$class = ref $class || $class;

	return bless _init({@_}), $class;
}

# Initialize our params
sub _init {
	my $args = shift;
	my $fh;

	unless ($args->{'file'}) {
		croak "$PKG: Must supply file: Log::Dynamic->open(file => 'foo')";
	}

	# Override append mode to clobber mode if requested
	if (defined $args->{'mode'} && $args->{'mode'} =~ m/^clobber$/) {
		$MODE = '>';
	}

	# Override ucase mode if requested
	if (exists $args->{'ucase'} && !$args->{'ucase'}) {
		$UCASE = 0;
	}

	_init_types($args->{'types'},$args->{'invalid_type'});

	if ($args->{'file'} =~ /STD(?:OUT|ERR)/i) {
		$fh = uc $args->{'file'};
	} else {
		CORE::open($fh, $MODE, $args->{'file'})
			or croak "$PKG: Failed to open file '$args->{file}': $!";
	}

	return \$fh;
}

# Type initialization was a large enough chunk of code that
# I felt it should be pulled into its own subroutine.
sub _init_types {
	my $types   = shift || return;
	my $handler = shift || \&_invalid_type;

	# If provided the invalid type handler must be a coderef
	croak "$PKG: Value for the 'invalid_type' param must be a code ref"
		unless ref $handler eq 'CODE';

	# A Smudge of error checking. Non-empty array ref please
	croak "$PKG: Value for the 'types' param must be an array ref"
		unless ref $types eq 'ARRAY';

	croak "$PKG: Value for the 'types' param must not be an empty list"
		unless @{ $types };

	# We have types! Make a hash of types for easy lookup.
	# Note that we explicitly register dump here as a valid
	# type. If we didn't the sub that validates types would
	# crap out when calling dump(). Seems a bit hacky, I know...
	# but for the time being I think this solution is OK.
	$TYPES = { map { $_ => 1 } @{ $types }, 'dump' };

	# Store our invalid type handler.
	$TYPES->{'_handle_invalid'} = $handler;
}

# For those of you that decide you want to use the standard
# constructor notation of new(), here you go.
sub new { shift->open(@_) }

# O'hai. Sry, we closing...
sub close { close ${(shift)} }

# Base logging function
sub log {
	my $fh   = shift;             # File handle reference
	my $type = shift || return;   # Message type, REQUIRED
	my $msg  = shift || return;   # Message body, REQUIRED
	my $time = scalar localtime;  # Formatted timestamp

	_validate_type($type);

	# Formatted caller info. Because custom types are essentially
	# wrapper functions for log() we need to check up one more
	# level to get the correct caller information.
	my $call = join(' ',
		map {
			(caller(1))[$_]  # Called using $log->[custom type]()
			    ||           #      - OR -
			(caller(0))[$_]  # Called using $log->log()
		} 0..2
	);

	# Output formatted log entry. We turn off strict refs so that
	# we can print to STDERR and STDOUT witout perl spitting an
	# error and dying.
	no strict 'refs';
	print {$$fh} "$time [".($UCASE?uc($type):$type)."] $msg ($call)\n";
}

sub dump {
	my $log  = shift;
	my $args = shift;

	unless (ref $args) {
		carp "$PKG: dump() requires a hash ref of arg=>value pairs";
		return;
	}

	unless ($args->{'data'}) {
		carp "$PKG: dump() requires the 'data' argument be supplied";
		return;
	}

	# Set defaults
	$args->{'dump_type'} ||= 'dump';
	$args->{'dump_name'} ||= 'anonymous data';
	$args->{'begin_msg'} ||= 'BEGIN dump for:';
	$args->{'end_msg'  } ||= 'END dump for:';

	$log->log($args->{'dump_type'},
		$args->{'begin_msg'}    . " '$args->{dump_name}'\n" .
		Dumper($args->{'data'}) .
		$args->{'end_msg'}      . " '$args->{dump_name}'"
	);
}

sub AUTOLOAD {
	my $log  = shift;
	my $type = (our $AUTOLOAD = $AUTOLOAD);

	return if $type =~ /::DESTROY$/;
	$type =~ s/.*::(.+)$/$1/;

	_validate_type($type);

	# Define a subroutine for our new type. Since this new
	# sub just turns around and calls log() with a set value
	# for the $type variable you can probably lable this a
	# form of function currying. Weeeeee =)
	{
		no strict;
		no warnings;
		*$type = sub { shift->log($type,@_) };
	}

	# Log with our new type
	$log->log($type,@_);
}

# Chage the ucase value
sub ucase { shift;$UCASE = shift || 0}

# Valid log type
sub _validate_type {
	my $type = shift;

	if (defined $TYPES and not $TYPES->{$type}) {
		$TYPES->{'_handle_invalid'}->($type);
	}
}

sub _invalid_type  {
	my $type = shift;
	croak "$PKG: Type '$type' was not specified as a valid type";
}

# Cleanup... Just close the file handle
sub DESTROY { shift->close }

1;

__END__