File Coverage

blib/lib/Log/Deep.pm

Criterion	Covered	Total	%
statement	216	220	98.1
branch	61	78	78.2
condition	41	71	57.7
subroutine	39	39	100.0
pod	24	24	100.0
total	381	432	88.1

package Log::Deep;

# Created on: 2008-10-19 04:44:02
# Create by:  ivan
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use strict;
use warnings;
use version;
use Carp qw/croak longmess/;
use List::MoreUtils qw/any/;
use Readonly;
use Clone qw/clone/;
use Data::Dump::Streamer;
use POSIX qw/strftime/;
use Fcntl qw/SEEK_END/;
use English qw/ -no_match_vars /;
use base qw/Exporter/;

our $VERSION     = version->new('0.3.5');

Readonly my @LOG_LEVELS => qw/info message debug warn error fatal/;

sub new {
	my $class  = shift;
	my %param  = @_;
	my $self   = {};

	bless $self, $class;

	$self->{dump} = Data::Dump::Streamer->new()->Indent(0)->Names('DATA');

	# set up log levels
	if (!$param{-level}) {
		$self->level(qw/warn error fatal/);
	}
	else {
		$self->level(ref $param{-level} eq 'ARRAY' ? @{$param{-level}} : $param{-level});
	}

	# set up the log file parameters
	$self->{file}     = $param{-file};
	$self->{log_dir}  = $param{-log_dir};
	$self->{log_name} = $param{-name};
	$self->{date_fmt} = $param{-date_fmt};
	$self->{style}    = $param{-style} || 'none';

	# set up the maximum random session id
	$self->{rand_max} = $param{-rand_max} || 10_000;

	# set up tracked variables
	# Configuration variables - These are only recorded with calls to session()
	$self->{vars_config}      = $param{-vars_config} || {};
	$self->{vars_config}{ENV} = \%ENV;

	# runtime varibles - These are recorded with every log message
	$self->{vars} = $param{-vars} || {};

	if ($param{-catchwarn}) {
		$self->catch_warnings(1);
	}

	# check if we are starting a session or not
	if ($param{-nosession}) {
		$self->{session} = $param{-session_id};
	}
	else {
		$self->session($param{-session_id});
	}

	return $self;
}

sub info {
	my ($self, @params) = @_;

	return if !$self->is_info;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'info';

	return $self->record(@params);
}

sub message {
	my ($self, @params) = @_;

	return if !$self->is_message;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'message';

	return $self->record(@params);
}

sub debug {
	my ($self, @params) = @_;

	return if !$self->is_debug;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'debug';

	return $self->record(@params);
}

sub warn {
	my ($self, @params) = @_;

	return if !$self->is_warn;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'warn';

	return $self->record(@params);
}

sub error {
	my ($self, @params) = @_;

	return if !$self->is_error;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'error';

	my $ans = $self->record(@params);
	$self->flush;

	return $ans;
}

sub fatal {
	my ($self, @params) = @_;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'fatal';

	$self->record(@params);

	croak join ' ', @params[ 1 .. @params -1 ];

	return;
}

sub security {
	my ($self, @params) = @_;

	if (!ref $params[0] || ref $params[0] ne 'HASH') {
		unshift @params, {};
	}

	$params[0]{-level} = 'security';

	return $self->record(@params);
}

sub record {
	my ($self, $data, @message) = @_;
	my $dump = $self->{dump};

	# check that a session has been created
	$self->session($data->{-session_id}) if !$self->{session_id};

	my $level  = $data->{-level} || '(none)';
	delete $data->{-level};

	my $configs = $data->{-write_configs};
	delete $data->{-write_configs};

	my $param = {
		data => $data,
		vars => $self->{vars},
	};

	# add all the config variables to the variables to be logged
	if ($configs) {
		for my $var ( keys %{ $self->{vars_config} } ) {
			$param->{vars}{$var} = $self->{vars_config}{$var};
		}
	}

	# set up
	$param->{stack} = substr longmess, 0, 1_000;
	$param->{stack} =~ s/^\s+[^\n]*Log::Deep::[^\n]*\n//gxms;
	$param->{stack} =~ s/\A\s at [^\n]*\n\s+//gxms;
	$param->{stack} =~ s/\n[^\n]+\Z/\n.../xms;

	my @log = (
		strftime('%Y-%m-%d %H:%M:%S', localtime),
		$self->{session_id},
		$level,
		(join ' ', @message),
		$dump->Data($param)->Out(),
	);

	# make each part safe for outputting to one line
	for my $col (@log) {
		chomp $col;
		# quote all back slashes
		$col =~ s{\\}{\\\\}g;
		# quote all new lines
		$col =~ s/\n/\\n/g;
	}

	my $log = $self->log_handle();
	print {$log} join ',', @log;
	print {$log} "\n";

	$self->{log_session_count}++;

	return ;
}

sub log_handle {
	my $self = shift;

	if ( !$self->{handle} ) {
		$self->{log_dir}  ||= $ENV{TMP} || '/tmp';
		$self->{log_name} ||= (split m{/}, $0)[-1] || 'deep';
		$self->{date_fmt} ||= '%Y-%m-%d';
		$self->{log_date}   = strftime $self->{date_fmt}, localtime;

		my $file = $self->{file} || "$self->{log_dir}/$self->{log_name}_$self->{log_date}.log";

		# guarentee that there is a new line before we start writing
		my $missing = 0;
		if ( !$self->{reopening} && -s $file ) {
			open my $fh, '<', $file or die "Could not open the log file $file to check that it ends in a new line: $OS_ERROR\n";
			seek $fh, -20, SEEK_END;
			my $end = <$fh>;
			$missing = $end =~ /\n$/;
			close $fh;
		}

		open my $fh, '>>', $file or die "Could not open log file $file: $OS_ERROR\n";
		$self->{file}   = $file;
		$self->{handle} = $fh;

		if ($missing) {
			print {$fh} "\n";
		}
	}

	return $self->{handle};
}

sub session {
	my ($self, $session_id) = @_;

	if ( ! defined $session_id ) {
		return if defined $self->{log_session_count} && $self->{log_session_count} == 0;
	}

	# use the supplied session id or create a new session id
	$self->{session_id} = $session_id || int rand $self->{rand_max};

	$self->record({ -write_configs => 1 }, '"START"');

	$self->{log_session_count} = 0;

	return;
}

sub level {
	my ($self, @level) = @_;

	$self->{level} ||= { map { $_ => 0 } @LOG_LEVELS };

	# if not called with any parameters return the level hash
	return clone $self->{level} if !@level;

	# return log state if asked about that state
	return $self->{level}{$level[1]}     if $level[0] eq '-log';

	# Set a log state if requested
	return $self->{level}{$level[1]} = 1 if $level[0] eq '-set';

	# Unset a log state if requested
	return $self->{level}{$level[1]} = 0 if $level[0] eq '-unset';

	# if there is only one parameter that is a single digit set the all levels of that digit and higher
	if (@level == 1 && $level[0] =~ /^\d$/) {
		my $i = 0;
		for my $log_level (@LOG_LEVELS) {
			$self->{level}{$log_level} = $i++ >= $level[0] ? 1 : 0;
		}

		return clone $self->{level};
	}

	# if the is one parameter and it is a string turn on that level and highter
	if ( @level == 1 && any { $_ eq $level[0] } @LOG_LEVELS ) {

		# flag that we have found the starting level
		my $found = 0;

		for my $log_level (@LOG_LEVELS) {

			# flag that we have the start level
			$found = 1 if $log_level eq $level[0];

			# mark the current level appropriatly
			$self->{level}{$log_level} = $found ? 1 : 0;
		}

		return clone $self->{level};
	}

	# set all levels passed in as active levels.
	for my $level (@level) {
		$self->{level}{$level} = 1;
	}

	return clone $self->{level};
}

sub enable {
	my ($self, @levels) = @_;

	for my $level (@levels) {
		$self->{level}{$level} = 1;
	}
	return;
}

sub disable {
	my ($self, @levels) = @_;

	for my $level (@levels) {
		$self->{level}{$level} = 0;
	}

	return;
}

sub is_info     { return $_[0]->{level}{info}     }
sub is_message  { return $_[0]->{level}{message}  }
sub is_debug    { return $_[0]->{level}{debug}    }
sub is_warn     { return $_[0]->{level}{warn}     }
sub is_error    { return $_[0]->{level}{error}    }
sub is_fatal    { return $_[0]->{level}{fatal}    }
sub is_security { return 1                        }

sub file {
	my ($self) = @_;

	return $self->{file};
}

sub catch_warnings {
	my ($self, $action) = @_;

	if ( $action == 1 && !$self->{old_warn_handle} ) {
		# save old handle
		$self->{old_warn_handle} = $SIG{__WARN__};

		# install a redirect of all warnings to $self->warn
		$SIG{__WARN__} = sub {
			my $data = {};
			if ( ref $_[0] ) {
				# record the error reference for better display
				# using the error in the message just stringifys it
				$data->{ERROR_OBJ} = $_[0];
			}
			$self->warn( $data, $_[0] );
		}
	}
	elsif ( $action == 0 && $self->{old_warn_handle} ) {
		$SIG{__WARN__} = $self->{old_warn_handle};
		delete $self->{old_warn_handle};
	}

	return $self->{old_warn_handle} && 1;
}

sub flush {
	my ($self) = @_;

	return if ! exists $self->{handle};

	close $self->{handle};
	delete $self->{handle};
	$self->{reopening} = 1;

	return;
}

sub DESTROY {
	my ($self) = @_;

	if ($self->{handle}) {
		close $self->{handle};
	}

	return;
}

1;

__END__