File Coverage

blib/lib/Log/Dispatch/Perl.pm

Criterion	Covered	Total	%
statement	34	42	80.9
branch	3	16	18.7
condition	10	32	31.2
subroutine	5	5	100.0
pod	0	2	0.0
total	52	97	53.6

package Log::Dispatch::Perl;
use base 'Log::Dispatch::Output';

$VERSION= '0.04';

# be as strict and verbose as possible
use strict;
use warnings;

# initialize level name / number conversion hashes
my %LEVEL2NUM;
my %NUM2LEVEL;
do {
    my @level2num= (
     debug      => 0,
     info       => 1,
     notice     => 2,
     warning    => 3,
     error      => 4,
     err        => 4, # MUST be after "error"
     critical   => 5,
     crit       => 5, # MUST be after "critical"
     alert      => 6,
     emergency  => 7,
     emerg      => 7, # MUST be after "emergency"
    );
    %LEVEL2NUM= @level2num;
    %NUM2LEVEL= reverse @level2num; # order fixes double assignments
};

# hide ourselves from Carp
my $havecarp= defined $Carp::VERSION;
unless ( $] < 5.008 ) {
    $Carp::Internal{$_}= 1 foreach ( 'Log::Dispatch', 'Log::Dispatch::Output' );
}

#  action to actual code hash
my %ACTION2CODE;
%ACTION2CODE= (
  ''      => sub { undef },

  carp    => $havecarp
               ? \&Carp::carp
               : sub {
                     $havecarp ||= require Carp;
                     $ACTION2CODE{carp}= \&Carp::carp;
                     goto &Carp::carp;
                 },

  cluck   => $] < 5.008
               ? sub {
                     $havecarp ||= require Carp;
                     ( my $m= Carp::longmess() )
                       =~ s#\s+Log::Dispatch::[^\n]+\n##sg;
                     return CORE::warn $_[0] . $m;
                 }
               : sub {
                     $havecarp ||= require Carp;
                     return CORE::warn $_[0] . Carp::longmess();
                 },

  confess => $] < 5.008
               ? sub {
                     $havecarp ||= require Carp;
                     ( my $m = Carp::longmess() )
                       =~ s#\s+Log::Dispatch::[^\n]+\n##sg;
                     return CORE::die $_[0] . $m;
                 }
               : sub {
                     $havecarp ||= require Carp;
                     return CORE::die $_[0] . Carp::longmess();
                 },

  croak   => $havecarp
               ? \&Carp::croak
               : sub {
                     $havecarp ||= require Carp;
                     $ACTION2CODE{croak}= \&Carp::croak;
                     goto &Carp::croak;
                 },

  die     => sub { CORE::die @_ },

  warn    => sub { CORE::warn @_ },
);

# satisfy require
1;

#-------------------------------------------------------------------------------
#
# Class methods
#
#-------------------------------------------------------------------------------
# new
#
# Required by Log::Dispatch::Output.  Creates a new Log::Dispatch::Perl
# object
#
#  IN: 1 class
#      2..N parameters as a hash
# OUT: 1 instantiated object

sub new {
    my ( $class, %param )= @_;

    # do the basic initializations
    my $self= bless {}, ref $class || $class;
    $self->_basic_init( %param );

    # we have specific actions specified
    my @action;
    if ( my $actions= $param{action} ) {

        # check all actions specified
        foreach my $level ( keys %{$actions} ) {
            my $action= $actions->{$level};
            $level= $NUM2LEVEL{$level} if exists $NUM2LEVEL{$level};

            # sanity check, store if ok
            my $warn;
            warn qq{"$level" is an unknown logging level, ignored\n"}, $warn++
              if !exists $LEVEL2NUM{ $level || '' };
            warn qq{"$action" is an unknown Perl action, ignored\n"}, $warn++
              if !exists $ACTION2CODE{$action};
            $action[$LEVEL2NUM{$level}]= $ACTION2CODE{$action}
              if !$warn;
        }
    }

    # set the actions that have not yet been specified
    $action[0] ||= $ACTION2CODE{''};
    $action[1] ||= $ACTION2CODE{''};
    $action[2] ||= $ACTION2CODE{warn};
    $action[3] ||= $ACTION2CODE{warn};
    $action[4] ||= $ACTION2CODE{die};
    $action[5] ||= $ACTION2CODE{die};
    $action[6] ||= $ACTION2CODE{confess};
    $action[7] ||= $ACTION2CODE{confess};

    # save this setting
    $self->{action}= \@action;

    return $self;
} #new

#-------------------------------------------------------------------------------
#
# Instance methods
#
#-------------------------------------------------------------------------------
# log_message
#
# Required by Log::Dispatch.  Log a single message.
#
#  IN: 1 instantiated Log::Dispatch::Perl object
#      2..N hash with parameters as required by Log::Dispatch

sub log_message {
    my ( $self, %param )= @_;

    # huh?
    my $level= $param{level};
    return if !exists $LEVEL2NUM{$level} and !exists $NUM2LEVEL{$level};

    # obtain level number
    my $num= $LEVEL2NUM{$level};
    $num= $level if !defined $num;  # //=

    # set message
    my $message= $param{message};
    $message .= "\n" if substr( $message, -1, 1 ) ne "\n";
    @_= ($message);

    # log it the right way
    goto &{$self->{action}->[$num]};
} #log_message

#-------------------------------------------------------------------------------

__END__