File Coverage

blib/lib/Log/Log4perl/Appender/Limit.pm
Criterion Covered Total %
statement 58 68 85.2
branch 16 28 57.1
condition 9 12 75.0
subroutine 10 12 83.3
pod 1 6 16.6
total 94 126 74.6


line stmt bran cond sub pod time code
1             ######################################################################
2             # Limit.pm -- 2003, Mike Schilli <m@perlmeister.com>
3             ######################################################################
4             # Special composite appender limiting the number of messages relayed
5             # to its appender(s).
6             ######################################################################
7              
8             ###########################################
9             ###########################################
10              
11             use strict;
12 1     1   9 use warnings;
  1         2  
  1         39  
13 1     1   5 use Storable;
  1         2  
  1         28  
14 1     1   5  
  1         2  
  1         869  
15             our @ISA = qw(Log::Log4perl::Appender);
16              
17             our $VERSION = '1.53';
18              
19             ###########################################
20             ###########################################
21             my($class, %options) = @_;
22              
23 8     8 1 32 my $self = {
24             max_until_flushed => undef,
25 8         64 max_until_discarded => undef,
26             appender_method_on_flush
27             => undef,
28             appender => undef,
29             accumulate => 1,
30             persistent => undef,
31             block_period => 3600,
32             buffer => [],
33             %options,
34             };
35              
36             # Pass back the appender to be limited as a dependency
37             # to the configuration file parser
38             push @{$options{l4p_depends_on}}, $self->{appender};
39              
40 8         18 # Run our post_init method in the configurator after
  8         19  
41             # all appenders have been defined to make sure the
42             # appenders we're connecting to really exist.
43             push @{$options{l4p_post_config_subs}}, sub { $self->post_init() };
44              
45 8     7   14 bless $self, $class;
  8         32  
  7         17  
46              
47 8         18 if(defined $self->{persistent}) {
48             $self->restore();
49 8 50       26 }
50 0         0  
51             return $self;
52             }
53 8         173  
54             ###########################################
55             ###########################################
56             my($self, %params) = @_;
57            
58             local $Log::Log4perl::caller_depth =
59 32     32 0 128 $Log::Log4perl::caller_depth + 2;
60              
61 32         52 # Check if message needs to be discarded
62             my $discard = 0;
63             if(defined $self->{max_until_discarded} and
64             scalar @{$self->{buffer}} >= $self->{max_until_discarded} - 1) {
65 32         47 $discard = 1;
66 32 100 66     68 }
67 22         66  
68 22         31 # Check if we need to flush
69             my $flush = 0;
70             if(defined $self->{max_until_flushed} and
71             scalar @{$self->{buffer}} >= $self->{max_until_flushed} - 1) {
72 32         42 $flush = 1;
73 32 100 100     71 }
74 6         30  
75 2         4 if(!$flush and
76             (exists $self->{sent_last} and
77             $self->{sent_last} + $self->{block_period} > time()
78 32 100 66     132 )
      66        
79             ) {
80             # Message needs to be blocked for now.
81             return if $discard;
82              
83             # Ask the appender to save a cached message in $cache
84 23 100       74 $self->{app}->SUPER::log(\%params,
85             $params{log4p_category},
86             $params{log4p_level}, \my $cache);
87              
88             # Save message and other parameters
89 3         16 push @{$self->{buffer}}, $cache if $self->{accumulate};
90              
91             $self->save() if $self->{persistent};
92 3 50       10  
  3         8  
93             return;
94 3 50       10 }
95              
96 3         10 # Relay all messages we got to the SUPER class, which needs to render the
97             # messages according to the appender's layout, first.
98              
99             # Log pending messages if we have any
100             $self->flush();
101              
102             # Log current message as well
103 9         26 $self->{app}->SUPER::log(\%params,
104             $params{log4p_category},
105             $params{log4p_level});
106              
107             $self->{sent_last} = time();
108 9         42  
109             # We need to store the timestamp persistently, if requested
110 9         19 $self->save() if $self->{persistent};
111             }
112              
113 9 50       35 ###########################################
114             ###########################################
115             my($self) = @_;
116              
117             if(! exists $self->{appender}) {
118             die "No appender defined for " . __PACKAGE__;
119 8     8 0 17 }
120              
121 8 50       19 my $appenders = Log::Log4perl->appenders();
122 0         0 my $appender = Log::Log4perl->appenders()->{$self->{appender}};
123              
124             if(! defined $appender) {
125 8         30 die "Appender $self->{appender} not defined (yet) when " .
126 8         21 __PACKAGE__ . " needed it";
127             }
128 8 50       20  
129 0         0 $self->{app} = $appender;
130             }
131              
132             ###########################################
133 8         34 ###########################################
134             my($self) = @_;
135              
136             my $pdata = [$self->{buffer}, $self->{sent_last}];
137              
138             # Save the buffer if we're in persistent mode
139 0     0 0 0 store $pdata, $self->{persistent} or
140             die "Cannot save messages in $self->{persistent} ($!)";
141 0         0 }
142              
143             ###########################################
144             ###########################################
145 0 0       0 my($self) = @_;
146              
147             if(-f $self->{persistent}) {
148             my $pdata = retrieve $self->{persistent} or
149             die "Cannot retrieve messages from $self->{persistent} ($!)";
150             ($self->{buffer}, $self->{sent_last}) = @$pdata;
151 0     0 0 0 }
152             }
153 0 0       0  
154             ###########################################
155 0 0       0 ###########################################
156 0         0 my($self) = @_;
157              
158             # Log pending messages if we have any
159             for(@{$self->{buffer}}) {
160             $self->{app}->SUPER::log_cached($_);
161             }
162              
163 14     14 0 26 # call flush() on the attached appender if so desired.
164             if( $self->{appender_method_on_flush} ) {
165             no strict 'refs';
166 14         18 my $method = $self->{appender_method_on_flush};
  14         87  
167 3         11 $self->{app}->$method();
168             }
169              
170             # Empty buffer
171 14 100       41 $self->{buffer} = [];
172 1     1   8 }
  1         2  
  1         132  
173 2         5  
174 2         15 ###########################################
175             ###########################################
176             my($self) = @_;
177              
178 14         35 }
179              
180             1;
181              
182              
183             =encoding utf8
184 1     1   8  
185             =head1 NAME
186              
187             Log::Log4perl::Appender::Limit - Limit message delivery via block period
188              
189             =head1 SYNOPSIS
190              
191             use Log::Log4perl qw(:easy);
192              
193             my $conf = qq(
194             log4perl.category = WARN, Limiter
195            
196             # Email appender
197             log4perl.appender.Mailer = Log::Dispatch::Email::MailSend
198             log4perl.appender.Mailer.to = drone\@pageme.com
199             log4perl.appender.Mailer.subject = Something's broken!
200             log4perl.appender.Mailer.buffered = 0
201             log4perl.appender.Mailer.layout = PatternLayout
202             log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n
203              
204             # Limiting appender, using the email appender above
205             log4perl.appender.Limiter = Log::Log4perl::Appender::Limit
206             log4perl.appender.Limiter.appender = Mailer
207             log4perl.appender.Limiter.block_period = 3600
208             );
209              
210             Log::Log4perl->init(\$conf);
211             WARN("This message will be sent immediately.");
212             WARN("This message will be delayed by one hour.");
213             sleep(3601);
214             WARN("This message plus the last one will be sent now, seperately.");
215              
216             =head1 DESCRIPTION
217              
218             =over 4
219              
220             =item C<appender>
221              
222             Specifies the name of the appender used by the limiter. The
223             appender specified must be defined somewhere in the configuration file,
224             not necessarily before the definition of
225             C<Log::Log4perl::Appender::Limit>.
226              
227             =item C<block_period>
228              
229             Period in seconds between delivery of messages. If messages arrive in between,
230             they will be either saved (if C<accumulate> is set to a true value) or
231             discarded (if C<accumulate> isn't set).
232              
233             =item C<persistent>
234              
235             File name in which C<Log::Log4perl::Appender::Limit> persistently stores
236             delivery times. If omitted, the appender will have no recollection of what
237             happened when the program restarts.
238              
239             =item C<max_until_flushed>
240              
241             Maximum number of accumulated messages. If exceeded, the appender flushes
242             all messages, regardless if the interval set in C<block_period>
243             has passed or not. Don't mix with C<max_until_discarded>.
244              
245             =item C<max_until_discarded>
246              
247             Maximum number of accumulated messages. If exceeded, the appender will
248             simply discard additional messages, waiting for C<block_period> to expire
249             to flush all accumulated messages. Don't mix with C<max_until_flushed>.
250              
251             =item C<appender_method_on_flush>
252              
253             Optional method name to be called on the appender attached to the
254             limiter when messages are flushed. For example, to have the sample code
255             in the SYNOPSIS section bundle buffered emails into one, change the
256             mailer's C<buffered> parameter to C<1> and set the limiters
257             C<appender_method_on_flush> value to the string C<"flush">:
258              
259             log4perl.category = WARN, Limiter
260            
261             # Email appender
262             log4perl.appender.Mailer = Log::Dispatch::Email::MailSend
263             log4perl.appender.Mailer.to = drone\@pageme.com
264             log4perl.appender.Mailer.subject = Something's broken!
265             log4perl.appender.Mailer.buffered = 1
266             log4perl.appender.Mailer.layout = PatternLayout
267             log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n
268              
269             # Limiting appender, using the email appender above
270             log4perl.appender.Limiter = Log::Log4perl::Appender::Limit
271             log4perl.appender.Limiter.appender = Mailer
272             log4perl.appender.Limiter.block_period = 3600
273             log4perl.appender.Limiter.appender_method_on_flush = flush
274              
275             This will cause the mailer to buffer messages and wait for C<flush()>
276             to send out the whole batch. The limiter will then call the appender's
277             C<flush()> method when it's own buffer gets flushed out.
278              
279             =back
280              
281             If the appender attached to C<Limit> uses C<PatternLayout> with a timestamp
282             specifier, you will notice that the message timestamps are reflecting the
283             original log event, not the time of the message rendering in the
284             attached appender. Major trickery has been applied to accomplish
285             this (Cough!).
286              
287             =head1 DEVELOPMENT NOTES
288              
289             C<Log::Log4perl::Appender::Limit> is a I<composite> appender.
290             Unlike other appenders, it doesn't log any messages, it just
291             passes them on to its attached sub-appender.
292             For this reason, it doesn't need a layout (contrary to regular appenders).
293             If it defines none, messages are passed on unaltered.
294              
295             Custom filters are also applied to the composite appender only.
296             They are I<not> applied to the sub-appender. Same applies to appender
297             thresholds. This behaviour might change in the future.
298              
299             =head1 LICENSE
300              
301             Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt>
302             and Kevin Goess E<lt>cpan@goess.orgE<gt>.
303              
304             This library is free software; you can redistribute it and/or modify
305             it under the same terms as Perl itself.
306              
307             =head1 AUTHOR
308              
309             Please contribute patches to the project on Github:
310              
311             http://github.com/mschilli/log4perl
312              
313             Send bug reports or requests for enhancements to the authors via our
314              
315             MAILING LIST (questions, bug reports, suggestions/patches):
316             log4perl-devel@lists.sourceforge.net
317              
318             Authors (please contact them via the list above, not directly):
319             Mike Schilli <m@perlmeister.com>,
320             Kevin Goess <cpan@goess.org>
321              
322             Contributors (in alphabetical order):
323             Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
324             Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
325             Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
326             Grundman, Paul Harrington, Alexander Hartmaier David Hull,
327             Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter,
328             Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope,
329             Lars Thegler, David Viner, Mac Yang.
330