/[cvs]/nfo/perl/libs/Log/Dispatch/Config.pm
ViewVC logotype

Contents of /nfo/perl/libs/Log/Dispatch/Config.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Wed Dec 10 18:13:28 2003 UTC (20 years, 6 months ago) by ts-dev
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +8 -3 lines
%s  subroutine without package name

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

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed