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

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

Initial revision

  • 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.01';
6
7 use AppConfig qw(:argcount);
8 use Log::Dispatch;
9
10 sub configure {
11     my($class, $file) = @_;
12     die "no config file supplied" unless $file;
13
14     my $config = AppConfig->new({
15         CREATE => 1,
16         GLOBAL => {
17             ARGCOUNT => ARGCOUNT_ONE,
18         },
19     });
20     $config->define(dispatchers => { DEFAULT => '' });
21     $config->define(format      => { DEFAULT => undef });
22     $config->file($file);
23
24     *Log::Dispatch::instance = $class->make_closure($config, $file);
25 }
26
27 sub make_closure {
28     my($class, $config, $file) = @_;
29
30     my($instance, $ctime);
31     return sub {
32         my $dispclass = shift;
33
34         # reload config, clear closure and refresh
35         if (defined $ctime && (stat($file))[9] > $ctime) {
36             $class->configure($file);
37             ($instance, $ctime) = (undef, undef);
38             return $dispclass->instance;
39         }
40
41         # create composit dispatcher
42         unless (defined $instance) {
43             my $callback = $class->format_to_cb($config->get('format'), 3);
44             my %dispatchers = $class->config_dispatchers($config);
45
46             my %args;
47             $args{callbacks} = $callback if defined $callback;
48             $instance = $dispclass->new(%args);
49
50             for my $dispname (keys %dispatchers) {
51                 my $logclass = delete $dispatchers{$dispname}->{class};
52                 $instance->add(
53                     $logclass->new(
54                         name => $dispname,
55                         %{$dispatchers{$dispname}},
56                     ),
57                 );
58             }
59             $ctime = time;      # memorize creation time
60         }
61
62         return $instance;
63     };
64 }
65
66 sub config_dispatchers {
67     my($class, $config) = @_;
68     my %dispatchers;
69     for my $disp (split /\s+/, $config->get('dispatchers')) {
70         my %var = $config->varlist("$disp.");
71         my %param = map {
72             (my $key = $_) =~ s/^$disp\.//;
73             $key => $var{$_};
74         } keys %var;
75
76         my $dispclass = $param{class}
77             or die "class param missing for $disp";
78
79         eval qq{require $dispclass};
80         die $@ if $@ && $@ !~ /locate/;
81
82         if (exists $param{format}) {
83             $param{callbacks} = $class->format_to_cb(delete $param{format}, 5);
84         }
85         $dispatchers{$disp} = \%param;
86     }
87     return %dispatchers;
88 }
89
90 sub format_to_cb {
91     my($class, $format, $stack) = @_;
92     return undef unless defined $format;
93
94     my %syn = (
95         d => 'datetime',
96         p => 'level',
97         m => 'message',
98         F => 'filename',
99         L => 'line',
100         P => 'package',
101     );
102     $format =~ s/%([dpmFLP])/\$\{$syn{$1}\}/g;
103     $format =~ s/%n/\n/g;
104
105     return sub {
106         my %p = @_;
107         @p{qw(package filename line)} = caller($stack);
108         $p{datetime} = scalar localtime;
109         my $log = $format;
110         $log =~ s/\$\{(.+?)\}/$p{$1}/g;
111         return $log;
112     };
113 }
114
115 1;
116 __END__
117
118 =head1 NAME
119
120 Log::Dispatch::Config - Log4j for Perl
121
122 =head1 SYNOPSIS
123
124   use Log::Dispatch::Config;
125   Log::Dispatch::Config->configure('/path/to/config');
126
127   my $dispatcher = Log::Dispatch->instance;
128
129 =head1 DESCRIPTION
130
131 Log::Dispatch::Config provides a way to configure Log::Dispatch with
132 configulation file (in AppConfig format). I mean, this is log4j for
133 Perl, not with all API compatibility though.
134
135 =head1 METHOD
136
137 This module has one class method C<configure> which parses config file
138 and declares C<instance> method in Log::Dispatch namespace. So what
139 you should do is call C<configure> method once in somewhere (like
140 C<startup.pl> in mod_perl), then you can get configured dispatcher
141 instance via C<Log::Dispatch-E<gt>instance>.
142
143 =head1 CONFIGURATION
144
145 Here is an example of the config file:
146
147   dispatchers = file screen
148
149   file.class = Log::Dispatch::File
150   file.min_level = debug
151   file.filename = /path/to/log
152   file.mode = append
153   file.format = [%d] [%p] %m at %F line %L%n
154
155   screen.class = Log::Dispatch::Screen
156   screen.min_level = info
157   screen.stderr = 1
158   screen.format = %m
159
160 Config file is parsed with AppConfig module, see L<AppConfig> when you
161 face configuration parsing error.
162
163 =head2 GLOBAL PARAMETERS
164
165 =over 4
166
167 =item dispatchers
168
169   dispatchers = file screen
170
171 C<dispatchers> defines logger names, which will be splitted by spaces.
172 If this parameter is unset, no logging is done.
173
174 =item format
175
176   format = [%d] [%p] %m at %F line %L%n
177   format = [${datetime}] [${prioity}] ${message} at ${filename} line ${line}\n
178
179 C<format> defines log format. C<%X> style and C<${XXX}> style are both
180 supported. Possible conversions format are
181
182   %d ${datetime}        datetime string
183   %p ${priority}        priority (debug, indo, warn ...)
184   %m ${message}         message string
185   %F ${filename}        filename
186   %L ${line}            line number
187   %P ${package}         package
188   %n                    newline (\n)
189
190 C<format> defined here would apply to all the log messages to
191 dispatchers. This parameter is B<optional>.
192
193 =back
194
195 =head2 PARAMETERS FOR EACH DISPATCHER
196
197 Parameters for each dispatcher should be prefixed with "name.", where
198 "name" is the name of each one, defined in global C<dispatchers>
199 parameter.
200
201 =over 4
202
203 =item class
204
205   screen.class = Log::Dispatch::Screen
206
207 C<class> defines class name of Log::Dispatch subclasses. This
208 parameter is B<essential>.
209
210 =item format
211
212   screen.format = -- %m --
213
214 C<format> defines log format which would be applied only to the
215 dispatcher. Note that if you define global C<format> also, C<%m> is
216 double formated (first global one, next each dispatcher one). This
217 parameter is B<optional>.
218
219 =item (others)
220
221   screen.min_level = info
222   screen.stderr = 1
223
224 Other parameters would be passed to the each dispatcher
225 construction. See Log::Dispatch::* manpage for the details.
226
227 =back
228
229 =head1 SINGLETON
230
231 Declared C<instance> method would make C<Log::Dispatch> class
232 singleton, so multiple calls of C<instance> will all result in
233 returning same object.
234
235   my $one = Log::Dispatch->instance;
236   my $two = Log::Dispatch->instance; # same as $one
237
238 See GoF Design Pattern book for Singleton Pattern.
239
240 But in practice, in persistent environment like mod_perl, Singleton
241 instance is not so useful. Log::Dispatch::Config defines C<instance>
242 method so that the object reloads itself when configuration file is
243 modified since its last object creation time.
244
245 =head1 TODO
246
247 =over 4
248
249 =item *
250
251 LogLevel configuration depending on caller package like log4j?
252
253 =back
254
255 =head1 AUTHOR
256
257 Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
258
259 This library is free software; you can redistribute it and/or modify
260 it under the same terms as Perl itself.
261
262 =head1 SEE ALSO
263
264 L<Log::Dispatch>, L<AppConfig>
265
266 =cut
Note: See TracBrowser for help on using the browser.