view release on metacpan or  search on metacpan

lib/Log/Dispatch/Perl.pm  view on Meta::CPAN

package Log::Dispatch::Perl; # git description: v0.04-5-g9e5eec5
# ABSTRACT: Use core Perl functions for logging

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

our $VERSION = '0.05';

# 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};