File Coverage

blib/lib/Log/LogLite.pm

Criterion	Covered	Total	%
statement	63	87	72.4
branch	6	16	37.5
condition	10	15	66.6
subroutine	10	12	83.3
pod	6	8	75.0
total	95	138	68.8

package Log::LogLite;

use strict;
use vars qw($VERSION);

$VERSION = 0.82;

use Carp;
use IO::LockedFile 0.21;

my $TEMPLATE = '[] <>
';
my $LOG_LINE_NUMBERS = 0; # by default we do not log the line numbers

##########################################
# new($filepath)
# new($filepath,$level)
# new($filepath,$level,$default_message)
##########################################
# the constructor
sub new {
    my $proto = shift; # get the class name
    my $class = ref($proto) || $proto;
    my $self  = {};
    # private data
    $self->{FILE_PATH} = shift; # get the file path of the config file
    $self->{LEVEL} = shift || 5; # the default level is 5
    # report when:
    # 0  the application is unusable
    # 1  the application is going to be unusable
    # 2  critical conditions
    # 3  error conditions
    # 4  warning conditions
    # 5  normal but significant condition
    # 6  informational
    # 7+ debug-level messages
    $self->{DEFAULT_MESSAGE} = shift || ""; # the default message
    $self->{TEMPLATE} = shift || $TEMPLATE; # the template
    $self->{LOG_LINE_NUMBERS} = $LOG_LINE_NUMBERS;
    # we create IO::LockedFile object that can be locked later
    $self->{FH} = new IO::LockedFile({ lock => 0 }, ">>".$self->{FILE_PATH});
    unless ($self->{FH}->opened) {
	croak("Log::LogLite: Cannot open the log file $self->{FILE_PATH}");
    }
    bless ($self, $class);
    return $self;
} # of new

##########################
# write($message, $level)
##########################
# will log the message in the log file only if $level>=LEVEL
sub write {
    my $self = shift;
    my $message = shift; # get the message are informational
    my $level = shift || "-";
    if ($level ne "-" && $level > $self->{LEVEL}) {
        # if the level of this message is higher
	# then the deafult level - do nothing
	return;
    }

    # lock the log file before we append
    $self->{FH}->lock();

    # parse the template
    my $line = $self->{TEMPLATE};
    $line =~ s!!date_string()!igoe;
    $line =~ s!!$level!igo;
    $line =~ s!!$self->called_by()!igoe;
    $line =~ s!!$self->{DEFAULT_MESSAGE}!igo;
    $line =~ s!!$message!igo;
    print {$self->{FH}} $line;

    # unlock the file
    $self->{FH}->unlock();
} # of write

##########################
# template()
# template($template)
##########################
sub template {
    my $self = shift;
    if (@_) { $self->{TEMPLATE} = shift }
    return $self->{TEMPLATE};
} # of template

##########################
# level()
# level($level)
##########################
# an interface to LEVEL
sub level {
    my $self = shift;
    if (@_) { $self->{LEVEL} = shift }
    return $self->{LEVEL};
} # of level

###########################
# default_message()
# default_message($message)
###########################
# an interface to DEFAULT_MESSAGE
sub default_message {
    my $self = shift;
    if (@_) { $self->{DEFAULT_MESSAGE} = shift }
    return $self->{DEFAULT_MESSAGE};
} # of default_message

##########################
# log_line_numbers()
# log_line_numbers($log_line_numbers)
##########################
# an interface to LOG_LINE_NUMBERS
sub log_line_numbers {
    my $self = shift;
    if (@_) { $self->{LOG_LINE_NUMBERS} = shift }
    return $self->{LOG_LINE_NUMBERS};
} # of log_line_numbers

#######################
# date_string()
#######################
sub date_string {
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
    # note that there is no Y2K bug here. see localtime in perlfunc.
    return sprintf("%02d/%02d/%04d %02d:%02d:%02d",
		   $mday, $mon + 1, $year + 1900, $hour, $min, $sec);
} # of date_string

#######################
# called_by
#######################
sub called_by {
    my $self = shift;
    my $depth = 2;
    my $args;
    my $pack;
    my $file;
    my $line;
    my $subr;
    my $has_args;
    my $wantarray;
    my $evaltext;
    my $is_require;
    my $hints;
    my $bitmask;
    my @subr;
    my $str = "";
    while (1) {
	($pack, $file, $line, $subr, $has_args, $wantarray, $evaltext,
	 $is_require, $hints, $bitmask) = caller($depth);
	unless (defined($subr)) {
	    last;
	}
	$depth++;
	$line = ($self->{LOG_LINE_NUMBERS}) ? "$file:".$line."-->" : "";
	push(@subr, $line.$subr);
    }
    @subr = reverse(@subr);
    foreach $subr (@subr) {
	$str .= $subr;
	$str .= " > ";
    }
    $str =~ s/ > $/: /;
    return $str;
} # of called_by

1;
__END__