diff options
Diffstat (limited to 'lib/Log/Log4perl/Appender')
| -rw-r--r-- | lib/Log/Log4perl/Appender/Buffer.pm | 279 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/DBI.pm | 643 | ||||
| -rwxr-xr-x | lib/Log/Log4perl/Appender/File.pm | 545 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/Limit.pm | 340 | ||||
| -rwxr-xr-x | lib/Log/Log4perl/Appender/RRDs.pm | 134 | ||||
| -rwxr-xr-x | lib/Log/Log4perl/Appender/Screen.pm | 124 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/ScreenColoredLevels.pm | 235 | ||||
| -rwxr-xr-x | lib/Log/Log4perl/Appender/Socket.pm | 226 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/String.pm | 110 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/Synchronized.pm | 292 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/TestArrayBuffer.pm | 94 | ||||
| -rw-r--r-- | lib/Log/Log4perl/Appender/TestBuffer.pm | 189 | ||||
| -rwxr-xr-x | lib/Log/Log4perl/Appender/TestFileCreeper.pm | 89 |
13 files changed, 3300 insertions, 0 deletions
diff --git a/lib/Log/Log4perl/Appender/Buffer.pm b/lib/Log/Log4perl/Appender/Buffer.pm new file mode 100644 index 0000000..9d6ccd5 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Buffer.pm @@ -0,0 +1,279 @@ +###################################################################### +# Buffer.pm -- 2004, Mike Schilli <m@perlmeister.com> +###################################################################### +# Composite appender buffering messages until a trigger condition is met. +###################################################################### + +########################################### +package Log::Log4perl::Appender::Buffer; +########################################### + +use strict; +use warnings; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.2 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + appender=> undef, + buffer => [], + options => { + max_messages => undef, + trigger => undef, + trigger_level => undef, + }, + level => 0, + %options, + }; + + if($self->{trigger_level}) { + $self->{trigger} = level_trigger($self->{trigger_level}); + } + + # Pass back the appender to be synchronized as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appender we're playing 'dam' for really exists + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + + # Do we need to discard a message because there's already + # max_size messages in the buffer? + if(defined $self->{max_messages} and + @{$self->{buffer}} == $self->{max_messages}) { + shift @{$self->{buffer}}; + } + # Ask the appender to save a cached message in $cache + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}, \my $cache); + + # Save it in the appender's message buffer, but only if + # it hasn't been suppressed by an appender threshold + if( defined $cache ) { + push @{ $self->{buffer} }, $cache; + } + + $self->flush() if $self->{trigger}->($self, \%params); +} + +########################################### +sub flush { +########################################### + my($self) = @_; + + # Flush pending messages if we have any + for my $cache (@{$self->{buffer}}) { + $self->{app}->SUPER::log_cached($cache); + } + + # Empty buffer + $self->{buffer} = []; +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +########################################### +sub level_trigger { +########################################### + my($level) = @_; + + # closure holding $level + return sub { + my($self, $params) = @_; + + return Log::Log4perl::Level::to_priority( + $params->{log4p_level}) >= + Log::Log4perl::Level::to_priority($level); + }; +} + +########################################### +sub DESTROY { +########################################### + my($self) = @_; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Buffer - Buffering Appender + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = DEBUG, Buffer + + # Regular Screen Appender + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.stdout = 1 + log4perl.appender.Screen.layout = PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, using the appender above as outlet + log4perl.appender.Buffer = Log::Log4perl::Appender::Buffer + log4perl.appender.Buffer.appender = Screen + log4perl.appender.Buffer.trigger_level = ERROR + ); + + Log::Log4perl->init(\$conf); + + DEBUG("This message gets buffered."); + INFO("This message gets buffered also."); + + # Time passes. Nothing happens. But then ... + + print "It's GO time!!!\n"; + + ERROR("This message triggers a buffer flush."); + +=head1 DESCRIPTION + +C<Log::Log4perl::Appender::Buffer> takes these arguments: + +=over 4 + +=item C<appender> + +Specifies the name of the appender it buffers messages for. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Buffer>. + +=item C<max_messages> + +Specifies the maximum number of messages the appender will hold in +its ring buffer. C<max_messages> is optional. By default, +C<Log::Log4perl::Appender::Buffer> will I<not> limit the number of +messages buffered. This might be undesirable in long-running processes +accumulating lots of messages before a flush happens. If +C<max_messages> is set to a numeric value, +C<Log::Log4perl::Appender::Buffer> will displace old messages in its +buffer to make room if the buffer is full. + +=item C<trigger_level> + +If trigger_level is set to one of Log4perl's levels (see +Log::Log4perl::Level), a C<trigger> function will be defined internally +to flush the buffer if a message with a priority of $level or higher +comes along. This is just a convenience function. Defining + + log4perl.appender.Buffer.trigger_level = ERROR + +is equivalent to creating a trigger function like + + log4perl.appender.Buffer.trigger = sub { \ + my($self, $params) = @_; \ + return $params->{log4p_level} >= \ + $Log::Log4perl::Level::ERROR; } + +See the next section for defining generic trigger functions. + +=item C<trigger> + +C<trigger> holds a reference to a subroutine, which +C<Log::Log4perl::Appender::Buffer> will call on every incoming message +with the same parameters as the appender's C<log()> method: + + my($self, $params) = @_; + +C<$params> references a hash containing +the message priority (key C<l4p_level>), the +message category (key C<l4p_category>) and the content of the message +(key C<message>). + +If the subroutine returns 1, it will trigger a flush of buffered messages. + +Shortcut + +=back + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Buffer> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/DBI.pm b/lib/Log/Log4perl/Appender/DBI.pm new file mode 100644 index 0000000..e2043d3 --- /dev/null +++ b/lib/Log/Log4perl/Appender/DBI.pm @@ -0,0 +1,643 @@ +package Log::Log4perl::Appender::DBI; + +our @ISA = qw(Log::Log4perl::Appender); + +use Carp; + +use strict; +use DBI; + +sub new { + my($proto, %p) = @_; + my $class = ref $proto || $proto; + + my $self = bless {}, $class; + + $self->_init(%p); + + my %defaults = ( + reconnect_attempts => 1, + reconnect_sleep => 0, + ); + + for (keys %defaults) { + if(exists $p{$_}) { + $self->{$_} = $p{$_}; + } else { + $self->{$_} = $defaults{$_}; + } + } + + #e.g. + #log4j.appender.DBAppndr.params.1 = %p + #log4j.appender.DBAppndr.params.2 = %5.5m + foreach my $pnum (keys %{$p{params}}){ + $self->{bind_value_layouts}{$pnum} = + Log::Log4perl::Layout::PatternLayout->new({ + ConversionPattern => {value => $p{params}->{$pnum}}, + undef_column_value => undef, + }); + } + #'bind_value_layouts' now contains a PatternLayout + #for each parameter heading for the Sql engine + + $self->{SQL} = $p{sql}; #save for error msg later on + + $self->{MAX_COL_SIZE} = $p{max_col_size}; + + $self->{BUFFERSIZE} = $p{bufferSize} || 1; + + if ($p{usePreparedStmt}) { + $self->{sth} = $self->create_statement($p{sql}); + $self->{usePreparedStmt} = 1; + }else{ + $self->{layout} = Log::Log4perl::Layout::PatternLayout->new({ + ConversionPattern => {value => $p{sql}}, + undef_column_value => undef, + }); + } + + if ($self->{usePreparedStmt} && $self->{bufferSize}){ + warn "Log4perl: you've defined both usePreparedStmt and bufferSize \n". + "in your appender '$p{name}'--\n". + "I'm going to ignore bufferSize and just use a prepared stmt\n"; + } + + return $self; +} + + +sub _init { + my $self = shift; + my %params = @_; + + if ($params{dbh}) { + $self->{dbh} = $params{dbh}; + } else { + $self->{connect} = sub { + DBI->connect(@params{qw(datasource username password)}, + {PrintError => 0, $params{attrs} ? %{$params{attrs}} : ()}) + or croak "Log4perl: $DBI::errstr"; + }; + $self->{dbh} = $self->{connect}->(); + $self->{_mine} = 1; + } +} + +sub create_statement { + my ($self, $stmt) = @_; + + $stmt || croak "Log4perl: sql not set in Log4perl::Appender::DBI"; + + return $self->{dbh}->prepare($stmt) || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt"; + +} + + +sub log { + my $self = shift; + my %p = @_; + + #%p is + # { name => $appender_name, + # level => loglevel + # message => $message, + # log4p_category => $category, + # log4p_level => $level,); + # }, + + #getting log4j behavior with no specified ConversionPattern + chomp $p{message} unless ref $p{message}; + + + my $qmarks = $self->calculate_bind_values(\%p); + + + if ($self->{usePreparedStmt}) { + + $self->query_execute($self->{sth}, @$qmarks); + + }else{ + + #first expand any %x's in the statement + my $stmt = $self->{layout}->render( + $p{message}, + $p{log4p_category}, + $p{log4p_level}, + 5 + $Log::Log4perl::caller_depth, + ); + + push @{$self->{BUFFER}}, $stmt, $qmarks; + + $self->check_buffer(); + } +} + +sub query_execute { + my($self, $sth, @qmarks) = @_; + + my $errstr = "[no error]"; + + for my $attempt (0..$self->{reconnect_attempts}) { + #warn "Exe: @qmarks"; # TODO + if(! $sth->execute(@qmarks)) { + + # save errstr because ping() would override it [RT 56145] + $errstr = $self->{dbh}->errstr(); + + # Exe failed -- was it because we lost the DB + # connection? + if($self->{dbh}->ping()) { + # No, the connection is ok, we failed because there's + # something wrong with the execute(): Bad SQL or + # missing parameters or some such). Abort. + croak "Log4perl: DBI appender error: '$errstr'"; + } + + if($attempt == $self->{reconnect_attempts}) { + croak "Log4perl: DBI appender failed to " . + ($self->{reconnect_attempts} == 1 ? "" : "re") . + "connect " . + "to database after " . + "$self->{reconnect_attempts} attempt" . + ($self->{reconnect_attempts} == 1 ? "" : "s") . + " (last error error was [$errstr]"; + } + if(! $self->{dbh}->ping()) { + # Ping failed, try to reconnect + if($attempt) { + #warn "Sleeping"; # TODO + sleep($self->{reconnect_sleep}) if $self->{reconnect_sleep}; + } + + eval { + #warn "Reconnecting to DB"; # TODO + $self->{dbh} = $self->{connect}->(); + }; + } + + if ($self->{usePreparedStmt}) { + $sth = $self->create_statement($self->{SQL}); + $self->{sth} = $sth if $self->{sth}; + } else { + #warn "Pending stmt: $self->{pending_stmt}"; #TODO + $sth = $self->create_statement($self->{pending_stmt}); + } + + next; + } + return 1; + } + croak "Log4perl: DBI->execute failed $errstr, \n". + "on $self->{SQL}\n @qmarks"; +} + +sub calculate_bind_values { + my ($self, $p) = @_; + + my @qmarks; + my $user_ph_idx = 0; + + my $i=0; + + if ($self->{bind_value_layouts}) { + + my $prev_pnum = 0; + my $max_pnum = 0; + + my @pnums = sort {$a <=> $b} keys %{$self->{bind_value_layouts}}; + $max_pnum = $pnums[-1]; + + #Walk through the integers for each possible bind value. + #If it doesn't have a layout assigned from the config file + #then shift it off the array from the $log call + #This needs to be reworked now that we always get an arrayref? --kg 1/2003 + foreach my $pnum (1..$max_pnum){ + my $msg; + + #we've got a bind_value_layout to fill the spot + if ($self->{bind_value_layouts}{$pnum}){ + $msg = $self->{bind_value_layouts}{$pnum}->render( + $p->{message}, + $p->{log4p_category}, + $p->{log4p_level}, + 5 + $Log::Log4perl::caller_depth, + ); + + #we don't have a bind_value_layout, so get + #a message bit + }elsif (ref $p->{message} eq 'ARRAY' && @{$p->{message}}){ + #$msg = shift @{$p->{message}}; + $msg = $p->{message}->[$i++]; + + #here handle cases where we ran out of message bits + #before we ran out of bind_value_layouts, just keep going + }elsif (ref $p->{message} eq 'ARRAY'){ + $msg = undef; + $p->{message} = undef; + + #here handle cases where we didn't get an arrayref + #log the message in the first placeholder and nothing in the rest + }elsif (! ref $p->{message} ){ + $msg = $p->{message}; + $p->{message} = undef; + + } + + if ($self->{MAX_COL_SIZE} && + length($msg) > $self->{MAX_COL_SIZE}){ + substr($msg, $self->{MAX_COL_SIZE}) = ''; + } + push @qmarks, $msg; + } + } + + #handle leftovers + if (ref $p->{message} eq 'ARRAY' && @{$p->{message}} ) { + #push @qmarks, @{$p->{message}}; + push @qmarks, @{$p->{message}}[$i..@{$p->{message}}-1]; + + } + + return \@qmarks; +} + + +sub check_buffer { + my $self = shift; + + return unless ($self->{BUFFER} && ref $self->{BUFFER} eq 'ARRAY'); + + if (scalar @{$self->{BUFFER}} >= $self->{BUFFERSIZE} * 2) { + + my ($sth, $stmt, $prev_stmt); + + $prev_stmt = ""; # Init to avoid warning (ms 5/10/03) + + while (@{$self->{BUFFER}}) { + my ($stmt, $qmarks) = splice (@{$self->{BUFFER}},0,2); + + $self->{pending_stmt} = $stmt; + + #reuse the sth if the stmt doesn't change + if ($stmt ne $prev_stmt) { + $sth->finish if $sth; + $sth = $self->create_statement($stmt); + } + + $self->query_execute($sth, @$qmarks); + + $prev_stmt = $stmt; + + } + + $sth->finish; + + my $dbh = $self->{dbh}; + + if ($dbh && ! $dbh->{AutoCommit}) { + $dbh->commit; + } + } +} + +sub DESTROY { + my $self = shift; + + $self->{BUFFERSIZE} = 1; + + $self->check_buffer(); + + if ($self->{_mine} && $self->{dbh}) { + $self->{dbh}->disconnect; + } +} + + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::DBI - implements appending to a DB + +=head1 SYNOPSIS + + my $config = q{ + log4j.category = WARN, DBAppndr + log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI + log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp + log4j.appender.DBAppndr.username = bobjones + log4j.appender.DBAppndr.password = 12345 + log4j.appender.DBAppndr.sql = \ + insert into log4perltest \ + (loglevel, custid, category, message, ipaddr) \ + values (?,?,?,?,?) + log4j.appender.DBAppndr.params.1 = %p + #2 is custid from the log() call + log4j.appender.DBAppndr.params.3 = %c + #4 is the message from log() + #5 is ipaddr from log() + + log4j.appender.DBAppndr.usePreparedStmt = 1 + #--or-- + log4j.appender.DBAppndr.bufferSize = 2 + + #just pass through the array of message items in the log statement + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + log4j.appender.DBAppndr.warp_message = 0 + + #driver attributes support + log4j.appender.DBAppndr.attrs.f_encoding = utf8 + }; + + $logger->warn( $custid, 'big problem!!', $ip_addr ); + +=head1 CAVEAT + +This is a very young module and there are a lot of variations +in setups with different databases and connection methods, +so make sure you test thoroughly! Any feedback is welcome! + +=head1 DESCRIPTION + +This is a specialized Log::Dispatch object customized to work with +log4perl and its abilities, originally based on Log::Dispatch::DBI +by Tatsuhiko Miyagawa but with heavy modifications. + +It is an attempted compromise between what Log::Dispatch::DBI was +doing and what log4j's JDBCAppender does. Note the log4j docs say +the JDBCAppender "is very likely to be completely replaced in the future." + +The simplest usage is this: + + log4j.category = WARN, DBAppndr + log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI + log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp + log4j.appender.DBAppndr.username = bobjones + log4j.appender.DBAppndr.password = 12345 + log4j.appender.DBAppndr.sql = \ + INSERT INTO logtbl \ + (loglevel, message) \ + VALUES ('%c','%m') + + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::PatternLayout + + + $logger->fatal('fatal message'); + $logger->warn('warning message'); + + =============================== + |FATAL|fatal message | + |WARN |warning message | + =============================== + + +But the downsides to that usage are: + +=over 4 + +=item * + +You'd better be darn sure there are not quotes in your log message, or your +insert could have unforeseen consequences! This is a very insecure way to +handle database inserts, using place holders and bind values is much better, +keep reading. (Note that the log4j docs warn "Be careful of quotes in your +messages!") B<*>. + +=item * + +It's not terribly high-performance, a statement is created and executed +for each log call. + +=item * + +The only run-time parameter you get is the %m message, in reality +you probably want to log specific data in specific table columns. + +=back + +So let's try using placeholders, and tell the logger to create a +prepared statement handle at the beginning and just reuse it +(just like Log::Dispatch::DBI does) + + + log4j.appender.DBAppndr.sql = \ + INSERT INTO logtbl \ + (custid, loglevel, message) \ + VALUES (?,?,?) + + #--------------------------------------------------- + #now the bind values: + #1 is the custid + log4j.appender.DBAppndr.params.2 = %p + #3 is the message + #--------------------------------------------------- + + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + log4j.appender.DBAppndr.warp_message = 0 + + log4j.appender.DBAppndr.usePreparedStmt = 1 + + + $logger->warn( 1234, 'warning message' ); + + +Now see how we're using the '?' placeholders in our statement? This +means we don't have to worry about messages that look like + + invalid input: 1234';drop table custid; + +fubaring our database! + +Normally a list of things in the logging statement gets concatenated into +a single string, but setting C<warp_message> to 0 and using the +NoopLayout means that in + + $logger->warn( 1234, 'warning message', 'bgates' ); + +the individual list values will still be available for the DBI appender later +on. (If C<warp_message> is not set to 0, the default behavior is to +join the list elements into a single string. If PatternLayout or SimpleLayout +are used, their attempt to C<render()> your layout will result in something +like "ARRAY(0x841d8dc)" in your logs. More information on C<warp_message> +is in Log::Log4perl::Appender.) + +In your insert SQL you can mix up '?' placeholders with conversion specifiers +(%c, %p, etc) as you see fit--the logger will match the question marks to +params you've defined in the config file and populate the rest with values +from your list. If there are more '?' placeholders than there are values in +your message, it will use undef for the rest. For instance, + + log4j.appender.DBAppndr.sql = \ + insert into log4perltest \ + (loglevel, message, datestr, subpoena_id)\ + values (?,?,?,?) + log4j.appender.DBAppndr.params.1 = %p + log4j.appender.DBAppndr.params.3 = %d + + log4j.appender.DBAppndr.warp_message=0 + + + $logger->info('arrest him!', $subpoena_id); + +results in the first '?' placeholder being bound to %p, the second to +"arrest him!", the third to the date from "%d", and the fourth to your +$subpoenaid. If you forget the $subpoena_id and just log + + $logger->info('arrest him!'); + +then you just get undef in the fourth column. + + +If the logger statement is also being handled by other non-DBI appenders, +they will just join the list into a string, joined with +C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (default is an empty string). + +And see the C<usePreparedStmt>? That creates a statement handle when +the logger object is created and just reuses it. That, however, may +be problematic for long-running processes like webservers, in which case +you can use this parameter instead + + log4j.appender.DBAppndr.bufferSize=2 + +This copies log4j's JDBCAppender's behavior, it saves up that many +log statements and writes them all out at once. If your INSERT +statement uses only ? placeholders and no %x conversion specifiers +it should be quite efficient because the logger can re-use the +same statement handle for the inserts. + +If the program ends while the buffer is only partly full, the DESTROY +block should flush the remaining statements, if the DESTROY block +runs of course. + +* I<As I was writing this, Danko Mannhaupt was coming out with his +improved log4j JDBCAppender (http://www.mannhaupt.com/danko/projects/) +which overcomes many of the drawbacks of the original JDBCAppender.> + +=head1 DESCRIPTION 2 + +Or another way to say the same thing: + +The idea is that if you're logging to a database table, you probably +want specific parts of your log information in certain columns. To this +end, you pass an list to the log statement, like + + $logger->warn('big problem!!',$userid,$subpoena_nr,$ip_addr); + +and the array members drop into the positions defined by the placeholders +in your SQL statement. You can also define information in the config +file like + + log4j.appender.DBAppndr.params.2 = %p + +in which case those numbered placeholders will be filled in with +the specified values, and the rest of the placeholders will be +filled in with the values from your log statement's array. + +=head1 MISC PARAMETERS + + +=over 4 + +=item usePreparedStmt + +See above. + +=item warp_message + +see Log::Log4perl::Appender + +=item max_col_size + +If you're used to just throwing debugging messages like huge stacktraces +into your logger, some databases (Sybase's DBD!!) may surprise you +by choking on data size limitations. Normally, the data would +just be truncated to fit in the column, but Sybases's DBD it turns out +maxes out at 255 characters. Use this parameter in such a situation +to truncate long messages before they get to the INSERT statement. + +=back + +=head1 CHANGING DBH CONNECTIONS (POOLING) + +If you want to get your dbh from some place in particular, like +maybe a pool, subclass and override _init() and/or create_statement(), +for instance + + sub _init { + ; #no-op, no pooling at this level + } + sub create_statement { + my ($self, $stmt) = @_; + + $stmt || croak "Log4perl: sql not set in ".__PACKAGE__; + + return My::Connections->getConnection->prepare($stmt) + || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt"; + } + + +=head1 LIFE OF CONNECTIONS + +If you're using C<log4j.appender.DBAppndr.usePreparedStmt> +this module creates an sth when it starts and keeps it for the life +of the program. For long-running processes (e.g. mod_perl), connections +might go stale, but if C<Log::Log4perl::Appender::DBI> tries to write +a message and figures out that the DB connection is no longer working +(using DBI's ping method), it will reconnect. + +The reconnection process can be controlled by two parameters, +C<reconnect_attempts> and C<reconnect_sleep>. C<reconnect_attempts> +specifies the number of reconnections attempts the DBI appender +performs until it gives up and dies. C<reconnect_sleep> is the +time between reconnection attempts, measured in seconds. +C<reconnect_attempts> defaults to 1, C<reconnect_sleep> to 0. + +Alternatively, use C<Apache::DBI> or C<Apache::DBI::Cache> and read +CHANGING DB CONNECTIONS above. + +Note that C<Log::Log4perl::Appender::DBI> holds one connection open +for every appender, which might be too many. + +=head1 SEE ALSO + +L<Log::Dispatch::DBI> + +L<Log::Log4perl::JavaMap::JDBCAppender> + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/File.pm b/lib/Log/Log4perl/Appender/File.pm new file mode 100755 index 0000000..484f416 --- /dev/null +++ b/lib/Log/Log4perl/Appender/File.pm @@ -0,0 +1,545 @@ +################################################## +package Log::Log4perl::Appender::File; +################################################## + +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; +use Log::Log4perl::Config::Watch; +use Fcntl; +use File::Path; +use File::Spec::Functions qw(splitpath); +use constant _INTERNAL_DEBUG => 0; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + umask => undef, + owner => undef, + group => undef, + autoflush => 1, + syswrite => 0, + mode => "append", + binmode => undef, + utf8 => undef, + recreate => 0, + recreate_check_interval => 30, + recreate_check_signal => undef, + recreate_pid_write => undef, + create_at_logtime => 0, + header_text => undef, + mkpath => 0, + mkpath_umask => 0, + @options, + }; + + if($self->{create_at_logtime}) { + $self->{recreate} = 1; + } + for my $param ('umask', 'mkpath_umask') { + if(defined $self->{$param} and $self->{$param} =~ /^0/) { + # umask value is a string, meant to be an oct value + $self->{$param} = oct($self->{$param}); + } + } + + die "Mandatory parameter 'filename' missing" unless + exists $self->{filename}; + + bless $self, $class; + + if($self->{recreate_pid_write}) { + print "Creating pid file", + " $self->{recreate_pid_write}\n" if _INTERNAL_DEBUG; + open FILE, ">$self->{recreate_pid_write}" or + die "Cannot open $self->{recreate_pid_write}"; + print FILE "$$\n"; + close FILE; + } + + # This will die() if it fails + $self->file_open() unless $self->{create_at_logtime}; + + return $self; +} + +################################################## +sub filename { +################################################## + my($self) = @_; + + return $self->{filename}; +} + +################################################## +sub file_open { +################################################## + my($self) = @_; + + my $arrows = ">"; + my $sysmode = (O_CREAT|O_WRONLY); + + + if($self->{mode} eq "append") { + $arrows = ">>"; + $sysmode |= O_APPEND; + } elsif ($self->{mode} eq "pipe") { + $arrows = "|"; + } else { + $sysmode |= O_TRUNC; + } + + my $fh = do { local *FH; *FH; }; + + + my $didnt_exist = ! -e $self->{filename}; + if($didnt_exist && $self->{mkpath}) { + my ($volume, $path, $file) = splitpath($self->{filename}); + if($path ne '' && !-e $path) { + my $old_umask = umask($self->{mkpath_umask}) if defined $self->{mkpath_umask}; + my $options = {}; + foreach my $param (qw(owner group) ) { + $options->{$param} = $self->{$param} if defined $self->{$param}; + } + eval { + mkpath($path,$options); + }; + umask($old_umask) if defined $old_umask; + die "Can't create path ${path} ($!)" if $@; + } + } + + my $old_umask = umask($self->{umask}) if defined $self->{umask}; + + eval { + if($self->{syswrite}) { + sysopen $fh, "$self->{filename}", $sysmode or + die "Can't sysopen $self->{filename} ($!)"; + } else { + open $fh, "$arrows$self->{filename}" or + die "Can't open $self->{filename} ($!)"; + } + }; + umask($old_umask) if defined $old_umask; + die $@ if $@; + + if($didnt_exist and + ( defined $self->{owner} or defined $self->{group} ) + ) { + + eval { $self->perms_fix() }; + + if($@) { + # Cleanup and re-throw + unlink $self->{filename}; + die $@; + } + } + + if($self->{recreate}) { + $self->{watcher} = Log::Log4perl::Config::Watch->new( + file => $self->{filename}, + (defined $self->{recreate_check_interval} ? + (check_interval => $self->{recreate_check_interval}) : ()), + (defined $self->{recreate_check_signal} ? + (signal => $self->{recreate_check_signal}) : ()), + ); + } + + $self->{fh} = $fh; + + if ($self->{autoflush} and ! $self->{syswrite}) { + my $oldfh = select $self->{fh}; + $| = 1; + select $oldfh; + } + + if (defined $self->{binmode}) { + binmode $self->{fh}, $self->{binmode}; + } + + if (defined $self->{utf8}) { + binmode $self->{fh}, ":utf8"; + } + + if(defined $self->{header_text}) { + if( $self->{header_text} !~ /\n\Z/ ) { + $self->{header_text} .= "\n"; + } + my $fh = $self->{fh}; + print $fh $self->{header_text}; + } +} + +################################################## +sub file_close { +################################################## + my($self) = @_; + + if(defined $self->{fh}) { + $self->close_with_care( $self->{ fh } ); + } + + undef $self->{fh}; +} + +################################################## +sub perms_fix { +################################################## + my($self) = @_; + + my ($uid_org, $gid_org) = (stat $self->{filename})[4,5]; + + my ($uid, $gid) = ($uid_org, $gid_org); + + if(!defined $uid) { + die "stat of $self->{filename} failed ($!)"; + } + + my $needs_fixing = 0; + + if(defined $self->{owner}) { + $uid = $self->{owner}; + if($self->{owner} !~ /^\d+$/) { + $uid = (getpwnam($self->{owner}))[2]; + die "Unknown user: $self->{owner}" unless defined $uid; + } + } + + if(defined $self->{group}) { + $gid = $self->{group}; + if($self->{group} !~ /^\d+$/) { + $gid = getgrnam($self->{group}); + + die "Unknown group: $self->{group}" unless defined $gid; + } + } + if($uid != $uid_org or $gid != $gid_org) { + chown($uid, $gid, $self->{filename}) or + die "chown('$uid', '$gid') on '$self->{filename}' failed: $!"; + } +} + +################################################## +sub file_switch { +################################################## + my($self, $new_filename) = @_; + + print "Switching file from $self->{filename} to $new_filename\n" if + _INTERNAL_DEBUG; + + $self->file_close(); + $self->{filename} = $new_filename; + $self->file_open(); +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + if($self->{recreate}) { + if($self->{recreate_check_signal}) { + if(!$self->{watcher} or + $self->{watcher}->{signal_caught}) { + $self->file_switch($self->{filename}); + $self->{watcher}->{signal_caught} = 0; + } + } else { + if(!$self->{watcher} or + $self->{watcher}->file_has_moved()) { + $self->file_switch($self->{filename}); + } + } + } + + my $fh = $self->{fh}; + + if($self->{syswrite}) { + defined (syswrite $fh, $params{message}) or + die "Cannot syswrite to '$self->{filename}': $!"; + } else { + print $fh $params{message} or + die "Cannot write to '$self->{filename}': $!"; + } +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + if ($self->{fh}) { + my $fh = $self->{fh}; + $self->close_with_care( $fh ); + } +} + +########################################### +sub close_with_care { +########################################### + my( $self, $fh ) = @_; + + my $prev_rc = $?; + + my $rc = close $fh; + + # [rt #84723] If a sig handler is reaping the child generated + # by close() internally before close() gets to it, it'll + # result in a weird (but benign) error that we don't want to + # expose to the user. + if( !$rc ) { + if( $self->{ mode } eq "pipe" and + $!{ ECHILD } ) { + if( $Log::Log4perl::CHATTY_DESTROY_METHODS ) { + warn "$$: pipe closed with ECHILD error -- guess that's ok"; + } + $? = $prev_rc; + } else { + warn "Can't close $self->{filename} ($!)"; + } + } + + return $rc; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::File - Log to file + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::File; + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + autoflush => 1, + umask => 0222, + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to a file. + +The C<log()> method takes a single scalar. If a newline character +should terminate the message, it has to be added explicitly. + +Upon destruction of the object, the filehandle to access the +file is flushed and closed. + +If you want to switch over to a different logfile, use the +C<file_switch($newfile)> method which will first close the old +file handle and then open a one to the new file specified. + +=head2 OPTIONS + +=over 4 + +=item filename + +Name of the log file. + +=item mode + +Messages will be append to the file if C<$mode> is set to the +string C<"append">. Will clobber the file +if set to C<"clobber">. If it is C<"pipe">, the file will be understood +as executable to pipe output to. Default mode is C<"append">. + +=item autoflush + +C<autoflush>, if set to a true value, triggers flushing the data +out to the file on every call to C<log()>. C<autoflush> is on by default. + +=item syswrite + +C<syswrite>, if set to a true value, makes sure that the appender uses +syswrite() instead of print() to log the message. C<syswrite()> usually +maps to the operating system's C<write()> function and makes sure that +no other process writes to the same log file while C<write()> is busy. +Might safe you from having to use other synchronisation measures like +semaphores (see: Synchronized appender). + +=item umask + +Specifies the C<umask> to use when creating the file, determining +the file's permission settings. +If set to C<0022> (default), new +files will be created with C<rw-r--r--> permissions. +If set to C<0000>, new files will be created with C<rw-rw-rw-> permissions. + +=item owner + +If set, specifies that the owner of the newly created log file should +be different from the effective user id of the running process. +Only makes sense if the process is running as root. +Both numerical user ids and user names are acceptable. +Log4perl does not attempt to change the ownership of I<existing> files. + +=item group + +If set, specifies that the group of the newly created log file should +be different from the effective group id of the running process. +Only makes sense if the process is running as root. +Both numerical group ids and group names are acceptable. +Log4perl does not attempt to change the group membership of I<existing> files. + +=item utf8 + +If you're printing out Unicode strings, the output filehandle needs +to be set into C<:utf8> mode: + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + utf8 => 1, + ); + +=item binmode + +To manipulate the output filehandle via C<binmode()>, use the +binmode parameter: + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + binmode => ":utf8", + ); + +A setting of ":utf8" for C<binmode> is equivalent to specifying +the C<utf8> option (see above). + +=item recreate + +Normally, if a file appender logs to a file and the file gets moved to +a different location (e.g. via C<mv>), the appender's open file handle +will automatically follow the file to the new location. + +This may be undesirable. When using an external logfile rotator, +for example, the appender should create a new file under the old name +and start logging into it. If the C<recreate> option is set to a true value, +C<Log::Log4perl::Appender::File> will do exactly that. It defaults to +false. Check the C<recreate_check_interval> option for performance +optimizations with this feature. + +=item recreate_check_interval + +In C<recreate> mode, the appender has to continuously check if the +file it is logging to is still in the same location. This check is +fairly expensive, since it has to call C<stat> on the file name and +figure out if its inode has changed. Doing this with every call +to C<log> can be prohibitively expensive. Setting it to a positive +integer value N will only check the file every N seconds. It defaults to 30. + +This obviously means that the appender will continue writing to +a moved file until the next check occurs, in the worst case +this will happen C<recreate_check_interval> seconds after the file +has been moved or deleted. If this is undesirable, +setting C<recreate_check_interval> to 0 will have the +appender check the file with I<every> call to C<log()>. + +=item recreate_check_signal + +In C<recreate> mode, if this option is set to a signal name +(e.g. "USR1"), the appender will recreate a missing logfile +when it receives the signal. It uses less resources than constant +polling. The usual limitation with perl's signal handling apply. +Check the FAQ for using this option with the log rotating +utility C<newsyslog>. + +=item recreate_pid_write + +The popular log rotating utility C<newsyslog> expects a pid file +in order to send the application a signal when its logs have +been rotated. This option expects a path to a file where the pid +of the currently running application gets written to. +Check the FAQ for using this option with the log rotating +utility C<newsyslog>. + +=item create_at_logtime + +The file appender typically creates its logfile in its constructor, i.e. +at Log4perl C<init()> time. This is desirable for most use cases, because +it makes sure that file permission problems get detected right away, and +not after days/weeks/months of operation when the appender suddenly needs +to log something and fails because of a problem that was obvious at +startup. + +However, there are rare use cases where the file shouldn't be created +at Log4perl C<init()> time, e.g. if the appender can't be used by the current +user although it is defined in the configuration file. If you set +C<create_at_logtime> to a true value, the file appender will try to create +the file at log time. Note that this setting lets permission problems +sit undetected until log time, which might be undesirable. + +=item header_text + +If you want Log4perl to print a header into every newly opened +(or re-opened) logfile, set C<header_text> to either a string +or a subroutine returning a string. If the message doesn't have a newline, +a newline at the end of the header will be provided. + +=item mkpath + +If this this option is set to true, +the directory path will be created if it does not exist yet. + +=item mkpath_umask + +Specifies the C<umask> to use when creating the directory, determining +the directory's permission settings. +If set to C<0022> (default), new +directory will be created with C<rwxr-xr-x> permissions. +If set to C<0000>, new directory will be created with C<rwxrwxrwx> permissions. + +=back + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C<Log::Dispatch> appender framework. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/Limit.pm b/lib/Log/Log4perl/Appender/Limit.pm new file mode 100644 index 0000000..8c55907 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Limit.pm @@ -0,0 +1,340 @@ +###################################################################### +# Limit.pm -- 2003, Mike Schilli <m@perlmeister.com> +###################################################################### +# Special composite appender limiting the number of messages relayed +# to its appender(s). +###################################################################### + +########################################### +package Log::Log4perl::Appender::Limit; +########################################### + +use strict; +use warnings; +use Storable; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.7 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + max_until_flushed => undef, + max_until_discarded => undef, + appender_method_on_flush + => undef, + appender => undef, + accumulate => 1, + persistent => undef, + block_period => 3600, + buffer => [], + %options, + }; + + # Pass back the appender to be limited as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appenders we're connecting to really exist. + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; + + if(defined $self->{persistent}) { + $self->restore(); + } + + return $self; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + + # Check if message needs to be discarded + my $discard = 0; + if(defined $self->{max_until_discarded} and + scalar @{$self->{buffer}} >= $self->{max_until_discarded} - 1) { + $discard = 1; + } + + # Check if we need to flush + my $flush = 0; + if(defined $self->{max_until_flushed} and + scalar @{$self->{buffer}} >= $self->{max_until_flushed} - 1) { + $flush = 1; + } + + if(!$flush and + (exists $self->{sent_last} and + $self->{sent_last} + $self->{block_period} > time() + ) + ) { + # Message needs to be blocked for now. + return if $discard; + + # Ask the appender to save a cached message in $cache + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}, \my $cache); + + # Save message and other parameters + push @{$self->{buffer}}, $cache if $self->{accumulate}; + + $self->save() if $self->{persistent}; + + return; + } + + # Relay all messages we got to the SUPER class, which needs to render the + # messages according to the appender's layout, first. + + # Log pending messages if we have any + $self->flush(); + + # Log current message as well + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}); + + $self->{sent_last} = time(); + + # We need to store the timestamp persistently, if requested + $self->save() if $self->{persistent}; +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +########################################### +sub save { +########################################### + my($self) = @_; + + my $pdata = [$self->{buffer}, $self->{sent_last}]; + + # Save the buffer if we're in persistent mode + store $pdata, $self->{persistent} or + die "Cannot save messages in $self->{persistent} ($!)"; +} + +########################################### +sub restore { +########################################### + my($self) = @_; + + if(-f $self->{persistent}) { + my $pdata = retrieve $self->{persistent} or + die "Cannot retrieve messages from $self->{persistent} ($!)"; + ($self->{buffer}, $self->{sent_last}) = @$pdata; + } +} + +########################################### +sub flush { +########################################### + my($self) = @_; + + # Log pending messages if we have any + for(@{$self->{buffer}}) { + $self->{app}->SUPER::log_cached($_); + } + + # call flush() on the attached appender if so desired. + if( $self->{appender_method_on_flush} ) { + no strict 'refs'; + my $method = $self->{appender_method_on_flush}; + $self->{app}->$method(); + } + + # Empty buffer + $self->{buffer} = []; +} + +########################################### +sub DESTROY { +########################################### + my($self) = @_; + +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Limit - Limit message delivery via block period + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Mailer = Log::Dispatch::Email::MailSend + log4perl.appender.Mailer.to = drone\@pageme.com + log4perl.appender.Mailer.subject = Something's broken! + log4perl.appender.Mailer.buffered = 0 + log4perl.appender.Mailer.layout = PatternLayout + log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Mailer + log4perl.appender.Limiter.block_period = 3600 + ); + + Log::Log4perl->init(\$conf); + WARN("This message will be sent immediately."); + WARN("This message will be delayed by one hour."); + sleep(3601); + WARN("This message plus the last one will be sent now, seperately."); + +=head1 DESCRIPTION + +=over 4 + +=item C<appender> + +Specifies the name of the appender used by the limiter. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Limit>. + +=item C<block_period> + +Period in seconds between delivery of messages. If messages arrive in between, +they will be either saved (if C<accumulate> is set to a true value) or +discarded (if C<accumulate> isn't set). + +=item C<persistent> + +File name in which C<Log::Log4perl::Appender::Limit> persistently stores +delivery times. If omitted, the appender will have no recollection of what +happened when the program restarts. + +=item C<max_until_flushed> + +Maximum number of accumulated messages. If exceeded, the appender flushes +all messages, regardless if the interval set in C<block_period> +has passed or not. Don't mix with C<max_until_discarded>. + +=item C<max_until_discarded> + +Maximum number of accumulated messages. If exceeded, the appender will +simply discard additional messages, waiting for C<block_period> to expire +to flush all accumulated messages. Don't mix with C<max_until_flushed>. + +=item C<appender_method_on_flush> + +Optional method name to be called on the appender attached to the +limiter when messages are flushed. For example, to have the sample code +in the SYNOPSIS section bundle buffered emails into one, change the +mailer's C<buffered> parameter to C<1> and set the limiters +C<appender_method_on_flush> value to the string C<"flush">: + + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Mailer = Log::Dispatch::Email::MailSend + log4perl.appender.Mailer.to = drone\@pageme.com + log4perl.appender.Mailer.subject = Something's broken! + log4perl.appender.Mailer.buffered = 1 + log4perl.appender.Mailer.layout = PatternLayout + log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Mailer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.appender_method_on_flush = flush + +This will cause the mailer to buffer messages and wait for C<flush()> +to send out the whole batch. The limiter will then call the appender's +C<flush()> method when it's own buffer gets flushed out. + +=back + +If the appender attached to C<Limit> uses C<PatternLayout> with a timestamp +specifier, you will notice that the message timestamps are reflecting the +original log event, not the time of the message rendering in the +attached appender. Major trickery has been applied to accomplish +this (Cough!). + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Limit> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/RRDs.pm b/lib/Log/Log4perl/Appender/RRDs.pm new file mode 100755 index 0000000..62fa793 --- /dev/null +++ b/lib/Log/Log4perl/Appender/RRDs.pm @@ -0,0 +1,134 @@ +################################################## +package Log::Log4perl::Appender::RRDs; +################################################## +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; +use RRDs; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + dbname => undef, + rrdupd_params => [], + @options, + }; + + die "Mandatory parameter 'dbname' missing" unless + defined $self->{dbname}; + + bless $self, $class; + + return $self; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + #print "UPDATE: '$self->{dbname}' - '$params{message}'\n"; + + RRDs::update($self->{dbname}, + @{$params{rrdupd_params}}, + $params{message}) or + die "Cannot update rrd $self->{dbname} ", + "with $params{message} ($!)"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::RRDs - Log to a RRDtool Archive + +=head1 SYNOPSIS + + use Log::Log4perl qw(get_logger); + use RRDs; + + my $DB = "myrrddb.dat"; + + RRDs::create( + $DB, "--step=1", + "DS:myvalue:GAUGE:2:U:U", + "RRA:MAX:0.5:1:120"); + + print time(), "\n"; + + Log::Log4perl->init(\qq{ + log4perl.category = INFO, RRDapp + log4perl.appender.RRDapp = Log::Log4perl::Appender::RRDs + log4perl.appender.RRDapp.dbname = $DB + log4perl.appender.RRDapp.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.RRDapp.layout.ConversionPattern = N:%m + }); + + my $logger = get_logger(); + + for(10, 15, 20, 25) { + $logger->info($_); + sleep 1; + } + +=head1 DESCRIPTION + +C<Log::Log4perl::Appender::RRDs> appenders facilitate writing data +to RRDtool round-robin archives via Log4perl. For documentation +on RRD and its Perl interface C<RRDs> (which comes with the distribution), +check out L<http://rrdtool.org>. + +Messages sent to Log4perl's RRDs appender are expected to be numerical values +(ints or floats), which then are used to run a C<rrdtool update> command +on an existing round-robin database. The name of this database needs to +be set in the appender's C<dbname> configuration parameter. + +If there's more parameters you wish to pass to the C<update> method, +use the C<rrdupd_params> configuration parameter: + + log4perl.appender.RRDapp.rrdupd_params = --template=in:out + +To read out the round robin database later on, use C<rrdtool fetch> +or C<rrdtool graph> for graphic displays. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/Screen.pm b/lib/Log/Log4perl/Appender/Screen.pm new file mode 100755 index 0000000..6581baf --- /dev/null +++ b/lib/Log/Log4perl/Appender/Screen.pm @@ -0,0 +1,124 @@ +################################################## +package Log::Log4perl::Appender::Screen; +################################################## + +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + stderr => 1, + utf8 => undef, + @options, + }; + + if( $self->{utf8} ) { + if( $self->{stderr} ) { + binmode STDERR, ":utf8"; + } else { + binmode STDOUT, ":utf8"; + } + } + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + if($self->{stderr}) { + print STDERR $params{message}; + } else { + print $params{message}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::Screen - Log to STDOUT/STDERR + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::Screen; + + my $app = Log::Log4perl::Appender::Screen->new( + stderr => 0, + utf8 => 1, + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to STDOUT or STDERR. + +The constructor C<new()> take an optional parameter C<stderr>, +if set to a true value, the appender will log to STDERR. +The default setting for C<stderr> is 1, so messages will be logged to +STDERR by default. + +If C<stderr> +is set to a false value, it will log to STDOUT (or, more accurately, +whichever file handle is selected via C<select()>, STDOUT by default). + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C<Log::Dispatch> appender framework. + +To enable printing wide utf8 characters, set the utf8 option to a true +value: + + my $app = Log::Log4perl::Appender::Screen->new( + stderr => 1, + utf8 => 1, + ); + +This will issue the necessary binmode command to the selected output +channel (stderr/stdout). + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm b/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm new file mode 100644 index 0000000..0abad3f --- /dev/null +++ b/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm @@ -0,0 +1,235 @@ +################################################## +package Log::Log4perl::Appender::ScreenColoredLevels; +################################################## +use Log::Log4perl::Appender::Screen; +our @ISA = qw(Log::Log4perl::Appender::Screen); + +use warnings; +use strict; + +use Term::ANSIColor qw(); +use Log::Log4perl::Level; + +BEGIN { + $Term::ANSIColor::EACHLINE="\n"; +} + +################################################## +sub new { +################################################## + my($class, %options) = @_; + + my %specific_options = ( color => {} ); + + for my $option ( keys %specific_options ) { + $specific_options{ $option } = delete $options{ $option } if + exists $options{ $option }; + } + + my $self = $class->SUPER::new( %options ); + @$self{ keys %specific_options } = values %specific_options; + bless $self, __PACKAGE__; # rebless + + # also accept lower/mixed case levels in config + for my $level ( keys %{ $self->{color} } ) { + my $uclevel = uc($level); + $self->{color}->{$uclevel} = $self->{color}->{$level}; + } + + my %default_colors = ( + TRACE => 'yellow', + DEBUG => '', + INFO => 'green', + WARN => 'blue', + ERROR => 'magenta', + FATAL => 'red', + ); + for my $level ( keys %default_colors ) { + if ( ! exists $self->{ 'color' }->{ $level } ) { + $self->{ 'color' }->{ $level } = $default_colors{ $level }; + } + } + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + my $msg = $params{ 'message' }; + + if ( my $color = $self->{ 'color' }->{ $params{ 'log4p_level' } } ) { + $msg = Term::ANSIColor::colored( $msg, $color ); + } + + if($self->{stderr}) { + print STDERR $msg; + } else { + print $msg; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::ScreenColoredLevel - Colorize messages according to level + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\ <<'EOT'); + log4perl.category = DEBUG, Screen + log4perl.appender.Screen = \ + Log::Log4perl::Appender::ScreenColoredLevels + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = \ + %d %F{1} %L> %m %n + EOT + + # Appears black + DEBUG "Debug Message"; + + # Appears green + INFO "Info Message"; + + # Appears blue + WARN "Warn Message"; + + # Appears magenta + ERROR "Error Message"; + + # Appears red + FATAL "Fatal Message"; + +=head1 DESCRIPTION + +This appender acts like Log::Log4perl::Appender::Screen, except that +it colorizes its output, based on the priority of the message sent. + +You can configure the colors and attributes used for the different +levels, by specifying them in your configuration: + + log4perl.appender.Screen.color.TRACE=cyan + log4perl.appender.Screen.color.DEBUG=bold blue + +You can also specify nothing, to indicate that level should not have +coloring applied, which means the text will be whatever the default +color for your terminal is. This is the default for debug messages. + + log4perl.appender.Screen.color.DEBUG= + +You can use any attribute supported by L<Term::ANSIColor> as a configuration +option. + + log4perl.appender.Screen.color.FATAL=\ + bold underline blink red on_white + +The commonly used colors and attributes are: + +=over 4 + +=item attributes + +BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK + +=item colors + +BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE + +=item background colors + +ON_BLACK, ON_RED, ON_GREEN, ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, ON_WHITE + +=back + +See L<Term::ANSIColor> for a complete list, and information on which are +supported by various common terminal emulators. + +The default values for these options are: + +=over 4 + +=item Trace + +Yellow + +=item Debug + +None (whatever the terminal default is) + +=item Info + +Green + +=item Warn + +Blue + +=item Error + +Magenta + +=item Fatal + +Red + +=back + +The constructor C<new()> takes an optional parameter C<stderr>, +if set to a true value, the appender will log to STDERR. If C<stderr> +is set to a false value, it will log to STDOUT. The default setting +for C<stderr> is 1, so messages will be logged to STDERR by default. +The constructor can also take an optional parameter C<color>, whose +value is a hashref of color configuration options, any levels that +are not included in the hashref will be set to their default values. + +=head2 Using ScreenColoredLevels on Windows + +Note that if you're using this appender on Windows, you need to fetch +Win32::Console::ANSI from CPAN and add + + use Win32::Console::ANSI; + +to your script. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/Socket.pm b/lib/Log/Log4perl/Appender/Socket.pm new file mode 100755 index 0000000..2941ef8 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Socket.pm @@ -0,0 +1,226 @@ +################################################## +package Log::Log4perl::Appender::Socket; +################################################## +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; + +use IO::Socket::INET; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + silent_recovery => 0, + no_warning => 0, + PeerAddr => "localhost", + Proto => 'tcp', + Timeout => 5, + @options, + }; + + bless $self, $class; + + unless ($self->{defer_connection}){ + unless($self->connect(@options)) { + if($self->{silent_recovery}) { + if( ! $self->{no_warning}) { + warn "Connect to $self->{PeerAddr}:$self->{PeerPort} failed: $!"; + } + return $self; + } + die "Connect to $self->{PeerAddr}:$self->{PeerPort} failed: $!"; + } + + $self->{socket}->autoflush(1); + #autoflush has been the default behavior since 1997 + } + + return $self; +} + +################################################## +sub connect { +################################################## + my($self, @options) = @_; + + $self->{socket} = IO::Socket::INET->new(@options); + + return $self->{socket}; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + + { + # If we were never able to establish + # a connection, try to establish one + # here. If it fails, return. + if(($self->{silent_recovery} or $self->{defer_connection}) and + !defined $self->{socket}) { + if(! $self->connect(%$self)) { + return undef; + } + } + + # Try to send the message across + eval { $self->{socket}->send($params{message}); + }; + + if($@) { + warn "Send to " . ref($self) . " failed ($@), retrying once..."; + if($self->connect(%$self)) { + redo; + } + if($self->{silent_recovery}) { + return undef; + } + warn "Reconnect to $self->{PeerAddr}:$self->{PeerPort} " . + "failed: $!"; + return undef; + } + }; + + return 1; +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + undef $self->{socket}; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::Socket - Log to a socket + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::Socket; + + my $appender = Log::Log4perl::Appender::Socket->new( + PeerAddr => "server.foo.com", + PeerPort => 1234, + ); + + $appender->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to a socket. It relies on +L<IO::Socket::INET> and offers all parameters this module offers. + +Upon destruction of the object, pending messages will be flushed +and the socket will be closed. + +If the appender cannot contact the server during the initialization +phase (while running the constructor C<new>), it will C<die()>. + +If the appender fails to log a message because the socket's C<send()> +method fails (most likely because the server went down), it will +try to reconnect once. If it succeeds, the message will be sent. +If the reconnect fails, a warning is sent to STDERR and the C<log()> +method returns, discarding the message. + +If the option C<silent_recovery> is given to the constructor and +set to a true value, the behaviour is different: If the socket connection +can't be established at initialization time, a single warning is issued. +Every log attempt will then try to establish the connection and +discard the message silently if it fails. +If you don't even want the warning, set the C<no_warning> option to +a true value. + +Connecting at initialization time may not be the best option when +running under Apache1 Apache2/prefork, because the parent process creates +the socket and the connections are shared among the forked children--all +the children writing to the same socket could intermingle messages. So instead +of that, you can use C<defer_connection> which will put off making the +connection until the first log message is sent. + +=head1 EXAMPLE + +Write a server quickly using the IO::Socket::INET module: + + use IO::Socket::INET; + + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + Proto => 'tcp'); + + while(my $client = $sock->accept()) { + print "Client connected\n"; + while(<$client>) { + print "$_\n"; + } + } + +Start it and then run the following script as a client: + + use Log::Log4perl qw(:easy); + + my $conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout + }; + + Log::Log4perl->init(\$conf); + + sleep(2); + + for(1..10) { + ERROR("Quack!"); + sleep(5); + } + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/String.pm b/lib/Log/Log4perl/Appender/String.pm new file mode 100644 index 0000000..9e1bff7 --- /dev/null +++ b/lib/Log/Log4perl/Appender/String.pm @@ -0,0 +1,110 @@ +package Log::Log4perl::Appender::String; +our @ISA = qw(Log::Log4perl::Appender); + +################################################## +# Log dispatcher writing to a string buffer +################################################## + +################################################## +sub new { +################################################## + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = { + name => "unknown name", + string => "", + %params, + }; + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + $self->{string} .= $params{message}; +} + +################################################## +sub string { +################################################## + my($self, $new) = @_; + + if(defined $new) { + $self->{string} = $new; + } + + return $self->{string}; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::String - Append to a string + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::String; + + my $appender = Log::Log4perl::Appender::String->new( + name => 'my string appender', + ); + + # Append to the string + $appender->log( + message => "I'm searching the city for sci-fi wasabi\n" + ); + + # Retrieve the result + my $result = $appender->string(); + + # Reset the buffer to the empty string + $appender->string(""); + +=head1 DESCRIPTION + +This is a simple appender used internally by C<Log::Log4perl>. It +appends messages to a scalar instance variable. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/Synchronized.pm b/lib/Log/Log4perl/Appender/Synchronized.pm new file mode 100644 index 0000000..a36ed31 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Synchronized.pm @@ -0,0 +1,292 @@ +###################################################################### +# Synchronized.pm -- 2003, 2007 Mike Schilli <m@perlmeister.com> +###################################################################### +# Special appender employing a locking strategy to synchronize +# access. +###################################################################### + +########################################### +package Log::Log4perl::Appender::Synchronized; +########################################### + +use strict; +use warnings; +use Log::Log4perl::Util::Semaphore; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.12 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + appender=> undef, + key => '_l4p', + level => 0, + %options, + }; + + my @values = (); + for my $param (qw(uid gid mode destroy key)) { + push @values, $param, $self->{$param} if defined $self->{$param}; + } + + $self->{sem} = Log::Log4perl::Util::Semaphore->new( + @values + ); + + # Pass back the appender to be synchronized as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appender we're synchronizing really exists + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + $self->{sem}->semlock(); + + # Relay that to the SUPER class which needs to render the + # message according to the appender's layout, first. + $Log::Log4perl::caller_depth +=2; + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}); + $Log::Log4perl::caller_depth -=2; + + $self->{sem}->semunlock(); +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Synchronized - Synchronizing other appenders + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = WARN, Syncer + + # File appender (unsynchronized) + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.autoflush = 1 + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.mode = truncate + log4perl.appender.Logfile.layout = SimpleLayout + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer.appender = Logfile +); + + Log::Log4perl->init(\$conf); + WARN("This message is guaranteed to be complete."); + +=head1 DESCRIPTION + +If multiple processes are using the same C<Log::Log4perl> appender +without synchronization, overwrites might happen. A typical scenario +for this would be a process spawning children, each of which inherits +the parent's Log::Log4perl configuration. + +In most cases, you won't need an external synchronisation tool like +Log::Log4perl::Appender::Synchronized at all. Log4perl's file appender, +Log::Log4perl::Appender::File, for example, provides the C<syswrite> +mechanism for making sure that even long log lines won't interleave. +Short log lines won't interleave anyway, because the operating system +makes sure the line gets written before a task switch occurs. + +In cases where you need additional synchronization, however, you can use +C<Log::Log4perl::Appender::Synchronized> as a gateway between your +loggers and your appenders. An appender itself, +C<Log::Log4perl::Appender::Synchronized> just takes two additional +arguments: + +=over 4 + +=item C<appender> + +Specifies the name of the appender it synchronizes access to. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Synchronized>. + +=item C<key> + +This optional argument specifies the key for the semaphore that +C<Log::Log4perl::Appender::Synchronized> uses internally to ensure +atomic operations. It defaults to C<_l4p>. If you define more than +one C<Log::Log4perl::Appender::Synchronized> appender, it is +important to specify different keys for them, as otherwise every +new C<Log::Log4perl::Appender::Synchronized> appender will nuke +previously defined semaphores. The maximum key length is four +characters, longer keys will be truncated to 4 characters -- +C<mylongkey1> and C<mylongkey2> are interpreted to be the same: +C<mylo> (thanks to David Viner E<lt>dviner@yahoo-inc.comE<gt> for +pointing this out). + +=back + +C<Log::Log4perl::Appender::Synchronized> uses Log::Log4perl::Util::Semaphore +internally to perform locking with semaphores provided by the +operating system used. + +=head2 Performance tips + +The C<Log::Log4perl::Appender::Synchronized> serializes access to a +protected resource globally, slowing down actions otherwise performed in +parallel. + +Unless specified otherwise, all instances of +C<Log::Log4perl::Appender::Synchronized> objects in the system will +use the same global IPC key C<_l4p>. + +To control access to different appender instances, it often makes sense +to define different keys for different synchronizing appenders. In this +way, Log::Log4perl serializes access to each appender instance separately: + + log4perl.category = WARN, Syncer1, Syncer2 + + # File appender 1 (unsynchronized) + log4perl.appender.Logfile1 = Log::Log4perl::Appender::File + log4perl.appender.Logfile1.filename = test1.log + log4perl.appender.Logfile1.layout = SimpleLayout + + # File appender 2 (unsynchronized) + log4perl.appender.Logfile2 = Log::Log4perl::Appender::File + log4perl.appender.Logfile2.filename = test2.log + log4perl.appender.Logfile2.layout = SimpleLayout + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer1 = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer1.appender = Logfile1 + log4perl.appender.Syncer1.key = l4p1 + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer2 = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer2.appender = Logfile2 + log4perl.appender.Syncer2.key = l4p2 + +Without the C<.key = l4p1> and C<.key = l4p2> lines, both Synchronized +appenders would be using the default C<_l4p> key, causing unnecessary +serialization of output written to different files. + +=head2 Advanced configuration + +To configure the underlying Log::Log4perl::Util::Semaphore module in +a different way than with the default settings provided by +Log::Log4perl::Appender::Synchronized, use the following parameters: + + log4perl.appender.Syncer1.destroy = 1 + log4perl.appender.Syncer1.mode = sub { 0775 } + log4perl.appender.Syncer1.uid = hugo + log4perl.appender.Syncer1.gid = 100 + +Valid options are +C<destroy> (Remove the semaphore on exit), +C<mode> (permissions on the semaphore), +C<uid> (uid or user name the semaphore is owned by), +and +C<gid> (group id the semaphore is owned by), + +Note that C<mode> is usually given in octal and therefore needs to be +specified as a perl sub {}, unless you want to calculate what 0755 means +in decimal. + +Changing ownership or group settings for a semaphore will obviously only +work if the current user ID owns the semaphore already or if the current +user is C<root>. The C<destroy> option causes the current process to +destroy the semaphore on exit. Spawned children of the process won't +inherit this behavior. + +=head2 Semaphore user and group IDs with mod_perl + +Setting user and group IDs is especially important when the Synchronized +appender is used with mod_perl. If Log4perl gets initialized by a startup +handler, which runs as root, and not as the user who will later use +the semaphore, the settings for uid, gid, and mode can help establish +matching semaphore ownership and access rights. + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Synchronized> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/TestArrayBuffer.pm b/lib/Log/Log4perl/Appender/TestArrayBuffer.pm new file mode 100644 index 0000000..ce62e1c --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestArrayBuffer.pm @@ -0,0 +1,94 @@ +################################################## +package Log::Log4perl::Appender::TestArrayBuffer; +################################################## +# Like Log::Log4perl::Appender::TestBuffer, just with +# array capability. +# For testing only. +################################################## + +use base qw( Log::Log4perl::Appender::TestBuffer ); + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + $self->{buffer} .= "[$params{level}]: " if $LOG_PRIORITY; + + if(ref($params{message}) eq "ARRAY") { + $self->{buffer} .= "[" . join(',', @{$params{message}}) . "]"; + } else { + $self->{buffer} .= $params{message}; + } +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestArrayBuffer - Subclass of Appender::TestBuffer + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestArrayBuffer; + + my $appender = Log::Log4perl::Appender::TestArrayBuffer->new( + name => 'buffer', + ); + + # Append to the buffer + $appender->log( + level = > 'alert', + message => ['first', 'second', 'third'], + ); + + # Retrieve the result + my $result = $appender->buffer(); + + # Reset the buffer to the empty string + $appender->reset(); + +=head1 DESCRIPTION + +This class is a subclass of Log::Log4perl::Appender::TestBuffer and +just provides message array refs as an additional feature. + +Just like Log::Log4perl::Appender::TestBuffer, +Log::Log4perl::Appender::TestArrayBuffer is used for internal +Log::Log4perl testing only. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/TestBuffer.pm b/lib/Log/Log4perl/Appender/TestBuffer.pm new file mode 100644 index 0000000..a929a6e --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestBuffer.pm @@ -0,0 +1,189 @@ +package Log::Log4perl::Appender::TestBuffer; +our @ISA = qw(Log::Log4perl::Appender); + +################################################## +# Log dispatcher writing to a string buffer +# For testing. +# This is like having a Log::Log4perl::Appender::TestBuffer +################################################## + +our %POPULATION = (); +our $LOG_PRIORITY = 0; +our $DESTROY_MESSAGES = ""; + +################################################## +sub new { +################################################## + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = { + name => "unknown name", + %params, + }; + + bless $self, $class; + + $self->{stderr} = exists $params{stderr} ? $params{stderr} : 1; + $self->{buffer} = ""; + + $POPULATION{$self->{name}} = $self; + + return $self; +} + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + if( !defined $params{level} ) { + die "No level defined in log() call of " . __PACKAGE__; + } + $self->{buffer} .= "[$params{level}]: " if $LOG_PRIORITY; + $self->{buffer} .= $params{message}; +} + +########################################### +sub clear { +########################################### + my($self) = @_; + + $self->{buffer} = ""; +} + +################################################## +sub buffer { +################################################## + my($self, $new) = @_; + + if(defined $new) { + $self->{buffer} = $new; + } + + return $self->{buffer}; +} + +################################################## +sub reset { +################################################## + my($self) = @_; + + %POPULATION = (); + $self->{buffer} = ""; +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + $DESTROY_MESSAGES .= __PACKAGE__ . " destroyed"; + + #this delete() along with &reset() above was causing + #Attempt to free unreferenced scalar at + #blib/lib/Log/Log4perl/TestBuffer.pm line 69. + #delete $POPULATION{$self->name}; +} + +################################################## +sub by_name { +################################################## + my($self, $name) = @_; + + # Return a TestBuffer by appender name. This is useful if + # test buffers are created behind our back (e.g. via the + # Log4perl config file) and later on we want to + # retrieve an instance to query its content. + + die "No name given" unless defined $name; + + return $POPULATION{$name}; + +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestBuffer - Appender class for testing + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestBuffer; + + my $appender = Log::Log4perl::Appender::TestBuffer->new( + name => 'mybuffer', + ); + + # Append to the buffer + $appender->log( + level = > 'alert', + message => "I'm searching the city for sci-fi wasabi\n" + ); + + # Retrieve the result + my $result = $appender->buffer(); + + # Clear the buffer to the empty string + $appender->clear(); + +=head1 DESCRIPTION + +This class is used for internal testing of C<Log::Log4perl>. It +is a C<Log::Dispatch>-style appender, which writes to a buffer +in memory, from where actual results can be easily retrieved later +to compare with expected results. + +Every buffer created is stored in an internal global array, and can +later be referenced by name: + + my $app = Log::Log4perl::Appender::TestBuffer->by_name("mybuffer"); + +retrieves the appender object of a previously created buffer "mybuffer". +To reset this global array and have it forget all of the previously +created testbuffer appenders (external references to those appenders +nonwithstanding), use + + Log::Log4perl::Appender::TestBuffer->reset(); + +=head1 SEE ALSO + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + diff --git a/lib/Log/Log4perl/Appender/TestFileCreeper.pm b/lib/Log/Log4perl/Appender/TestFileCreeper.pm new file mode 100755 index 0000000..aadf099 --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestFileCreeper.pm @@ -0,0 +1,89 @@ +################################################## +package Log::Log4perl::Appender::TestFileCreeper; +################################################## +# Test appender, intentionally slow. It writes +# out one byte at a time to provoke sync errors. +# Don't use it, unless for testing. +################################################## + +use warnings; +use strict; + +use Log::Log4perl::Appender::File; + +our @ISA = qw(Log::Log4perl::Appender::File); + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + my $fh = $self->{fh}; + + for (split //, $params{message}) { + print $fh $_; + my $oldfh = select $self->{fh}; + $| = 1; + select $oldfh; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestFileCreeper - Intentionally slow test appender + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestFileCreeper; + + my $app = Log::Log4perl::Appender::TestFileCreeper->new( + filename => 'file.log', + mode => 'append', + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a test appender, and it is intentionally slow. It writes +out one byte at a time to provoke sync errors. Don't use it, unless +for testing. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + |