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