root/Log-Dispatch-Config/trunk/lib/Log/Dispatch/Config.pm

Revision 582 (checked in by miyagawa, 18 years ago)

1.00

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