File Coverage

blib/lib/Log/Contextual/WarnLogger/Fancy.pm
Criterion Covered Total %
statement 81 99 81.8
branch 43 70 61.4
condition 15 30 50.0
subroutine 23 24 95.8
pod 0 14 0.0
total 162 237 68.3


line stmt bran cond sub pod time code
1 8     8   77201 use 5.006; # our
  8         16  
2 8     8   26 use strict;
  8         7  
  8         129  
3 8     8   22 use warnings;
  8         9  
  8         358  
4              
5             package Log::Contextual::WarnLogger::Fancy;
6              
7             our $VERSION = '0.001003';
8              
9 8     8   25 use Carp qw( croak );
  8         7  
  8         354  
10 8     8   3219 use Term::ANSIColor qw( colored );
  8         37255  
  8         2762  
11              
12             delete $Log::Contextual::WarnLogger::Fancy::{$_}
13             for qw( croak colored ); # namespace clean
14              
15             delete $Log::Contextual::WarnLogger::Fancy::{$_}
16             for qw( _gen_level_sub _gen_is_level_sub _name_sub _can_name_sub _elipsis )
17             ; # not for external use cleaning
18              
19             BEGIN {
20             # Lazily find the best XS Sub naming implementation possible.
21             # Preferring an already loaded implementation where possible.
22             #<<< Tidy Guard
23             my $impl = ( $INC{'Sub/Util.pm'} and defined &Sub::Util::set_subname ) ? 'SU'
24             : ( $INC{'Sub/Name.pm'} and defined &Sub::Name::subname ) ? 'SN'
25             : ( eval { require Sub::Util; 1 } and defined &Sub::Util::set_subname ) ? 'SU'
26 8 50 66 8   61 : ( eval { require Sub::Name; 1 } and defined &Sub::Name::subname ) ? 'SN'
    100 33        
    50 66        
    100 33        
27             : '';
28             *_name_sub = $impl eq 'SU' ? \&Sub::Util::set_subname
29             : $impl eq 'SN' ? \&Sub::Name::subname
30 8 50       32 : sub { $_[1] };
  0 100       0  
31             #>>>
32 8 100       5230 *_can_name_sub = $impl ? sub() { 1 } : sub () { 0 };
33             }
34              
35             _gen_level($_) for (qw( trace debug info warn error fatal ));
36              
37             # Hack Notes: Custom levels are not currently recommended, but doing the following *should* work:
38             #
39             # Log::Contextual::WarnLogger::Fancy::_gen_level('custom');
40             # $logger->{levels} = [ @{ $logger->{levels}, 'custom' ];
41             # $logger->{level_nums}->{ 'custom' } = 1;
42             # $logger->{level_labels}->{ 'custom' } = 'custo';
43              
44             sub new {
45 17     17 0 6446 my ( $class, @args ) = @_;
46              
47 17 100 66     101 my $args = ( @args == 1 && ref $args[0] ? { %{ $args[0] } } : { @args } );
  15         44  
48              
49 17         28 my $self = bless {}, $class;
50              
51             $self->{env_prefix} = $args->{env_prefix}
52 17 50       56 or croak 'no env_prefix passed to ' . __PACKAGE__ . '->new';
53              
54 17         26 for my $field (qw( group_env_prefix default_upto label label_length )) {
55 68 100       119 $self->{$field} = $args->{$field} if exists $args->{$field};
56             }
57 17 100 66     60 if ( defined $self->{label} and length $self->{label} ) {
58 10 100       16 $self->{label_length} = 16 unless exists $args->{label_length};
59             $self->{effective_label} =
60 10         19 _elipsis( $self->{label}, $self->{label_length} );
61             }
62 17         37 my @levels = qw( trace debug info warn error fatal );
63 17         100 my %level_colors = (
64             trace => [],
65             debug => ['blue'],
66             info => ['white'],
67             warn => ['yellow'],
68             error => ['magenta'],
69             fatal => ['red'],
70             );
71              
72 17         34 $self->{levels} = [@levels];
73 17         30 @{ $self->{level_nums} }{@levels} = ( 0 .. $#levels );
  17         52  
74 17         66 for my $level (@levels) {
75 102         1395 $self->{level_labels}->{$level} = sprintf "%-5s", $level;
76 102 50       76 if ( @{ $level_colors{$level} || [] } ) {
  102 100       235  
77             $self->{level_labels}->{$level} =
78 85         151 colored( $level_colors{$level}, $self->{level_labels}->{$level} );
79             }
80             }
81              
82 17 100       279 unless ( exists $self->{default_upto} ) {
83 14         22 $self->{default_upto} = 'warn';
84             }
85 17         62 return $self;
86             }
87              
88             # TODO: Work out how to savely use Unicode \x{2026}, and then elipsis_width
89             # becomes 1. Otherwise utf8::encode() here after computing width might have to do.
90             my $elipsis_char = chr(166); #"\x{183}";
91             my $elipsis_width = length $elipsis_char;
92              
93             sub _elipsis {
94             my ( $text, $length ) = @_;
95             return sprintf "%" . $length . "s", $text if ( length $text ) <= $length;
96              
97             # Because the elipsis doesn't count for our calculations because its logically
98             # "in the middle". Subsequent math should be done assuming there is no elipsis.
99             my $pad_space = $length - $elipsis_width;
100             return '' if $pad_space <= 0;
101              
102             # Doing it this way handles a not entirely balanced case automatically.
103             # trimming asdfghij to length 6 with a 1 character elipis
104             # -> "....._"
105             # -> ".._..."
106             # so left gets a few less than the right here to have room for elipsis.
107             #
108             # When pad_space is even, it all works out in the end due to int truncation.
109             my $lw = int( $pad_space / 2 );
110             my $rw = $pad_space - $lw;
111              
112             return sprintf "%s%s%s", ( substr $text, 0, $lw ), $elipsis_char,
113             ( substr $text, -$rw, $rw );
114             }
115              
116             sub _log {
117 38     38   40 my $self = shift;
118 38         26 my $level = shift;
119 38         48 my $message = join( "\n", @_ );
120 38 50       88 $message .= qq[\n] unless $message =~ /\n\z/;
121 38         36 my $label = $self->{level_labels}->{$level};
122              
123 38 100       70 $label .= ' ' . $self->{effective_label} if $self->{effective_label};
124 38         275 warn "[${label}] $message";
125             }
126              
127             sub _gen_level_sub {
128             my ( $level, $is_name ) = @_;
129             return sub {
130 35     38 0 261 my $self = shift;
  3     38 0 25  
        38 0    
        38 0    
        38 0    
        38 0    
        3 0    
131 35 50       44 return unless $self->$is_name;
  3 50       5  
132 35         56 $self->_log( $level, @_ );
  3         7  
133             };
134             }
135              
136             sub _gen_is_level_sub {
137             my ($level) = @_;
138             my $ulevel = '_' . uc $level;
139             return sub {
140 87     96 0 1636 my $self = shift;
  0     87 0    
        87 0    
        87 0    
        87 0    
        87 0    
        0      
141              
142 87         71 my ( $ep, $gp ) = @{$self}{qw( env_prefix group_env_prefix )};
  87         108  
  0            
  0            
143              
144 87         120 my ( $ep_level, $ep_upto ) = ( $ep . $ulevel, $ep . '_UPTO' );
  0            
145              
146 87 100       140 my ( $gp_level, $gp_upto ) = ( $gp . $ulevel, $gp . '_UPTO' )
  0 0          
147             if defined $gp;
148              
149             # Explicit true/false takes precedence
150 87 100       175 return !!$ENV{$ep_level} if defined $ENV{$ep_level};
  0 0          
151              
152             # Explicit true/false takes precedence
153 51 100 100     109 return !!$ENV{$gp_level} if $gp_level and defined $ENV{$gp_level};
  0 0 0        
154              
155 47         32 my $upto;
  0            
156              
157 47 100 66     118 if ( defined $ENV{$ep_upto} ) {
  0 100 0        
    50          
    0          
    0          
    0          
158 12         13 $upto = lc $ENV{$ep_upto};
  0            
159             croak "Unrecognized log level '$upto' in \$ENV{$ep_upto}"
160 12 50       18 if not defined $self->{level_nums}->{$upto};
  0 0          
161             }
162             elsif ( $gp_upto and defined $ENV{$gp_upto} ) {
163 10         11 $upto = lc $ENV{$gp_upto};
  0            
164             croak "Unrecognized log level '$upto' in \$ENV{$gp_upto}"
165 10 50       15 if not defined $self->{level_nums}->{$upto};
  0 0          
166             }
167             elsif ( defined $self->{default_upto} ) {
168 25         23 $upto = $self->{default_upto};
  0            
169             }
170             else {
171 0         0 return 0;
  0            
172             }
173              
174 47         101 return $self->{level_nums}->{$level} >= $self->{level_nums}->{$upto};
  0            
175             };
176             }
177              
178             sub _gen_level {
179 49     49   89 my ($level) = @_;
180 49         52 my $is_name = "is_$level";
181              
182 49         50 my $level_sub = _gen_level_sub( $level, $is_name );
183 49         60 my $is_level_sub = _gen_is_level_sub($level);
184              
185 49         221 _can_name_sub and _name_sub( "$level", $level_sub );
186 49         111 _can_name_sub and _name_sub( "$is_name", $is_level_sub );
187              
188 8     8   36 no strict 'refs';
  8         8  
  8         409  
189 49         36 *{$level} = $level_sub;
  49         111  
190 49         31 *{$is_name} = $is_level_sub;
  49         139  
191             }
192              
193             1;
194              
195             __END__