File Coverage

blib/lib/MarpaX/Languages/C/AST/Impl/Logger.pm
Criterion Covered Total %
statement 25 36 69.4
branch 3 10 30.0
condition 1 11 9.0
subroutine 8 11 72.7
pod n/a
total 37 68 54.4


line stmt bran cond sub pod time code
1 2     2   7 use strict;
  2         3  
  2         53  
2 2     2   7 use warnings FATAL => 'all';
  2         2  
  2         83  
3              
4             package MarpaX::Languages::C::AST::Impl::Logger;
5              
6             # ABSTRACT: Log::Any implementation on top of Marpa
7              
8 2     2   876 use diagnostics;
  2         275790  
  2         19  
9 2     2   567 use Carp;
  2         5  
  2         152  
10 2     2   7 use Log::Any;
  2         2  
  2         17  
11              
12             our $VERSION = '0.47'; # VERSION
13              
14             sub BEGIN {
15             #
16             ## Some Log implementation specificities
17             #
18 2   50 2   293 my $log4perl = eval 'use Log::Log4perl; 1;' || 0; ## no critic
  2     2   1607  
  2         70030  
  2         8  
19 2 50       10 if ($log4perl) {
20             #
21             ## Here we put know hooks for logger implementations
22             #
23 2         11 Log::Log4perl->wrapper_register(__PACKAGE__);
24             }
25             }
26              
27             sub TIEHANDLE {
28 2     2   5 my($class, %options) = @_;
29              
30             my $self = {
31             level => exists($options{level}) ? ($options{level} || 'trace') : 'trace',
32             category => exists($options{category}) ? $options{category} : undef, # undef is ok
33 2 50 0     23 };
    50          
34              
35 2         17 $self->{logger} = Log::Any->get_logger(category => $self->{category});
36              
37 2         1765 bless $self, $class;
38             }
39              
40             sub PRINT {
41 0     0     my $self = shift;
42 0   0       my $logger = $self->{logger} || '';
43 0   0       my $level = $self->{level} || '';
44 0 0 0       if ($logger && $level) {
45 0           $logger->trace(@_);
46             }
47 0           return 1;
48             }
49              
50             sub PRINTF {
51 0     0     my $self = shift;
52 0           return $self->PRINT(sprintf(@_));
53             }
54              
55             sub UNTIE {
56 0     0     my ($obj, $count) = @_;
57 0 0         if ($count) {
58 0           croak "untie attempted while $count inner references still exist";
59             }
60             }
61              
62              
63             1;
64              
65             __END__