#!/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;