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

Revision 382 (checked in by miyagawa, 19 years ago)

doc tweak

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