1###############r################################### 2package Log::Log4perl::Level; 3################################################## 4 5use 5.006; 6use strict; 7use warnings; 8use Carp; 9 10# log4j, for whatever reason, puts 0 as all and MAXINT as OFF. 11# this seems less optimal, as more logging would imply a higher 12# level. But oh well. Probably some brokenness that has persisted. :) 13use constant ALL_INT => 0; 14use constant TRACE_INT => 5000; 15use constant DEBUG_INT => 10000; 16use constant INFO_INT => 20000; 17use constant WARN_INT => 30000; 18use constant ERROR_INT => 40000; 19use constant FATAL_INT => 50000; 20use constant OFF_INT => (2 ** 31) - 1; 21 22no strict qw(refs); 23use vars qw(%PRIORITY %LEVELS %SYSLOG %L4P_TO_LD); 24 25%PRIORITY = (); # unless (%PRIORITY); 26%LEVELS = () unless (%LEVELS); 27%SYSLOG = () unless (%SYSLOG); 28%L4P_TO_LD = () unless (%L4P_TO_LD); 29 30sub add_priority { 31 my ($prio, $intval, $syslog, $log_dispatch_level) = @_; 32 $prio = uc($prio); # just in case; 33 34 $PRIORITY{$prio} = $intval; 35 $LEVELS{$intval} = $prio; 36 37 # Set up the mapping between Log4perl integer levels and 38 # Log::Dispatch levels 39 # Note: Log::Dispatch uses the following levels: 40 # 0 debug 41 # 1 info 42 # 2 notice 43 # 3 warning 44 # 4 error 45 # 5 critical 46 # 6 alert 47 # 7 emergency 48 49 # The equivalent Log::Dispatch level is optional, set it to 50 # the highest value (7=emerg) if it's not provided. 51 $log_dispatch_level = 7 unless defined $log_dispatch_level; 52 53 $L4P_TO_LD{$prio} = $log_dispatch_level; 54 55 $SYSLOG{$prio} = $syslog if defined($syslog); 56} 57 58# create the basic priorities 59add_priority("OFF", OFF_INT, -1, 7); 60add_priority("FATAL", FATAL_INT, 0, 7); 61add_priority("ERROR", ERROR_INT, 3, 4); 62add_priority("WARN", WARN_INT, 4, 3); 63add_priority("INFO", INFO_INT, 6, 1); 64add_priority("DEBUG", DEBUG_INT, 7, 0); 65add_priority("TRACE", TRACE_INT, 8, 0); 66add_priority("ALL", ALL_INT, 8, 0); 67 68# we often sort numerically, so a helper func for readability 69sub numerically {$a <=> $b} 70 71########################################### 72sub import { 73########################################### 74 my($class, $namespace) = @_; 75 76 if(defined $namespace) { 77 # Export $OFF, $FATAL, $ERROR etc. to 78 # the given namespace 79 $namespace .= "::" unless $namespace =~ /::$/; 80 } else { 81 # Export $OFF, $FATAL, $ERROR etc. to 82 # the caller's namespace 83 $namespace = caller(0) . "::"; 84 } 85 86 for my $key (keys %PRIORITY) { 87 my $name = "$namespace$key"; 88 my $value = $PRIORITY{$key}; 89 *{"$name"} = \$value; 90 my $nameint = "$namespace${key}_INT"; 91 my $func = uc($key) . "_INT"; 92 *{"$nameint"} = \&$func; 93 } 94} 95 96################################################## 97sub new { 98################################################## 99 # We don't need any of this class nonsense 100 # in Perl, because we won't allow subclassing 101 # from this. We're optimizing for raw speed. 102} 103 104################################################## 105sub to_priority { 106# changes a level name string to a priority numeric 107################################################## 108 my($string) = @_; 109 110 if(exists $PRIORITY{$string}) { 111 return $PRIORITY{$string}; 112 }else{ 113 croak "level '$string' is not a valid error level (".join ('|', keys %PRIORITY),')'; 114 } 115} 116 117################################################## 118sub to_level { 119# changes a priority numeric constant to a level name string 120################################################## 121 my ($priority) = @_; 122 if (exists $LEVELS{$priority}) { 123 return $LEVELS{$priority} 124 }else { 125 croak("priority '$priority' is not a valid error level number (", 126 join("|", sort numerically keys %LEVELS), " 127 )"); 128 } 129 130} 131 132################################################## 133sub to_LogDispatch_string { 134# translates into strings that Log::Dispatch recognizes 135################################################## 136 my($priority) = @_; 137 138 confess "do what? no priority?" unless defined $priority; 139 140 my $string; 141 142 if(exists $LEVELS{$priority}) { 143 $string = $LEVELS{$priority}; 144 } 145 146 # Log::Dispatch idiosyncrasies 147 if($priority == $PRIORITY{WARN}) { 148 $string = "WARNING"; 149 } 150 151 if($priority == $PRIORITY{FATAL}) { 152 $string = "EMERGENCY"; 153 } 154 155 return $string; 156} 157 158################################################### 159sub is_valid { 160################################################### 161 my $q = shift; 162 163 if ($q =~ /[A-Z]/) { 164 return exists $PRIORITY{$q}; 165 }else{ 166 return $LEVELS{$q}; 167 } 168 169} 170 171sub get_higher_level { 172 my ($old_priority, $delta) = @_; 173 174 $delta ||= 1; 175 176 my $new_priority = 0; 177 178 foreach (1..$delta){ 179 #so the list is TRACE, DEBUG, INFO, WARN, ERROR, FATAL 180 # but remember, the numbers go in reverse order! 181 foreach my $p (sort numerically keys %LEVELS){ 182 if ($p > $old_priority) { 183 $new_priority = $p; 184 last; 185 } 186 } 187 $old_priority = $new_priority; 188 } 189 return $new_priority; 190} 191 192sub get_lower_level { 193 my ($old_priority, $delta) = @_; 194 195 $delta ||= 1; 196 197 my $new_priority = 0; 198 199 foreach (1..$delta){ 200 #so the list is FATAL, ERROR, WARN, INFO, DEBUG, TRACE 201 # but remember, the numbers go in reverse order! 202 foreach my $p (reverse sort numerically keys %LEVELS){ 203 if ($p < $old_priority) { 204 $new_priority = $p; 205 last; 206 } 207 } 208 $old_priority = $new_priority; 209 } 210 return $new_priority; 211} 212 213sub isGreaterOrEqual { 214 my $lval = shift; 215 my $rval = shift; 216 217 # in theory, we should check if the above really ARE valid levels. 218 # but we just use numeric comparison, since they aren't really classes. 219 220 # oh, yeah, and 'cuz level ints go from 0 .. N with 0 being highest, 221 # these are reversed. 222 return $lval <= $rval; 223} 224 225###################################################################### 226# 227# since the integer representation of levels is reversed from what 228# we normally want, we don't want to use < and >... instead, we 229# want to use this comparison function 230 231 2321; 233 234__END__ 235 236=head1 NAME 237 238Log::Log4perl::Level - Predefined log levels 239 240=head1 SYNOPSIS 241 242 use Log::Log4perl::Level; 243 print $ERROR, "\n"; 244 245 # -- or -- 246 247 use Log::Log4perl qw(:levels); 248 print $ERROR, "\n"; 249 250=head1 DESCRIPTION 251 252C<Log::Log4perl::Level> simply exports a predefined set of I<Log4perl> log 253levels into the caller's name space. It is used internally by 254C<Log::Log4perl>. The following scalars are defined: 255 256 $OFF 257 $FATAL 258 $ERROR 259 $WARN 260 $INFO 261 $DEBUG 262 $TRACE 263 $ALL 264 265C<Log::Log4perl> also exports these constants into the caller's namespace 266if you pull it in providing the C<:levels> tag: 267 268 use Log::Log4perl qw(:levels); 269 270This is the preferred way, there's usually no need to call 271C<Log::Log4perl::Level> explicitely. 272 273The numerical values assigned to these constants are purely virtual, 274only used by Log::Log4perl internally and can change at any time, 275so please don't make any assumptions. 276 277If the caller wants to import these constants into a different namespace, 278it can be provided with the C<use> command: 279 280 use Log::Log4perl::Level qw(MyNameSpace); 281 282After this C<$MyNameSpace::ERROR>, C<$MyNameSpace::INFO> etc. 283will be defined accordingly. 284 285=head1 SEE ALSO 286 287=head1 AUTHOR 288 289Mike Schilli, E<lt>m@perlmeister.comE<gt> 290 291=head1 COPYRIGHT AND LICENSE 292 293Copyright 2002 by Mike Schilli 294 295This library is free software; you can redistribute it and/or modify 296it under the same terms as Perl itself. 297 298=cut 299