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