File Coverage

blib/lib/Log/Any/Adapter/Carp.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	20	24	83.3
condition	4	5	80.0
subroutine	13	13	100.0
pod	0	1	0.0
total	98	104	94.2

#!perl
#

use strict;
use warnings;

package Log::Any::Adapter::Carp;

our ($VERSION) = '1.02';
our (@CARP_NOT) = ( __PACKAGE__, 'Log::Any::Proxy' );

use Scalar::Util qw(reftype);
use Log::Any::Adapter::Util 1;

use parent 'Log::Any::Adapter::Base';

sub init {
    my ($self) = @_;
    my $i = 1;
    my $callpack;
    my $logger;

    do { $callpack = caller( $i++ ) } while $callpack =~ /^Log::Any::/;

    $self->{log_level} = 'trace' unless exists $self->{log_level};
    $self->{log_level} =
      Log::Any::Adapter::Util::numeric_level( $self->{log_level} )
      unless $self->{log_level} =~ /^\d+$/;

    if ( $self->{no_trace} ) {
        $self->{send_msg} = sub {
            my $text = shift || '';
            $text .= "\n" unless $text =~ /\n$/;
            warn $text;
        };
    }
    elsif ( $self->{skip_packages}
        and reftype( $self->{skip_packages} ) eq 'REGEXP' )
    {
        my $skipadd = '|^Log::Any::|^Carp::Clan::'
          . ( $self->{skip_me} ? "|^$callpack\$" : '' );
        my $skipre = qr/$self->{skip_packages}$skipadd/;

        require Carp::Clan;
        {

            package Log::Any::Adapter::Carp::Clannish;
            Carp::Clan->import($skipre);
        }
        no warnings 'once';
        $self->{send_msg} =
            $self->{full_trace}
          ? *Log::Any::Adapter::Carp::Clannish::cluck
          : *Log::Any::Adapter::Carp::Clannish::carp;
    }
    else {
        require Carp;
        {

            package Log::Any::Adapter::Carp::Carpish;
            Carp->import(qw/ carp cluck /);
        }

        my @skip_pkgs;
        push @skip_pkgs, $callpack
          if $self->{skip_me};

        if ( exists $self->{skip_packages} ) {
            if ( reftype $self->{skip_packages} eq 'ARRAY' ) {
                push @skip_pkgs, @{ $self->{skip_packages} };
            }
            else {
                push @skip_pkgs, $self->{skip_packages};
            }
        }

        my $carp =
            $self->{full_trace}
          ? *Log::Any::Adapter::Carp::Carpish::cluck
          : *Log::Any::Adapter::Carp::Carpish::carp;

        $self->{send_msg} = sub {

            # Ugh, but this is the only Carp mechanism to keep a package out
            # of the shortmess if the call is *from* it
            local %Carp::Internal;
            $Carp::Internal{$_}++ for @skip_pkgs;
            $carp->(@_);
          }
    }

}

foreach my $method ( Log::Any::Adapter::Util::logging_methods() ) {
    no strict 'refs';
    my $method_level = Log::Any::Adapter::Util::numeric_level($method);
    *{$method} = sub {
        my $self = shift;
        return if $method_level > $self->{log_level};
        $self->{send_msg}->(@_);
    };
}

foreach my $method ( Log::Any::Adapter::Util::detection_methods() ) {
    no strict 'refs';
    my $base = substr( $method, 3 );
    my $method_level = Log::Any::Adapter::Util::numeric_level($base);
    *{$method} = sub {
        return !!( $method_level <= $_[0]->{log_level} );
    };
}

1;

__END__