File Coverage

blib/lib/Log/Log4perl/Level.pm
Criterion Covered Total %
statement 96 107 89.7
branch 16 26 61.5
condition 2 4 50.0
subroutine 23 25 92.0
pod 0 10 0.0
total 137 172 79.6


line stmt bran cond sub pod time code
1             ###############r###################################
2             ##################################################
3              
4             use 5.006;
5 71     71   107373 use strict;
  71         253  
6 71     71   408 use warnings;
  71         175  
  71         4909  
7 71     71   381 use Carp;
  71         160  
  71         2014  
8 71     71   434  
  71         1844  
  71         6462  
9             # log4j, for whatever reason, puts 0 as all and MAXINT as OFF.
10             # this seems less optimal, as more logging would imply a higher
11             # level. But oh well. Probably some brokenness that has persisted. :)
12             use constant ALL_INT => 0;
13 71     71   3958 use constant TRACE_INT => 5000;
  71         165  
  71         7939  
14 71     71   490 use constant DEBUG_INT => 10000;
  71         173  
  71         5601  
15 71     71   484 use constant INFO_INT => 20000;
  71         189  
  71         4159  
16 71     71   514 use constant WARN_INT => 30000;
  71         165  
  71         4075  
17 71     71   584 use constant ERROR_INT => 40000;
  71         189  
  71         3689  
18 71     71   490 use constant FATAL_INT => 50000;
  71         231  
  71         5000  
19 71     71   610 use constant OFF_INT => (2 ** 31) - 1;
  71         150  
  71         4324  
20 71     71   512  
  71         175  
  71         4061  
21             no strict qw(refs);
22 71     71   2151 use vars qw(%PRIORITY %LEVELS %SYSLOG %L4P_TO_LD);
  71         196  
  71         2720  
23 71     71   482  
  71         173  
  71         81326  
24             %PRIORITY = (); # unless (%PRIORITY);
25             %LEVELS = () unless (%LEVELS);
26             %SYSLOG = () unless (%SYSLOG);
27             %L4P_TO_LD = () unless (%L4P_TO_LD);
28              
29             my ($prio, $intval, $syslog, $log_dispatch_level) = @_;
30             $prio = uc($prio); # just in case;
31 599     599 0 1141  
32 599         1013 $PRIORITY{$prio} = $intval;
33             $LEVELS{$intval} = $prio;
34 599         1170  
35 599         1336 # Set up the mapping between Log4perl integer levels and
36             # Log::Dispatch levels
37             # Note: Log::Dispatch uses the following levels:
38             # 0 debug
39             # 1 info
40             # 2 notice
41             # 3 warning
42             # 4 error
43             # 5 critical
44             # 6 alert
45             # 7 emergency
46              
47             # The equivalent Log::Dispatch level is optional, set it to
48             # the highest value (7=emerg) if it's not provided.
49             $log_dispatch_level = 7 unless defined $log_dispatch_level;
50            
51 599 100       1157 $L4P_TO_LD{$prio} = $log_dispatch_level;
52              
53 599         980 $SYSLOG{$prio} = $syslog if defined($syslog);
54             }
55 599 100       1325  
56             # create the basic priorities
57             add_priority("OFF", OFF_INT, -1, 7);
58             add_priority("FATAL", FATAL_INT, 0, 7);
59             add_priority("ERROR", ERROR_INT, 3, 4);
60             add_priority("WARN", WARN_INT, 4, 3);
61             add_priority("INFO", INFO_INT, 6, 1);
62             add_priority("DEBUG", DEBUG_INT, 7, 0);
63             add_priority("TRACE", TRACE_INT, 8, 0);
64             add_priority("ALL", ALL_INT, 8, 0);
65              
66             # we often sort numerically, so a helper func for readability
67              
68             ###########################################
69 45634     45634 0 54599 ###########################################
70             my($class, $namespace) = @_;
71            
72             if(defined $namespace) {
73             # Export $OFF, $FATAL, $ERROR etc. to
74 577     577   1820 # the given namespace
75             $namespace .= "::" unless $namespace =~ /::$/;
76 577 100       3612 } else {
77             # Export $OFF, $FATAL, $ERROR etc. to
78             # the caller's namespace
79 2 50       8 $namespace = caller(0) . "::";
80             }
81              
82             for my $key (keys %PRIORITY) {
83 575         1526 my $name = "$namespace$key";
84             my $value = $PRIORITY{$key};
85             *{"$name"} = \$value;
86 577         2817 my $nameint = "$namespace${key}_INT";
87 4616         9229 my $func = uc($key) . "_INT";
88 4616         6912 *{"$nameint"} = \&$func;
89 4616         6147 }
  4616         16999  
90 4616         8885 }
91 4616         7128  
92 4616         8216 ##################################################
  4616         32994  
93             ##################################################
94             # We don't need any of this class nonsense
95             # in Perl, because we won't allow subclassing
96             # from this. We're optimizing for raw speed.
97       0 0   }
98              
99             ##################################################
100             # changes a level name string to a priority numeric
101             ##################################################
102             my($string) = @_;
103              
104             if(exists $PRIORITY{$string}) {
105             return $PRIORITY{$string};
106             }else{
107             croak "level '$string' is not a valid error level (".join ('|', keys %PRIORITY),')';
108 239     239 0 530 }
109             }
110 239 100       701  
111 238         1121 ##################################################
112             # changes a priority numeric constant to a level name string
113 1         247 ##################################################
114             my ($priority) = @_;
115             if (exists $LEVELS{$priority}) {
116             return $LEVELS{$priority}
117             }else {
118             croak("priority '$priority' is not a valid error level number (",
119             join("|", sort numerically keys %LEVELS), "
120             )");
121 90     90 0 5676 }
122 90 50       228  
123 90         322 }
124              
125 0         0 ##################################################
126             # translates into strings that Log::Dispatch recognizes
127             ##################################################
128             my($priority) = @_;
129              
130             confess "do what? no priority?" unless defined $priority;
131              
132             my $string;
133              
134             if(exists $LEVELS{$priority}) {
135             $string = $LEVELS{$priority};
136 0     0 0 0 }
137              
138 0 0       0 # Log::Dispatch idiosyncrasies
139             if($priority == $PRIORITY{WARN}) {
140 0         0 $string = "WARNING";
141             }
142 0 0       0
143 0         0 if($priority == $PRIORITY{FATAL}) {
144             $string = "EMERGENCY";
145             }
146            
147 0 0       0 return $string;
148 0         0 }
149              
150             ###################################################
151 0 0       0 ###################################################
152 0         0 my $q = shift;
153              
154             if ($q =~ /[A-Z]/) {
155 0         0 return exists $PRIORITY{$q};
156             }else{
157             return $LEVELS{$q};
158             }
159            
160             }
161 241     241 0 486  
162             my ($old_priority, $delta) = @_;
163 241 100       910  
164 3         10 $delta ||= 1;
165              
166 238         962 my $new_priority = 0;
167              
168             foreach (1..$delta){
169             #so the list is TRACE, DEBUG, INFO, WARN, ERROR, FATAL
170             # but remember, the numbers go in reverse order!
171             foreach my $p (sort numerically keys %LEVELS){
172 4     4 0 12 if ($p > $old_priority) {
173             $new_priority = $p;
174 4   50     12 last;
175             }
176 4         7 }
177             $old_priority = $new_priority;
178 4         12 }
179             return $new_priority;
180             }
181 153         745  
182 5194 100       8402 my ($old_priority, $delta) = @_;
183 41         56  
184 41         56 $delta ||= 1;
185              
186             my $new_priority = 0;
187 153         419  
188             foreach (1..$delta){
189 4         14 #so the list is FATAL, ERROR, WARN, INFO, DEBUG, TRACE
190             # but remember, the numbers go in reverse order!
191             foreach my $p (reverse sort numerically keys %LEVELS){
192             if ($p < $old_priority) {
193 40     40 0 99 $new_priority = $p;
194             last;
195 40   50     89 }
196             }
197 40         60 $old_priority = $new_priority;
198             }
199 40         92 return $new_priority;
200             }
201              
202 140         752 my $lval = shift;
203 3774 100       6044 my $rval = shift;
204 76         112
205 76         110 # in theory, we should check if the above really ARE valid levels.
206             # but we just use numeric comparison, since they aren't really classes.
207              
208 140         415 # oh, yeah, and 'cuz level ints go from 0 .. N with 0 being highest,
209             # these are reversed.
210 40         115 return $lval <= $rval;
211             }
212              
213             ######################################################################
214 10537     10537 0 16524 #
215 10537         13387 # since the integer representation of levels is reversed from what
216             # we normally want, we don't want to use < and >... instead, we
217             # want to use this comparison function
218              
219              
220             1;
221              
222 10537         23611  
223             =encoding utf8
224              
225             =head1 NAME
226              
227             Log::Log4perl::Level - Predefined log levels
228              
229             =head1 SYNOPSIS
230              
231             use Log::Log4perl::Level;
232             print $ERROR, "\n";
233              
234             # -- or --
235              
236             use Log::Log4perl qw(:levels);
237             print $ERROR, "\n";
238              
239             =head1 DESCRIPTION
240              
241             C<Log::Log4perl::Level> simply exports a predefined set of I<Log4perl> log
242             levels into the caller's name space. It is used internally by
243             C<Log::Log4perl>. The following scalars are defined:
244              
245             $OFF
246             $FATAL
247             $ERROR
248             $WARN
249             $INFO
250             $DEBUG
251             $TRACE
252             $ALL
253              
254             C<Log::Log4perl> also exports these constants into the caller's namespace
255             if you pull it in providing the C<:levels> tag:
256              
257             use Log::Log4perl qw(:levels);
258              
259             This is the preferred way, there's usually no need to call
260             C<Log::Log4perl::Level> explicitly.
261              
262             The numerical values assigned to these constants are purely virtual,
263             only used by Log::Log4perl internally and can change at any time,
264             so please don't make any assumptions. You can test for numerical equality
265             by directly comparing two level values, that's ok:
266              
267             if( get_logger()->level() == $DEBUG ) {
268             print "The logger's level is DEBUG\n";
269             }
270              
271             But if you want to figure out which of two levels is more verbose, use
272             Log4perl's own comparator:
273              
274             if( Log::Log4perl::Level::isGreaterOrEqual( $level1, $level2 ) ) {
275             print Log::Log4perl::Level::to_level( $level1 ),
276             " is equal or more verbose than ",
277             Log::Log4perl::Level::to_level( $level2 ), "\n";
278             }
279              
280             If the caller wants to import level constants into a different namespace,
281             it can be provided with the C<use> command:
282              
283             use Log::Log4perl::Level qw(MyNameSpace);
284              
285             After this C<$MyNameSpace::ERROR>, C<$MyNameSpace::INFO> etc.
286             will be defined accordingly.
287              
288             =head2 Numeric levels and Strings
289              
290             Level variables like $DEBUG or $WARN have numeric values that are
291             internal to Log4perl. Transform them to strings that can be used
292             in a Log4perl configuration file, use the c<to_level()> function
293             provided by Log::Log4perl::Level:
294              
295             use Log::Log4perl qw(:easy);
296             use Log::Log4perl::Level;
297              
298             # prints "DEBUG"
299             print Log::Log4perl::Level::to_level( $DEBUG ), "\n";
300              
301             To perform the reverse transformation, which takes a string like
302             "DEBUG" and converts it into a constant like C<$DEBUG>, use the
303             to_priority() function:
304              
305             use Log::Log4perl qw(:easy);
306             use Log::Log4perl::Level;
307              
308             my $numval = Log::Log4perl::Level::to_priority( "DEBUG" );
309              
310             after which $numval could be used where a numerical value is required:
311              
312             Log::Log4perl->easy_init( $numval );
313              
314             =head1 LICENSE
315              
316             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
317             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
318              
319             This library is free software; you can redistribute it and/or modify
320             it under the same terms as Perl itself.
321              
322             =head1 AUTHOR
323              
324             Please contribute patches to the project on Github:
325              
326             http://github.com/mschilli/log4perl
327              
328             Send bug reports or requests for enhancements to the authors via our
329              
330             MAILING LIST (questions, bug reports, suggestions/patches):
331             log4perl-devel@lists.sourceforge.net
332              
333             Authors (please contact them via the list above, not directly):
334             Mike Schilli <m@perlmeister.com>,
335             Kevin Goess <cpan@goess.org>
336              
337             Contributors (in alphabetical order):
338             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
339             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
340             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
341             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
342             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
343             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
344             Lars Thegler, David Viner, Mac Yang.
345