1 |
package Log::Dispatch::Config; |
2 |
|
3 |
use strict; |
4 |
use vars qw($VERSION); |
5 |
$VERSION = 1.02; |
6 |
|
7 |
use Log::Dispatch 2.00; |
8 |
use base qw(Log::Dispatch); |
9 |
|
10 |
# caller depth: can be changed from outside |
11 |
$Log::Dispatch::Config::CallerDepth = 0; |
12 |
|
13 |
sub _croak { require Carp; Carp::croak(@_); } |
14 |
|
15 |
# accessor for symblic reference |
16 |
sub __instance { |
17 |
my $class = shift; |
18 |
no strict 'refs'; |
19 |
my $instance = "$class\::_instance"; |
20 |
$$instance = shift if @_; |
21 |
return $$instance; |
22 |
} |
23 |
|
24 |
sub _configurator_for { |
25 |
my($class, $stuff) = @_; |
26 |
return $stuff if UNIVERSAL::isa($stuff, 'Log::Dispatch::Configurator'); |
27 |
require Log::Dispatch::Configurator::AppConfig; |
28 |
return Log::Dispatch::Configurator::AppConfig->new($stuff); |
29 |
} |
30 |
|
31 |
sub configure { |
32 |
my($class, $stuff) = @_; |
33 |
_croak "no config file or configurator supplied" unless $stuff; |
34 |
my $config = $class->_configurator_for($stuff); |
35 |
$config->myinit; |
36 |
$class->__instance($config); |
37 |
} |
38 |
|
39 |
sub configure_and_watch { |
40 |
my $class = shift; |
41 |
$class->configure(@_); |
42 |
$class->__instance->should_watch(1); # tells conf to watch config file |
43 |
} |
44 |
|
45 |
# backward compatibility |
46 |
sub Log::Dispatch::instance { __PACKAGE__->instance; } |
47 |
|
48 |
sub instance { |
49 |
my $class = shift; |
50 |
|
51 |
my $instance = $class->__instance or _croak "configure not yet called."; |
52 |
if ($instance->isa('Log::Dispatch::Config')) { |
53 |
# reload singleton on the fly |
54 |
$class->reload if $instance->needs_reload; |
55 |
} |
56 |
else { |
57 |
# first time call: $_instance is L::D::Configurator::* |
58 |
$class->__instance($class->create_instance($instance)); |
59 |
} |
60 |
return $class->__instance; |
61 |
} |
62 |
|
63 |
sub needs_reload { |
64 |
my $self = shift; |
65 |
return $self->{config}->should_watch && $self->{config}->needs_reload; |
66 |
} |
67 |
|
68 |
sub reload { |
69 |
my $proto = shift; |
70 |
my $class = ref $proto || $proto; |
71 |
my $instance = $class->__instance; |
72 |
$instance->{config}->reload; |
73 |
$class->__instance($class->create_instance($instance->{config})); |
74 |
} |
75 |
|
76 |
sub create_instance { |
77 |
my($class, $config) = @_; |
78 |
$config->{LDC_ctime} = time; # creation time |
79 |
|
80 |
my $global = $config->get_attrs_global; |
81 |
my $callback = $class->format_to_cb($global->{format}, 0); |
82 |
my %dispatchers; |
83 |
foreach my $disp (@{$global->{dispatchers}}) { |
84 |
$dispatchers{$disp} = $class->config_dispatcher( |
85 |
$disp, $config->get_attrs($disp), |
86 |
); |
87 |
} |
88 |
my %args; |
89 |
$args{callbacks} = $callback if defined $callback; |
90 |
my $instance = $class->new(%args); |
91 |
|
92 |
for my $dispname (keys %dispatchers) { |
93 |
my $logclass = delete $dispatchers{$dispname}->{class}; |
94 |
$instance->add( |
95 |
$logclass->new( |
96 |
name => $dispname, |
97 |
%{$dispatchers{$dispname}}, |
98 |
), |
99 |
); |
100 |
} |
101 |
|
102 |
$instance->{config} = $config; |
103 |
return $instance; |
104 |
} |
105 |
|
106 |
sub config_dispatcher { |
107 |
my($class, $disp, $var) = @_; |
108 |
|
109 |
my $dispclass = $var->{class} or _croak "class param missing for $disp"; |
110 |
|
111 |
eval qq{require $dispclass}; |
112 |
_croak $@ if $@ && $@ !~ /locate/; |
113 |
|
114 |
if (exists $var->{format}) { |
115 |
$var->{callbacks} = $class->format_to_cb(delete $var->{format}, 2); |
116 |
} |
117 |
return $var; |
118 |
} |
119 |
|
120 |
sub format_to_cb { |
121 |
my($class, $format, $stack) = @_; |
122 |
return undef unless defined $format; |
123 |
|
124 |
# caller() called only when necessary |
125 |
my $needs_caller = $format =~ /%[FLPS]/; |
126 |
return sub { |
127 |
my %p = @_; |
128 |
$p{p} = delete $p{level}; |
129 |
$p{m} = delete $p{message}; |
130 |
$p{n} = "\n"; |
131 |
$p{'%'} = '%'; |
132 |
require POSIX; |
133 |
$p{i} = POSIX::getpid(); |
134 |
|
135 |
if ($needs_caller) { |
136 |
my $depth = 0; |
137 |
$depth++ while caller($depth) =~ /^Log::Dispatch/; |
138 |
$depth += $Log::Dispatch::Config::CallerDepth; |
139 |
@p{qw(P F L S)} = caller($depth); |
140 |
} |
141 |
|
142 |
my $log = $format; |
143 |
$log =~ s{ |
144 |
(%d(?:{(.*?)})?)| # $1: datetime $2: datetime fmt |
145 |
(?:%([%pmFLPniS])) # $3: others |
146 |
}{ |
147 |
if ($1 && $2) { |
148 |
_strftime($2); |
149 |
} |
150 |
elsif ($1) { |
151 |
scalar localtime; |
152 |
} |
153 |
elsif ($3) { |
154 |
$p{$3}; |
155 |
} |
156 |
}egx; |
157 |
return $log; |
158 |
}; |
159 |
} |
160 |
|
161 |
{ |
162 |
use vars qw($HasTimePiece); |
163 |
BEGIN { eval { require Time::Piece; $HasTimePiece = 1 }; } |
164 |
|
165 |
sub _strftime { |
166 |
my $fmt = shift; |
167 |
if ($HasTimePiece) { |
168 |
return Time::Piece->new->strftime($fmt); |
169 |
} else { |
170 |
require POSIX; |
171 |
return POSIX::strftime($fmt, localtime); |
172 |
} |
173 |
} |
174 |
} |
175 |
|
176 |
1; |
177 |
__END__ |
178 |
|
179 |
=head1 NAME |
180 |
|
181 |
Log::Dispatch::Config - Log4j for Perl |
182 |
|
183 |
=head1 SYNOPSIS |
184 |
|
185 |
use Log::Dispatch::Config; |
186 |
Log::Dispatch::Config->configure('/path/to/log.conf'); |
187 |
|
188 |
my $dispatcher = Log::Dispatch::Config->instance; |
189 |
$dispatcher->debug('this is debug message'); |
190 |
$dispatcher->emergency('something *bad* happened!'); |
191 |
|
192 |
# automatic reloading conf file, when modified |
193 |
Log::Dispatch::Config->configure_and_watch('/path/to/log.conf'); |
194 |
|
195 |
# or if you write your own config parser: |
196 |
use Log::Dispatch::Configurator::XMLSimple; |
197 |
|
198 |
my $config = Log::Dispatch::Configurator::XMLSimple->new('log.xml'); |
199 |
Log::Dispatch::Config->configure($config); |
200 |
|
201 |
=head1 DESCRIPTION |
202 |
|
203 |
Log::Dispatch::Config is a subclass of Log::Dispatch and provides a |
204 |
way to configure Log::Dispatch object with configulation file |
205 |
(default, in AppConfig format). I mean, this is log4j for Perl, not |
206 |
with all API compatibility though. |
207 |
|
208 |
=head1 METHOD |
209 |
|
210 |
This module has a class method C<configure> which parses config file |
211 |
for later creation of the Log::Dispatch::Config singleton instance. |
212 |
(Actual construction of the object is done in the first C<instance> |
213 |
call). |
214 |
|
215 |
So, what you should do is call C<configure> method once in somewhere |
216 |
(like C<startup.pl> in mod_perl), then you can get configured |
217 |
dispatcher instance via C<Log::Dispatch::Config-E<gt>instance>. |
218 |
|
219 |
=head1 CONFIGURATION |
220 |
|
221 |
Here is an example of the config file: |
222 |
|
223 |
dispatchers = file screen |
224 |
|
225 |
file.class = Log::Dispatch::File |
226 |
file.min_level = debug |
227 |
file.filename = /path/to/log |
228 |
file.mode = append |
229 |
file.format = [%d] [%p] %m at %F line %L%n |
230 |
|
231 |
screen.class = Log::Dispatch::Screen |
232 |
screen.min_level = info |
233 |
screen.stderr = 1 |
234 |
screen.format = %m |
235 |
|
236 |
In this example, config file is written in AppConfig format. See |
237 |
L<Log::Dispatch::Configurator::AppConfig> for details. |
238 |
|
239 |
See L</"PLUGGABLE CONFIGURATOR"> for other config parsing scheme. |
240 |
|
241 |
=head2 GLOBAL PARAMETERS |
242 |
|
243 |
=over 4 |
244 |
|
245 |
=item dispatchers |
246 |
|
247 |
dispatchers = file screen |
248 |
|
249 |
C<dispatchers> defines logger names, which will be splitted by spaces. |
250 |
If this parameter is unset, no logging is done. |
251 |
|
252 |
=item format |
253 |
|
254 |
format = [%d] [%p] %m at %F line %L%n |
255 |
|
256 |
C<format> defines log format. Possible conversions format are |
257 |
|
258 |
%d datetime string (ctime(3)) |
259 |
%p priority (debug, info, warning ...) |
260 |
%m message string |
261 |
%F filename |
262 |
%L line number |
263 |
%P package |
264 |
%n newline (\n) |
265 |
%% % itself |
266 |
%i process-id, returns POSIX::getpid() |
267 |
%S subroutine |
268 |
|
269 |
Note that datetime (%d) format is configurable by passing C<strftime> |
270 |
fmt in braket after %d. (I know it looks quite messy, but its |
271 |
compatible with Java Log4j ;) |
272 |
|
273 |
format = [%d{%Y%m%d}] %m # datetime is now strftime "%Y%m%d" |
274 |
|
275 |
If you have Time::Piece, this module uses its C<strftime> |
276 |
implementation, otherwise POSIX. |
277 |
|
278 |
C<format> defined here would apply to all the log messages to |
279 |
dispatchers. This parameter is B<optional>. |
280 |
|
281 |
See L</"CALLER STACK"> for details about package, line number and |
282 |
filename. |
283 |
|
284 |
=back |
285 |
|
286 |
=head2 PARAMETERS FOR EACH DISPATCHER |
287 |
|
288 |
Parameters for each dispatcher should be prefixed with "name.", where |
289 |
"name" is the name of each one, defined in global C<dispatchers> |
290 |
parameter. |
291 |
|
292 |
You can also use C<.ini> style grouping like: |
293 |
|
294 |
[foo] |
295 |
class = Log::Dispatch::File |
296 |
min_level = debug |
297 |
|
298 |
See L<Log::Dispatch::Configurator::AppConfig> for details. |
299 |
|
300 |
=over 4 |
301 |
|
302 |
=item class |
303 |
|
304 |
screen.class = Log::Dispatch::Screen |
305 |
|
306 |
C<class> defines class name of Log::Dispatch subclasses. This |
307 |
parameter is B<essential>. |
308 |
|
309 |
=item format |
310 |
|
311 |
screen.format = -- %m -- |
312 |
|
313 |
C<format> defines log format which would be applied only to the |
314 |
dispatcher. Note that if you define global C<format> also, C<%m> is |
315 |
double formated (first global one, next each dispatcher one). This |
316 |
parameter is B<optional>. |
317 |
|
318 |
=item (others) |
319 |
|
320 |
screen.min_level = info |
321 |
screen.stderr = 1 |
322 |
|
323 |
Other parameters would be passed to the each dispatcher |
324 |
construction. See Log::Dispatch::* manpage for the details. |
325 |
|
326 |
=back |
327 |
|
328 |
=head1 SINGLETON |
329 |
|
330 |
Declared C<instance> method would make C<Log::Dispatch::Config> class |
331 |
singleton, so multiple calls of C<instance> will all result in |
332 |
returning same object. |
333 |
|
334 |
my $one = Log::Dispatch::Config->instance; |
335 |
my $two = Log::Dispatch::Config->instance; # same as $one |
336 |
|
337 |
See GoF Design Pattern book for Singleton Pattern. |
338 |
|
339 |
But in practice, in persistent environment like mod_perl, lifetime of |
340 |
Singleton instance becomes sometimes messy. If you want to reload |
341 |
singleton object manually, call C<reload> method. |
342 |
|
343 |
Log::Dispatch::Config->reload; |
344 |
|
345 |
And, if you want to reload object on the fly, as you edit C<log.conf> |
346 |
or something like that, what you should do is to call |
347 |
C<configure_and_watch> method on Log::Dispatch::Config instead of |
348 |
C<configure>. Then C<instance> call will check mtime of configuration |
349 |
file, and compares it with instanciation time of singleton object. If |
350 |
config file is newer than last instanciation, it will automatically |
351 |
reload object. |
352 |
|
353 |
=head1 NAMESPACE COLLISION |
354 |
|
355 |
If you use Log::Dispatch::Config in multiple projects on the same perl |
356 |
interpreter (like mod_perl), namespace collision would be a |
357 |
problem. Bizzare thing will happen when you call |
358 |
C<Log::Dispatch::Config-E<gt>configure> multiple times with differenct |
359 |
argument. |
360 |
|
361 |
In such cases, what you should do is to define your own logger class. |
362 |
|
363 |
package My::Logger; |
364 |
use Log::Dispatch::Config; |
365 |
use base qw(Log::Dispatch::Config); |
366 |
|
367 |
Or make wrapper for it. See L<POE::Component::Logger> implementation |
368 |
by Matt Sergeant. |
369 |
|
370 |
=head1 PLUGGABLE CONFIGURATOR |
371 |
|
372 |
If you pass filename to C<configure> method call, this module handles |
373 |
the config file with AppConfig. You can change config parsing scheme |
374 |
by passing another pluggable configurator object. |
375 |
|
376 |
Here is a way to declare new configurator class. The example below is |
377 |
hardwired version equivalent to the one above in L</"CONFIGURATION">. |
378 |
|
379 |
=over 4 |
380 |
|
381 |
=item * |
382 |
|
383 |
Inherit from Log::Dispatch::Configurator. |
384 |
|
385 |
package Log::Dispatch::Configurator::Hardwired; |
386 |
use base qw(Log::Dispatch::Configurator); |
387 |
|
388 |
Declare your own C<new> constructor. Stub C<new> method is defined in |
389 |
Configurator base class, but you want to put parsing method in your |
390 |
own constructor. In this example, we just bless reference. Note that |
391 |
your object should be blessed hash. |
392 |
|
393 |
sub new { bless {}, shift } |
394 |
|
395 |
=item * |
396 |
|
397 |
Implement two required object methods C<get_attrs_global> and |
398 |
C<get_attrs>. |
399 |
|
400 |
C<get_attrs_global> should return hash reference of global parameters. |
401 |
C<dispatchers> should be an array reference of names of dispatchers. |
402 |
|
403 |
sub get_attrs_global { |
404 |
my $self = shift; |
405 |
return { |
406 |
format => undef, |
407 |
dispatchers => [ qw(file screen) ], |
408 |
}; |
409 |
} |
410 |
|
411 |
C<get_attrs> accepts name of a dispatcher and should return hash |
412 |
reference of parameters associated with the dispatcher. |
413 |
|
414 |
sub get_attrs { |
415 |
my($self, $name) = @_; |
416 |
if ($name eq 'file') { |
417 |
return { |
418 |
class => 'Log::Dispatch::File', |
419 |
min_level => 'debug', |
420 |
filename => '/path/to/log', |
421 |
mode => 'append', |
422 |
format => '[%d] [%p] %m at %F line %L%n', |
423 |
}; |
424 |
} |
425 |
elsif ($name eq 'screen') { |
426 |
return { |
427 |
class => 'Log::Dispatch::Screen', |
428 |
min_level => 'info', |
429 |
stderr => 1, |
430 |
format => '%m', |
431 |
}; |
432 |
} |
433 |
else { |
434 |
die "invalid dispatcher name: $name"; |
435 |
} |
436 |
} |
437 |
|
438 |
=item * |
439 |
|
440 |
Implement optional C<needs_reload> and C<reload> |
441 |
methods. C<needs_reload> should return boolean value if the object is |
442 |
stale and needs reloading itself. This method will be triggered when |
443 |
you configure logging object with C<configure_and_watch> method. |
444 |
|
445 |
Stub config file mtime based C<needs_reload> method is declared in |
446 |
Log::Dispatch::Configurator, so if your config class is based on |
447 |
filesystem files, you do not need to reimplement this. |
448 |
|
449 |
If you do not need I<singleton-ness> at all, always return true. |
450 |
|
451 |
sub needs_reload { 1 } |
452 |
|
453 |
C<reload> method should redo parsing of the config file. Configurator |
454 |
base class has a stub null C<reload> method, so you should better |
455 |
override it. |
456 |
|
457 |
See Log::Dispatch::Configurator::AppConfig source code for details. |
458 |
|
459 |
=item * |
460 |
|
461 |
That's all. Now you can plug your own configurator (Hardwired) into |
462 |
Log::Dispatch::Config. What you should do is to pass configurator |
463 |
object to C<configure> method call instead of config file name. |
464 |
|
465 |
use Log::Dispatch::Config; |
466 |
use Log::Dispatch::Configurator::Hardwired; |
467 |
|
468 |
my $config = Log::Dispatch::Configurator::Hardwired->new; |
469 |
Log::Dispatch::Config->configure($config); |
470 |
|
471 |
=back |
472 |
|
473 |
=head1 CALLER STACK |
474 |
|
475 |
When you call logging method from your subroutines / methods, caller |
476 |
stack would increase and thus you can't see where the log really comes |
477 |
from. |
478 |
|
479 |
package Logger; |
480 |
my $Logger = Log::Dispatch::Config->instance; |
481 |
|
482 |
sub logit { |
483 |
my($class, $level, $msg) = @_; |
484 |
$Logger->$level($msg); |
485 |
} |
486 |
|
487 |
package main; |
488 |
Logger->logit('debug', 'foobar'); |
489 |
|
490 |
You can adjust package variable C<$Log::Dispatch::Config::CallerDepth> |
491 |
to increase the caller stack depth. The default value is 0. |
492 |
|
493 |
sub logit { |
494 |
my($class, $level, $msg) = @_; |
495 |
local $Log::Dispatch::Config::CallerDepth = 1; |
496 |
$Logger->$level($msg); |
497 |
} |
498 |
|
499 |
Note that your log caller's namespace should not match against |
500 |
C</^Log::Dispatch/>, which makes this module confusing. |
501 |
|
502 |
=head1 AUTHOR |
503 |
|
504 |
Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> with much help from |
505 |
Matt Sergeant E<lt>matt@sergeant.orgE<gt>. |
506 |
|
507 |
This library is free software; you can redistribute it and/or modify |
508 |
it under the same terms as Perl itself. |
509 |
|
510 |
=head1 SEE ALSO |
511 |
|
512 |
L<Log::Dispatch::Configurator::AppConfig>, L<Log::Dispatch>, |
513 |
L<AppConfig>, L<POE::Component::Logger> |
514 |
|
515 |
=cut |