Jump to code

• NAME
• SYNOPSIS
• FUNCTIONS
• CONFIGURATION
• DUPLICATING AND DIVERTING LOGS
• SIGNAL HANDLERS
• LOGFILE FORMAT
• LICENSE

---

$Id: Painless.pod,v 1.1 2006-02-27 09:58:51 radiant Exp $ $Revision: 1.1 $

---

NAME

This document describes the Log::Painless module.

---

SYNOPSIS

Log::Painless (hereafter, LP) is a module designed to allow reasonably configurable, yet painless logging. Everything from reasonable defaults to the interface, to the configuration system is meant to be as painless as possible without sacrificing too much functionality.

This module abuses Exporter to create the info, debug, and trace subroutines in the importing package. There is no way to turn this off: it's kind of the whole point.

Warnings and exceptions are handled via signal handlers attached to the perl built-in functions warn and die. See SIGNAL HANDLERS for more on these.

Examples:

        #!/bin/perl
        use Log::Painless; # sends warnings, info, and exceptions to m
+ain.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.
[download]

LP is configured during import (see CONFIGURATION):

        use Log::Painless { file => 'myscript.log', level => 'debug' }
+;
[download]

Any logging calls that are supressed by the current logging level are empty subs, so performance should not be impacted by peppering code with trace calls.

There are also three shortcuts (enter, leave, caught) imported by default to make tracing/debugging easier:

        use Log::Painless { level => 'debug' };
        
        sub test_log {
            debug enter;  # puts 'Entered subroutine main::test_log' t
+o log
            eval {
               # .. something which could die..
            };
            if ($@) {
               # logs 'Caught exception [$@] 1 evals deep in main::tes
+t_log'
               info caught;
               # .. handle the exception
            }
            debug leave;  # as enter, above, but "Left subroutine"
        }
        test_log();
[download]

The caught call removes the 'at file.pl line ##.' from the caught exception message, for clarity.

---

FUNCTIONS

info

        info 'Starting to connect to data source: '.$dsn;
[download]

Records an info-level log message.

Takes one scalar argument as a message to record to the log. This and all other exported functions are prototyped so that only one argument will be accepted (and parentheses are not required) -- this is much like the behavior of the functions warn and die.

debug

As info, bug for debug-level messages. More verbose than info, less verbose than trace.

trace

As info, but for trace-level messages. Most verbose level, should be used for extremely detailed information only.

caught

A shortcut that returns a string indicating that an exception was caught, and providing information about the nature and location of the caught exception. This is intended to be paired with a logging statement. The exception will still be logged. For example:

        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.
        }
[download]

Might result in the following log:

        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 CS
+V file...
[download]

Note that nested evals are noted, and either the package name or the subroutine that generates the exception is noted.

enter

A shortcut that returns a message string indicating entry into the calling subroutine. This is intended to be paired with a logging statement. For example:

        sub test_sub {
                trace enter;
                # .. some stuff
        }
[download]

Might result in a the following log:

        2006-03-14T13:21:33 4509 T Entered subroutine main::test_sub
[download]

Note that the package name is included.

leave

A shorcut in the style of enter, but provides a 'Left subroutine' message:

        sub test_sub {
                # .. some stuff
                trace leave;
        }
[download]

Might result in a the following log:

        2006-03-14T13:21:35 4509 T Left subroutine main::test_sub
[download]

---

CONFIGURATION

Almost all configuration is done during import by passing a single hashref. The exceptions to this rule are covered in DUPLICATING AND DIVERTING LOGS.

Following are the options for import-time configuration:

file

The default logging destination. This may be either a filehandle typeglob (e.g. *STDERR) or a file name. If a file name, the file will be opened for appending, and created if it does not exist. If a handle, LP will assume that it is already open for writing.

By default, it is the package name followed by '.log';

        use Log::Painless { file => 'messages.log' };
[download]

level

The maximum level of detail to record in any log. Levels are literal strings: exception, warning, info, debug, trace (in order of increasing detail). The default level is 'info'.

        use Log::Painless { level => 'debug' }; # only trace will be s
+upressed
[download]

timeformat

A format string for the Date-Time stamp on each message, in the POSIX::strftime manner. The default is an ISO8601 format.

logformat

A format string in the sprintf manner. This controls how the log lines appear. The default is '%s %d %s %s'; the order of format codes is Date-Time, PID, Type-Char, Message. See LOGFILE FORMAT for more information.

lineformat

An optional CODEref for reformatting the log line before it is written to disk. The CODEref must accept the preformatted line as its first parameter, and return the line to be written to disk. See LOGFILE FORMAT for more information.

shortcuts

A list of shortcuts to be exported. By default, all three shortcuts (enter, leave, and caught) are exported. This option allows the implementor to avoid exporting one or more of these by specifying the ones s?he wants imported.

        use Log::Painless { shortcuts => [ 'caught' ] }; # only import
+ caught()
[download]

quiet_warn

When set, supressess passing of warnings to CORE::warn. By default, this is unset, and warnings behave as usual, with logging as appropriate. See SIGNAL HANDLERS for more details.

---

DUPLICATING AND DIVERTING LOGS

Using only import-time configuration, only one log file may be used. However, it is commonly useful to have particular classes of messages be directed to separate log files. For example, an implementor may wish to have all debug messages directed to a file named 'debug.log'.

LP supports this functionality through runtime configuration, allowing specific-level messages to be duplicated to several logs or diverted to a separate log.

For example, to divert all debug-level messages to 'debug.log':

        Log::Painless->divert('debug' => 'debug.log');
[download]

Either a filehandle typeglob or filename may be given to divert. In some cases, an implementor wishes to duplicate messages to a secondary target:

        Log::Painless->duplicate('debug' => *STDERR);
[download]

This will log all debug messages as previously configured, but also log them to STDERR. This call can be repeated to cause messages to be written to a theoretically limitless number of logs. Duplicating to more than two or three targets is, though, strongly discouraged for practical reasons.

These calls can be sensibly combined, as well. For example, if the default log target is 'main.log', but debug messages are to go only to 'debug.log' and STDERR:

        Log::Painless->divert('debug' => 'debug.log');
        Log::Painless->duplicate('debug' => *STDERR);
[download]

It's worth noting that divert will disable all previous targets for the given message level.

---

SIGNAL HANDLERS

Warnings and exceptions are handled via overriding the signal handlers for the built-in warn and die functions. That is, $SIG{__WARN__} and $SIG{__DIE__} are universally overridden. If there are signal handlers already existing at import time, these will be automatically chained onto the logging handlers.

For warnings, CORE::warn will be called to propagate warnings unless quiet_warn is set. For exceptions, CORE::die will be called for propagation under all circumstances. This means all calls to die -- even those inside eval{} blocks -- will be logged. It is a good idea to use caught to note when such exceptions are handled internally.

To preserve logging capabilities when overriding these handlers at runtime, merely chain them:

        use Log::Painless;
        {
           my $old_warn = $SIG{__WARN__};
           $SIG{__WARN__} = sub {
              # my own signal handling;
              $old_warn->(@_);
           };
        }
[download]

See perlvar under %SIG for more details about this.

---

LOGFILE FORMAT

The logfile format is:

        Date-Time PID Type-Char Message
        
With default format settings, this results in something like:
[download]

        2006-03-14T14:22:32 4856 E (testlog.pl/10):the death
[download]

The Type-Char is one of Trace, Debug, Info, Warning, Exception. The line format may be altered through the logformat and timeformat configuration directives. Additionally, the lineformat directive can be used to specify a CODEref that will reformat each log line before it is written.

For example, to elimitate the PID from the log:

        use Log::Painless {
                lineformat => sub { my $m = shift; $m=~s/^(.*?) \d+/$1
+/; return $m },
        };
[download]

Any newlines found within Message are converted to the ASCII Field Separator char (0x1F).

---

LICENSE

Copyright (c) 2006 Darren Meyer <darren.meyer@gmail.com>

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the ``Software''), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

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 sectio
+n)
#=====================================================================
+==========
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} } );
    }
}

#__________________________________________________________________ du
+plicate()_
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 ##' m
+sg.
    $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});
}

#_________________________________________________________________ _ex
+ception()_
sub _exception ($) {
    # exception ( $msg )
    (my $msg = shift) =~ m/(.*)\s+at (.*?) line (\d+).*$/;
    _write('exception', "($2\/$3):$1");
    CORE::die($msg);
}


1;
[download]