File Coverage

lib/Badger/Log.pm
Criterion Covered Total %
statement 43 45 95.5
branch 23 26 88.4
condition 2 3 66.6
subroutine 12 13 92.3
pod 5 6 83.3
total 85 93 91.4


line stmt bran cond sub pod time code
1             #========================================================================
2             #
3             # Badger::Log
4             #
5             # DESCRIPTION
6             # A simple base class logging module.
7             #
8             # AUTHOR
9             # Andy Wardley
10             #
11             #========================================================================
12              
13             package Badger::Log;
14              
15             use Badger::Class
16 2         21 version => 0.01,
17             base => 'Badger::Prototype',
18             import => 'class',
19             utils => 'blessed Now',
20             config => 'system|class:SYSTEM format|class:FORMAT strftime|class:STRFTIME',
21             constants => 'ARRAY CODE',
22             constant => {
23             MSG => '_msg', # suffix for message methods, e.g. warn_msg()
24             LOG => 'log', # method a delegate must implement
25             },
26             vars => {
27             SYSTEM => 'Badger',
28             FORMAT => '[
29             STRFTIME => '%a %b %d %T %Y',
30             LEVELS => {
31             debug => 0,
32             info => 0,
33             warn => 1,
34             error => 1,
35             fatal => 1,
36             }
37             },
38             messages => {
39             bad_level => 'Invalid logging level: %s',
40 2     2   395 };
  2         2  
41              
42              
43              
44             class->methods(
45             # Our init method is called init_log() so that we can use Badger::Log as
46             # a mixin or base class without worrying about the init() method clashing
47             # with init() methods from other base classes or mixins. We create an
48             # alias from init() to init_log() so that it also Just Works[tm] as a
49             # stand-alone object
50             init => \&init_log,
51              
52             # Now we define two methods for each logging level. The first expects
53             # a pre-formatted output message (e.g. debug(), info(), warn(), etc)
54             # the second additionally wraps around the message() method inherited
55             # from Badger::Base (eg. debug_msg(), info_msg(), warn_msg(), etc)
56             map {
57             my $level = $_; # lexical variable for closure
58              
59             $level => sub {
60 41     41   87 my $self = shift;
61 41 100       113 return $self->{ $level } unless @_;
62             $self->log($level, @_)
63 16 100       48 if $self->{ $level };
64             },
65              
66             ($level.MSG) => sub {
67 2     2   9 my $self = shift;
        2      
        1      
68 2 50       6 return $self->{ $level } unless @_;
69             $self->log($level, $self->message(@_))
70 2 100       11 if $self->{ $level };
71             }
72             }
73             keys %$LEVELS
74             );
75              
76              
77             sub init_log {
78 9     9 0 17 my ($self, $config) = @_;
79 9         21 my $class = $self->class;
80 9         27 my $levels = $class->hash_vars( LEVELS => $config->{ levels } );
81              
82             # populate $self for each level in $LEVEL using the
83             # value in $config, or the default in $LEVEL
84 9         41 while (my ($level, $default) = each %$levels) {
85             $self->{ $level } =
86             defined $config->{ $level }
87             ? $config->{ $level }
88 45 100       130 : $levels->{ $level };
89             }
90              
91             # call the auto-generated configure() method to update $self from $config
92 9         26 $self->configure($config);
93              
94 9         22 return $self;
95             }
96              
97             sub log {
98 11     11 1 12 my $self = shift;
99 11         11 my $level = shift;
100 11         11 my $action = $self->{ $level };
101 11         20 my $message = join('', @_);
102 11         10 my $method;
103              
104 11 50       18 return $self->_fatal_msg( bad_level => $level )
105             unless defined $action;
106              
107             # depending on what the $action is set to, we add the message to
108             # an array, call a code reference, delegate to another log object,
109             # print or ignore the mesage
110              
111 11 100 66     40 if (ref $action eq ARRAY) {
    100          
    100          
    50          
112 3         7 push(@$action, $message);
113             }
114             elsif (ref $action eq CODE) {
115 3         6 &$action($level, $message);
116             }
117             elsif (blessed $action && ($method = $action->can(LOG))) {
118 1         4 $method->($action, $level, $message);
119             }
120             elsif ($action) {
121 4         16 warn $self->format($level, $message), "\n";
122             }
123             }
124              
125             sub format {
126 8     8 1 11 my $self = shift;
127             my $args = {
128             time => Now->format($self->{ strftime }),
129             system => $self->{ system },
130 8         22 level => shift,
131             message => shift,
132             };
133 8         44 my $format = $self->{ format };
134 8         48 $format =~
135             s/<(\w+)>/
136             defined $args->{ $1 }
137 20 100       83 ? $args->{ $1 }
138             : "<$1>"
139             /eg;
140 8         55 return $format;
141             }
142              
143             sub level {
144 9     9 1 9 my $self = shift;
145 9         9 my $level = shift;
146             return $self->_fatal_msg( bad_level => $level )
147 9 100       16 unless exists $LEVELS->{ $level };
148 8 100       22 return @_ ? ($self->{ $level } = shift) : $self->{ $level };
149             }
150              
151             sub enable {
152 1     1 1 3 my $self = shift;
153 1         2 $self->level($_ => 1) for @_;
154             }
155              
156             sub disable {
157 1     1 1 6 my $self = shift;
158 1         2 $self->level($_ => 0) for @_;
159             }
160              
161             sub _error_msg {
162 0     0   0 my $self = shift;
163 0         0 $self->Badger::Base::error(
164             $self->Badger::Base::message(@_)
165             );
166             }
167              
168             sub _fatal_msg {
169 1     1   11 my $self = shift;
170 1         4 $self->Badger::Base::fatal(
171             $self->Badger::Base::message(@_)
172             );
173             }
174              
175              
176             1;
177              
178             __END__