File Coverage

blib/lib/Log/Contextual/WarnLogger.pm
Criterion Covered Total %
statement 62 62 100.0
branch 23 26 88.4
condition 10 11 90.9
subroutine 16 16 100.0
pod 1 1 100.0
total 112 116 96.5


line stmt bran cond sub pod time code
1             package Log::Contextual::WarnLogger;
2             $Log::Contextual::WarnLogger::VERSION = '0.008000';
3             # ABSTRACT: logger for libraries using Log::Contextual
4              
5 3     3   950 use strict;
  3         26  
  3         109  
6 3     3   24 use warnings;
  3         9  
  3         114  
7              
8 3     3   23 use Carp 'croak';
  3         9  
  3         310  
9              
10             my @default_levels = qw( trace debug info warn error fatal );
11              
12             # generate subs to handle the default levels
13             # anything else will have to be handled by AUTOLOAD at runtime
14             {
15             for my $level (@default_levels) {
16              
17 3     3   25 no strict 'refs';
  3         81  
  3         1217  
18              
19             my $is_name = "is_$level";
20             *{$level} = sub {
21 15     15   37 my $self = shift;
        8      
        8      
        8      
        8      
22              
23 15 50       44 $self->_log($level, @_)
24             if $self->$is_name;
25             };
26              
27             *{$is_name} = sub {
28 82     82   1275 my $self = shift;
29 82 100       432 return 1 if $ENV{$self->{env_prefix} . '_' . uc $level};
30 66         213 my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
31 66 100       248 return unless $upto;
32 32         81 $upto = lc $upto;
33              
34 32         221 return $self->{level_num}{$level} >= $self->{level_num}{$upto};
35             };
36             }
37             }
38              
39             our $AUTOLOAD;
40              
41             sub AUTOLOAD {
42 9     9   6053 my $self = $_[0];
43              
44 9         85 (my $name = our $AUTOLOAD) =~ s/.*:://;
45 9 100       182 return if $name eq 'DESTROY';
46              
47             # extract the log level from the sub name
48 4         32 my ($is, $level) = $name =~ m/^(is_)?(.+)$/;
49 4         18 my $is_name = "is_$level";
50              
51 3     3   29 no strict 'refs';
  3         14  
  3         1753  
52 4         31 *{$level} = sub {
53 3     3   3178 my $self = shift;
54              
55 3 50       14 $self->_log($level, @_)
56             if $self->$is_name;
57 4         25 };
58              
59 4         19 *{$is_name} = sub {
60 20     20   2373 my $self = shift;
61              
62 20         101 my $prefix_field = $self->{env_prefix} . '_' . uc $level;
63 20 100       132 return 1 if $ENV{$prefix_field};
64              
65             # don't log if the variable specifically says not to
66 18 100 66     88 return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field};
67              
68 16         60 my $upto_field = $self->{env_prefix} . '_UPTO';
69 16         43 my $upto = $ENV{$upto_field};
70              
71 16 100       45 if ($upto) {
72 6         19 $upto = lc $upto;
73              
74             croak "Unrecognized log level '$upto' in \$ENV{$upto_field}"
75 6 100       456 if not defined $self->{level_num}{$upto};
76              
77 4         27 return $self->{level_num}{$level} >= $self->{level_num}{$upto};
78             }
79              
80             # if we don't recognize this level and nothing says otherwise, log!
81 10 100       68 return 1 if not $self->{custom_levels};
82 4         34 };
83 4         37 goto &$AUTOLOAD;
84             }
85              
86             sub new {
87 11     11 1 6932 my ($class, $args) = @_;
88              
89 11         40 my $levels = $args->{levels};
90 11 100 100     457 croak 'invalid levels specification: must be non-empty arrayref'
      100        
91             if defined $levels and (ref $levels ne 'ARRAY' or !@$levels);
92              
93 9         29 my $custom_levels = defined $levels;
94 9   100     86 $levels ||= [@default_levels];
95              
96 9         28 my %level_num;
97 9         29 @level_num{@$levels} = (0 .. $#{$levels});
  9         70  
98              
99 9         69 my $self = bless {
100             levels => $levels,
101             level_num => \%level_num,
102             custom_levels => $custom_levels,
103             }, $class;
104              
105             $self->{env_prefix} = $args->{env_prefix}
106 9 50       104 or die 'no env_prefix passed to Log::Contextual::WarnLogger->new';
107 9         74 return $self;
108             }
109              
110             sub _log {
111 15     15   34 my $self = shift;
112 15         31 my $level = shift;
113 15         45 my $message = join("\n", @_);
114 15 100       64 $message .= "\n" unless $message =~ /\n$/;
115 15         143 warn "[$level] $message";
116             }
117              
118             1;
119              
120             __END__