1######################################################################
2# Buffer.pm -- 2004, Mike Schilli <m@perlmeister.com>
3######################################################################
4# Composite appender buffering messages until a trigger condition is met.
5######################################################################
6
7###########################################
8package Log::Log4perl::Appender::Buffer;
9###########################################
10
11use strict;
12use warnings;
13
14our @ISA = qw(Log::Log4perl::Appender);
15
16our $CVSVERSION   = '$Revision: 1.2 $';
17our ($VERSION)    = ($CVSVERSION =~ /(\d+\.\d+)/);
18
19###########################################
20sub new {
21###########################################
22    my($class, %options) = @_;
23
24    my $self = {
25        appender=> undef,
26        buffer  => [],
27        options => {
28            max_messages  => undef,
29            trigger       => undef,
30            trigger_level => undef,
31        },
32        level   => 0,
33        %options,
34    };
35
36    if($self->{trigger_level}) {
37        $self->{trigger} = level_trigger($self->{trigger_level});
38    }
39
40        # Pass back the appender to be synchronized as a dependency
41        # to the configuration file parser
42    push @{$options{l4p_depends_on}}, $self->{appender};
43
44        # Run our post_init method in the configurator after
45        # all appenders have been defined to make sure the
46        # appender we're playing 'dam' for really exists
47    push @{$options{l4p_post_config_subs}}, sub { $self->post_init() };
48
49    bless $self, $class;
50}
51
52###########################################
53sub log {
54###########################################
55    my($self, %params) = @_;
56
57        # Do we need to discard a message because there's already
58        # max_size messages in the buffer?
59    if(defined $self->{max_messages} and
60       @{$self->{buffer}} == $self->{max_messages}) {
61        shift @{$self->{buffer}};
62    }
63
64        # Save event time for later
65    $params{log4p_logtime} = $self->{app}->{layout}->{time_function}->() if
66       exists $self->{app}->{layout}->{time_function};
67
68        # Save message and other parameters
69    push @{$self->{buffer}}, \%params;
70
71    $self->flush() if $self->{trigger}->($self, \%params);
72}
73
74###########################################
75sub flush {
76###########################################
77    my($self) = @_;
78
79        # Log pending messages if we have any
80    for(@{$self->{buffer}}) {
81            # Trick the renderer into using the original event time
82        local $self->{app}->{layout}->{time_function};
83        $self->{app}->{layout}->{time_function} =
84                                    sub { $_->{log4p_logtime} };
85        $self->{app}->SUPER::log($_,
86                                 $_->{log4p_category},
87                                 $_->{log4p_level});
88    }
89
90        # Empty buffer
91    $self->{buffer} = [];
92}
93
94###########################################
95sub post_init {
96###########################################
97    my($self) = @_;
98
99    if(! exists $self->{appender}) {
100       die "No appender defined for " . __PACKAGE__;
101    }
102
103    my $appenders = Log::Log4perl->appenders();
104    my $appender = Log::Log4perl->appenders()->{$self->{appender}};
105
106    if(! defined $appender) {
107       die "Appender $self->{appender} not defined (yet) when " .
108           __PACKAGE__ . " needed it";
109    }
110
111    $self->{app} = $appender;
112}
113
114###########################################
115sub level_trigger {
116###########################################
117    my($level) = @_;
118
119        # closure holding $level
120    return sub {
121        my($self, $params) = @_;
122
123        return Log::Log4perl::Level::to_priority(
124                 $params->{log4p_level}) >=
125               Log::Log4perl::Level::to_priority($level);
126    };
127}
128
129###########################################
130sub DESTROY {
131###########################################
132    my($self) = @_;
133}
134
1351;
136
137__END__
138
139=head1 NAME
140
141    Log::Log4perl::Appender::Buffer - Buffering Appender
142
143=head1 SYNOPSIS
144
145    use Log::Log4perl qw(:easy);
146
147    my $conf = qq(
148    log4perl.category                  = DEBUG, Buffer
149
150        # Regular Screen Appender
151    log4perl.appender.Screen           = Log::Log4perl::Appender::Screen
152    log4perl.appender.Screen.stdout    = 1
153    log4perl.appender.Screen.layout    = PatternLayout
154    log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n
155
156        # Buffering appender, using the appender above as outlet
157    log4perl.appender.Buffer               = Log::Log4perl::Appender::Buffer
158    log4perl.appender.Buffer.appender      = Screen
159    log4perl.appender.Buffer.trigger_level = ERROR
160    );
161
162    Log::Log4perl->init(\$conf);
163
164    DEBUG("This message gets buffered.");
165    INFO("This message gets buffered also.");
166
167    # Time passes. Nothing happens. But then ...
168
169    print "It's GO time!!!\n";
170
171    ERROR("This message triggers a buffer flush.");
172
173=head1 DESCRIPTION
174
175C<Log::Log4perl::Appender::Buffer> takes these arguments:
176
177=over 4
178
179=item C<appender>
180
181Specifies the name of the appender it buffers messages for. The
182appender specified must be defined somewhere in the configuration file,
183not necessarily before the definition of
184C<Log::Log4perl::Appender::Buffer>.
185
186=item C<max_messages>
187
188Specifies the maximum number of messages the appender will hold in
189its ring buffer. C<max_messages> is optional. By default,
190C<Log::Log4perl::Appender::Buffer> will I<not> limit the number of
191messages buffered. This might be undesirable in long-running processes
192accumulating lots of messages before a flush happens. If
193C<max_messages> is set to a numeric value,
194C<Log::Log4perl::Appender::Buffer> will displace old messages in its
195buffer to make room if the buffer is full.
196
197=item C<trigger_level>
198
199If trigger_level is set to one of Log4perl's levels (see
200Log::Log4perl::Level), a C<trigger> function will be defined internally
201to flush the buffer if a message with a priority of $level or higher
202comes along. This is just a convenience function. Defining
203
204    log4perl.appender.Buffer.trigger_level = ERROR
205
206is equivalent to creating a trigger function like
207
208    log4perl.appender.Buffer.trigger = sub {   \
209        my($self, $params) = @_;               \
210        return $params->{log4p_level} >=       \
211               $Log::Log4perl::Level::ERROR; }
212
213See the next section for defining generic trigger functions.
214
215=item C<trigger>
216
217C<trigger> holds a reference to a subroutine, which
218C<Log::Log4perl::Appender::Buffer> will call on every incoming message
219with the same parameters as the appender's C<log()> method:
220
221        my($self, $params) = @_;
222
223C<$params> references a hash containing
224the message priority (key C<l4p_level>), the
225message category (key C<l4p_category>) and the content of the message
226(key C<message>).
227
228If the subroutine returns 1, it will trigger a flush of buffered messages.
229
230Shortcut
231
232=back
233
234=head1 DEVELOPMENT NOTES
235
236C<Log::Log4perl::Appender::Buffer> is a I<composite> appender.
237Unlike other appenders, it doesn't log any messages, it just
238passes them on to its attached sub-appender.
239For this reason, it doesn't need a layout (contrary to regular appenders).
240If it defines none, messages are passed on unaltered.
241
242Custom filters are also applied to the composite appender only.
243They are I<not> applied to the sub-appender. Same applies to appender
244thresholds. This behaviour might change in the future.
245
246=head1 LEGALESE
247
248Copyright 2004 by Mike Schilli, all rights reserved.
249This program is free software, you can redistribute it and/or
250modify it under the same terms as Perl itself.
251
252=head1 AUTHOR
253
2542004, Mike Schilli <m@perlmeister.com>
255