#!/bin/perl
use Log::Painless; # sends warnings, info, and exceptions to main.log
info "Logging begun";
warn "Hello, there!"; #behaves like warn, but logs warning as well.
die "Program done."; #behaves like die, but logs exception as well.
####
use Log::Painless { file => 'myscript.log', level => 'debug' };
##
##
use Log::Painless { level => 'debug' };
sub test_log {
debug enter; # puts 'Entered subroutine main::test_log' to log
eval {
# .. something which could die..
};
if ($@) {
# logs 'Caught exception [$@] 1 evals deep in main::test_log'
info caught;
# .. handle the exception
}
debug leave; # as enter, above, but "Left subroutine"
}
test_log();
##
##
info 'Starting to connect to data source: '.$dsn;
##
##
eval {
$dbh = DBI->connect('dbi:SQLite2:dbname=test.db','','') or
die ("Can't connect!");
};
if ($@) {
info caught;
warn "Falling back to CSV file..."
# do stuff.
}
##
##
2006-03-14T13:21:32 4508 E (myscript.pl/11):Can't connect!
2006-03-14T13:21:32 4508 I Caught exception [Can't connect!] 1 evals deep in main
2006-03-14T13:21:32 4508 W (myscript.pl/16):Falling back to CSV file...
##
##
sub test_sub {
trace enter;
# .. some stuff
}
##
##
2006-03-14T13:21:33 4509 T Entered subroutine main::test_sub
##
##
sub test_sub {
# .. some stuff
trace leave;
}
##
##
2006-03-14T13:21:35 4509 T Left subroutine main::test_sub
##
##
use Log::Painless { file => 'messages.log' };
##
##
use Log::Painless { level => 'debug' }; # only trace will be supressed
##
##
use Log::Painless { shortcuts => [ 'caught' ] }; # only import caught()
##
##
Log::Painless->divert('debug' => 'debug.log');
##
##
Log::Painless->duplicate('debug' => *STDERR);
##
##
Log::Painless->divert('debug' => 'debug.log');
Log::Painless->duplicate('debug' => *STDERR);
##
##
use Log::Painless;
{
my $old_warn = $SIG{__WARN__};
$SIG{__WARN__} = sub {
# my own signal handling;
$old_warn->(@_);
};
}
##
##
Date-Time PID Type-Char Message
With default format settings, this results in something like:
##
##
2006-03-14T14:22:32 4856 E (testlog.pl/10):the death
##
##
use Log::Painless {
lineformat => sub { my $m = shift; $m=~s/^(.*?) \d+/$1/; return $m },
};
##
##
package Log::Painless;
#===============================================================================
# $Id: Painless.pm,v 1.1 2006-02-27 09:58:51 radiant Exp $
# Painless, simple logging facility
#-------------------------------------------------------------------------------
# (c) 2006 RadiantMatrix, under an MIT License (see LICENSE doc section)
#===============================================================================
use strict;
#use warnings;
#__Modules__#
require Exporter;
use Fcntl;
use IO::Handle;
use Data::Dumper ();
use POSIX qw[strftime];
use vars qw[@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION];
#__setup__#
$VERSION = sprintf "%d.%03d", q$Revision: 1.1 $ =~ /: (\d+)\.(\d+)/; #CVS
@ISA = qw[Exporter];
@EXPORT = qw[info debug trace];
@EXPORT_OK = qw[enter leave caught];
my %Config;
my %Lvl = ( trace => 5, debug => 4, info => 3, warning => 2, exception => 1 );
#__configuration and import__#
my $LE = "\n";
# ( $^O eq 'MSWin32' ? "\x0D\x0A" : "\x0A" ); #Win line endings or Unix?
sub trace ($) { }
sub debug ($) { }
sub info ($) { }
#_____________________________________________________________________ import()_
sub import {
# import ( \%config )
my $self = shift;
my $config = shift;
(my $dlog = caller().'.log') =~ s/\W+/_/g;
my %default = (
file => $dlog,
level => 'info',
logformat => '%s %d %s %s',
timeformat => '%Y-%m-%dT%H:%M:%S',
shortcuts => [ qw(enter leave caught) ],
quiet_warn => 0,
);
foreach (keys %default) {
$config->{$_} = $default{$_} unless exists $config->{$_};
}
unless ( exists $Lvl{ $config->{level} } ) {
die "Bad log level: $$config{level}" ;
}
no warnings 'redefine';
foreach ( sort { $Lvl{$a} <=> $Lvl{$b} } keys %Lvl ) {
$Config{$_}{files} = [];
$self->divert( $_ => $config->{file} );
if ($Lvl{$config->{level}} >= $Lvl{$_}) {
eval '*'.$_.'=\&_'.$_.';';
}
else {
eval '*'.$_.'=\&_empty;';
}
}
for (qw [logformat timeformat lineformat level quiet_warn] ) {
$Config{$_} = $config->{$_} if exists $config->{$_};
}
my ($sig_warn, $sig_die) = ($SIG{__WARN__}, $SIG{__DIE__});
$SIG{__WARN__} = sub {
CORE::warn(@_) unless $Config{quiet_warn};
warning ( @_ );
if (defined $sig_warn && ref $sig_warn eq 'CODE') { $sig_warn->(@_) }
};
$SIG{__DIE__} = sub {
exception( @_ );
if (defined $sig_die && ref $sig_die eq 'CODE') { $sig_die->(@_) }
};
$self->export_to_level(1, $self, @EXPORT);
if (defined $config->{shortcuts}) {
$self->export_to_level(1, $self, @{ $config->{shortcuts} } );
}
}
#__________________________________________________________________ duplicate()_
sub duplicate {
# duplicate ( %cfg )
my $self = shift;
my %cfg = @_;
foreach ( keys %cfg ) {
next unless exists $Config{$_}{files};
my $fh;
if ( $cfg{$_} =~ /^\*/ ) {
$fh = $cfg{$_};
# die("handle not open for writing while duplicating log '$_'")
# unless ( O_WRONLY | O_RDWR ) & fcntl( $fh, F_GETFL, my $slush );
}
else {
open $fh, '>>', $cfg{$_}
or die("Can't append to $cfg{$_} while duplicating log '$_'");
}
autoflush $fh 1;
push @{ $Config{$_}{files} }, $fh;
}
return 1;
}
#_____________________________________________________________________ divert()_
sub divert {
# divert ( %cfg )
my $self = shift;
my %cfg = @_;
my %sav;
foreach ( keys %cfg ) {
next unless exists $Config{$_}{files};
$sav{$_} = $Config{$_}{files} unless exists $sav{$_};
my $fh;
if ( $cfg{$_} =~ /^\*/ ) {
$fh = $cfg{$_};
# die("handle not open for writing while diverting log '$_'")
# unless ( O_WRONLY | O_RDWR ) & fcntl( $fh, F_GETFL, my $slush );
}
else {
open $fh, '>>', $cfg{$_}
or die("Can't append to $cfg{$_} while diverting log '$_'");
}
autoflush $fh 1;
$Config{$_}{files} = [$fh];
}
return \%sav;
}
#_____________________________________________________________________ _write()_
sub _write {
# _write ( $level, $msg )
my ( $level, $msg ) = @_;
$msg =~ s/[\r\n]/\x1F/g; # change line-breaks to field-seps.
my $line = sprintf $Config{'logformat'},
strftime($Config{'timeformat'}, localtime),
$$, uc substr($level,0,1), $msg;
# call global custom formater if it exists
$line = $Config{'lineformat'}->($line)
if ( exists $Config{'lineformat'}
&& ref $Config{'lineformat'} eq 'CODE' );
# call level custom formater if it exists
$line = $Config{$level}{'lineformat'}->($line)
if ( exists $Config{$level}{'lineformat'}
&& ref $Config{$level}{'lineformat'} eq 'CODE' );
# write to log
for ( @{ $Config{$level}{files} } ) {
print $_ $line,$LE;
}
return 1;
}
#__ shortcuts __#
#______________________________________________________________________ enter()_
sub enter () {
# enter ( ) - generates a sub entrance message.
my ($pack, $file, $line, $sub) = caller(1);
return 'Entered subroutine '.$sub;
}
#______________________________________________________________________ leave()_
sub leave () {
# leave ( ) - generates a sub departure message.
my ($pack, $file, $line, $sub) = caller(1);
return 'Left subroutine '.$sub;
}
#_____________________________________________________________________ caught()_
sub caught () {
# caught ( ) - invoked as, e.g. info caught;
my $cl = 1;
my ($pack, $file, $sub);
do {
($pack,$file, undef, $sub) = caller($cl++);
} until ($sub ne '(eval)');
$cl--;
(my $exc = $@) =~ s/(.*) at .*$/$1/s; #trim of 'at file line ##' msg.
$exc=~ s/[\r\n]/\x1F/gs; #replace line endings.
return 'Caught exception ['.$exc.'] '
.($cl>0 ? "$cl evals deep " : '').'in '
.($sub ? $sub : 'main');
}
#_____________________________________________________________________ _empty()_
sub _empty ($) { } # executed when a log level is to be skipped
#__ interfaces __#
#_____________________________________________________________________ _trace()_
sub _trace ($) {
# trace ( $msg )
_write('trace', @_)
}
#_____________________________________________________________________ _debug()_
sub _debug ($) {
# debug ( $msg )
_write('debug', @_)
}
#_____________________________________________________________________ _info()_
sub _info ($) {
# info ( $msg )
_write('info', @_)
}
#___________________________________________________________________ _warning()_
sub _warning ($) {
# warning ( $msg )
(my $msg = shift) =~ m/(.*)\s+at (.*?) line (\d+).*$/;
_write('warning', "($2\/$3):$1");
#- CORE::warn($msg) if ($Lvl{$Config{level}} >= $Lvl{warning});
}
#_________________________________________________________________ _exception()_
sub _exception ($) {
# exception ( $msg )
(my $msg = shift) =~ m/(.*)\s+at (.*?) line (\d+).*$/;
_write('exception', "($2\/$3):$1");
CORE::die($msg);
}
1;