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