File Coverage

blib/lib/Log/Deep/Line.pm

Criterion	Covered	Total	%
statement	59	110	53.6
branch	7	50	14.0
condition	5	18	27.7
subroutine	12	20	60.0
pod	10	10	100.0
total	93	208	44.7

package Log::Deep::Line;

# Created on: 2009-05-30 21:19:07
# Create by:  Ivan Wills
# $Id$
# $Revision$, $HeadURL$, $Date$
# $Revision$, $Source$, $Date$

use strict;
use warnings;
use version;
use Carp;
use Readonly;
use Data::Dumper qw/Dumper/;
use English qw/ -no_match_vars /;
use base qw/Exporter/;
use Term::ANSIColor;

our $VERSION     = version->new('0.3.5');
our @EXPORT_OK   = qw//;
our %EXPORT_TAGS = ();

Readonly my $LEVEL_COLOURS => {
		info     => '',
		message  => '',
		debug    => '',
		warn  => 'yellow',
		error    => 'red',
		fatal    => 'bold red',
		security => '',
	};

sub new {
	my $caller = shift;
	my $class  = ref $caller ? ref $caller : $caller;
	my ($self, $line, $file) = @_;

	if (ref $self ne 'HASH') {
		$file = $line;
		$line = $self;
		$self = {};
	}

	bless $self, $class;

	$self->parse($line, $file) if $line && $file;

	return $self;
}

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

	# split the line into 5 parts
	# TODO this might cause some problems if the message happens to have a \, in it
	my @log = split /(?

	if ( @log != 5 && $self->{verbose} ) {
		# get the file name and line number
		my $name    = $file->{name};
		my $line_no = $file->{handle}->input_line_number;

		# output the warnings about the bad line
		warn "The log $name line ($line_no) did not contain 4 columns! Got ". (scalar @log) . " columns\n";
		warn $line if $self->{verbose} > 1;
	}

	# un-quote the individual columns
	for my $col (@log) {
		$col =~ s/ \\ \\ /\\/gxms;
		$col =~ s/ (?
		$col =~ s/ (?
	}

	# re-process the data so we can display what is needed.
	my $DATA;
	if ( $log[-1] =~ /;$/xms && length $log[-1] < 1_000_000 ) {
		local $SIG{__WARN__} = sub {};
		eval $log[-1];  ## no critic
	}
	else {
		warn '' . (length $log[-1] < 1_000_000 ? 'The data is too large to process' : 'There appears to be a problem with the data' ) . ' on line ' . $file->{handle}->input_line_number . "\n";
		$DATA = {};
	}

	$self->{date}    = $log[0];
	$self->{session} = $log[1];
	$self->{level}   = $log[2];
	$self->{message} = $log[3];
	$self->{DATA}    = $DATA;

	$self->{file}     = $file;
	$self->{position} = $file->{handle} ? tell $file->{handle} : 0;

	return $self;
}

sub id { $_[0]->{session} };

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

	if ($colour) {
		my ($foreground, $background) = $colour =~ /^ ( \w+ ) \s+ on_ ( \w+ ) $/xms;
		$self->{fg} = $foreground;
		$self->{bg} = $background;
	}

	return "$self->{fg} on_$self->{bg}";
}

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

	# TODO add real filtering body here
	return 0 if !$self->{date} || !$self->{session};

	return 1;
}

sub text {
	my ($self) = @_;
	my $out = '';

#	my $last = $self->{last_line_time} || 0;
#	my $now  = time;
#
#	# check if we are putting line breaks when there is a large time between followed file output
#	if ( $self->{breaks} && $now > $last + $self->{short_break} ) {
#		my $lines = $now > $last + $self->{long_break} ? $self->{long_lines} : $self->{short_lines};
#		$out .= "\n" x $lines;
#	}
#	$self->{last_line_time} = $now;

	# construct the log line determining colours to use etc
	my $level = $self->{mono} ? $self->{level} : colored $self->{level}, $LEVEL_COLOURS->{$self->{level}};
	$out .= $self->{mono} ? '' : color $self->colour();
	$out .= "[$self->{date}]";

	if ( !$self->{verbose} ) {
		# add the session id if the user cares
		$out .= " $self->{session}";
	}
	if ( !$self->{mono} ) {
		# reset the colour if we are not in mono
		$out .= color 'reset';
	}

	# finish constructing the log line
	$out .= " $level - $self->{message}\n";

	return $out;
}

sub data {
	my ($self) = @_;
	my $display = $self->{display};
	my @fields;
	my @out;
	my $data = $self->{DATA};

	$display->{data} = defined $display->{data} ? $display->{data} : 1;

	# check for any fields that should be displayed
	FIELD:
	for my $field ( sort keys %{ $display } ) {
		push @out,
			  $display->{$field} eq 0                                      ? ()
			: !defined $data->{$field}                                     ? data_missing($field, $data)
			: ref $display->{$field} eq 'ARRAY' || $display->{$field} ne 1 ? data_sub_fields($field, $data->{$field})
			: !ref $data->{$field}                                         ? data_scalar($field, $data->{$field})
			: $field ne 'data' || %{ $data->{$field} }                     ? $self->{dump}->Names($field)->Data($data->{$field})->Out()
			:                                                                ();
	}

	return @out;
}

sub data_missing {
	my ( $self, $field, $data ) = @_;
	return if ref $field;
	return if $field eq 'data';
	return "\$$field = " . (exists $data->{field} ? 'undef' : 'missing') . "\n";
}

sub data_sub_fields {
	my ( $self, $field, $data ) = @_;
	my $display = $self->{display};
	my @out;

	# select the specified sub keys of $field
	if ( !ref $display->{$field} ) {
		# convert the display field into an array so that we can select it's sub fields
		$display->{$field} = [ split /,/, $display->{$field} ];
	}

	# out put each named sub field of $field
	for my $sub_field ( @{ $display->{$field} } ) {
		push @out, $self->{dump}->Names( $field . '_' . $sub_field )->Data( $data->{$sub_field} )->Out();
	}

	return @out;
}

sub data_scalar {
	my ( $self, $field, $data ) = @_;

	# out put scalar values with out the DDS formatting
	my $out .= "\$$field = " . ( defined $data ? $data : 'undef' );

	# safely guarentee that there is a new line at the end of this line
	chomp $out;
	$out .= "\n";
	return $out;
}

1;

__END__