eaiovnaovbqoebvqoeavibavo PK jZqg** Catalyst.pmnu[package Log::Log4perl::Catalyst; use strict; use Log::Log4perl qw(:levels); use Log::Log4perl::Logger; our $VERSION = $Log::Log4perl::VERSION; our $CATALYST_APPENDER_SUFFIX = "catalyst_buffer"; our $LOG_LEVEL_ADJUSTMENT = 1; init(); ################################################## sub init { ################################################## my @levels = qw[ trace debug info warn error fatal ]; Log::Log4perl->wrapper_register(__PACKAGE__); for my $level (@levels) { no strict 'refs'; *{$level} = sub { my ( $self, @message ) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $LOG_LEVEL_ADJUSTMENT; my $logger = Log::Log4perl->get_logger(); $logger->$level(@message); return 1; }; *{"is_$level"} = sub { my ( $self, @message ) = @_; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + $LOG_LEVEL_ADJUSTMENT; my $logger = Log::Log4perl->get_logger(); my $func = "is_" . $level; return $logger->$func; }; } } ################################################## sub new { ################################################## my($class, $config, %options) = @_; my $self = { autoflush => 0, abort => 0, watch_delay => 0, %options, }; if( !Log::Log4perl->initialized() ) { if( defined $config ) { if( $self->{watch_delay} ) { Log::Log4perl::init_and_watch( $config, $self->{watch_delay} ); } else { Log::Log4perl::init( $config ); } } else { Log::Log4perl->easy_init({ level => $DEBUG, layout => "[%d] [catalyst] [%p] %m%n", }); } } # Unless we have autoflush, Catalyst likes to buffer all messages # until it calls flush(). This is somewhat unusual for Log4perl, # but we just put an army of buffer appenders in front of all # appenders defined in the system. if(! $options{autoflush} ) { for my $appender (values %Log::Log4perl::Logger::APPENDER_BY_NAME) { next if $appender->{name} =~ /_$CATALYST_APPENDER_SUFFIX$/; # put a buffering appender in front of every appender # defined so far my $buf_app_name = "$appender->{name}_$CATALYST_APPENDER_SUFFIX"; my $buf_app = Log::Log4perl::Appender->new( 'Log::Log4perl::Appender::Buffer', name => $buf_app_name, appender => $appender->{name}, trigger => sub { 0 }, # only trigger on explicit flush() ); Log::Log4perl->add_appender($buf_app); $buf_app->post_init(); $buf_app->composite(1); # Point all loggers currently connected to the previously defined # appenders to the chained buffer appenders instead. foreach my $logger ( values %$Log::Log4perl::Logger::LOGGERS_BY_NAME){ if(defined $logger->remove_appender( $appender->{name}, 0, 1)) { $logger->add_appender( $buf_app ); } } } } bless $self, $class; return $self; } ################################################## sub _flush { ################################################## my ($self) = @_; for my $appender (values %Log::Log4perl::Logger::APPENDER_BY_NAME) { next if $appender->{name} !~ /_$CATALYST_APPENDER_SUFFIX$/; $appender->flush(); } } ################################################## sub abort { ################################################## my($self, $abort) = @_; $self->{abort} = $abort; for my $appender (values %Log::Log4perl::Logger::APPENDER_BY_NAME) { next if $appender->{name} !~ /_$CATALYST_APPENDER_SUFFIX$/; $appender->{buffer} = []; } return $self->{abort}; } ################################################## sub levels { ################################################## # stub function, until we have something meaningful return 0; } ################################################## sub enable { ################################################## # stub function, until we have something meaningful return 0; } ################################################## sub disable { ################################################## # stub function, until we have something meaningful return 0; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Catalyst - Log::Log4perl Catalyst Module =head1 SYNOPSIS In your main Catalyst application module: use Log::Log4perl::Catalyst; # Either make Log4perl act like the Catalyst default logger: __PACKAGE__->log(Log::Log4perl::Catalyst->new()); # or use a Log4perl configuration file, utilizing the full # functionality of Log4perl __PACKAGE__->log(Log::Log4perl::Catalyst->new('l4p.conf')); ... and then sprinkly logging statements all over any code executed by Catalyst: $c->log->debug("This is using log4perl!"); =head1 DESCRIPTION This module provides Log4perl functions to Catalyst applications. It was inspired by Catalyst::Log::Log4perl on CPAN, but has been completely rewritten and uses a different approach to unite Catalyst and Log4perl. Log4perl provides loggers, usually associated with the current package, which can then be remote-controlled by a central configuration. This means that if you have a controller function like package MyApp::Controller::User; sub add : Chained('base'): PathPart('add'): Args(0) { my ( $self, $c ) = @_; $c->log->info("Adding a user"); # ... } Level-based control is available via the following methods: $c->log->debug("Reading configuration"); $c->log->info("Adding a user"); $c->log->warn("Can't read configuration ($!)"); $c->log->error("Can't add user ", $user); $c->log->fatal("Database down, aborting request"); But that's no all, Log4perl is much more powerful. The logging statement can be suppressed or activated based on a Log4perl file that looks like # All MyApp loggers opened up for DEBUG and above log4perl.logger.MyApp = DEBUG, Screen # ... or # All loggers block messages below INFO log4perl.logger=INFO, Screen # ... respectively. See the Log4perl manpage on how to perform fine-grained log-level and location filtering, and how to forward messages not only to the screen or to log files, but also to databases, email appenders, and much more. Also, you can vary the layout of each message. For example if you want to know where a particular statement was logged, turn on file names and line numbers: # Log4perl configuration file # ... log4perl.appender.Screen.layout.ConversionPattern = \ %F{1}-%L: %p %m%n Messages will then look like MyApp.pm-1869: INFO Saving user profile for user "wonko" Or want to log a request's IP address with every log statement? No problem with Log4perl, just call Log::Log4perl::MDC->put( "ip", $c->req->address() ); at the beginning of the request cycle and use # Log4perl configuration file # ... log4perl.appender.Screen.layout.ConversionPattern = \ [%d]-%X{ip} %F{1}-%L: %p %m%n as a Log4perl layout. Messages will look like [2010/02/22 23:25:55]-123.122.108.10 MyApp.pm-1953: INFO Reading profile for user "wonko" Again, check the Log4perl manual page, there's a plethora of configuration options. =head1 METHODS =over 4 =item new($config, [%options]) If called without parameters, new() initializes Log4perl in a way so that messages are logged similiarly to Catalyst's default logging mechanism. If you provide configuration, either the name of a configuration file or a reference to scalar string containing the configuration, it will call Log4perl with these parameters. The second (optional) parameter is a list of key/value pairs: 'autoflush' => 1 # Log without buffering ('abort' not supported) 'watch_delay' => 30 # If set, use L's init_and_watch =item _flush() Flushes the cache. =item abort($abort) Clears the logging system's internal buffers without logging anything. =back =head2 Using :easy Macros with Catalyst If you're tired of typing $c->log->debug("..."); and would prefer to use Log4perl's convenient :easy mode macros like DEBUG "..."; then just pull those macros in via Log::Log4perl's :easy mode and start cranking: use Log::Log4perl qw(:easy); # ... use macros later on sub base :Chained('/') :PathPart('apples') :CaptureArgs(0) { my ( $self, $c ) = @_; DEBUG "Handling apples"; } Note the difference between Log4perl's initialization in Catalyst, which uses the Catalyst-specific Log::Log4perl::Catalyst module (top of this page), and making use of Log4perl's loggers with the standard Log::Log4perl loggers and macros. While initialization requires Log4perl to perform dark magic to conform to Catalyst's different logging strategy, obtaining Log4perl's logger objects or calling its macros are unchanged. Instead of using Catalyst's way of referencing the "context" object $c to obtain logger references via its log() method, you can just as well use Log4perl's get_logger() or macros to access Log4perl's logger singletons. The result is the same. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZv9I*I*Appender/Limit.pmnu[###################################################################### # Limit.pm -- 2003, Mike Schilli ###################################################################### # 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 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. =item C Period in seconds between delivery of messages. If messages arrive in between, they will be either saved (if C is set to a true value) or discarded (if C isn't set). =item C File name in which C persistently stores delivery times. If omitted, the appender will have no recollection of what happened when the program restarts. =item C Maximum number of accumulated messages. If exceeded, the appender flushes all messages, regardless if the interval set in C has passed or not. Don't mix with C. =item C Maximum number of accumulated messages. If exceeded, the appender will simply discard additional messages, waiting for C to expire to flush all accumulated messages. Don't mix with C. =item C 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 parameter to C<1> and set the limiters C 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 to send out the whole batch. The limiter will then call the appender's C method when it's own buffer gets flushed out. =back If the appender attached to C uses C 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 is a I 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 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZIAppender/ScreenColoredLevels.pmnu[################################################## 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 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 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 takes an optional parameter C, if set to a true value, the appender will log to STDERR. If C is set to a false value, it will log to STDOUT. The default setting for C is 1, so messages will be logged to STDERR by default. The constructor can also take an optional parameter C, 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ, q7i i Appender/Screen.pmnu[################################################## 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 take an optional parameter C, if set to a true value, the appender will log to STDERR. The default setting for C is 1, so messages will be logged to STDERR by default. If C is set to a false value, it will log to STDOUT (or, more accurately, whichever file handle is selected via C, STDOUT by default). Design and implementation of this module has been greatly inspired by Dave Rolsky's C 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZnN((Appender/Synchronized.pmnu[###################################################################### # Synchronized.pm -- 2003, 2007 Mike Schilli ###################################################################### # 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 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 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 as a gateway between your loggers and your appenders. An appender itself, C just takes two additional arguments: =over 4 =item C 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. =item C This optional argument specifies the key for the semaphore that C uses internally to ensure atomic operations. It defaults to C<_l4p>. If you define more than one C appender, it is important to specify different keys for them, as otherwise every new C appender will nuke previously defined semaphores. The maximum key length is four characters, longer keys will be truncated to 4 characters -- C and C are interpreted to be the same: C (thanks to David Viner Edviner@yahoo-inc.comE for pointing this out). =back C uses Log::Log4perl::Util::Semaphore internally to perform locking with semaphores provided by the operating system used. =head2 Performance tips The C serializes access to a protected resource globally, slowing down actions otherwise performed in parallel. Unless specified otherwise, all instances of C 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 (Remove the semaphore on exit), C (permissions on the semaphore), C (uid or user name the semaphore is owned by), and C (group id the semaphore is owned by), Note that C 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. The C 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 is a I 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 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ%XO O Appender/TestFileCreeper.pmnu[################################################## 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZWWAppender/Socket.pmnu[################################################## 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 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), it will C. If the appender fails to log a message because the socket's C 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 method returns, discarding the message. If the option C 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 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 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ_8 Appender/Buffer.pmnu[###################################################################### # Buffer.pm -- 2004, Mike Schilli ###################################################################### # 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 takes these arguments: =over 4 =item C 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. =item C Specifies the maximum number of messages the appender will hold in its ring buffer. C is optional. By default, C will I limit the number of messages buffered. This might be undesirable in long-running processes accumulating lots of messages before a flush happens. If C is set to a numeric value, C will displace old messages in its buffer to make room if the buffer is full. =item C If trigger_level is set to one of Log4perl's levels (see Log::Log4perl::Level), a C 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 C holds a reference to a subroutine, which C will call on every incoming message with the same parameters as the appender's C method: my($self, $params) = @_; C<$params> references a hash containing the message priority (key C), the message category (key C) and the content of the message (key C). If the subroutine returns 1, it will trigger a flush of buffered messages. Shortcut =back =head1 DEVELOPMENT NOTES C is a I 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 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZso o Appender/TestArrayBuffer.pmnu[################################################## 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ!yAppender/RRDs.pmnu[################################################## 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 appenders facilitate writing data to RRDtool round-robin archives via Log4perl. For documentation on RRD and its Perl interface C (which comes with the distribution), check out L. Messages sent to Log4perl's RRDs appender are expected to be numerical values (ints or floats), which then are used to run a C command on an existing round-robin database. The name of this database needs to be set in the appender's C configuration parameter. If there's more parameters you wish to pass to the C method, use the C configuration parameter: log4perl.appender.RRDapp.rrdupd_params = --template=in:out To read out the round robin database later on, use C or C for graphic displays. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZs'Appender/TestBuffer.pmnu[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. It is a C-style appender, which writes to a buffer in memory, from where actual results can be easily retrieved later to compare with expeced 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 Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ Appender/String.pmnu[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. It appends messages to a scalar instance variable. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ!ht|;|;Appender/File.pmnu[################################################## package Log::Log4perl::Appender::File; ################################################## our @ISA = qw(Log::Log4perl::Appender); use warnings; use strict; use Log::Log4perl::Config::Watch; use Fcntl; 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, @options, }; if($self->{create_at_logtime}) { $self->{recreate} = 1; } if(defined $self->{umask} and $self->{umask} =~ /^0/) { # umask value is a string, meant to be an oct value $self->{umask} = oct($self->{umask}); } 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); my $old_umask = umask(); 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; }; umask($self->{umask}) if defined $self->{umask}; my $didnt_exist = ! -e $self->{filename}; 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} ($!)"; } 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}) : ()), ); } umask($old_umask) if defined $self->{umask}; $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 method takes a single scalar. If a newline character should terminate the message, it has to be added explicitely. 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 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, if set to a true value, triggers flushing the data out to the file on every call to C. C is on by default. =item syswrite C, if set to a true value, makes sure that the appender uses syswrite() instead of print() to log the message. C usually maps to the operating system's C function and makes sure that no other process writes to the same log file while C is busy. Might safe you from having to use other syncronisation measures like semaphores (see: Synchronized appender). =item umask Specifies the C to use when creating the file, determining the file's permission settings. If set to C<0222> (default), new files will be created with C permissions. If set to C<0000>, new files will be created with C 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 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 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, use the binmode parameter: my $app = Log::Log4perl::Appender::File->new( filename => 'file.log', mode => 'append', binmode => ":utf8", ); A setting of ":utf8" for C is equivalent to specifying the C 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), 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 option is set to a true value, C will do exactly that. It defaults to false. Check the C option for performance optimizations with this feature. =item recreate_check_interval In C 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 on the file name and figure out if its inode has changed. Doing this with every call to C 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 seconds after the file has been moved or deleted. If this is undesirable, setting C to 0 will have the appender check the file with I call to C. =item recreate_check_signal In C 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. =item recreate_pid_write The popular log rotating utility C 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. =item create_at_logtime The file appender typically creates its logfile in its constructor, i.e. at Log4perl C 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 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 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 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. =back Design and implementation of this module has been greatly inspired by Dave Rolsky's C appender framework. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ0JNJNAppender/DBI.pmnu[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 unforseen 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 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 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 your layout will result in something like "ARRAY(0x841d8dc)" in your logs. More information on C 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 '?' placholder 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? 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 =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 suprise 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 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 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 and C. C specifies the number of reconnections attempts the DBI appender performs until it gives up and dies. C is the time between reconnection attempts, measured in seconds. C defaults to 1, C to 0. Alternatively, use C or C and read CHANGING DB CONNECTIONS above. Note that C holds one connection open for every appender, which might be too many. =head1 SEE ALSO L L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZT<__ Config.pmnu[################################################## package Log::Log4perl::Config; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Logger; use Log::Log4perl::Level; use Log::Log4perl::Config::PropertyConfigurator; use Log::Log4perl::JavaMap; use Log::Log4perl::Filter; use Log::Log4perl::Filter::Boolean; use Log::Log4perl::Config::Watch; use constant _INTERNAL_DEBUG => 0; our $CONFIG_FILE_READS = 0; our $CONFIG_INTEGRITY_CHECK = 1; our $CONFIG_INTEGRITY_ERROR = undef; our $WATCHER; our $DEFAULT_WATCH_DELAY = 60; # seconds our $OPTS = {}; our $OLD_CONFIG; our $LOGGERS_DEFINED; our $UTF8 = 0; ########################################### sub init { ########################################### Log::Log4perl::Logger->reset(); undef $WATCHER; # just in case there's a one left over (e.g. test cases) return _init(@_); } ########################################### sub utf8 { ########################################### my( $class, $flag ) = @_; $UTF8 = $flag if defined $flag; return $UTF8; } ########################################### sub watcher { ########################################### return $WATCHER; } ########################################### sub init_and_watch { ########################################### my ($class, $config, $delay, $opts) = @_; # delay can be a signal name - in this case we're gonna # set up a signal handler. if(defined $WATCHER) { $config = $WATCHER->file(); if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { $delay = $WATCHER->signal(); } else { $delay = $WATCHER->check_interval(); } } print "init_and_watch ($config-$delay). Resetting.\n" if _INTERNAL_DEBUG; Log::Log4perl::Logger->reset(); defined ($delay) or $delay = $DEFAULT_WATCH_DELAY; if (ref $config) { die "Log4perl can only watch a file, not a string of " . "configuration information"; }elsif ($config =~ m!^(https?|ftp|wais|gopher|file):!){ die "Log4perl can only watch a file, not a url like $config"; } if($delay =~ /\D/) { $WATCHER = Log::Log4perl::Config::Watch->new( file => $config, signal => $delay, l4p_internal => 1, ); } else { $WATCHER = Log::Log4perl::Config::Watch->new( file => $config, check_interval => $delay, l4p_internal => 1, ); } if(defined $opts) { die "Parameter $opts needs to be a hash ref" if ref($opts) ne "HASH"; $OPTS = $opts; } eval { _init($class, $config); }; if($@) { die "$@" unless defined $OLD_CONFIG; # Call _init with a pre-parsed config to go back to old setting _init($class, undef, $OLD_CONFIG); warn "Loading new config failed, reverted to old one\n"; } } ################################################## sub _init { ################################################## my($class, $config, $data) = @_; my %additivity = (); $LOGGERS_DEFINED = 0; print "Calling _init\n" if _INTERNAL_DEBUG; #keep track so we don't create the same one twice my %appenders_created = (); #some appenders need to run certain subroutines right at the #end of the configuration phase, when all settings are in place. my @post_config_subs = (); # This logic is probably suited to win an obfuscated programming # contest. It desperately needs to be rewritten. # Basically, it works like this: # config_read() reads the entire config file into a hash of hashes: # log4j.logger.foo.bar.baz: WARN, A1 # gets transformed into # $data->{log4j}->{logger}->{foo}->{bar}->{baz} = "WARN, A1"; # The code below creates the necessary loggers, sets the appenders # and the layouts etc. # In order to transform parts of this tree back into identifiers # (like "foo.bar.baz"), we're using the leaf_paths functions below. # Pretty scary. But it allows the lines of the config file to be # in *arbitrary* order. $data = config_read($config) unless defined $data; if(_INTERNAL_DEBUG) { require Data::Dumper; Data::Dumper->import(); print Data::Dumper::Dumper($data); } my @loggers = (); my %filter_names = (); my $system_wide_threshold; # Autocorrect the rootlogger/rootLogger typo if(exists $data->{rootlogger} and ! exists $data->{rootLogger}) { $data->{rootLogger} = $data->{rootlogger}; } # Find all logger definitions in the conf file. Start # with root loggers. if(exists $data->{rootLogger}) { $LOGGERS_DEFINED++; push @loggers, ["", $data->{rootLogger}->{value}]; } # Check if we've got a system-wide threshold setting if(exists $data->{threshold}) { # yes, we do. $system_wide_threshold = $data->{threshold}->{value}; } if (exists $data->{oneMessagePerAppender}){ $Log::Log4perl::one_message_per_appender = $data->{oneMessagePerAppender}->{value}; } # Boolean filters my %boolean_filters = (); # Continue with lower level loggers. Both 'logger' and 'category' # are valid keywords. Also 'additivity' is one, having a logger # attached. We'll differenciate between the two further down. for my $key (qw(logger category additivity PatternLayout filter)) { if(exists $data->{$key}) { for my $path (@{leaf_paths($data->{$key})}) { print "Path before: @$path\n" if _INTERNAL_DEBUG; my $value = boolean_to_perlish(pop @$path); pop @$path; # Drop the 'value' keyword part if($key eq "additivity") { # This isn't a logger but an additivity setting. # Save it in a hash under the logger's name for later. $additivity{join('.', @$path)} = $value; #a global user-defined conversion specifier (cspec) }elsif ($key eq "PatternLayout"){ &add_global_cspec(@$path[-1], $value); }elsif ($key eq "filter"){ print "Found entry @$path\n" if _INTERNAL_DEBUG; $filter_names{@$path[0]}++; } else { if (ref($value) eq "ARRAY") { die "Multiple definitions of logger ".join('.',@$path)." in log4perl config"; } # This is a regular logger $LOGGERS_DEFINED++; push @loggers, [join('.', @$path), $value]; } } } } # Now go over all filters found by name for my $filter_name (keys %filter_names) { print "Checking filter $filter_name\n" if _INTERNAL_DEBUG; # The boolean filter needs all other filters already # initialized, defer its initialization if($data->{filter}->{$filter_name}->{value} eq "Log::Log4perl::Filter::Boolean") { print "Boolean filter ($filter_name)\n" if _INTERNAL_DEBUG; $boolean_filters{$filter_name}++; next; } my $type = $data->{filter}->{$filter_name}->{value}; if(my $code = compile_if_perl($type)) { $type = $code; } print "Filter $filter_name is of type $type\n" if _INTERNAL_DEBUG; my $filter; if(ref($type) eq "CODE") { # Subroutine - map into generic Log::Log4perl::Filter class $filter = Log::Log4perl::Filter->new($filter_name, $type); } else { # Filter class die "Filter class '$type' doesn't exist" unless Log::Log4perl::Util::module_available($type); eval "require $type" or die "Require of $type failed ($!)"; # Invoke with all defined parameter # key/values (except the key 'value' which is the entry # for the class) $filter = $type->new(name => $filter_name, map { $_ => $data->{filter}->{$filter_name}->{$_}->{value} } grep { $_ ne "value" } keys %{$data->{filter}->{$filter_name}}); } # Register filter with the global filter registry $filter->register(); } # Initialize boolean filters (they need the other filters to be # initialized to be able to compile their logic) for my $name (keys %boolean_filters) { my $logic = $data->{filter}->{$name}->{logic}->{value}; die "No logic defined for boolean filter $name" unless defined $logic; my $filter = Log::Log4perl::Filter::Boolean->new( name => $name, logic => $logic); $filter->register(); } for (@loggers) { my($name, $value) = @$_; my $logger = Log::Log4perl::Logger->get_logger($name); my ($level, @appnames) = split /\s*,\s*/, $value; $logger->level( Log::Log4perl::Level::to_priority($level), 'dont_reset_all'); if(exists $additivity{$name}) { $logger->additivity($additivity{$name}, 1); } for my $appname (@appnames) { my $appender = create_appender_instance( $data, $appname, \%appenders_created, \@post_config_subs, $system_wide_threshold); $logger->add_appender($appender, 'dont_reset_all'); set_appender_by_name($appname, $appender, \%appenders_created); } } #run post_config subs for(@post_config_subs) { $_->(); } #now we're done, set up all the output methods (e.g. ->debug('...')) Log::Log4perl::Logger::reset_all_output_methods(); #Run a sanity test on the config not disabled if($Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK and !config_is_sane()) { warn "Log::Log4perl configuration looks suspicious: ", "$CONFIG_INTEGRITY_ERROR"; } # Successful init(), save config for later $OLD_CONFIG = $data; $Log::Log4perl::Logger::INITIALIZED = 1; } ################################################## sub config_is_sane { ################################################## if(! $LOGGERS_DEFINED) { $CONFIG_INTEGRITY_ERROR = "No loggers defined"; return 0; } if(scalar keys %Log::Log4perl::Logger::APPENDER_BY_NAME == 0) { $CONFIG_INTEGRITY_ERROR = "No appenders defined"; return 0; } return 1; } ################################################## sub create_appender_instance { ################################################## my($data, $appname, $appenders_created, $post_config_subs, $system_wide_threshold) = @_; my $appenderclass = get_appender_by_name( $data, $appname, $appenders_created); print "appenderclass=$appenderclass\n" if _INTERNAL_DEBUG; my $appender; if (ref $appenderclass) { $appender = $appenderclass; } else { die "ERROR: you didn't tell me how to " . "implement your appender '$appname'" unless $appenderclass; if (Log::Log4perl::JavaMap::translate($appenderclass)){ # It's Java. Try to map print "Trying to map Java $appname\n" if _INTERNAL_DEBUG; $appender = Log::Log4perl::JavaMap::get($appname, $data->{appender}->{$appname}); }else{ # It's Perl my @params = grep { $_ ne "layout" and $_ ne "value" } keys %{$data->{appender}->{$appname}}; my %param = (); foreach my $pname (@params){ #this could be simple value like #{appender}{myAppender}{file}{value} => 'log.txt' #or a structure like #{appender}{myAppender}{login} => # { name => {value => 'bob'}, # pwd => {value => 'xxx'}, # } #in the latter case we send a hashref to the appender if (exists $data->{appender}{$appname} {$pname}{value} ) { $param{$pname} = $data->{appender}{$appname} {$pname}{value}; }else{ $param{$pname} = {map {$_ => $data->{appender} {$appname} {$pname} {$_} {value}} keys %{$data->{appender} {$appname} {$pname}} }; } } my $depends_on = []; $appender = Log::Log4perl::Appender->new( $appenderclass, name => $appname, l4p_post_config_subs => $post_config_subs, l4p_depends_on => $depends_on, %param, ); for my $dependency (@$depends_on) { # If this appender indicates that it needs other appenders # to exist (e.g. because it's a composite appender that # relays messages on to its appender-refs) then we're # creating their instances here. Reason for this is that # these appenders are not attached to any logger and are # therefore missed by the config parser which goes through # the defined loggers and just creates *their* attached # appenders. $appender->composite(1); next if exists $appenders_created->{$appname}; my $app = create_appender_instance($data, $dependency, $appenders_created, $post_config_subs); # If the appender appended a subroutine to $post_config_subs # (a reference to an array of subroutines) # here, the configuration parser will later execute this # method. This is used by a composite appender which needs # to make sure all of its appender-refs are available when # all configuration settings are done. # Smuggle this sub-appender into the hash of known appenders # without attaching it to any logger directly. $ Log::Log4perl::Logger::APPENDER_BY_NAME{$dependency} = $app; } } } add_layout_by_name($data, $appender, $appname) unless $appender->composite(); # Check for appender thresholds my $threshold = $data->{appender}->{$appname}->{Threshold}->{value}; if(defined $system_wide_threshold and !defined $threshold) { $threshold = $system_wide_threshold; } if(defined $threshold) { # Need to split into two lines because of CVS $appender->threshold($ Log::Log4perl::Level::PRIORITY{$threshold}); } # Check for custom filters attached to the appender my $filtername = $data->{appender}->{$appname}->{Filter}->{value}; if(defined $filtername) { # Need to split into two lines because of CVS my $filter = Log::Log4perl::Filter::by_name($filtername); die "Filter $filtername doesn't exist" unless defined $filter; $appender->filter($filter); } if(defined $system_wide_threshold and defined $threshold and $ Log::Log4perl::Level::PRIORITY{$system_wide_threshold} > $ Log::Log4perl::Level::PRIORITY{$threshold} ) { $appender->threshold($ Log::Log4perl::Level::PRIORITY{$system_wide_threshold}); } if(exists $data->{appender}->{$appname}->{threshold}) { die "invalid keyword 'threshold' - perhaps you meant 'Threshold'?"; } return $appender; } ########################################### sub add_layout_by_name { ########################################### my($data, $appender, $appender_name) = @_; my $layout_class = $data->{appender}->{$appender_name}->{layout}->{value}; die "Layout not specified for appender $appender_name" unless $layout_class; $layout_class =~ s/org.apache.log4j./Log::Log4perl::Layout::/; # Check if we have this layout class if(!Log::Log4perl::Util::module_available($layout_class)) { if(Log::Log4perl::Util::module_available( "Log::Log4perl::Layout::$layout_class")) { # Someone used the layout shortcut, use the fully qualified # module name instead. $layout_class = "Log::Log4perl::Layout::$layout_class"; } else { die "ERROR: trying to set layout for $appender_name to " . "'$layout_class' failed"; } } eval "require $layout_class" or die "Require to $layout_class failed ($!)"; $appender->layout($layout_class->new( $data->{appender}->{$appender_name}->{layout}, )); } ########################################### sub get_appender_by_name { ########################################### my($data, $name, $appenders_created) = @_; if (exists $appenders_created->{$name}) { return $appenders_created->{$name}; } else { return $data->{appender}->{$name}->{value}; } } ########################################### sub set_appender_by_name { ########################################### # keep track of appenders we've already created ########################################### my($appname, $appender, $appenders_created) = @_; $appenders_created->{$appname} ||= $appender; } ################################################## sub add_global_cspec { ################################################## # the config file said # log4j.PatternLayout.cspec.Z=sub {return $$*2} ################################################## my ($letter, $perlcode) = @_; die "error: only single letters allowed in log4j.PatternLayout.cspec.$letter" unless ($letter =~ /^[a-zA-Z]$/); Log::Log4perl::Layout::PatternLayout::add_global_cspec($letter, $perlcode); } my $LWP_USER_AGENT; sub set_LWP_UserAgent { $LWP_USER_AGENT = shift; } ########################################### sub config_read { ########################################### # Read the lib4j configuration and store the # values into a nested hash structure. ########################################### my($config) = @_; die "Configuration not defined" unless defined $config; my @text; my $parser; $CONFIG_FILE_READS++; # Count for statistical purposes my $base_configurator = Log::Log4perl::Config::BaseConfigurator->new( utf8 => $UTF8, ); my $data = {}; if (ref($config) eq 'HASH') { # convert the hashref into a list # of name/value pairs print "Reading config from hash\n" if _INTERNAL_DEBUG; @text = (); for my $key ( keys %$config ) { if( ref( $config->{$key} ) eq "CODE" ) { $config->{$key} = $config->{$key}->(); } push @text, $key . '=' . $config->{$key} . "\n"; } } elsif (ref $config eq 'SCALAR') { print "Reading config from scalar\n" if _INTERNAL_DEBUG; @text = split(/\n/,$$config); } elsif (ref $config eq 'GLOB' or ref $config eq 'IO::File') { # If we have a file handle, just call the reader print "Reading config from file handle\n" if _INTERNAL_DEBUG; @text = @{ $base_configurator->file_h_read( $config ) }; } elsif (ref $config) { # Caller provided a config parser object, which already # knows which file (or DB or whatever) to parse. print "Reading config from parser object\n" if _INTERNAL_DEBUG; $data = $config->parse(); return $data; } elsif ($config =~ m|^ldap://|){ if(! Log::Log4perl::Util::module_available("Net::LDAP")) { die "Log4perl: missing Net::LDAP needed to parse LDAP urls\n$@\n"; } require Net::LDAP; require Log::Log4perl::Config::LDAPConfigurator; return Log::Log4perl::Config::LDAPConfigurator->new->parse($config); } else { if ($config =~ /^(https?|ftp|wais|gopher|file):/){ my ($result, $ua); die "LWP::UserAgent not available" unless Log::Log4perl::Util::module_available("LWP::UserAgent"); require LWP::UserAgent; unless (defined $LWP_USER_AGENT) { $LWP_USER_AGENT = LWP::UserAgent->new; # Load proxy settings from environment variables, i.e.: # http_proxy, ftp_proxy, no_proxy etc (see LWP::UserAgent) # You need these to go thru firewalls. $LWP_USER_AGENT->env_proxy; } $ua = $LWP_USER_AGENT; my $req = new HTTP::Request GET => $config; my $res = $ua->request($req); if ($res->is_success) { @text = split(/\n/, $res->content); } else { die "Log4perl couln't get $config, ". $res->message." "; } } else { print "Reading config from file '$config'\n" if _INTERNAL_DEBUG; print "Reading ", -s $config, " bytes.\n" if _INTERNAL_DEBUG; # Use the BaseConfigurator's file reader to avoid duplicating # utf8 handling here. $base_configurator->file( $config ); @text = @{ $base_configurator->text() }; } } print "Reading $config: [@text]\n" if _INTERNAL_DEBUG; if(! grep /\S/, @text) { return $data; } if ($text[0] =~ /^<\?xml /) { die "XML::DOM not available" unless Log::Log4perl::Util::module_available("XML::DOM"); require XML::DOM; require Log::Log4perl::Config::DOMConfigurator; XML::DOM->VERSION($Log::Log4perl::DOM_VERSION_REQUIRED); $parser = Log::Log4perl::Config::DOMConfigurator->new(); $data = $parser->parse(\@text); } else { $parser = Log::Log4perl::Config::PropertyConfigurator->new(); $data = $parser->parse(\@text); } $data = $parser->parse_post_process( $data, leaf_paths($data) ); return $data; } ########################################### sub unlog4j { ########################################### my ($string) = @_; $string =~ s#^org\.apache\.##; $string =~ s#^log4j\.##; $string =~ s#^l4p\.##; $string =~ s#^log4perl\.##i; $string =~ s#\.#::#g; return $string; } ############################################################ sub leaf_paths { ############################################################ # Takes a reference to a hash of hashes structure of # arbitrary depth, walks the tree and returns a reference # to an array of all possible leaf paths (each path is an # array again). # Example: { a => { b => { c => d }, e => f } } would generate # [ [a, b, c, d], [a, e, f] ] ############################################################ my ($root) = @_; my @stack = (); my @result = (); push @stack, [$root, []]; while(@stack) { my $item = pop @stack; my($node, $path) = @$item; if(ref($node) eq "HASH") { for(keys %$node) { push @stack, [$node->{$_}, [@$path, $_]]; } } else { push @result, [@$path, $node]; } } return \@result; } ########################################### sub leaf_path_to_hash { ########################################### my($leaf_path, $data) = @_; my $ref = \$data; for my $part ( @$leaf_path[0..$#$leaf_path-1] ) { $ref = \$$ref->{ $part }; } return $ref; } ########################################### sub eval_if_perl { ########################################### my($value) = @_; if(my $cref = compile_if_perl($value)) { return $cref->(); } return $value; } ########################################### sub compile_if_perl { ########################################### my($value) = @_; if($value =~ /^\s*sub\s*{/ ) { my $mask; unless( Log::Log4perl::Config->allow_code() ) { die "\$Log::Log4perl::Config->allow_code() setting " . "prohibits Perl code in config file"; } if( defined( $mask = Log::Log4perl::Config->allowed_code_ops() ) ) { return compile_in_safe_cpt($value, $mask ); } elsif( $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( Log::Log4perl::Config->allow_code() ) ) { return compile_in_safe_cpt($value, $mask ); } elsif( Log::Log4perl::Config->allow_code() == 1 ) { # eval without restriction my $cref = eval "package main; $value" or die "Can't evaluate '$value' ($@)"; return $cref; } else { die "Invalid value for \$Log::Log4perl::Config->allow_code(): '". Log::Log4perl::Config->allow_code() . "'"; } } return undef; } ########################################### sub compile_in_safe_cpt { ########################################### my($value, $allowed_ops) = @_; # set up a Safe compartment require Safe; my $safe = Safe->new(); $safe->permit_only( @{ $allowed_ops } ); # share things with the compartment for( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() } ) { my $toshare = Log::Log4perl::Config->vars_shared_with_safe_compartment($_); $safe->share_from( $_, $toshare ) or die "Can't share @{ $toshare } with Safe compartment"; } # evaluate with restrictions my $cref = $safe->reval("package main; $value") or die "Can't evaluate '$value' in Safe compartment ($@)"; return $cref; } ########################################### sub boolean_to_perlish { ########################################### my($value) = @_; # Translate boolean to perlish $value = 1 if $value =~ /^true$/i; $value = 0 if $value =~ /^false$/i; return $value; } ########################################### sub vars_shared_with_safe_compartment { ########################################### my($class, @args) = @_; # Allow both for ...::Config::foo() and ...::Config->foo() if(defined $class and $class ne __PACKAGE__) { unshift @args, $class; } # handle different invocation styles if(@args == 1 && ref $args[0] eq 'HASH' ) { # replace entire hash of vars %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT = %{$args[0]}; } elsif( @args == 1 ) { # return vars for given package return $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ $args[0]}; } elsif( @args == 2 ) { # add/replace package/var pair $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ $args[0]} = $args[1]; } return wantarray ? %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT : \%Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT; } ########################################### sub allowed_code_ops { ########################################### my($class, @args) = @_; # Allow both for ...::Config::foo() and ...::Config->foo() if(defined $class and $class ne __PACKAGE__) { unshift @args, $class; } if(@args) { @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE = @args; } else { # give back 'undef' instead of an empty arrayref unless( @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE ) { return; } } return wantarray ? @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE : \@Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; } ########################################### sub allowed_code_ops_convenience_map { ########################################### my($class, @args) = @_; # Allow both for ...::Config::foo() and ...::Config->foo() if(defined $class and $class ne __PACKAGE__) { unshift @args, $class; } # handle different invocation styles if( @args == 1 && ref $args[0] eq 'HASH' ) { # replace entire map %Log::Log4perl::ALLOWED_CODE_OPS = %{$args[0]}; } elsif( @args == 1 ) { # return single opcode mask return $Log::Log4perl::ALLOWED_CODE_OPS{ $args[0]}; } elsif( @args == 2 ) { # make sure the mask is an array ref if( ref $args[1] ne 'ARRAY' ) { die "invalid mask (not an array ref) for convenience name '$args[0]'"; } # add name/mask pair $Log::Log4perl::ALLOWED_CODE_OPS{ $args[0]} = $args[1]; } return wantarray ? %Log::Log4perl::ALLOWED_CODE_OPS : \%Log::Log4perl::ALLOWED_CODE_OPS } ########################################### sub allow_code { ########################################### my($class, @args) = @_; # Allow both for ...::Config::foo() and ...::Config->foo() if(defined $class and $class ne __PACKAGE__) { unshift @args, $class; } if(@args) { $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE = $args[0]; } return $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE; } ################################################ sub var_subst { ################################################ my($varname, $subst_hash) = @_; # Throw out blanks $varname =~ s/\s+//g; if(exists $subst_hash->{$varname}) { print "Replacing variable: '$varname' => '$subst_hash->{$varname}'\n" if _INTERNAL_DEBUG; return $subst_hash->{$varname}; } elsif(exists $ENV{$varname}) { print "Replacing ENV variable: '$varname' => '$ENV{$varname}'\n" if _INTERNAL_DEBUG; return $ENV{$varname}; } die "Undefined Variable '$varname'"; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config - Log4perl configuration file syntax =head1 DESCRIPTION In C, configuration files are used to describe how the system's loggers ought to behave. The format is the same as the one as used for C, just with a few perl-specific extensions, like enabling the C syntax instead of insisting on the Java-specific C. Comment lines and blank lines (all whitespace or empty) are ignored. Comment lines may start with arbitrary whitespace followed by one of: =over 4 =item # - Common comment delimiter =item ! - Java .properties file comment delimiter accepted by log4j =item ; - Common .ini file comment delimiter =back Comments at the end of a line are not supported. So if you write log4perl.appender.A1.filename=error.log #in current dir you will find your messages in a file called C. Also, blanks between syntactical entities are ignored, it doesn't matter if you write log4perl.logger.Bar.Twix=WARN,Screen or log4perl.logger.Bar.Twix = WARN, Screen C will strip the blanks while parsing your input. Assignments need to be on a single line. However, you can break the line if you want to by using a continuation character at the end of the line. Instead of writing log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout you can break the line at any point by putting a backslash at the very (!) end of the line to be continued: log4perl.appender.A1.layout=\ Log::Log4perl::Layout::SimpleLayout Watch out for trailing blanks after the backslash, which would prevent the line from being properly concatenated. =head2 Loggers Loggers are addressed by category: log4perl.logger.Bar.Twix = WARN, Screen This sets all loggers under the C hierarchy on priority C and attaches a later-to-be-defined C appender to them. Settings for the root appender (which doesn't have a name) can be accomplished by simply omitting the name: log4perl.logger = FATAL, Database, Mailer This sets the root appender's level to C and also attaches the later-to-be-defined appenders C and C to it. The additivity flag of a logger is set or cleared via the C keyword: log4perl.additivity.Bar.Twix = 0|1 (Note the reversed order of keyword and logger name, resulting from the dilemma that a logger name could end in C<.additivity> according to the log4j documentation). =head2 Appenders and Layouts Appender names used in Log4perl configuration file lines need to be resolved later on, in order to define the appender's properties and its layout. To specify properties of an appender, just use the C keyword after the C intro and the appender's name: # The Bar::Twix logger and its appender log4perl.logger.Bar.Twix = DEBUG, A1 log4perl.appender.A1=Log::Log4perl::Appender::File log4perl.appender.A1.filename=test.log log4perl.appender.A1.mode=append log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout This sets a priority of C for loggers in the C hierarchy and assigns the C appender to it, which is later on resolved to be an appender of type C, simply appending to a log file. According to the C manpage, the C parameter specifies the name of the log file and the C parameter can be set to C or C (the former will append to the logfile if one with the specified name already exists while the latter would clobber and overwrite it). The order of the entries in the configuration file is not important, C will read in the entire file first and try to make sense of the lines after it knows the entire context. You can very well define all loggers first and then their appenders (you could even define your appenders first and then your loggers, but let's not go there): log4perl.logger.Bar.Twix = DEBUG, A1 log4perl.logger.Bar.Snickers = FATAL, A2 log4perl.appender.A1=Log::Log4perl::Appender::File log4perl.appender.A1.filename=test.log log4perl.appender.A1.mode=append log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout log4perl.appender.A2=Log::Log4perl::Appender::Screen log4perl.appender.A2.stderr=0 log4perl.appender.A2.layout=Log::Log4perl::Layout::PatternLayout log4perl.appender.A2.layout.ConversionPattern = %d %m %n Note that you have to specify the full path to the layout class and that C is the keyword to specify the printf-style formatting instructions. =head1 Configuration File Cookbook Here's some examples of often-used Log4perl configuration files: =head2 Append to STDERR log4perl.category.Bar.Twix = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.Screen.layout.ConversionPattern = %d %m %n =head2 Append to STDOUT log4perl.category.Bar.Twix = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.stderr = 0 log4perl.appender.Screen.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.Screen.layout.ConversionPattern = %d %m %n =head2 Append to a log file log4perl.logger.Bar.Twix = DEBUG, A1 log4perl.appender.A1=Log::Log4perl::Appender::File log4perl.appender.A1.filename=test.log log4perl.appender.A1.mode=append log4perl.appender.A1.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.A1.layout.ConversionPattern = %d %m %n Note that you could even leave out log4perl.appender.A1.mode=append and still have the logger append to the logfile by default, although the C module does exactly the opposite. This is due to some nasty trickery C performs behind the scenes to make sure that beginner's CGI applications don't clobber the log file every time they're called. =head2 Write a log file from scratch If you loathe the Log::Log4perl's append-by-default strategy, you can certainly override it: log4perl.logger.Bar.Twix = DEBUG, A1 log4perl.appender.A1=Log::Log4perl::Appender::File log4perl.appender.A1.filename=test.log log4perl.appender.A1.mode=write log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout C is the C that has C explicitely clobber the log file if it exists. =head2 Configuration files encoded in utf-8 If your configuration file is encoded in utf-8 (which matters if you e.g. specify utf8-encoded appender filenames in it), then you need to tell Log4perl before running init(): use Log::Log4perl::Config; Log::Log4perl::Config->utf( 1 ); Log::Log4perl->init( ... ); This makes sure Log4perl interprets utf8-encoded config files correctly. This setting might become the default at some point. =head1 SEE ALSO Log::Log4perl::Config::PropertyConfigurator Log::Log4perl::Config::DOMConfigurator Log::Log4perl::Config::LDAPConfigurator (coming soon!) =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZh-YYConfig/PropertyConfigurator.pmnu[package Log::Log4perl::Config::PropertyConfigurator; use Log::Log4perl::Config::BaseConfigurator; use warnings; use strict; our @ISA = qw(Log::Log4perl::Config::BaseConfigurator); our %NOT_A_MULT_VALUE = map { $_ => 1 } qw(conversionpattern); #poor man's export *eval_if_perl = \&Log::Log4perl::Config::eval_if_perl; *compile_if_perl = \&Log::Log4perl::Config::compile_if_perl; *unlog4j = \&Log::Log4perl::Config::unlog4j; use constant _INTERNAL_DEBUG => 0; our $COMMENT_REGEX = qr/[#;!]/; ################################################ sub parse { ################################################ my($self, $newtext) = @_; $self->text($newtext) if defined $newtext; my $text = $self->{text}; die "Config parser has nothing to parse" unless defined $text; my $data = {}; my %var_subst = (); while (@$text) { local $_ = shift @$text; s/^\s*$COMMENT_REGEX.*//; next unless /\S/; my @parts = (); while (/(.+?)\\\s*$/) { my $prev = $1; my $next = shift(@$text); $next =~ s/^ +//g; #leading spaces $next =~ s/^$COMMENT_REGEX.*//; $_ = $prev. $next; chomp; } if(my($key, $val) = /(\S+?)\s*=\s*(.*)/) { my $key_org = $key; $val =~ s/\s+$//; # Everything could potentially be a variable assignment $var_subst{$key} = $val; # Substitute any variables $val =~ s/\$\{(.*?)\}/ Log::Log4perl::Config::var_subst($1, \%var_subst)/gex; $key = unlog4j($key); my $how_deep = 0; my $ptr = $data; for my $part (split /\.|::/, $key) { push @parts, $part; $ptr->{$part} = {} unless exists $ptr->{$part}; $ptr = $ptr->{$part}; ++$how_deep; } #here's where we deal with turning multiple values like this: # log4j.appender.jabbender.to = him@a.jabber.server # log4j.appender.jabbender.to = her@a.jabber.server #into an arrayref like this: #to => { value => # ["him\@a.jabber.server", "her\@a.jabber.server"] }, # # This only is allowed for properties of appenders # not listed in %NOT_A_MULT_VALUE (see top of file). if (exists $ptr->{value} && $how_deep > 2 && defined $parts[0] && lc($parts[0]) eq "appender" && defined $parts[2] && ! exists $NOT_A_MULT_VALUE{lc($parts[2])} ) { if (ref ($ptr->{value}) ne 'ARRAY') { my $temp = $ptr->{value}; $ptr->{value} = []; push (@{$ptr->{value}}, $temp); } push (@{$ptr->{value}}, $val); }else{ if(defined $ptr->{value}) { if(! $Log::Log4perl::Logger::NO_STRICT) { die "$key_org redefined"; } } $ptr->{value} = $val; } } } $self->{data} = $data; return $data; } ################################################ sub value { ################################################ my($self, $path) = @_; $path = unlog4j($path); my @p = split /::/, $path; my $found = 0; my $r = $self->{data}; while (my $n = shift @p) { if (exists $r->{$n}) { $r = $r->{$n}; $found = 1; } else { $found = 0; } } if($found and exists $r->{value}) { return $r->{value}; } else { return undef; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::PropertyConfigurator - reads properties file =head1 SYNOPSIS # This class is used internally by Log::Log4perl use Log::Log4perl::Config::PropertyConfigurator; my $conf = Log::Log4perl::Config::PropertyConfigurator->new(); $conf->file("l4p.conf"); $conf->parse(); # will die() on error my $value = $conf->value("log4perl.appender.LOGFILE.filename"); if(defined $value) { printf("The appender's file name is $value\n"); } else { printf("The appender's file name is not defined.\n"); } =head1 DESCRIPTION Initializes log4perl from a properties file, stuff like log4j.category.a.b.c.d = WARN, A1 log4j.category.a.b = INFO, A1 It also understands variable substitution, the following configuration is equivalent to the previous one: settings = WARN, A1 log4j.category.a.b.c.d = ${settings} log4j.category.a.b = INFO, A1 =head1 SEE ALSO Log::Log4perl::Config Log::Log4perl::Config::BaseConfigurator Log::Log4perl::Config::DOMConfigurator Log::Log4perl::Config::LDAPConfigurator (tbd!) =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZW!!Config/BaseConfigurator.pmnu[package Log::Log4perl::Config::BaseConfigurator; use warnings; use strict; use constant _INTERNAL_DEBUG => 0; *eval_if_perl = \&Log::Log4perl::Config::eval_if_perl; *compile_if_perl = \&Log::Log4perl::Config::compile_if_perl; *leaf_path_to_hash = \&Log::Log4perl::Config::leaf_path_to_hash; ################################################ sub new { ################################################ my($class, %options) = @_; my $self = { utf8 => 0, %options, }; bless $self, $class; $self->file($self->{file}) if exists $self->{file}; $self->text($self->{text}) if exists $self->{text}; return $self; } ################################################ sub text { ################################################ my($self, $text) = @_; # $text is an array of scalars (lines) if(defined $text) { if(ref $text eq "ARRAY") { $self->{text} = $text; } else { $self->{text} = [split "\n", $text]; } } return $self->{text}; } ################################################ sub file { ################################################ my($self, $filename) = @_; open my $fh, "$filename" or die "Cannot open $filename ($!)"; if( $self->{ utf8 } ) { binmode $fh, ":utf8"; } $self->file_h_read( $fh ); close $fh; } ################################################ sub file_h_read { ################################################ my($self, $fh) = @_; # Dennis Gregorovic added this # to protect apps which are tinkering with $/ globally. local $/ = "\n"; $self->{text} = [<$fh>]; } ################################################ sub parse { ################################################ die __PACKAGE__ . "::parse() is a virtual method. " . "It must be implemented " . "in a derived class (currently: ", ref(shift), ")"; } ################################################ sub parse_post_process { ################################################ my($self, $data, $leaf_paths) = @_; # [ # 'category', # 'value', # 'WARN, Logfile' # ], # [ # 'appender', # 'Logfile', # 'value', # 'Log::Log4perl::Appender::File' # ], # [ # 'appender', # 'Logfile', # 'filename', # 'value', # 'test.log' # ], # [ # 'appender', # 'Logfile', # 'layout', # 'value', # 'Log::Log4perl::Layout::PatternLayout' # ], # [ # 'appender', # 'Logfile', # 'layout', # 'ConversionPattern', # 'value', # '%d %F{1} %L> %m %n' # ] for my $path ( @{ Log::Log4perl::Config::leaf_paths( $data )} ) { print "path=@$path\n" if _INTERNAL_DEBUG; if(0) { } elsif( $path->[0] eq "appender" and $path->[2] eq "trigger" ) { my $ref = leaf_path_to_hash( $path, $data ); my $code = compile_if_perl( $$ref ); if(_INTERNAL_DEBUG) { if($code) { print "Code compiled: $$ref\n"; } else { print "Not compiled: $$ref\n"; } } $$ref = $code if defined $code; } elsif ( $path->[0] eq "filter" ) { # do nothing } elsif ( $path->[0] eq "appender" and $path->[2] eq "warp_message" ) { # do nothing } elsif ( $path->[0] eq "appender" and $path->[3] eq "cspec" or $path->[1] eq "cspec" ) { # could be either # appender appndr layout cspec # or # PatternLayout cspec U value ... # # do nothing } else { my $ref = leaf_path_to_hash( $path, $data ); if(_INTERNAL_DEBUG) { print "Calling eval_if_perl on $$ref\n"; } $$ref = eval_if_perl( $$ref ); } } return $data; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::BaseConfigurator - Configurator Base Class =head1 SYNOPSIS This is a virtual base class, all configurators should be derived from it. =head1 DESCRIPTION =head2 METHODS =over 4 =item C<< new >> Constructor, typically called like my $config_parser = SomeConfigParser->new( file => $file, ); my $data = $config_parser->parse(); Instead of C, the derived class C may define any type of configuration input medium (e.g. C 'http://foobar'>). It just has to make sure its C method will later pull the input data from the medium specified. The base class accepts a filename or a reference to an array of text lines: =over 4 =item C<< file >> Specifies a file which the C method later parses. =item C<< text >> Specifies a reference to an array of scalars, representing configuration records (typically lines of a file). Also accepts a simple scalar, which it splits at its newlines and transforms it into an array: my $config_parser = MyYAMLParser->new( text => ['foo: bar', 'baz: bam', ], ); my $data = $config_parser->parse(); =back If either C or C parameters have been specified in the constructor call, a later call to the configurator's C method will return a reference to an array of configuration text lines. This will typically be used by the C method to process the input. =item C<< parse >> Virtual method, needs to be defined by the derived class. =back =head2 Parser requirements =over 4 =item * If the parser provides variable substitution functionality, it has to implement it. =item * The parser's C method returns a reference to a hash of hashes (HoH). The top-most hash contains the top-level keywords (C, C) as keys, associated with values which are references to more deeply nested hashes. =item * The C prefix (e.g. as used in the PropertyConfigurator class) is stripped, it's not part in the HoH structure. =item * Each Log4perl config value is indicated by the C key, as in $data->{category}->{Bar}->{Twix}->{value} = "WARN, Logfile" =back =head2 EXAMPLES The following Log::Log4perl configuration: log4perl.category.Bar.Twix = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::File log4perl.appender.Screen.filename = test.log log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout needs to be transformed by the parser's C method into this data structure: { appender => { Screen => { layout => { value => "Log::Log4perl::Layout::SimpleLayout" }, value => "Log::Log4perl::Appender::Screen", }, }, category => { Bar => { Twix => { value => "WARN, Screen" } } } } For a full-fledged example, check out the sample YAML parser implementation in C. It uses a simple YAML syntax to specify the Log4perl configuration to illustrate the concept. =head1 SEE ALSO Log::Log4perl::Config::PropertyConfigurator Log::Log4perl::Config::DOMConfigurator Log::Log4perl::Config::LDAPConfigurator (tbd!) =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZjjConfig/DOMConfigurator.pmnu[package Log::Log4perl::Config::DOMConfigurator; use Log::Log4perl::Config::BaseConfigurator; our @ISA = qw(Log::Log4perl::Config::BaseConfigurator); #todo # DONE(param-text) some params not attrs but values, like ... # DONE see DEBUG!!! below # NO, (really is only used for AsyncAppender) appender-ref in # DONE check multiple appenders in a category # DONE in Config.pm re URL loading, steal from XML::DOM # DONE, OK see PropConfigurator re importing unlog4j, eval_if_perl # NO (is specified in DTD) - need to handle 0/1, true/false? # DONEsee Config, need to check version of XML::DOM # OK user defined levels? see parse_level # OK make sure 2nd test is using log4perl constructs, not log4j # OK handle new filter stuff # make sure sample code actually works # try removing namespace prefixes in the xml use XML::DOM; use Log::Log4perl::Level; use strict; use constant _INTERNAL_DEBUG => 0; our $VERSION = 0.03; our $APPENDER_TAG = qr/^((log4j|log4perl):)?appender$/; our $FILTER_TAG = qr/^(log4perl:)?filter$/; our $FILTER_REF_TAG = qr/^(log4perl:)?filter-ref$/; #can't use ValParser here because we're using namespaces? #doesn't seem to work - kg 3/2003 our $PARSER_CLASS = 'XML::DOM::Parser'; our $LOG4J_PREFIX = 'log4j'; our $LOG4PERL_PREFIX = 'log4perl'; #poor man's export *eval_if_perl = \&Log::Log4perl::Config::eval_if_perl; *unlog4j = \&Log::Log4perl::Config::unlog4j; ################################################### sub parse { ################################################### my($self, $newtext) = @_; $self->text($newtext) if defined $newtext; my $text = $self->{text}; my $parser = $PARSER_CLASS->new; my $doc = $parser->parse (join('',@$text)); my $l4p_tree = {}; my $config = $doc->getElementsByTagName("$LOG4J_PREFIX:configuration")->item(0)|| $doc->getElementsByTagName("$LOG4PERL_PREFIX:configuration")->item(0); my $threshold = uc(subst($config->getAttribute('threshold'))); if ($threshold) { $l4p_tree->{threshold}{value} = $threshold; } if (subst($config->getAttribute('oneMessagePerAppender')) eq 'true') { $l4p_tree->{oneMessagePerAppender}{value} = 1; } for my $kid ($config->getChildNodes){ next unless $kid->getNodeType == ELEMENT_NODE; my $tag_name = $kid->getTagName; if ($tag_name =~ $APPENDER_TAG) { &parse_appender($l4p_tree, $kid); }elsif ($tag_name eq 'category' || $tag_name eq 'logger'){ &parse_category($l4p_tree, $kid); #Treating them the same is not entirely accurate, #the dtd says 'logger' doesn't accept #a 'class' attribute while 'category' does. #But that's ok, log4perl doesn't do anything with that attribute }elsif ($tag_name eq 'root'){ &parse_root($l4p_tree, $kid); }elsif ($tag_name =~ $FILTER_TAG){ #parse log4perl's chainable boolean filters &parse_l4p_filter($l4p_tree, $kid); }elsif ($tag_name eq 'renderer'){ warn "Log4perl: ignoring renderer tag in config, unimplemented"; #"log4j will render the content of the log message according to # user specified criteria. For example, if you frequently need # to log Oranges, an object type used in your current project, # then you can register an OrangeRenderer that will be invoked # whenever an orange needs to be logged. " }elsif ($tag_name eq 'PatternLayout'){#log4perl only &parse_patternlayout($l4p_tree, $kid); } } $doc->dispose; return $l4p_tree; } #this is just for toplevel log4perl.PatternLayout tags #holding the custome cspecs sub parse_patternlayout { my ($l4p_tree, $node) = @_; my $l4p_branch = {}; for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; my $name = subst($child->getAttribute('name')); my $value; foreach my $grandkid ($child->getChildNodes){ if ($grandkid->getNodeType == TEXT_NODE) { $value .= $grandkid->getData; } } $value =~ s/^ +//; #just to make the unit tests pass $value =~ s/ +$//; $l4p_branch->{$name}{value} = subst($value); } $l4p_tree->{PatternLayout}{cspec} = $l4p_branch; } #for parsing the root logger, if any sub parse_root { my ($l4p_tree, $node) = @_; my $l4p_branch = {}; &parse_children_of_logger_element($l4p_branch, $node); $l4p_tree->{category}{value} = $l4p_branch->{value}; } #this parses a custom log4perl-specific filter set up under #the root element, as opposed to children of the appenders sub parse_l4p_filter { my ($l4p_tree, $node) = @_; my $l4p_branch = {}; my $name = subst($node->getAttribute('name')); my $class = subst($node->getAttribute('class')); my $value = subst($node->getAttribute('value')); if ($class && $value) { die "Log4perl: only one of class or value allowed, not both, " ."in XMLConfig filter '$name'"; }elsif ($class || $value){ $l4p_branch->{value} = ($value || $class); } for my $child ($node->getChildNodes) { if ($child->getNodeType == ELEMENT_NODE){ my $tag_name = $child->getTagName(); if ($tag_name =~ /^(param|param-nested|param-text)$/) { &parse_any_param($l4p_branch, $child); } }elsif ($child->getNodeType == TEXT_NODE){ my $text = $child->getData; next unless $text =~ /\S/; if ($class && $value) { die "Log4perl: only one of class, value or PCDATA allowed, " ."in XMLConfig filter '$name'"; } $l4p_branch->{value} .= subst($text); } } $l4p_tree->{filter}{$name} = $l4p_branch; } #for parsing a category/logger element sub parse_category { my ($l4p_tree, $node) = @_; my $name = subst($node->getAttribute('name')); $l4p_tree->{category} ||= {}; my $ptr = $l4p_tree->{category}; for my $part (split /\.|::/, $name) { $ptr->{$part} = {} unless exists $ptr->{$part}; $ptr = $ptr->{$part}; } my $l4p_branch = $ptr; my $class = subst($node->getAttribute('class')); $class && $class ne 'Log::Log4perl' && $class ne 'org.apache.log4j.Logger' && warn "setting category $name to class $class ignored, only Log::Log4perl implemented"; #this is kind of funky, additivity has its own spot in the tree my $additivity = subst(subst($node->getAttribute('additivity'))); if (length $additivity > 0) { $l4p_tree->{additivity} ||= {}; my $add_ptr = $l4p_tree->{additivity}; for my $part (split /\.|::/, $name) { $add_ptr->{$part} = {} unless exists $add_ptr->{$part}; $add_ptr = $add_ptr->{$part}; } $add_ptr->{value} = &parse_boolean($additivity); } &parse_children_of_logger_element($l4p_branch, $node); } # parses the children of a category element sub parse_children_of_logger_element { my ($l4p_branch, $node) = @_; my (@appenders, $priority); for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; my $tag_name = $child->getTagName(); if ($tag_name eq 'param') { my $name = subst($child->getAttribute('name')); my $value = subst($child->getAttribute('value')); if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)^/) { $value = uc $value; } $l4p_branch->{$name} = {value => $value}; }elsif ($tag_name eq 'appender-ref'){ push @appenders, subst($child->getAttribute('ref')); }elsif ($tag_name eq 'level' || $tag_name eq 'priority'){ $priority = &parse_level($child); } } $l4p_branch->{value} = $priority.', '.join(',', @appenders); return; } sub parse_level { my $node = shift; my $level = uc (subst($node->getAttribute('value'))); die "Log4perl: invalid level in config: $level" unless Log::Log4perl::Level::is_valid($level); return $level; } sub parse_appender { my ($l4p_tree, $node) = @_; my $name = subst($node->getAttribute("name")); my $l4p_branch = {}; my $class = subst($node->getAttribute("class")); $l4p_branch->{value} = $class; print "looking at $name----------------------\n" if _INTERNAL_DEBUG; for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; my $tag_name = $child->getTagName(); my $name = unlog4j(subst($child->getAttribute('name'))); if ($tag_name =~ /^(param|param-nested|param-text)$/) { &parse_any_param($l4p_branch, $child); my $value; }elsif ($tag_name =~ /($LOG4PERL_PREFIX:)?layout/){ $l4p_branch->{layout} = parse_layout($child); }elsif ($tag_name =~ $FILTER_TAG){ $l4p_branch->{Filter} = parse_filter($child); }elsif ($tag_name =~ $FILTER_REF_TAG){ $l4p_branch->{Filter} = parse_filter_ref($child); }elsif ($tag_name eq 'errorHandler'){ die "errorHandlers not supported yet"; }elsif ($tag_name eq 'appender-ref'){ #dtd: Appenders may also reference (or include) other appenders. #This feature in log4j is only for appenders who implement the #AppenderAttachable interface, and the only one that does that #is the AsyncAppender, which writes logs in a separate thread. #I don't see the need to support this on the perl side any #time soon. --kg 3/2003 die "Log4perl: in config file, tag is unsupported in "; }else{ die "Log4perl: in config file, <$tag_name> is unsupported\n"; } } $l4p_tree->{appender}{$name} = $l4p_branch; } sub parse_any_param { my ($l4p_branch, $child) = @_; my $tag_name = $child->getTagName(); my $name = subst($child->getAttribute('name')); my $value; print "parse_any_param: <$tag_name name=$name\n" if _INTERNAL_DEBUG; # #note we don't set it to { value => $value } #and we don't test for multiple values if ($tag_name eq 'param-nested'){ if ($l4p_branch->{$name}){ die "Log4perl: in config file, multiple param-nested tags for $name not supported"; } $l4p_branch->{$name} = &parse_param_nested($child); return; # }elsif ($tag_name eq 'param') { $value = subst($child->getAttribute('value')); print "parse_param_nested: got param $name = $value\n" if _INTERNAL_DEBUG; if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) { $value = uc $value; } if ($name !~ /warp_message|filter/ && $child->getParentNode->getAttribute('name') ne 'cspec') { $value = eval_if_perl($value); } # }elsif ($tag_name eq 'param-text'){ foreach my $grandkid ($child->getChildNodes){ if ($grandkid->getNodeType == TEXT_NODE) { $value .= $grandkid->getData; } } if ($name !~ /warp_message|filter/ && $child->getParentNode->getAttribute('name') ne 'cspec') { $value = eval_if_perl($value); } } $value = subst($value); #multiple values for the same param name if (defined $l4p_branch->{$name}{value} ) { if (ref $l4p_branch->{$name}{value} ne 'ARRAY'){ my $temp = $l4p_branch->{$name}{value}; $l4p_branch->{$name}{value} = [$temp]; } push @{$l4p_branch->{$name}{value}}, $value; }else{ $l4p_branch->{$name} = {value => $value}; } } #handles an appender's elements sub parse_param_nested { my ($node) = shift; my $l4p_branch = {}; for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; my $tag_name = $child->getTagName(); if ($tag_name =~ /^param|param-nested|param-text$/) { &parse_any_param($l4p_branch, $child); } } return $l4p_branch; } #this handles filters that are children of appenders, as opposed #to the custom filters that go under the root element sub parse_filter { my $node = shift; my $filter_tree = {}; my $class_name = subst($node->getAttribute('class')); $filter_tree->{value} = $class_name; print "\tparsing filter on class $class_name\n" if _INTERNAL_DEBUG; for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; my $tag_name = $child->getTagName(); if ($tag_name =~ 'param|param-nested|param-text') { &parse_any_param($filter_tree, $child); }else{ die "Log4perl: don't know what to do with a ".$child->getTagName() ."inside a filter element"; } } return $filter_tree; } sub parse_filter_ref { my $node = shift; my $filter_tree = {}; my $filter_id = subst($node->getAttribute('id')); $filter_tree->{value} = $filter_id; return $filter_tree; } sub parse_layout { my $node = shift; my $layout_tree = {}; my $class_name = subst($node->getAttribute('class')); $layout_tree->{value} = $class_name; # print "\tparsing layout $class_name\n" if _INTERNAL_DEBUG; for my $child ($node->getChildNodes) { next unless $child->getNodeType == ELEMENT_NODE; if ($child->getTagName() eq 'param') { my $name = subst($child->getAttribute('name')); my $value = subst($child->getAttribute('value')); if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) { $value = uc $value; } print "\tparse_layout: got param $name = $value\n" if _INTERNAL_DEBUG; $layout_tree->{$name}{value} = $value; }elsif ($child->getTagName() eq 'cspec') { my $name = subst($child->getAttribute('name')); my $value; foreach my $grandkid ($child->getChildNodes){ if ($grandkid->getNodeType == TEXT_NODE) { $value .= $grandkid->getData; } } $value =~ s/^ +//; $value =~ s/ +$//; $layout_tree->{cspec}{$name}{value} = subst($value); } } return $layout_tree; } sub parse_boolean { my $a = shift; if ($a eq '0' || lc $a eq 'false') { return '0'; }elsif ($a eq '1' || lc $a eq 'true'){ return '1'; }else{ return $a; #probably an error, punt } } #this handles variable substitution sub subst { my $val = shift; $val =~ s/\$\{(.*?)}/ Log::Log4perl::Config::var_subst($1, {})/gex; return $val; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::DOMConfigurator - reads xml config files =head1 SYNOPSIS -------------------------- --using the log4j DTD-- -------------------------- -------------------------- --using the log4perl DTD-- -------------------------- mary@another.jabber.server sub { return sprintf "%1x", $$} sub {return 'thisistheGcspec'} INSERT INTO log4perltest (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) VALUES (?,?,?,?,?,?,?,?) =head1 DESCRIPTION This module implements an XML config, complementing the properties-style config described elsewhere. =head1 WHY "Why would I want my config in XML?" you ask. Well, there are a couple reasons you might want to. Maybe you have a personal preference for XML. Maybe you manage your config with other tools that have an affinity for XML, like XML-aware editors or automated config generators. Or maybe (and this is the big one) you don't like having to run your application just to check the syntax of your config file. By using an XML config and referencing a DTD, you can use a namespace-aware validating parser to see if your XML config at least follows the rules set in the DTD. =head1 HOW To reference a DTD, drop this in after the declaration in your config file: That tells the parser to validate your config against the DTD in "log4perl.dtd", which is available in the xml/ directory of the log4perl distribution. Note that you'll also need to grab the log4j-1.2.dtd from there as well, since the it's included by log4perl.dtd. Namespace-aware validating parsers are not the norm in Perl. But the Xerces project (http://xml.apache.org/xerces-c/index.html --lots of binaries available, even rpm's) does provide just such a parser that you can use like this: StdInParse -ns -v < my-log4perl-config.xml This module itself does not use a validating parser, the obvious one XML::DOM::ValParser doesn't seem to handle namespaces. =head1 WHY TWO DTDs The log4j DTD is from the log4j project, they designed it to handle their needs. log4perl has added some extensions to the original log4j functionality which needed some extensions to the log4j DTD. If you aren't using these features then you can validate your config against the log4j dtd and know that you're using unadulterated log4j config tags. The features added by the log4perl dtd are: =over 4 =item 1 oneMessagePerAppender global setting log4perl.oneMessagePerAppender=1 =item 2 globally defined user conversion specifiers log4perl.PatternLayout.cspec.G=sub { return "UID $< GID $("; } =item 3 appender-local custom conversion specifiers log4j.appender.appndr1.layout.cspec.K = sub {return sprintf "%1x", $$ } =item 4 nested options log4j.appender.jabbender = Log::Dispatch::Jabber #(note how these are nested under 'login') log4j.appender.jabbender.login.hostname = a.jabber.server log4j.appender.jabbender.login.port = 5222 log4j.appender.jabbender.login.username = bobjones =item 5 the log4perl-specific filters, see L, lots of examples in t/044XML-Filter.t, here's a short one: sub { /and that, too/ } =back So we needed to extend the log4j dtd to cover these additions. Now I could have just taken a 'steal this code' approach and mixed parts of the log4j dtd into a log4perl dtd, but that would be cut-n-paste programming. So I've used namespaces and =over 4 =item * replaced three elements: =over 4 =item handles #1) and accepts =item accepts and =item accepts custom cspecs for #3) =back =item * added a element (complementing the element) to handle #4) =item * added a root element to handle #2) =item * added which lets you put things like perl code into escaped CDATA between the tags, so you don't have to worry about escaping characters and quotes =item * added =back See the examples up in the L<"SYNOPSIS"> for how all that gets used. =head1 WHY NAMESPACES I liked the idea of using the log4j DTD I, so I used namespaces to extend it. If you really don't like having to type instead of just , you can make your own DTD combining the two DTDs and getting rid of the namespace prefixes. Then you can validate against that, and log4perl should accept it just fine. =head1 VARIABLE SUBSTITUTION This supports variable substitution like C<${foobar}> in text and in attribute values except for appender-ref. If an environment variable is defined for that name, its value is substituted. So you can do stuff like ${currentsysadmin}@foo.com =head1 REQUIRES To use this module you need XML::DOM installed. To use the log4perl.dtd, you'll have to reference it in your XML config, and you'll also need to note that log4perl.dtd references the log4j dtd as "log4j-1.2.dtd", so your validator needs to be able to find that file as well. If you don't like having to schlep two files around, feel free to dump the contents of "log4j-1.2.dtd" into your "log4perl.dtd" file. =head1 CAVEATS You can't mix a multiple param-nesteds with the same name, I'm going to leave that for now, there's presently no need for a list of structs in the config. =head1 CHANGES 0.03 2/26/2003 Added support for log4perl extensions to the log4j dtd =head1 SEE ALSO t/038XML-DOM1.t, t/039XML-DOM2.t for examples xml/log4perl.dtd, xml/log4j-1.2.dtd Log::Log4perl::Config Log::Log4perl::Config::PropertyConfigurator Log::Log4perl::Config::LDAPConfigurator (coming soon!) The code is brazenly modeled on log4j's DOMConfigurator class, (by Christopher Taylor, Ceki Gülcü, and Anders Kristensen) and any perceived similarity is not coincidental. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZPQ@(@(Config/Watch.pmnu[package Log::Log4perl::Config::Watch; use constant _INTERNAL_DEBUG => 0; our $NEXT_CHECK_TIME; our $SIGNAL_CAUGHT; our $L4P_TEST_CHANGE_DETECTED; our $L4P_TEST_CHANGE_CHECKED; ########################################### sub new { ########################################### my($class, %options) = @_; my $self = { file => "", check_interval => 30, l4p_internal => 0, signal => undef, %options, _last_checked_at => 0, _last_timestamp => 0, }; bless $self, $class; if($self->{signal}) { # We're in signal mode, set up the handler print "Setting up signal handler for '$self->{signal}'\n" if _INTERNAL_DEBUG; # save old signal handlers; they belong to other appenders or # possibly something else in the consuming application my $old_sig_handler = $SIG{$self->{signal}}; $SIG{$self->{signal}} = sub { print "Caught $self->{signal} signal\n" if _INTERNAL_DEBUG; $self->force_next_check(); $old_sig_handler->(@_) if $old_sig_handler and ref $old_sig_handler eq 'CODE'; }; # Reset the marker. The handler is going to modify it. $self->{signal_caught} = 0; $SIGNAL_CAUGHT = 0 if $self->{l4p_internal}; } else { # Just called to initialize $self->change_detected(undef, 1); $self->file_has_moved(undef, 1); } return $self; } ########################################### sub force_next_check { ########################################### my($self) = @_; $self->{signal_caught} = 1; $self->{next_check_time} = 0; if( $self->{l4p_internal} ) { $SIGNAL_CAUGHT = 1; $NEXT_CHECK_TIME = 0; } } ########################################### sub force_next_check_reset { ########################################### my($self) = @_; $self->{signal_caught} = 0; $SIGNAL_CAUGHT = 0 if $self->{l4p_internal}; } ########################################### sub file { ########################################### my($self) = @_; return $self->{file}; } ########################################### sub signal { ########################################### my($self) = @_; return $self->{signal}; } ########################################### sub check_interval { ########################################### my($self) = @_; return $self->{check_interval}; } ########################################### sub file_has_moved { ########################################### my($self, $time, $force) = @_; my $task = sub { my @stat = stat($self->{file}); my $has_moved = 0; if(! $stat[0]) { # The file's gone, obviously it got moved or deleted. print "File is gone\n" if _INTERNAL_DEBUG; return 1; } my $current_inode = "$stat[0]:$stat[1]"; print "Current inode: $current_inode\n" if _INTERNAL_DEBUG; if(exists $self->{_file_inode} and $self->{_file_inode} ne $current_inode) { print "Inode changed from $self->{_file_inode} to ", "$current_inode\n" if _INTERNAL_DEBUG; $has_moved = 1; } $self->{_file_inode} = $current_inode; return $has_moved; }; return $self->check($time, $task, $force); } ########################################### sub change_detected { ########################################### my($self, $time, $force) = @_; my $task = sub { my @stat = stat($self->{file}); my $new_timestamp = $stat[9]; $L4P_TEST_CHANGE_CHECKED = 1; if(! defined $new_timestamp) { if($self->{l4p_internal}) { # The file is gone? Let it slide, we don't want L4p to re-read # the config now, it's gonna die. return undef; } $L4P_TEST_CHANGE_DETECTED = 1; return 1; } if($new_timestamp > $self->{_last_timestamp}) { $self->{_last_timestamp} = $new_timestamp; print "Change detected (file=$self->{file} store=$new_timestamp)\n" if _INTERNAL_DEBUG; $L4P_TEST_CHANGE_DETECTED = 1; return 1; # Has changed } print "$self->{file} unchanged (file=$new_timestamp ", "stored=$self->{_last_timestamp})!\n" if _INTERNAL_DEBUG; return ""; # Hasn't changed }; return $self->check($time, $task, $force); } ########################################### sub check { ########################################### my($self, $time, $task, $force) = @_; $time = time() unless defined $time; if( $self->{signal_caught} or $SIGNAL_CAUGHT ) { $force = 1; $self->force_next_check_reset(); print "Caught signal, forcing check\n" if _INTERNAL_DEBUG; } print "Soft check (file=$self->{file} time=$time)\n" if _INTERNAL_DEBUG; # Do we need to check? if(!$force and $self->{_last_checked_at} + $self->{check_interval} > $time) { print "No need to check\n" if _INTERNAL_DEBUG; return ""; # don't need to check, return false } $self->{_last_checked_at} = $time; # Set global var for optimizations in case we just have one watcher # (like in Log::Log4perl) $self->{next_check_time} = $time + $self->{check_interval}; $NEXT_CHECK_TIME = $self->{next_check_time} if $self->{l4p_internal}; print "Hard check (file=$self->{file} time=$time)\n" if _INTERNAL_DEBUG; return $task->($time); } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::Watch - Detect file changes =head1 SYNOPSIS use Log::Log4perl::Config::Watch; my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", check_interval => 30, ); while(1) { if($watcher->change_detected()) { print "Change detected!\n"; } sleep(1); } =head1 DESCRIPTION This module helps detecting changes in files. Although it comes with the C distribution, it can be used independently. The constructor defines the file to be watched and the check interval in seconds. Subsequent calls to C will =over 4 =item * return a false value immediately without doing physical file checks if C hasn't elapsed. =item * perform a physical test on the specified file if the number of seconds specified in C have elapsed since the last physical check. If the file's modification date has changed since the last physical check, it will return a true value, otherwise a false value is returned. =back Bottom line: C allows you to call the function C as often as you like, without paying the performing a significant performance penalty because file system operations are being performed (however, you pay the price of not knowing about file changes until C seconds have elapsed). The module clearly distinguishes system time from file system time. If your (e.g. NFS mounted) file system is off by a constant amount of time compared to the executing computer's clock, it'll just work fine. To disable the resource-saving delay feature, just set C to 0 and C will run a physical file test on every call. If you already have the current time available, you can pass it on to C as an optional parameter, like in change_detected($time) which then won't trigger a call to C, but use the value provided. =head2 SIGNAL MODE Instead of polling time and file changes, C can be instructed to set up a signal handler. If you call the constructor like my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", signal => 'HUP' ); then a signal handler will be installed, setting the object's variable C<$self-E{signal_caught}> to a true value when the signal arrives. Comes with all the problems that signal handlers go along with. =head2 TRIGGER CHECKS To trigger a physical file check on the next call to C regardless if C has expired or not, call $watcher->force_next_check(); on the watcher object. =head2 DETECT MOVED FILES The watcher can also be used to detect files that have moved. It will not only detect if a watched file has disappeared, but also if it has been replaced by a new file in the meantime. my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", check_interval => 30, ); while(1) { if($watcher->file_has_moved()) { print "File has moved!\n"; } sleep(1); } The parameters C and C limit the number of physical file system checks, simililarily as with C. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ,JavaMap/RollingFileAppender.pmnu[package Log::Log4perl::JavaMap::RollingFileAppender; use Carp; use strict; use Log::Dispatch::FileRotate 1.10; sub new { my ($class, $appender_name, $data) = @_; my $stderr; my $filename = $data->{File}{value} || $data->{filename}{value} || die "'File' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; my $mode; if (defined($data->{Append}{value})){ if (lc $data->{Append}{value} eq 'true' || $data->{Append}{value} == 1){ $mode = 'append'; }elsif (lc $data->{Append}{value} eq 'false' || $data->{Append}{value} == 0) { $mode = 'write'; }elsif($data->{Append} =~ /^(write|append)$/){ $mode = $data->{Append} }else{ die "'$data->{Append}' is not a legal value for Append for appender '$appender_name', '$data->{value}'\n"; } }else{ $mode = 'append'; } my $autoflush; if (defined($data->{BufferedIO}{value})){ if (lc $data->{BufferedIO}{value} eq 'true' || $data->{BufferedIO}{value}){ $autoflush = 1; }elsif (lc $data->{BufferedIO}{value} eq 'true' || ! $data->{BufferedIO}{value}) { $autoflush = 0; }else{ die "'$data->{BufferedIO}' is not a legal value for BufferedIO for appender '$appender_name', '$data->{value}'\n"; } }else{ $autoflush = 1; } my $max; if (defined $data->{MaxBackupIndex}{value}) { $max = $data->{MaxBackupIndex}{value}; }elsif (defined $data->{max}{value}){ $max = $data->{max}{value}; }else{ $max = 1; } my $size; if (defined $data->{MaxFileSize}{value}) { $size = $data->{MaxFileSize}{value} }elsif (defined $data->{size}{value}){ $size = $data->{size}{value}; }else{ $size = 10_000_000; } return Log::Log4perl::Appender->new("Log::Dispatch::FileRotate", name => $appender_name, filename => $filename, mode => $mode, autoflush => $autoflush, size => $size, max => $max, ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::RollingFileAppender - wraps Log::Dispatch::FileRotate =head1 SYNOPSIS =head1 DESCRIPTION This maps log4j's RollingFileAppender to Log::Dispatch::FileRotate by Mark Pfeiffer, . Possible config properties for log4j ConsoleAppender are File Append "true|false|1|0" default=true BufferedIO "true|false|1|0" default=false (i.e. autoflush is on) MaxFileSize default 10_000_000 MaxBackupIndex default is 1 Possible config properties for Log::Dispatch::FileRotate are filename mode "write|append" autoflush 0|1 size max =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ=JavaMap/ConsoleAppender.pmnu[package Log::Log4perl::JavaMap::ConsoleAppender; use Carp; use strict; use Log::Dispatch::Screen; sub new { my ($class, $appender_name, $data) = @_; my $stderr; if (my $t = $data->{Target}{value}) { if ($t eq 'System.out') { $stderr = 0; }elsif ($t eq 'System.err') { $stderr = 1; }else{ die "ERROR: illegal value '$t' for $data->{value}.Target' in appender $appender_name\n"; } }elsif (defined $data->{stderr}{value}){ $stderr = $data->{stderr}{value}; }else{ $stderr = 0; } return Log::Log4perl::Appender->new("Log::Dispatch::Screen", name => $appender_name, stderr => $stderr ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::ConsoleAppender - wraps Log::Dispatch::Screen =head1 SYNOPSIS =head1 DESCRIPTION Possible config properties for log4j ConsoleAppender are Target (System.out, System.err, default is System.out) Possible config properties for Log::Dispatch::Screen are stderr (0 or 1) =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap Log::Dispatch::Screen =cut =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZJJJavaMap/JDBCAppender.pmnu[package Log::Log4perl::JavaMap::JDBCAppender; use Carp; use strict; sub new { my ($class, $appender_name, $data) = @_; my $stderr; my $pwd = $data->{password}{value} || die "'password' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; my $username = $data->{user}{value} || $data->{username}{value} || die "'user' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; my $sql = $data->{sql}{value} || die "'sql' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; my $dsn; my $databaseURL = $data->{URL}{value}; if ($databaseURL) { $databaseURL =~ m|^jdbc:(.+?):(.+?)://(.+?):(.+?);(.+)|; my $driverName = $1; my $databaseName = $2; my $hostname = $3; my $port = $4; my $params = $5; $dsn = "dbi:$driverName:database=$databaseName;host=$hostname;port=$port;$params"; }elsif ($data->{datasource}{value}){ $dsn = $data->{datasource}{value}; }else{ die "'databaseURL' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; } #this part isn't supported by log4j, it's my Log4perl #hack, but I think it's so useful I'm going to implement it #anyway my %bind_value_params; foreach my $p (keys %{$data->{params}}){ $bind_value_params{$p} = $data->{params}{$p}{value}; } return Log::Log4perl::Appender->new("Log::Log4perl::Appender::DBI", datasource => $dsn, username => $username, password => $pwd, sql => $sql, params => \%bind_value_params, #warp_message also not a log4j thing, but see above warp_message=> $data->{warp_message}{value}, ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::JDBCAppender - wraps Log::Log4perl::Appender::DBI =head1 SYNOPSIS =head1 DESCRIPTION Possible config properties for log4j JDBCAppender are bufferSize sql password user URL - attempting to translate a JDBC URL into DBI parameters, let me know if you find problems Possible config properties for Log::Log4perl::Appender::DBI are bufferSize sql password username datasource usePreparedStmt 0|1 (patternLayout).dontCollapseArrayRefs 0|1 =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap Log::Log4perl::Appender::DBI =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ:p JavaMap/FileAppender.pmnu[package Log::Log4perl::JavaMap::FileAppender; use Carp; use strict; use Log::Dispatch::File; sub new { my ($class, $appender_name, $data) = @_; my $stderr; my $filename = $data->{File}{value} || $data->{filename}{value} || die "'File' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; my $mode; if (defined($data->{Append}{value})){ if (lc $data->{Append}{value} eq 'true' || $data->{Append}{value} == 1){ $mode = 'append'; }elsif (lc $data->{Append}{value} eq 'false' || $data->{Append}{value} == 0) { $mode = 'write'; }elsif($data->{Append} =~ /^(write|append)$/){ $mode = $data->{Append} }else{ die "'$data->{Append}' is not a legal value for Append for appender '$appender_name', '$data->{value}'\n"; } }else{ $mode = 'append'; } my $autoflush; if (defined($data->{BufferedIO}{value})){ if (lc $data->{BufferedIO}{value} eq 'true' || $data->{BufferedIO}{value}){ $autoflush = 1; }elsif (lc $data->{BufferedIO}{value} eq 'true' || ! $data->{BufferedIO}{value}) { $autoflush = 0; }else{ die "'$data->{BufferedIO}' is not a legal value for BufferedIO for appender '$appender_name', '$data->{value}'\n"; } }else{ $autoflush = 1; } return Log::Log4perl::Appender->new("Log::Dispatch::File", name => $appender_name, filename => $filename, mode => $mode, autoflush => $autoflush, ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::FileAppender - wraps Log::Dispatch::File =head1 SYNOPSIS =head1 DESCRIPTION Possible config properties for log4j ConsoleAppender are File Append "true|false|1|0" default=true BufferedIO "true|false|1|0" default=false (i.e. autoflush is on) Possible config properties for Log::Dispatch::File are filename mode "write|append" autoflush 0|1 =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap Log::Dispatch::File =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ=!YYJavaMap/NTEventLogAppender.pmnu[package Log::Log4perl::JavaMap::NTEventLogAppender; use Carp; use strict; sub new { my ($class, $appender_name, $data) = @_; my $stderr; my ($source, # ); if (defined $data->{Source}{value}) { $source = $data->{Source}{value} }elsif (defined $data->{source}{value}){ $source = $data->{source}{value}; }else{ $source = 'user'; } return Log::Log4perl::Appender->new("Log::Dispatch::Win32EventLog", name => $appender_name, source => $source, min_level => 'debug', ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::NTEventLogAppender - wraps Log::Dispatch::Win32EventLog =head1 DESCRIPTION This maps log4j's NTEventLogAppender to Log::Dispatch::Win32EventLog Possible config properties for log4j NTEventLogAppender are Source Possible config properties for Log::Dispatch::Win32EventLog are source Boy, that was hard. =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZw2Ƅ JavaMap/SyslogAppender.pmnu[package Log::Log4perl::JavaMap::SyslogAppender; use Carp; use strict; use Log::Dispatch::Syslog; sub new { my ($class, $appender_name, $data) = @_; my $stderr; my ($ident, #defaults to $0 $logopt, #Valid options are 'cons', 'pid', 'ndelay', and 'nowait'. $facility, #Valid options are 'auth', 'authpriv', # 'cron', 'daemon', 'kern', 'local0' through 'local7', # 'mail, 'news', 'syslog', 'user', 'uucp'. Defaults to # 'user' $socket, #Valid options are 'unix' or 'inet'. Defaults to 'inet' ); if (defined $data->{Facility}{value}) { $facility = $data->{Facility}{value} }elsif (defined $data->{facility}{value}){ $facility = $data->{facility}{value}; }else{ $facility = 'user'; } return Log::Log4perl::Appender->new("Log::Dispatch::Syslog", name => $appender_name, facility => $facility, min_level => 'debug', ); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::SysLogAppender - wraps Log::Dispatch::Syslog =head1 DESCRIPTION This maps log4j's SyslogAppender to Log::Dispatch::Syslog Possible config properties for log4j SyslogAppender are SyslogHost (Log::Dispatch::Syslog only accepts 'localhost') Facility Possible config properties for Log::Dispatch::Syslog are min_level (debug) max_level ident (defaults to $0) logopt facility socket (defaults to 'inet') =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ2JavaMap/TestBuffer.pmnu[package Log::Log4perl::JavaMap::TestBuffer; use Carp; use strict; use Log::Log4perl::Appender::TestBuffer; use constant _INTERNAL_DEBUG => 0; sub new { my ($class, $appender_name, $data) = @_; my $stderr; return Log::Log4perl::Appender->new("Log::Log4perl::Appender::TestBuffer", name => $appender_name); } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap::TestBuffer - wraps Log::Log4perl::Appender::TestBuffer =head1 SYNOPSIS =head1 DESCRIPTION Just for testing the Java mapping. =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ Log::Log4perl::Javamap Log::Dispatch::Screen =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZL MDC.pmnu[################################################## package Log::Log4perl::MDC; ################################################## use 5.006; use strict; use warnings; our %MDC_HASH = (); ########################################### sub get { ########################################### my($class, $key) = @_; if($class ne __PACKAGE__) { # Somebody called us with Log::Log4perl::MDC::get($key) $key = $class; } if(exists $MDC_HASH{$key}) { return $MDC_HASH{$key}; } else { return undef; } } ########################################### sub put { ########################################### my($class, $key, $value) = @_; if($class ne __PACKAGE__) { # Somebody called us with Log::Log4perl::MDC::put($key, $value) $value = $key; $key = $class; } $MDC_HASH{$key} = $value; } ########################################### sub remove { ########################################### %MDC_HASH = (); 1; } ########################################### sub get_context { ########################################### return \%MDC_HASH; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::MDC - Mapped Diagnostic Context =head1 DESCRIPTION Log::Log4perl allows loggers to maintain global thread-specific data, called the Nested Diagnostic Context (NDC) and Mapped Diagnostic Context (MDC). The MDC is a simple thread-specific hash table, in which the application can stuff values under certain keys and retrieve them later via the C<"%X{key}"> placeholder in Cs. =over 4 =item Log::Log4perl::MDC->put($key, $value); Store a value C<$value> under key C<$key> in the map. =item my $value = Log::Log4perl::MDC->get($key); Retrieve the content of the map under the specified key. Typically done by C<%X{key}> in C. If no value exists to the given key, C is returned. =item my $text = Log::Log4perl::MDC->remove(); Delete all entries from the map. =item Log::Log4perl::MDC->get_context(); Returns a reference to the hash table. =back Please note that all of the methods above are class methods, there's no instances of this class. Since the thread model in perl 5.8.0 is "no shared data unless explicetly requested" the data structures used are just global (and therefore thread-specific). =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ}E))Filter/LevelRange.pmnu[################################################## package Log::Log4perl::Filter::LevelRange; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Level; use Log::Log4perl::Config; use Log::Log4perl::Util qw( params_check ); use constant _INTERNAL_DEBUG => 0; use base "Log::Log4perl::Filter"; ################################################## sub new { ################################################## my ($class, %options) = @_; my $self = { LevelMin => 'DEBUG', LevelMax => 'FATAL', AcceptOnMatch => 1, %options, }; params_check( $self, [ qw( LevelMin LevelMax ) ], [ qw( name AcceptOnMatch ) ] ); $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( $self->{AcceptOnMatch}); bless $self, $class; return $self; } ################################################## sub ok { ################################################## my ($self, %p) = @_; if(Log::Log4perl::Level::to_priority($self->{LevelMin}) <= Log::Log4perl::Level::to_priority($p{log4p_level}) and Log::Log4perl::Level::to_priority($self->{LevelMax}) >= Log::Log4perl::Level::to_priority($p{log4p_level})) { return $self->{AcceptOnMatch}; } else { return ! $self->{AcceptOnMatch}; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter::LevelRange - Filter for a range of log levels =head1 SYNOPSIS log4perl.filter.Match1 = Log::Log4perl::Filter::LevelRange log4perl.filter.Match1.LevelMin = INFO log4perl.filter.Match1.LevelMax = ERROR log4perl.filter.Match1.AcceptOnMatch = true =head1 DESCRIPTION This Log4perl custom filter checks if the current message has a priority matching a predefined range. The C and C parameters define the levels (choose from C, C, C, C, C) marking the window of allowed messages priorities. C defaults to C, and C to C. The additional parameter C defines if the filter is supposed to pass or block the message (C or C). =head1 SEE ALSO L, L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZcj j Filter/MDC.pmnu[package Log::Log4perl::Filter::MDC; use strict; use warnings; use Log::Log4perl::Util qw( params_check ); use base "Log::Log4perl::Filter"; sub new { my ( $class, %options ) = @_; my $self = {%options}; params_check( $self, [qw( KeyToMatch RegexToMatch )] ); $self->{RegexToMatch} = qr/$self->{RegexToMatch}/; bless $self, $class; return $self; } sub ok { my ( $self, %p ) = @_; my $context = Log::Log4perl::MDC->get_context; my $value = $context->{ $self->{KeyToMatch} }; return 1 if defined $value && $value =~ $self->{RegexToMatch}; return 0; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter::MDC - Filter to match on values of a MDC key =head1 SYNOPSIS log4perl.filter.Match1 = Log::Log4perl::Filter::MDC log4perl.filter.Match1.KeyToMatch = foo log4perl.filter.Match1.RegexToMatch = bar =head1 DESCRIPTION This Log4perl filter checks if a predefined MDC key, as set in C, of the currently submitted message matches a predefined regex, as set in C. =head1 SEE ALSO L, L, L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZO OzzFilter/Boolean.pmnu[################################################## package Log::Log4perl::Filter::Boolean; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Level; use Log::Log4perl::Config; use constant _INTERNAL_DEBUG => 0; use base qw(Log::Log4perl::Filter); ################################################## sub new { ################################################## my ($class, %options) = @_; my $self = { params => {}, %options, }; bless $self, $class; print "Compiling '$options{logic}'\n" if _INTERNAL_DEBUG; # Set up meta-decider for later $self->compile_logic($options{logic}); return $self; } ################################################## sub ok { ################################################## my ($self, %p) = @_; return $self->eval_logic(\%p); } ################################################## sub compile_logic { ################################################## my ($self, $logic) = @_; # Extract Filter placeholders in logic as defined # in configuration file. while($logic =~ /([\w_-]+)/g) { # Get the corresponding filter object my $filter = Log::Log4perl::Filter::by_name($1); die "Filter $filter required by Boolean filter, but not defined" unless $filter; $self->{params}->{$1} = $filter; } # Fabricate a parameter list: A1/A2/A3 => $A1, $A2, $A3 my $plist = join ', ', map { '$' . $_ } keys %{$self->{params}}; # Replace all the (dollar-less) placeholders in the code # by scalars (basically just put dollars in front of them) $logic =~ s/([\w_-]+)/\$$1/g; # Set up the meta decider, which transforms the config file # logic into compiled perl code my $func = <{eval_func} = $eval_func; } ################################################## sub eval_logic { ################################################## my($self, $p) = @_; my @plist = (); # Eval the results of all filters referenced # in the code (although the order of keys is # not predictable, it is consistent :) for my $param (keys %{$self->{params}}) { # Call ok() and map the result to 1 or 0 print "Calling filter $param\n" if _INTERNAL_DEBUG; push @plist, ($self->{params}->{$param}->ok(%$p) ? 1 : 0); } # Now pipe the parameters into the canned function, # have it evaluate the logic and return the final # decision print "Passing in (", join(', ', @plist), ")\n" if _INTERNAL_DEBUG; return $self->{eval_func}->(@plist); } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter::Boolean - Special filter to combine the results of others =head1 SYNOPSIS log4perl.logger = WARN, AppWarn, AppError log4perl.filter.Match1 = sub { /let this through/ } log4perl.filter.Match2 = sub { /and that, too/ } log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean log4perl.filter.MyBoolean.logic = Match1 || Match2 log4perl.appender.Screen = Log::Dispatch::Screen log4perl.appender.Screen.Filter = MyBoolean log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout =head1 DESCRIPTION Sometimes, it's useful to combine the output of various filters to arrive at a log/no log decision. While Log4j, Log4perl's mother ship, chose to implement this feature as a filter chain, similar to Linux' IP chains, Log4perl tries a different approach. Typically, filter results will not need to be passed along in chains but combined in a programmatic manner using boolean logic. "Log if this filter says 'yes' and that filter says 'no'" is a fairly common requirement but hard to implement as a chain. C is a special predefined custom filter for Log4perl which combines the results of other custom filters in arbitrary ways, using boolean expressions: log4perl.logger = WARN, AppWarn, AppError log4perl.filter.Match1 = sub { /let this through/ } log4perl.filter.Match2 = sub { /and that, too/ } log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean log4perl.filter.MyBoolean.logic = Match1 || Match2 log4perl.appender.Screen = Log::Dispatch::Screen log4perl.appender.Screen.Filter = MyBoolean log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout C's boolean expressions allow for combining different appenders by name using AND (&& or &), OR (|| or |) and NOT (!) as logical expressions. Parentheses are used for grouping. Precedence follows standard Perl. Here's a bunch of examples: Match1 && !Match2 # Match1 and not Match2 !(Match1 || Match2) # Neither Match1 nor Match2 (Match1 && Match2) || Match3 # Both Match1 and Match2 or Match3 =head1 SEE ALSO L, L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ[g* Filter/LevelMatch.pmnu[################################################## package Log::Log4perl::Filter::LevelMatch; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Level; use Log::Log4perl::Config; use Log::Log4perl::Util qw( params_check ); use constant _INTERNAL_DEBUG => 0; use base qw(Log::Log4perl::Filter); ################################################## sub new { ################################################## my ($class, %options) = @_; my $self = { LevelToMatch => '', AcceptOnMatch => 1, %options, }; params_check( $self, [ qw( LevelToMatch ) ], [ qw( name AcceptOnMatch ) ] ); $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( $self->{AcceptOnMatch}); bless $self, $class; return $self; } ################################################## sub ok { ################################################## my ($self, %p) = @_; if($self->{LevelToMatch} eq $p{log4p_level}) { print "Levels match\n" if _INTERNAL_DEBUG; return $self->{AcceptOnMatch}; } else { print "Levels don't match\n" if _INTERNAL_DEBUG; return !$self->{AcceptOnMatch}; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter::LevelMatch - Filter to match the log level exactly =head1 SYNOPSIS log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch log4perl.filter.Match1.LevelToMatch = ERROR log4perl.filter.Match1.AcceptOnMatch = true =head1 DESCRIPTION This Log4perl custom filter checks if the currently submitted message matches a predefined priority, as set in C. The additional parameter C defines if the filter is supposed to pass or block the message (C or C) on a match. =head1 SEE ALSO L, L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZNټ Filter/StringMatch.pmnu[################################################## package Log::Log4perl::Filter::StringMatch; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Config; use Log::Log4perl::Util qw( params_check ); use constant _INTERNAL_DEBUG => 0; use base "Log::Log4perl::Filter"; ################################################## sub new { ################################################## my ($class, %options) = @_; print join('-', %options) if _INTERNAL_DEBUG; my $self = { StringToMatch => undef, AcceptOnMatch => 1, %options, }; params_check( $self, [ qw( StringToMatch ) ], [ qw( name AcceptOnMatch ) ] ); $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( $self->{AcceptOnMatch}); $self->{StringToMatch} = qr($self->{StringToMatch}); bless $self, $class; return $self; } ################################################## sub ok { ################################################## my ($self, %p) = @_; local($_) = join $ Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p{message}}; if($_ =~ $self->{StringToMatch}) { print "Strings match\n" if _INTERNAL_DEBUG; return $self->{AcceptOnMatch}; } else { print "Strings don't match ($_/$self->{StringToMatch})\n" if _INTERNAL_DEBUG; return !$self->{AcceptOnMatch}; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter::StringMatch - Filter on log message string =head1 SYNOPSIS log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch log4perl.filter.Match1.StringToMatch = blah blah log4perl.filter.Match1.AcceptOnMatch = true =head1 DESCRIPTION This Log4perl custom filter checks if the currently submitted message matches a predefined regular expression, as set in the C parameter. It uses common Perl 5 regexes. The additional parameter C defines if the filter is supposed to pass or block the message on a match (C or C). =head1 SEE ALSO L, L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZAooFAQ.pmnu[1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::FAQ - Frequently Asked Questions on Log::Log4perl =head1 DESCRIPTION This FAQ shows a wide variety of commonly encountered logging tasks and how to solve them in the most elegant way with Log::Log4perl. Most of the time, this will be just a matter of smartly configuring your Log::Log4perl configuration files. =head2 Why use Log::Log4perl instead of any other logging module on CPAN? That's a good question. There's dozens of logging modules on CPAN. When it comes to logging, people typically think: "Aha. Writing out debug and error messages. Debug is lower than error. Easy. I'm gonna write my own." Writing a logging module is like a rite of passage for every Perl programmer, just like writing your own templating system. Of course, after getting the basics right, features need to be added. You'd like to write a timestamp with every message. Then timestamps with microseconds. Then messages need to be written to both the screen and a log file. And, as your application grows in size you might wonder: Why doesn't my logging system scale along with it? You would like to switch on logging in selected parts of the application, and not all across the board, because this kills performance. This is when people turn to Log::Log4perl, because it handles all of that. Avoid this costly switch. Use C right from the start. C's C<:easy> mode supports easy logging in simple scripts: use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); DEBUG "A low-level message"; ERROR "Won't make it until level gets increased to ERROR"; And when your application inevitably grows, your logging system grows with it without you having to change any code. Please, don't re-invent logging. C is here, it's easy to use, it scales, and covers many areas you haven't thought of yet, but will enter soon. =head2 What's the easiest way to use Log4perl? If you just want to get all the comfort of logging, without much overhead, use I. If you use Log::Log4perl in C<:easy> mode like use Log::Log4perl qw(:easy); you'll have the following functions available in the current package: DEBUG("message"); INFO("message"); WARN("message"); ERROR("message"); FATAL("message"); Just make sure that every package of your code where you're using them in pulls in C first, then you're set. Every stealth logger's category will be equivalent to the name of the package it's located in. These stealth loggers will be absolutely silent until you initialize Log::Log4perl in your main program with either # Define any Log4perl behavior Log::Log4perl->init("foo.conf"); (using a full-blown Log4perl config file) or the super-easy method # Just log to STDERR Log::Log4perl->easy_init($DEBUG); or the parameter-style method with a complexity somewhat in between: # Append to a log file Log::Log4perl->easy_init( { level => $DEBUG, file => ">>test.log" } ); For more info, please check out L. =head2 How can I simply log all my ERROR messages to a file? After pulling in the C module, just initialize its behavior by passing in a configuration to its C method as a string reference. Then, obtain a logger instance and write out a message with its C method: use Log::Log4perl qw(get_logger); # Define configuration my $conf = q( log4perl.logger = ERROR, FileApp log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log log4perl.appender.FileApp.layout = PatternLayout log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n ); # Initialize logging behavior Log::Log4perl->init( \$conf ); # Obtain a logger instance my $logger = get_logger("Bar::Twix"); $logger->error("Oh my, a dreadful error!"); $logger->warn("Oh my, a dreadful warning!"); This will append something like 2002/10/29 20:11:55> Oh my, a dreadful error! to the log file C. How does this all work? While the Log::Log4perl C method typically takes the name of a configuration file as its input parameter like in Log::Log4perl->init( "/path/mylog.conf" ); the example above shows how to pass in a configuration as text in a scalar reference. The configuration as shown defines a logger of the root category, which has an appender of type C attached. The line log4perl.logger = ERROR, FileApp doesn't list a category, defining a root logger. Compare that with log4perl.logger.Bar.Twix = ERROR, FileApp which would define a logger for the category C, showing probably different behavior. C on the right side of the assignment is an arbitrarily defined variable name, which is only used to somehow reference an appender defined later on. Appender settings in the configuration are defined as follows: log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log It selects the file appender of the C hierarchy, which will append to the file C if it already exists. If we wanted to overwrite a potentially existing file, we would have to explicitly set the appropriate C parameter C: log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log log4perl.appender.FileApp.mode = write Also, the configuration defines a PatternLayout format, adding the nicely formatted current date and time, an arrow (E) and a space before the messages, which is then followed by a newline: log4perl.appender.FileApp.layout = PatternLayout log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n Obtaining a logger instance and actually logging something is typically done in a different system part as the Log::Log4perl initialisation section, but in this example, it's just done right after init for the sake of compactness: # Obtain a logger instance my $logger = get_logger("Bar::Twix"); $logger->error("Oh my, a dreadful error!"); This retrieves an instance of the logger of the category C, which, as all other categories, inherits behavior from the root logger if no other loggers are defined in the initialization section. The C method fires up a message, which the root logger catches. Its priority is equal to or higher than the root logger's priority (ERROR), which causes the root logger to forward it to its attached appender. By contrast, the following $logger->warn("Oh my, a dreadful warning!"); doesn't make it through, because the root logger sports a higher setting (ERROR and up) than the WARN priority of the message. =head2 How can I install Log::Log4perl on Microsoft Windows? You can install Log::Log4perl using the CPAN client. Alternatively you can install it using ppm install Log-Log4perl if you're using ActiveState perl. That's it! Afterwards, just create a Perl script like use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); my $logger = get_logger("Twix::Bar"); $logger->debug("Watch me!"); and run it. It should print something like 2002/11/06 01:22:05 Watch me! If you find that something doesn't work, please let us know at log4perl-devel@lists.sourceforge.net -- we'll appreciate it. Have fun! =head2 How can I include global (thread-specific) data in my log messages? Say, you're writing a web application and want all your log messages to include the current client's IP address. Most certainly, you don't want to include it in each and every log message like in $logger->debug( $r->connection->remote_ip, " Retrieving user data from DB" ); do you? Instead, you want to set it in a global data structure and have Log::Log4perl include it automatically via a PatternLayout setting in the configuration file: log4perl.appender.FileApp.layout.ConversionPattern = %X{ip} %m%n The conversion specifier C<%X{ip}> references an entry under the key C in the global C (mapped diagnostic context) table, which you've set once via Log::Log4perl::MDC->put("ip", $r->connection->remote_ip); at the start of the request handler. Note that this is a I (class) method, there's no logger object involved. You can use this method with as many key/value pairs as you like as long as you reference them under different names. The mappings are stored in a global hash table within Log::Log4perl. Luckily, because the thread model in 5.8.0 doesn't share global variables between threads unless they're explicitly marked as such, there's no problem with multi-threaded environments. For more details on the MDC, please refer to L and L. =head2 My application is already logging to a file. How can I duplicate all messages to also go to the screen? Assuming that you already have a Log4perl configuration file like log4perl.logger = DEBUG, FileApp log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log log4perl.appender.FileApp.layout = PatternLayout log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n and log statements all over your code, it's very easy with Log4perl to have the same messages both printed to the logfile and the screen. No reason to change your code, of course, just add another appender to the configuration file and you're done: log4perl.logger = DEBUG, FileApp, ScreenApp log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log log4perl.appender.FileApp.layout = PatternLayout log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen log4perl.appender.ScreenApp.stderr = 0 log4perl.appender.ScreenApp.layout = PatternLayout log4perl.appender.ScreenApp.layout.ConversionPattern = %d> %m%n The configuration file above is assuming that both appenders are active in the same logger hierarchy, in this case the C category. But even if you've got file loggers defined in several parts of your system, belonging to different logger categories, each logging to different files, you can gobble up all logged messages by defining a root logger with a screen appender, which would duplicate messages from all your file loggers to the screen due to Log4perl's appender inheritance. Check http://www.perl.com/pub/a/2002/09/11/log4perl.html for details. Have fun! =head2 How can I make sure my application logs a message when it dies unexpectedly? Whenever you encounter a fatal error in your application, instead of saying something like open FILE, "logdie("Can't open blah -- bailing out!"); This will both log the message with priority FATAL according to your current Log::Log4perl configuration and then call Perl's C afterwards to terminate the program. It works the same with stealth loggers (see L), all you need to do is call use Log::Log4perl qw(:easy); open FILE, " internally if something goes wrong? Use a C<$SIG{__DIE__}> pseudo signal handler use Log::Log4perl qw(get_logger); $SIG{__DIE__} = sub { if($^S) { # We're in an eval {} and don't want log # this message but catch it later return; } local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $logger = get_logger(""); $logger->fatal(@_); die @_; # Now terminate really }; This will catch every C-Exception of your application or the modules it uses. In case you want to It will fetch a root logger and pass on the C-Message to it. If you make sure you've configured with a root logger like this: Log::Log4perl->init(\q{ log4perl.category = FATAL, Logfile log4perl.appender.Logfile = Log::Log4perl::Appender::File log4perl.appender.Logfile.filename = fatal_errors.log log4perl.appender.Logfile.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.Logfile.layout.ConversionPattern = %F{1}-%L (%M)> %m%n }); then all C messages will be routed to a file properly. The line local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; in the pseudo signal handler above merits a more detailed explanation. With the setup above, if a module calls C in one of its functions, the fatal message will be logged in the signal handler and not in the original function -- which will cause the %F, %L and %M placeholders in the pattern layout to be replaced by the filename, the line number and the function/method name of the signal handler, not the error-throwing module. To adjust this, Log::Log4perl has the C<$caller_depth> variable, which defaults to 0, but can be set to positive integer values to offset the caller level. Increasing it by one will cause it to log the calling function's parameters, not the ones of the signal handler. See L for more details. =head2 How can I hook up the LWP library with Log::Log4perl? Or, to put it more generally: How can you utilize a third-party library's embedded logging and debug statements in Log::Log4perl? How can you make them print to configurable appenders, turn them on and off, just as if they were regular Log::Log4perl logging statements? The easiest solution is to map the third-party library logging statements to Log::Log4perl's stealth loggers via a typeglob assignment. As an example, let's take LWP, one of the most popular Perl modules, which makes handling WWW requests and responses a breeze. Internally, LWP uses its own logging and debugging system, utilizing the following calls inside the LWP code (from the LWP::Debug man page): # Function tracing LWP::Debug::trace('send()'); # High-granular state in functions LWP::Debug::debug('url ok'); # Data going over the wire LWP::Debug::conns("read $n bytes: $data"); First, let's assign Log::Log4perl priorities to these functions: I'd suggest that C messages have priority C, C uses C and C also logs with C -- although your mileage may certainly vary. Now, in order to transpartently hook up LWP::Debug with Log::Log4perl, all we have to do is say package LWP::Debug; use Log::Log4perl qw(:easy); *trace = *INFO; *conns = *DEBUG; *debug = *DEBUG; package main; # ... go on with your regular program ... at the beginning of our program. In this way, every time the, say, C module calls C, it will implicitely call INFO(), which is the C method of a stealth logger defined for the Log::Log4perl category C. Is this cool or what? Here's a complete program: use LWP::UserAgent; use HTTP::Request::Common; use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( { category => "LWP::Debug", level => $DEBUG, layout => "%r %p %M-%L %m%n", }); package LWP::Debug; use Log::Log4perl qw(:easy); *trace = *INFO; *conns = *DEBUG; *debug = *DEBUG; package main; my $ua = LWP::UserAgent->new(); my $resp = $ua->request(GET "http://amazon.com"); if($resp->is_success()) { print "Success: Received ", length($resp->content()), "\n"; } else { print "Error: ", $resp->code(), "\n"; } This will generate the following output on STDERR: 174 INFO LWP::UserAgent::new-164 () 208 INFO LWP::UserAgent::request-436 () 211 INFO LWP::UserAgent::send_request-294 GET http://amazon.com 212 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied 405 INFO LWP::Protocol::http::request-122 () 859 DEBUG LWP::Protocol::collect-206 read 233 bytes 863 DEBUG LWP::UserAgent::request-443 Simple response: Found 869 INFO LWP::UserAgent::request-436 () 871 INFO LWP::UserAgent::send_request-294 GET http://www.amazon.com:80/exec/obidos/gateway_redirect 872 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied 873 INFO LWP::Protocol::http::request-122 () 1016 DEBUG LWP::UserAgent::request-443 Simple response: Found 1020 INFO LWP::UserAgent::request-436 () 1022 INFO LWP::UserAgent::send_request-294 GET http://www.amazon.com/exec/obidos/subst/home/home.html/ 1023 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied 1024 INFO LWP::Protocol::http::request-122 () 1382 DEBUG LWP::Protocol::collect-206 read 632 bytes ... 2605 DEBUG LWP::Protocol::collect-206 read 77 bytes 2607 DEBUG LWP::UserAgent::request-443 Simple response: OK Success: Received 42584 Of course, in this way, the embedded logging and debug statements within LWP can be utilized in any Log::Log4perl way you can think of. You can have them sent to different appenders, block them based on the category and everything else Log::Log4perl has to offer. Only drawback of this method: Steering logging behavior via category is always based on the C package. Although the logging statements reflect the package name of the issuing module properly, the stealth loggers in C are all of the category C. This implies that you can't control the logging behavior based on the package that's I a log request (e.g. LWP::UserAgent) but only based on the package that's actually I the logging statement, C in this case. To work around this conundrum, we need to write a wrapper function and plant it into the C package. It will determine the caller and create a logger bound to a category with the same name as the caller's package: package LWP::Debug; use Log::Log4perl qw(:levels get_logger); sub l4p_wrapper { my($prio, @message) = @_; $Log::Log4perl::caller_depth += 2; get_logger(scalar caller(1))->log($prio, @message); $Log::Log4perl::caller_depth -= 2; } no warnings 'redefine'; *trace = sub { l4p_wrapper($INFO, @_); }; *debug = *conns = sub { l4p_wrapper($DEBUG, @_); }; package main; # ... go on with your main program ... This is less performant than the previous approach, because every log request will request a reference to a logger first, then call the wrapper, which will in turn call the appropriate log function. This hierarchy shift has to be compensated for by increasing C<$Log::Log4perl::caller_depth> by 2 before calling the log function and decreasing it by 2 right afterwards. Also, the C function shown above calls C which determines the name of the package I levels down the calling hierarchy (and therefore compensates for both the wrapper function and the anonymous subroutine calling it). C suppresses a warning Perl would generate otherwise upon redefining C's C, C and C functions. In case you use a perl prior to 5.6.x, you need to manipulate C<$^W> instead. To make things easy for you when dealing with LWP, Log::Log4perl 0.47 introduces Cinfiltrate_lwp()> which does exactly the above. =head2 What if I need dynamic values in a static Log4perl configuration file? Say, your application uses Log::Log4perl for logging and therefore comes with a Log4perl configuration file, specifying the logging behavior. But, you also want it to take command line parameters to set values like the name of the log file. How can you have both a static Log4perl configuration file and a dynamic command line interface? As of Log::Log4perl 0.28, every value in the configuration file can be specified as a I. So, instead of saying log4perl.appender.Logfile.filename = test.log you could just as well have a Perl subroutine deliver the value dynamically: log4perl.appender.Logfile.filename = sub { logfile(); }; given that C is a valid function in your C
package returning a string containing the path to the log file. Or, think about using the value of an environment variable: log4perl.appender.DBI.user = sub { $ENV{USERNAME} }; When Cinit()> parses the configuration file, it will notice the assignment above because of its C pattern and treat it in a special way: It will evaluate the subroutine (which can contain arbitrary Perl code) and take its return value as the right side of the assignment. A typical application would be called like this on the command line: app # log file is "test.log" app -l mylog.txt # log file is "mylog.txt" Here's some sample code implementing the command line interface above: use Log::Log4perl qw(get_logger); use Getopt::Std; getopt('l:', \our %OPTS); my $conf = q( log4perl.category.Bar.Twix = WARN, Logfile log4perl.appender.Logfile = Log::Log4perl::Appender::File log4perl.appender.Logfile.filename = sub { logfile(); }; log4perl.appender.Logfile.layout = SimpleLayout ); Log::Log4perl::init(\$conf); my $logger = get_logger("Bar::Twix"); $logger->error("Blah"); ########################################### sub logfile { ########################################### if(exists $OPTS{l}) { return $OPTS{l}; } else { return "test.log"; } } Every Perl hook may contain arbitrary perl code, just make sure to fully qualify eventual variable names (e.g. C<%main::OPTS> instead of C<%OPTS>). B: this feature means arbitrary perl code can be embedded in the config file. In the rare case where the people who have access to your config file are different from the people who write your code and shouldn't have execute rights, you might want to call $Log::Log4perl::Config->allow_code(0); before you call init(). This will prevent Log::Log4perl from executing I Perl code in the config file (including code for custom conversion specifiers (see L). =head2 How can I roll over my logfiles automatically at midnight? Long-running applications tend to produce ever-increasing logfiles. For backup and cleanup purposes, however, it is often desirable to move the current logfile to a different location from time to time and start writing a new one. This is a non-trivial task, because it has to happen in sync with the logging system in order not to lose any messages in the process. Luckily, I's C appender works well with Log::Log4perl to rotate your logfiles in a variety of ways. Note, however, that having the application deal with rotating a log file is not cheap. Among other things, it requires locking the log file with every write to avoid race conditions. There are good reasons to use external rotators like C instead. See the entry C in the FAQ for more information on how to configure it. When using C, all you have to do is specify it in your Log::Log4perl configuration file and your logfiles will be rotated automatically. You can choose between rolling based on a maximum size ("roll if greater than 10 MB") or based on a date pattern ("roll everyday at midnight"). In both cases, C allows you to define a number C of saved files to keep around until it starts overwriting the oldest ones. If you set the C parameter to 2 and the name of your logfile is C, C will move C to C on the first rollover. On the second rollover, it will move C to C and then C to C. On the third rollover, it will move C to C (therefore discarding the old C) and C to C. And so forth. This way, there's always going to be a maximum of 2 saved log files around. Here's an example of a Log::Log4perl configuration file, defining a daily rollover at midnight (date pattern C), keeping a maximum of 5 saved logfiles around: log4perl.category = WARN, Logfile log4perl.appender.Logfile = Log::Dispatch::FileRotate log4perl.appender.Logfile.filename = test.log log4perl.appender.Logfile.max = 5 log4perl.appender.Logfile.DatePattern = yyyy-MM-dd log4perl.appender.Logfile.TZ = PST log4perl.appender.Logfile.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.Logfile.layout.ConversionPattern = %d %m %n Please see the C documentation for details. C is available on CPAN. =head2 What's the easiest way to turn off all logging, even with a lengthy Log4perl configuration file? In addition to category-based levels and appender thresholds, Log::Log4perl supports system-wide logging thresholds. This is the minimum level the system will require of any logging events in order for them to make it through to any configured appenders. For example, putting the line log4perl.threshold = ERROR anywhere in your configuration file will limit any output to any appender to events with priority of ERROR or higher (ERROR or FATAL that is). However, in order to suppress all logging entirely, you need to use a priority that's higher than FATAL: It is simply called C, and it is never used by any logger. By definition, it is higher than the highest defined logger level. Therefore, if you keep the line log4perl.threshold = OFF somewhere in your Log::Log4perl configuration, the system will be quiet as a graveyard. If you deactivate the line (e.g. by commenting it out), the system will, upon config reload, snap back to normal operation, providing logging messages according to the rest of the configuration file again. =head2 I keep getting duplicate log messages! What's wrong? Having several settings for related categories in the Log4perl configuration file sometimes leads to a phenomenon called "message duplication". It can be very confusing at first, but if thought through properly, it turns out that Log4perl behaves as advertised. But, don't despair, of course there's a number of ways to avoid message duplication in your logs. Here's a sample Log4perl configuration file that produces the phenomenon: log4perl.logger.Cat = ERROR, Screen log4perl.logger.Cat.Subcat = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.layout = SimpleLayout It defines two loggers, one for category C and one for C, which is obviously a subcategory of C. The parent logger has a priority setting of ERROR, the child is set to the lower C level. Now imagine the following code in your program: my $logger = get_logger("Cat.Subcat"); $logger->warn("Warning!"); What do you think will happen? An unexperienced Log4perl user might think: "Well, the message is being sent with level WARN, so the C logger will accept it and forward it to the attached C appender. Then, the message will percolate up the logger hierarchy, find the C logger, which will suppress the message because of its ERROR setting." But, perhaps surprisingly, what you'll get with the code snippet above is not one but two log messages written to the screen: WARN - Warning! WARN - Warning! What happened? The culprit is that once the logger C decides to fire, it will forward the message I to all directly or indirectly attached appenders. The C logger will never be asked if it wants the message or not -- the message will just be pushed through to the appender attached to C. One way to prevent the message from bubbling up the logger hierarchy is to set the C flag of the subordinate logger to C<0>: log4perl.logger.Cat = ERROR, Screen log4perl.logger.Cat.Subcat = WARN, Screen log4perl.additivity.Cat.Subcat = 0 log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.layout = SimpleLayout The message will now be accepted by the C logger, forwarded to its appender, but then C will suppress any further action. While this setting avoids duplicate messages as seen before, it is often not the desired behavior. Messages percolating up the hierarchy are a useful Log4perl feature. If you're defining I appenders for the two loggers, one other option is to define an appender threshold for the higher-level appender. Typically it is set to be equal to the logger's level setting: log4perl.logger.Cat = ERROR, Screen1 log4perl.logger.Cat.Subcat = WARN, Screen2 log4perl.appender.Screen1 = Log::Log4perl::Appender::Screen log4perl.appender.Screen1.layout = SimpleLayout log4perl.appender.Screen1.Threshold = ERROR log4perl.appender.Screen2 = Log::Log4perl::Appender::Screen log4perl.appender.Screen2.layout = SimpleLayout Since the C appender now blocks every message with a priority less than ERROR, even if the logger in charge lets it through, the message percolating up the hierarchy is being blocked at the last minute and I appended to C. So far, we've been operating well within the boundaries of the Log4j standard, which Log4perl adheres to. However, if you would really, really like to use a single appender and keep the message percolation intact without having to deal with message duplication, there's a non-standard solution for you: log4perl.logger.Cat = ERROR, Screen log4perl.logger.Cat.Subcat = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.layout = SimpleLayout log4perl.oneMessagePerAppender = 1 The C flag will suppress duplicate messages to the same appender. Again, that's non-standard. But way cool :). =head2 How can I configure Log::Log4perl to send me email if something happens? Some incidents require immediate action. You can't wait until someone checks the log files, you need to get notified on your pager right away. The easiest way to do that is by using the C module as an appender. It comes with the C bundle and allows you to specify recipient and subject of outgoing emails in the Log4perl configuration file: log4perl.category = FATAL, Mailer log4perl.appender.Mailer = Log::Dispatch::Email::MailSend log4perl.appender.Mailer.to = drone@pageme.net log4perl.appender.Mailer.subject = Something's broken! log4perl.appender.Mailer.layout = SimpleLayout The message of every log incident this appender gets will then be forwarded to the given email address. Check the C documentation for details. And please make sure there's not a flood of email messages sent out by your application, filling up the receipient's inbox. There's one caveat you need to know about: The C hierarchy of appenders turns on I by default. This means that the appender will not send out messages right away but wait until a certain threshold has been reached. If you'd rather have your alerts sent out immeditately, use log4perl.appender.Mailer.buffered = 0 to turn buffering off. =head2 How can I write my own appender? First off, Log::Log4perl comes with a set of standard appenders. Then, there's a lot of Log4perl-compatible appenders already available on CPAN: Just run a search for C on http://search.cpan.org and chances are that what you're looking for has already been developed, debugged and been used successfully in production -- no need for you to reinvent the wheel. Also, Log::Log4perl ships with a nifty database appender named Log::Log4perl::Appender::DBI -- check it out if talking to databases is your desire. But if you're up for a truly exotic task, you might have to write an appender yourself. That's very easy -- it takes no longer than a couple of minutes. Say, we wanted to create an appender of the class C, which logs messages to the screen in a configurable color. Just create a new class in C: package ColorScreenAppender; Now let's assume that your Log::Log4perl configuration file C looks like this: log4perl.logger = INFO, ColorApp log4perl.appender.ColorApp=ColorScreenAppender log4perl.appender.ColorApp.color=blue log4perl.appender.ColorApp.layout = PatternLayout log4perl.appender.ColorApp.layout.ConversionPattern=%d %m %n This will cause Log::Log4perl on C to look for a class ColorScreenAppender and call its constructor new(). Let's add new() to ColorScreenAppender.pm: sub new { my($class, %options) = @_; my $self = { %options }; bless $self, $class; return $self; } To initialize this appender, Log::Log4perl will call and pass all attributes of the appender as defined in the configuration file to the constructor as name/value pairs (in this case just one): ColorScreenAppender->new(color => "blue"); The new() method listed above stores the contents of the %options hash in the object's instance data hash (referred to by $self). That's all for initializing a new appender with Log::Log4perl. Second, ColorScreenAppender needs to expose a C method, which will be called by Log::Log4perl every time it thinks the appender should fire. Along with the object reference (as usual in Perl's object world), log() will receive a list of name/value pairs, of which only the one under the key C shall be of interest for now since it is the message string to be logged. At this point, Log::Log4perl has already taken care of joining the message to be a single string. For our special appender ColorScreenAppender, we're using the Term::ANSIColor module to colorize the output: use Term::ANSIColor; sub log { my($self, %params) = @_; print colored($params{message}, $self->{color}); } The color (as configured in the Log::Log4perl configuration file) is available as $self-E{color} in the appender object. Don't forget to return 1; at the end of ColorScreenAppender.pm and you're done. Install the new appender somewhere where perl can find it and try it with a test script like use Log::Log4perl qw(:easy); Log::Log4perl->init("test.conf"); ERROR("blah"); to see the new colored output. Is this cool or what? And it gets even better: You can write dynamically generated appender classes using the C module. Here's an example of an appender prepending every outgoing message with a configurable number of bullets: use Class::Prototyped; my $class = Class::Prototyped->newPackage( "MyAppenders::Bulletizer", bullets => 1, log => sub { my($self, %params) = @_; print "*" x $self->bullets(), $params{message}; }, ); use Log::Log4perl qw(:easy); Log::Log4perl->init(\ q{ log4perl.logger = INFO, Bully log4perl.appender.Bully=MyAppenders::Bulletizer log4perl.appender.Bully.bullets=3 log4perl.appender.Bully.layout = PatternLayout log4perl.appender.Bully.layout.ConversionPattern=%m %n }); # ... prints: "***Boo!\n"; INFO "Boo!"; =head2 How can I drill down on references before logging them? If you've got a reference to a nested structure or object, then you probably don't want to log it as C but rather dump it as something like $VAR1 = { 'a' => 'b', 'd' => 'e' }; via a module like Data::Dumper. While it's syntactically correct to say $logger->debug(Data::Dumper::Dumper($ref)); this call imposes a huge performance penalty on your application if the message is suppressed by Log::Log4perl, because Data::Dumper will perform its expensive operations in any case, because it doesn't know that its output will be thrown away immediately. As of Log::Log4perl 0.28, there's a better way: Use the message output filter format as in $logger->debug( {filter => \&Data::Dumper::Dumper, value => $ref} ); and Log::Log4perl won't call the filter function unless the message really gets written out to an appender. Just make sure to pass the whole slew as a reference to a hash specifying a filter function (as a sub reference) under the key C and the value to be passed to the filter function in C). When it comes to logging, Log::Log4perl will call the filter function, pass the C as an argument and log the return value. Saves you serious cycles. =head2 How can I collect all FATAL messages in an extra log file? Suppose you have employed Log4perl all over your system and you've already activated logging in various subsystems. On top of that, without disrupting any other settings, how can you collect all FATAL messages all over the system and send them to a separate log file? If you define a root logger like this: log4perl.logger = FATAL, File log4perl.appender.File = Log::Log4perl::Appender::File log4perl.appender.File.filename = /tmp/fatal.txt log4perl.appender.File.layout = PatternLayout log4perl.appender.File.layout.ConversionPattern= %d %m %n # !!! Something's missing ... you'll be surprised to not only receive all FATAL messages issued anywhere in the system, but also everything else -- gazillions of ERROR, WARN, INFO and even DEBUG messages will end up in your fatal.txt logfile! Reason for this is Log4perl's (or better: Log4j's) appender additivity. Once a lower-level logger decides to fire, the message is going to be forwarded to all appenders upstream -- without further priority checks with their attached loggers. There's a way to prevent this, however: If your appender defines a minimum threshold, only messages of this priority or higher are going to be logged. So, just add log4perl.appender.File.Threshold = FATAL to the configuration above, and you'll get what you wanted in the first place: An overall system FATAL message collector. =head2 How can I bundle several log messages into one? Would you like to tally the messages arriving at your appender and dump out a summary once they're exceeding a certain threshold? So that something like $logger->error("Blah"); $logger->error("Blah"); $logger->error("Blah"); won't be logged as Blah Blah Blah but as [3] Blah instead? If you'd like to hold off on logging a message until it has been sent a couple of times, you can roll that out by creating a buffered appender. Let's define a new appender like package TallyAppender; sub new { my($class, %options) = @_; my $self = { maxcount => 5, %options }; bless $self, $class; $self->{last_message} = ""; $self->{last_message_count} = 0; return $self; } with two additional instance variables C and C, storing the content of the last message sent and a counter of how many times this has happened. Also, it features a configuration parameter C which defaults to 5 in the snippet above but can be set in the Log4perl configuration file like this: log4perl.logger = INFO, A log4perl.appender.A=TallyAppender log4perl.appender.A.maxcount = 3 The main tallying logic lies in the appender's C method, which is called every time Log4perl thinks a message needs to get logged by our appender: sub log { my($self, %params) = @_; # Message changed? Print buffer. if($self->{last_message} and $params{message} ne $self->{last_message}) { print "[$self->{last_message_count}]: " . "$self->{last_message}"; $self->{last_message_count} = 1; $self->{last_message} = $params{message}; return; } $self->{last_message_count}++; $self->{last_message} = $params{message}; # Threshold exceeded? Print, reset counter if($self->{last_message_count} >= $self->{maxcount}) { print "[$self->{last_message_count}]: " . "$params{message}"; $self->{last_message_count} = 0; $self->{last_message} = ""; return; } } We basically just check if the oncoming message in C<$param{message}> is equal to what we've saved before in the C instance variable. If so, we're increasing C. We print the message in two cases: If the new message is different than the buffered one, because then we need to dump the old stuff and store the new. Or, if the counter exceeds the threshold, as defined by the C configuration parameter. Please note that the appender always gets the fully rendered message and just compares it as a whole -- so if there's a date/timestamp in there, that might confuse your logic. You can work around this by specifying %m %n as a layout and add the date later on in the appender. Or, make the comparison smart enough to omit the date. At last, don't forget what happens if the program is being shut down. If there's still messages in the buffer, they should be printed out at that point. That's easy to do in the appender's DESTROY method, which gets called at object destruction time: sub DESTROY { my($self) = @_; if($self->{last_message_count}) { print "[$self->{last_message_count}]: " . "$self->{last_message}"; return; } } This will ensure that none of the buffered messages are lost. Happy buffering! =head2 I want to log ERROR and WARN messages to different files! How can I do that? Let's assume you wanted to have each logging statement written to a different file, based on the statement's priority. Messages with priority C are supposed to go to C, events prioritized as C should end up in C. Now, if you define two appenders C and C and assign them both to the root logger, messages bubbling up from any loggers below will be logged by both appenders because of Log4perl's message propagation feature. If you limit their exposure via the appender threshold mechanism and set C's threshold to C and C's to C, you'll still get C messages in C, because C's C setting will just filter out messages with a I priority than C -- C is higher and will be allowed to pass through. What we need for this is a Log4perl I, available with Log::Log4perl 0.30. Both appenders need to verify that the priority of the oncoming messages exactly I the priority the appender is supposed to log messages of. To accomplish this task, let's define two custom filters, C and C, which, when attached to their appenders, will limit messages passed on to them to those matching a given priority: log4perl.logger = WARN, AppWarn, AppError # Filter to match level ERROR log4perl.filter.MatchError = Log::Log4perl::Filter::LevelMatch log4perl.filter.MatchError.LevelToMatch = ERROR log4perl.filter.MatchError.AcceptOnMatch = true # Filter to match level WARN log4perl.filter.MatchWarn = Log::Log4perl::Filter::LevelMatch log4perl.filter.MatchWarn.LevelToMatch = WARN log4perl.filter.MatchWarn.AcceptOnMatch = true # Error appender log4perl.appender.AppError = Log::Log4perl::Appender::File log4perl.appender.AppError.filename = /tmp/app.err log4perl.appender.AppError.layout = SimpleLayout log4perl.appender.AppError.Filter = MatchError # Warning appender log4perl.appender.AppWarn = Log::Log4perl::Appender::File log4perl.appender.AppWarn.filename = /tmp/app.warn log4perl.appender.AppWarn.layout = SimpleLayout log4perl.appender.AppWarn.Filter = MatchWarn The appenders C and C defined above are logging to C and C respectively and have the custom filters C and C attached. This setup will direct all WARN messages, issued anywhere in the system, to /tmp/app.warn (and ERROR messages to /tmp/app.error) -- without any overlaps. =head2 On our server farm, Log::Log4perl configuration files differ slightly from host to host. Can I roll them all into one? You sure can, because Log::Log4perl allows you to specify attribute values dynamically. Let's say that one of your appenders expects the host's IP address as one of its attributes. Now, you could certainly roll out different configuration files for every host and specify the value like log4perl.appender.MyAppender = Log::Log4perl::Appender::SomeAppender log4perl.appender.MyAppender.ip = 10.0.0.127 but that's a maintenance nightmare. Instead, you can have Log::Log4perl figure out the IP address at configuration time and set the appender's value correctly: # Set the IP address dynamically log4perl.appender.MyAppender = Log::Log4perl::Appender::SomeAppender log4perl.appender.MyAppender.ip = sub { \ use Sys::Hostname; \ use Socket; \ return inet_ntoa(scalar gethostbyname hostname); \ } If Log::Log4perl detects that an attribute value starts with something like C<"sub {...">, it will interpret it as a perl subroutine which is to be executed once at configuration time (not runtime!) and its return value is to be used as the attribute value. This comes in handy for rolling out applications whichs Log::Log4perl configuration files show small host-specific differences, because you can deploy the unmodified application distribution on all instances of the server farm. =head2 Log4perl doesn't interpret my backslashes correctly! If you're using Log4perl's feature to specify the configuration as a string in your program (as opposed to a separate configuration file), chances are that you've written it like this: # *** WRONG! *** Log::Log4perl->init( \ <EEND_HERE>) and that Perl won't interpret backslashes at line-ends as continuation characters but will essentially throw them out. So, in the code above, the layout line will look like log4perl.appender.A1.layout = to Log::Log4perl which causes it to report an error. To interpret the backslash at the end of the line correctly as a line-continuation character, use the non-interpreting mode of the here-document like in # *** RIGHT! *** Log::Log4perl->init( \ <<'END_HERE'); log4perl.logger = WARN, A1 log4perl.appender.A1 = Log::Log4perl::Appender::Screen log4perl.appender.A1.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.A1.layout.ConversionPattern = %m%n END_HERE # *** RIGHT! *** (note the single quotes around C<'END_HERE'>) or use C instead of a here-document and Perl will treat the backslashes at line-end as intended. =head2 I want to suppress certain messages based on their content! Let's assume you've plastered all your functions with Log4perl statements like sub some_func { INFO("Begin of function"); # ... Stuff happens here ... INFO("End of function"); } to issue two log messages, one at the beginning and one at the end of each function. Now you want to suppress the message at the beginning and only keep the one at the end, what can you do? You can't use the category mechanism, because both messages are issued from the same package. Log::Log4perl's custom filters (0.30 or better) provide an interface for the Log4perl user to step in right before a message gets logged and decide if it should be written out or suppressed, based on the message content or other parameters: use Log::Log4perl qw(:easy); Log::Log4perl::init( \ <<'EOT' ); log4perl.logger = INFO, A1 log4perl.appender.A1 = Log::Log4perl::Appender::Screen log4perl.appender.A1.layout = \ Log::Log4perl::Layout::PatternLayout log4perl.appender.A1.layout.ConversionPattern = %m%n log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch log4perl.filter.M1.StringToMatch = Begin log4perl.filter.M1.AcceptOnMatch = false log4perl.appender.A1.Filter = M1 EOT The last four statements in the configuration above are defining a custom filter C of type C, which comes with Log4perl right out of the box and allows you to define a text pattern to match (as a perl regular expression) and a flag C indicating if a match is supposed to suppress the message or let it pass through. The last line then assigns this filter to the C appender, which will call it every time it receives a message to be logged and throw all messages out I matching the regular expression C. Instead of using the standard C filter, you can define your own, simply using a perl subroutine: log4perl.filter.ExcludeBegin = sub { !/Begin/ } log4perl.appender.A1.Filter = ExcludeBegin For details on custom filters, check L. =head2 My new module uses Log4perl -- but what happens if the calling program didn't configure it? If a Perl module uses Log::Log4perl, it will typically rely on the calling program to initialize it. If it is using Log::Log4perl in C<:easy> mode, like in package MyMod; use Log::Log4perl qw(:easy); sub foo { DEBUG("In foo"); } 1; and the calling program doesn't initialize Log::Log4perl at all (e.g. because it has no clue that it's available), Log::Log4perl will silently ignore all logging messages. However, if the module is using Log::Log4perl in regular mode like in package MyMod; use Log::Log4perl qw(get_logger); sub foo { my $logger = get_logger(""); $logger->debug("blah"); } 1; and the main program is just using the module like in use MyMode; MyMode::foo(); then Log::Log4perl will also ignore all logging messages but issue a warning like Log4perl: Seems like no initialization happened. Forgot to call init()? (only once!) to remind novice users to not forget to initialize the logging system before using it. However, if you want to suppress this message, just add the C<:nowarn> target to the module's C call: use Log::Log4perl qw(get_logger :nowarn); This will have Log::Log4perl silently ignore all logging statements if no initialization has taken place. If, instead of using init(), you're using Log4perl's API to define loggers and appenders, the same notification happens if no call to add_appenders() is made, i.e. no appenders are defined. If the module wants to figure out if some other program part has already initialized Log::Log4perl, it can do so by calling Log::Log4perl::initialized() which will return a true value in case Log::Log4perl has been initialized and a false value if not. =head2 How can I synchronize access to an appender? If you're using the same instance of an appender in multiple processes, and each process is passing on messages to the appender in parallel, you might end up with overlapping log entries. Typical scenarios include a file appender that you create in the main program, and which will then be shared between the parent and a forked child process. Or two separate processes, each initializing a Log4perl file appender on the same logfile. Log::Log4perl won't synchronize access to the shared logfile by default. Depending on your operating system's flush mechanism, buffer size and the size of your messages, there's a small chance of an overlap. The easiest way to prevent overlapping messages in logfiles written to by multiple processes is setting the file appender's C flag along with a file write mode of C<"append">. This makes sure that C uses C (which is guaranteed to run uninterrupted) instead of C which might buffer the message or get interrupted by the OS while it is writing. And in C<"append"> mode, the OS kernel ensures that multiple processes share one end-of-file marker, ensuring that each process writes to the I end of the file. (The value of C<"append"> for the C parameter is the default setting in Log4perl's file appender so you don't have to set it explicitely.) # Guarantees atomic writes log4perl.category.Bar.Twix = WARN, Logfile log4perl.appender.Logfile = Log::Log4perl::Appender::File log4perl.appender.Logfile.mode = append log4perl.appender.Logfile.syswrite = 1 log4perl.appender.Logfile.filename = test.log log4perl.appender.Logfile.layout = SimpleLayout Another guaranteed way of having messages separated with any kind of appender is putting a Log::Log4perl::Appender::Synchronized composite appender in between Log::Log4perl and the real appender. It will make sure to let messages pass through this virtual gate one by one only. Here's a sample configuration to synchronize access to a file appender: log4perl.category.Bar.Twix = WARN, Syncer log4perl.appender.Logfile = Log::Log4perl::Appender::File log4perl.appender.Logfile.autoflush = 1 log4perl.appender.Logfile.filename = test.log log4perl.appender.Logfile.layout = SimpleLayout log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized log4perl.appender.Syncer.appender = Logfile C uses the C module and its semaphores, which will slow down writing the log messages, but ensures sequential access featuring atomic checks. Check L for details. =head2 Can I use Log::Log4perl with log4j's Chainsaw? Yes, Log::Log4perl can be configured to send its events to log4j's graphical log UI I. =for html

Figure 1: Chainsaw receives Log::Log4perl events

=for text Figure1: Chainsaw receives Log::Log4perl events Here's how it works: =over 4 =item * Get Guido Carls' Egcarls@cpan.orgE Log::Log4perl extension C from CPAN and install it: perl -MCPAN -eshell cpan> install Log::Log4perl::Layout::XMLLayout =item * Install and start Chainsaw, which is part of the C distribution now (see http://jakarta.apache.org/log4j ). Create a configuration file like and name it e.g. C. Then start Chainsaw like java -Dlog4j.debug=true -Dlog4j.configuration=config.xml \ -classpath ".:log4j-1.3alpha.jar:log4j-chainsaw-1.3alpha.jar" \ org.apache.log4j.chainsaw.LogUI and watch the GUI coming up. =item * Configure Log::Log4perl to use a socket appender with an XMLLayout, pointing to the host/port where Chainsaw (as configured above) is waiting with its XMLSocketReceiver: use Log::Log4perl qw(get_logger); use Log::Log4perl::Layout::XMLLayout; my $conf = q( log4perl.category.Bar.Twix = WARN, Appender log4perl.appender.Appender = Log::Log4perl::Appender::Socket log4perl.appender.Appender.PeerAddr = localhost log4perl.appender.Appender.PeerPort = 4445 log4perl.appender.Appender.layout = Log::Log4perl::Layout::XMLLayout ); Log::Log4perl::init(\$conf); # Nasty hack to suppress encoding header my $app = Log::Log4perl::appenders->{"Appender"}; $app->layout()->{enc_set} = 1; my $logger = get_logger("Bar.Twix"); $logger->error("One"); The nasty hack shown in the code snippet above is currently (October 2003) necessary, because Chainsaw expects XML messages to arrive in a format like without a preceding which Log::Log4perl::Layout::XMLLayout applies to the first event sent over the socket. =back See figure 1 for a screenshot of Chainsaw in action, receiving events from the Perl script shown above. Many thanks to Chainsaw's Scott Deboy for his support! =head2 How can I run Log::Log4perl under mod_perl? In persistent environments it's important to play by the rules outlined in section L. If you haven't read this yet, please go ahead and read it right now. It's very important. And no matter if you use a startup handler to init() Log::Log4perl or use the init_once() strategy (added in 0.42), either way you're very likely to have unsynchronized writes to logfiles. If Log::Log4perl is configured with a log file appender, and it is initialized via the Apache startup handler, the file handle created initially will be shared among all Apache processes. Similarly, with the init_once() approach: although every process has a separate L4p configuration, processes are gonna share the appender file I instead, effectively opening several different file handles on the same file. Now, having several appenders using the same file handle or having several appenders logging to the same file unsynchronized, this might result in overlapping messages. Sometimes, this is acceptable. If it's not, here's two strategies: =over 4 =item * Use the L appender to connect to your file appenders. Here's the writeup: http://log4perl.sourceforge.net/releases/Log-Log4perl/docs/html/Log/Log4perl/FAQ.html#23804 =item * Use a different logfile for every process like in #log4perl.conf ... log4perl.appender.A1.filename = sub { "mylog.$$.log" } =back =head2 My program already uses warn() and die(). How can I switch to Log4perl? If your program already uses Perl's C function to spew out error messages and you'd like to channel those into the Log4perl world, just define a C<__WARN__> handler where your program or module resides: use Log::Log4perl qw(:easy); $SIG{__WARN__} = sub { local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; WARN @_; }; Why the C setting of C<$Log::Log4perl::caller_depth>? If you leave that out, C conversion specifiers like C<%M> or C<%F> (printing the current function/method and source filename) will refer to where the __WARN__ handler resides, not the environment Perl's C function was issued from. Increasing C adjusts for this offset. Having it C, makes sure the level gets set back after the handler exits. Once done, if your program does something like sub some_func { warn "Here's a warning"; } you'll get (depending on your Log::Log4perl configuration) something like 2004/02/19 20:41:02-main::some_func: Here's a warning at ./t line 25. in the appropriate appender instead of having a screen full of STDERR messages. It also works with the C module and its C and C functions. If, on the other hand, catching C and friends is required, a C<__DIE__> handler is appropriate: $SIG{__DIE__} = sub { if($^S) { # We're in an eval {} and don't want log # this message but catch it later return; } local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; LOGDIE @_; }; This will call Log4perl's C function, which will log a fatal error and then call die() internally, causing the program to exit. Works equally well with C's C and C functions. =head2 Some module prints messages to STDERR. How can I funnel them to Log::Log4perl? If a module you're using doesn't use Log::Log4perl but prints logging messages to STDERR instead, like ######################################## package IgnorantModule; ######################################## sub some_method { print STDERR "Parbleu! An error!\n"; } 1; there's still a way to capture these messages and funnel them into Log::Log4perl, even without touching the module. What you need is a trapper module like ######################################## package Trapper; ######################################## use Log::Log4perl qw(:easy); sub TIEHANDLE { my $class = shift; bless [], $class; } sub PRINT { my $self = shift; $Log::Log4perl::caller_depth++; DEBUG @_; $Log::Log4perl::caller_depth--; } 1; and a C command in the main program to tie STDERR to the trapper module along with regular Log::Log4perl initialization: ######################################## package main; ######################################## use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( {level => $DEBUG, file => 'stdout', # make sure not to use stderr here! layout => "%d %M: %m%n", }); tie *STDERR, "Trapper"; Make sure not to use STDERR as Log::Log4perl's file appender here (which would be the default in C<:easy> mode), because it would end up in an endless recursion. Now, calling IgnorantModule::some_method(); will result in the desired output 2004/05/06 11:13:04 IgnorantModule::some_method: Parbleu! An error! =head2 How come PAR (Perl Archive Toolkit) creates executables which then can't find their Log::Log4perl appenders? If not instructed otherwise, C dynamically pulls in appender classes found in its configuration. If you specify #!/usr/bin/perl # mytest.pl use Log::Log4perl qw(get_logger); my $conf = q( log4perl.category.Bar.Twix = WARN, Logfile log4perl.appender.Logfile = Log::Log4perl::Appender::Screen log4perl.appender.Logfile.layout = SimpleLayout ); Log::Log4perl::init(\$conf); my $logger = get_logger("Bar::Twix"); $logger->error("Blah"); then C will be pulled in while the program runs, not at compile time. If you have PAR compile the script above to an executable binary via pp -o mytest mytest.pl and then run C on a machine without having Log::Log4perl installed, you'll get an error message like ERROR: can't load appenderclass 'Log::Log4perl::Appender::Screen' Can't locate Log/Log4perl/Appender/Screen.pm in @INC ... Why? At compile time, C didn't realize that C would be needed later on and didn't wrap it into the executable created. To avoid this, either say C in the script explicitely or compile it with pp -o mytest -M Log::Log4perl::Appender::Screen mytest.pl to make sure the appender class gets included. =head2 How can I access a custom appender defined in the configuration? Any appender defined in the configuration file or somewhere in the code can be accessed later via Cappender_by_name("appender_name")>, which returns a reference the the appender object. Once you've got a hold of the object, it can be queried or modified to your liking. For example, see the custom C defined below: After calling C to define the Log4perl settings, the appender object is retrieved to call its C and C methods to control indentation of messages: package IndentAppender; sub new { bless { indent => 0 }, $_[0]; } sub indent_more { $_[0]->{indent}++ } sub indent_less { $_[0]->{indent}-- } sub log { my($self, %params) = @_; print " " x $self->{indent}, $params{message}; } package main; use Log::Log4perl qw(:easy); my $conf = q( log4perl.category = DEBUG, Indented log4perl.appender.Indented = IndentAppender log4perl.appender.Indented.layout = Log::Log4perl::Layout::SimpleLayout ); Log::Log4perl::init(\$conf); my $appender = Log::Log4perl->appender_by_name("Indented"); DEBUG "No identation"; $appender->indent_more(); DEBUG "One more"; $appender->indent_more(); DEBUG "Two more"; $appender->indent_less(); DEBUG "One less"; As you would expect, this will print DEBUG - No identation DEBUG - One more DEBUG - Two more DEBUG - One less because the very appender used by Log4perl is modified dynamically at runtime. =head2 I don't know if Log::Log4perl is installed. How can I prepare my script? In case your script needs to be prepared for environments that may or may not have Log::Log4perl installed, there's a trick. If you put the following BEGIN blocks at the top of the program, you'll be able to use the DEBUG(), INFO(), etc. macros in Log::Log4perl's C<:easy> mode. If Log::Log4perl is installed in the target environment, the regular Log::Log4perl rules apply. If not, all of DEBUG(), INFO(), etc. are "stubbed" out, i.e. they turn into no-ops: use warnings; use strict; BEGIN { eval { require Log::Log4perl; }; if($@) { print "Log::Log4perl not installed - stubbing.\n"; no strict qw(refs); *{"main::$_"} = sub { } for qw(DEBUG INFO WARN ERROR FATAL); } else { no warnings; print "Log::Log4perl installed - life is good.\n"; require Log::Log4perl::Level; Log::Log4perl::Level->import(__PACKAGE__); Log::Log4perl->import(qw(:easy)); Log::Log4perl->easy_init($main::DEBUG); } } # The regular script begins ... DEBUG "Hey now!"; This snippet will first probe for Log::Log4perl, and if it can't be found, it will alias DEBUG(), INFO(), with empty subroutines via typeglobs. If Log::Log4perl is available, its level constants are first imported (C<$DEBUG>, C<$INFO>, etc.) and then C gets called to initialize the logging system. =head2 Can file appenders create files with different permissions? Typically, when C creates a new file, its permissions are set to C. Why? Because your environment's I most likely defaults to C<0022>, that's the standard setting. What's a I, you're asking? It's a template that's applied to the permissions of all newly created files. While calls like Cfoo")> will always try to create files in C mode, the system will apply the current I template to determine the final permission setting. I is a bit mask that's inverted and then applied to the requested permission setting, using a bitwise AND: $request_permission &~ $umask So, a I setting of 0000 (the leading 0 simply indicates an octal value) will create files in C mode, a setting of 0277 will use C, and the standard 0022 will use C. As an example, if you want your log files to be created with C permissions, use a I of C<0020> before calling Log::Log4perl->init(): use Log::Log4perl; umask 0020; # Creates log.out in rw-r--rw mode Log::Log4perl->init(\ q{ log4perl.logger = WARN, File log4perl.appender.File = Log::Log4perl::Appender::File log4perl.appender.File.filename = log.out log4perl.appender.File.layout = SimpleLayout }); =head2 Using Log4perl in an END block causes a problem! It's not easy to get to this error, but if you write something like END { Log::Log4perl::get_logger()->debug("Hey there."); } use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); it won't work. The reason is that C defines an END block that cleans up all loggers. And perl will run END blocks in the reverse order as they're encountered in the compile phase, so in the scenario above, the END block will run I Log4perl has cleaned up its loggers. Placing END blocks using Log4perl I a C statement fixes the problem: use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); END { Log::Log4perl::get_logger()->debug("Hey there."); } In this scenario, the shown END block is executed I Log4perl cleans up and the debug message will be processed properly. =head2 Help! My appender is throwing a "Wide character in print" warning! This warning shows up when Unicode strings are printed without precautions. The warning goes away if the complaining appender is set to utf-8 mode: # Either in the log4perl configuration file: log4perl.appender.Logfile.filename = test.log log4perl.appender.Logfile.utf8 = 1 # Or, in easy mode: Log::Log4perl->easy_init( { level => $DEBUG, file => ":utf8> test.log" } ); If the complaining appender is a screen appender, set its C option: log4perl.appender.Screen.stderr = 1 log4perl.appender.Screen.utf8 = 1 Alternatively, C does the trick: # Either STDOUT ... binmode(STDOUT, ":utf8); # ... or STDERR. binmode(STDERR, ":utf8); Some background on this: Perl's strings are either byte strings or Unicode strings. C<"Mike"> is a byte string. C<"\x{30DE}\x{30A4}\x{30AF}"> is a Unicode string. Unicode strings are marked specially and are UTF-8 encoded internally. If you print a byte string to STDOUT, all is well, because STDOUT is by default set to byte mode. However, if you print a Unicode string to STDOUT without precautions, C will try to transform the Unicode string back to a byte string before printing it out. This is troublesome if the Unicode string contains 'wide' characters which can't be represented in Latin-1. For example, if you create a Unicode string with three japanese Katakana characters as in perl -le 'print "\x{30DE}\x{30A4}\x{30AF}"' (coincidentally pronounced Ma-i-ku, the japanese pronounciation of "Mike"), STDOUT is in byte mode and the warning Wide character in print at ./script.pl line 14. appears. Setting STDOUT to UTF-8 mode as in perl -le 'binmode(STDOUT, ":utf8"); print "\x{30DE}\x{30A4}\x{30AF}"' will silently print the Unicode string to STDOUT in UTF-8. To see the characters printed, you'll need a UTF-8 terminal with a font including japanese Katakana characters. =head2 How can I send errors to the screen, and debug messages to a file? Let's assume you want to maintain a detailed DEBUG output in a file and only messages of level ERROR and higher should be printed on the screen. Often times, developers come up with something like this: # Wrong!!! log4perl.logger = DEBUG, FileApp log4perl.logger = ERROR, ScreenApp # Wrong!!! This won't work, however. Logger definitions aren't additive, and the second statement will overwrite the first one. Log4perl versions below 1.04 were silently accepting this, leaving people confused why it wouldn't work as expected. As of 1.04, this will throw a I to notify the user of the problem. What you want to do instead, is this: log4perl.logger = DEBUG, FileApp, ScreenApp log4perl.appender.FileApp = Log::Log4perl::Appender::File log4perl.appender.FileApp.filename = test.log log4perl.appender.FileApp.layout = SimpleLayout log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen log4perl.appender.ScreenApp.stderr = 0 log4perl.appender.ScreenApp.layout = SimpleLayout ### limiting output to ERROR messages log4perl.appender.ScreenApp.Threshold = ERROR ### Note that without the second appender's C setting, both appenders would receive all messages prioritized DEBUG and higher. With the threshold set to ERROR, the second appender will filter the messages as required. =head2 Where should I put my logfiles? Your log files may go anywhere you want them, but the effective user id of the calling process must have write access. If the log file doesn't exist at program start, Log4perl's file appender will create it. For this, it needs write access to the directory where the new file will be located in. If the log file already exists at startup, the process simply needs write access to the file. Note that it will need write access to the file's directory if you're encountering situations where the logfile gets recreated, e.g. during log rotation. If Log::Log4perl is used by a web server application (e.g. in a CGI script or mod_perl), then the webserver's user (usually C or C) must have the permissions mentioned above. To prepare your web server to use log4perl, we'd recommend: webserver:~$ su - webserver:~# mkdir /var/log/cgiapps webserver:~# chown nobody:root /var/log/cgiapps/ webserver:~# chown nobody:root -R /var/log/cgiapps/ webserver:~# chmod 02755 -R /var/log/cgiapps/ Then set your /etc/log4perl.conf file to include: log4perl.appender.FileAppndr1.filename = /var/log/cgiapps/.log =head2 How can my file appender deal with disappearing log files? The file appender that comes with Log4perl, L, will open a specified log file at initialization time and will keep writing to it via a file handle. In case the associated file goes way, messages written by a long-running process will still be written to the file handle. In case the file has been moved to a different location on the same file system, the writer will keep writing to it under the new filename. In case the file has been removed from the file system, the log messages will end up in nowhere land. This is not a bug in Log4perl, this is how Unix works. There is no error message in this case, because the writer has no idea that the file handle is not associated with a visible file. To prevent the loss of log messages when log files disappear, the file appender's C option needs to be set to a true value: log4perl.appender.Logfile.recreate = 1 This will instruct the file appender to check in regular intervals (default: 30 seconds) if the log file is still there. If it finds out that the file is missing, it will recreate it. Continuously checking if the log file still exists is fairly expensive. For this reason it is only performed every 30 seconds. To change this interval, the option C can be set to the number of seconds between checks. In the extreme case where the check should be performed before every write, it can even be set to 0: log4perl.appender.Logfile.recreate = 1 log4perl.appender.Logfile.recreate_check_interval = 0 To avoid having to check the file system so frequently, a signal handler can be set up: log4perl.appender.Logfile.recreate = 1 log4perl.appender.Logfile.recreate_check_signal = USR1 This will install a signal handler which will recreate a missing log file immediatly when it receives the defined signal. Note that the init_and_watch() method for Log4perl's initialization can also be instructed to install a signal handler, usually using the HUP signal. Make sure to use a different signal if you're using both of them at the same time. =head2 How can I rotate a logfile with newsyslog? Here's a few things that need to be taken care of when using the popular log file rotating utilty C (http://www.courtesan.com/newsyslog) with Log4perl's file appender in long-running processes. For example, with a newsyslog configuration like # newsyslog.conf /tmp/test.log 666 12 5 * B and a call to # newsyslog -f /path/to/newsyslog.conf C will take action if C is larger than the specified 5K in size. It will move the current log file C to C and create a new and empty C with the specified permissions (this is why C needs to run as root). An already existing C would be moved to C, C to C, and so forth, for every one of a max number of 12 archived logfiles that have been configured in C. Although a new file has been created, from Log4perl's appender's point of view, this situation is identical to the one described in the previous FAQ entry, labeled C. To make sure that log messages are written to the new log file and not to an archived one or end up in nowhere land, the appender's C and C have to be configured to deal with the 'disappearing' log file. The situation gets interesting when C's option to compress archived log files is enabled. This causes the original log file not to be moved, but to disappear. If the file appender isn't configured to recreate the logfile in this situation, log messages will actually be lost without warning. This also applies for the short time frame of C seconds in between the recreator's file checks. To make sure that no messages get lost, one option is to set the interval to log4perl.appender.Logfile.recreate_check_interval = 0 However, this is fairly expensive. A better approach is to define a signal handler: log4perl.appender.Logfile.recreate = 1 log4perl.appender.Logfile.recreate_check_signal = USR1 log4perl.appender.Logfile.recreate_pid_write = /tmp/myappid As a service for C users, Log4perl's file appender writes the current process ID to a PID file specified by the C option. C then needs to be configured as in # newsyslog.conf configuration for compressing archive files and # sending a signal to the Log4perl-enabled application /tmp/test.log 666 12 5 * B /tmp/myappid 30 to send the defined signal (30, which is USR1 on FreeBSD) to the application process at rotation time. Note that the signal number is different on Linux, where USR1 denotes as 10. Check C for details. =head2 How can a process under user id A log to a file under user id B? This scenario often occurs in configurations where processes run under various user IDs but need to write to a log file under a fixed, but different user id. With a traditional file appender, the log file will probably be created under one user's id and appended to under a different user's id. With a typical umask of 0002, the file will be created with -rw-rw-r-- permissions. If a user who's not in the first user's group subsequently appends to the log file, it will fail because of a permission problem. Two potential solutions come to mind: =over 4 =item * Creating the file with a umask of 0000 will allow all users to append to the log file. Log4perl's file appender C has an C option that can be set to support this: log4perl.appender.File = Log::Log4perl::Appender::File log4perl.appender.File.umask = sub { 0000 }; This way, the log file will be created with -rw-rw-rw- permissions and therefore has world write permissions. This might open up the logfile for unwanted manipulations by arbitrary users, though. =item * Running the process under an effective user id of C will allow it to write to the log file, no matter who started the process. However, this is not a good idea, because of security concerns. =back Luckily, under Unix, there's the syslog daemon which runs as root and takes log requests from user processes over a socket and writes them to log files as configured in C. By modifying C and HUPing the syslog daemon, you can configure new log files: # /etc/syslog.conf ... user.* /some/path/file.log Using the C appender, which comes with the C distribution, you can then send messages via syslog: use Log::Log4perl qw(:easy); Log::Log4perl->init(\< $DEBUG, category => '', %options }; $self->{logger} = get_logger($self->{category}), bless $self, $class; } sub PRINT { my($self, @rest) = @_; $Log::Log4perl::caller_depth++; $self->{logger}->log($self->{level}, @rest); $Log::Log4perl::caller_depth--; } sub PRINTF { my($self, $fmt, @rest) = @_; $Log::Log4perl::caller_depth++; $self->PRINT(sprintf($fmt, @rest)); $Log::Log4perl::caller_depth--; } 1; Now, if you have a function like sub function_printing_to_fh { my($fh) = @_; printf $fh "Hi there!\n"; } which takes a filehandle and prints something to it, it can be used with Log4perl: use Log::Log4perl qw(:easy); usa FileHandleLogger; Log::Log4perl->easy_init($DEBUG); tie *SOMEHANDLE, 'FileHandleLogger' or die "tie failed ($!)"; function_printing_to_fh(*SOMEHANDLE); # prints "2007/03/22 21:43:30 Hi there!" If you want, you can even specify a different log level or category: tie *SOMEHANDLE, 'FileHandleLogger', level => $INFO, category => "Foo::Bar" or die "tie failed ($!)"; =head2 I want multiline messages rendered line-by-line! With the standard C, if you send a multiline message to an appender as in use Log::Log4perl qw(:easy); Log it gets rendered this way: 2007/04/04 23:23:39 multi line message If you want each line to be rendered separately according to the layout use C: use Log::Log4perl qw(:easy); Log::Log4perl->init(\<easy_init($DEBUG); my $a = A->new(); $a->{selfref} = $a; then you'll see the error message shown above during global destruction. How to tackle this problem? First, you should clean up your circular references before global destruction. They will not only cause objects to be destroyed in an order that's hard to predict, but also eat up memory until the program shuts down. So, the program above could easily be fixed by putting $a->{selfref} = undef; at the end or in an END handler. If that's hard to do, use weak references: package main; use Scalar::Util qw(weaken); use Log::Log4perl qw(:easy); Log::Log4perl->easy_init($DEBUG); my $a = A->new(); $a->{selfref} = weaken $a; This allows perl to clean up the circular reference when the object goes out of scope, and doesn't wait until global destruction. =head2 How can I access POE heap values from Log4perl's layout? POE is a framework for creating multitasked applications running in a single process and a single thread. POE's threads equivalents are 'sessions' and since they run quasi-simultaneously, you can't use Log4perl's global NDC/MDC to hold session-specific data. However, POE already maintains a data store for every session. It is called 'heap' and is just a hash storing session-specific data in key-value pairs. To access this per-session heap data from a Log4perl layout, define a custom cspec and reference it with the newly defined pattern in the layout: use strict; use POE; use Log::Log4perl qw(:easy); Log::Log4perl->init( \ q{ log4perl.logger = DEBUG, Screen log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.layout = PatternLayout log4perl.appender.Screen.layout.ConversionPattern = %U %m%n log4perl.PatternLayout.cspec.U = \ sub { POE::Kernel->get_active_session->get_heap()->{ user } } } ); for (qw( Huey Lewey Dewey )) { POE::Session->create( inline_states => { _start => sub { $_[HEAP]->{user} = $_; POE::Kernel->yield('hello'); }, hello => sub { DEBUG "I'm here now"; } } ); } POE::Kernel->run(); exit; The code snippet above defines a new layout placeholder (called 'cspec' in Log4perl) %U which calls a subroutine, retrieves the active session, gets its heap and looks up the entry specified ('user'). Starting with Log::Log4perl 1.20, cspecs also support parameters in curly braces, so you can say log4perl.appender.Screen.layout.ConversionPattern = %U{user} %U{id} %m%n log4perl.PatternLayout.cspec.U = \ sub { POE::Kernel->get_active_session-> \ get_heap()->{ $_[0]->{curlies} } } and print the POE session heap entries 'user' and 'id' with every logged message. For more details on cpecs, read the PatternLayout manual. =head2 I want to print something unconditionally! Sometimes it's a script that's supposed to log messages regardless if Log4perl has been initialized or not. Or there's a logging statement that's not going to be suppressed under any circumstances -- many people want to have the final word, make the executive decision, because it seems like the only logical choice. But think about it: First off, if a messages is supposed to be printed, where is it supposed to end up at? STDOUT? STDERR? And are you sure you want to set in stone that this message needs to be printed, while someone else might find it annoying and wants to get rid of it? The truth is, there's always going to be someone who wants to log a messages at all cost, but also another person who wants to suppress it with equal vigilance. There's no good way to serve these two conflicting desires, someone will always want to win at the cost of leaving the other party dissappointed. So, the best Log4perl offers is the ALWAYS level for a message that even fires if the system log level is set to $OFF: use Log::Log4perl qw(:easy); Log::Log4perl->easy_init( $OFF ); ALWAYS "This gets logged always. Well, almost always"; The logger won't fire, though, if Log4perl hasn't been initialized or if someone defines a custom log hurdle that's higher than $OFF. Bottom line: Leave the setting of the logging level to the initial Perl script -- let their owners decided what they want, no matter how tempting it may be to decide it for them. =cut =head1 SEE ALSO Log::Log4perl =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ~װ&&Level.pmnu[###############r################################### package Log::Log4perl::Level; ################################################## use 5.006; use strict; use warnings; use Carp; # log4j, for whatever reason, puts 0 as all and MAXINT as OFF. # this seems less optimal, as more logging would imply a higher # level. But oh well. Probably some brokenness that has persisted. :) use constant ALL_INT => 0; use constant TRACE_INT => 5000; use constant DEBUG_INT => 10000; use constant INFO_INT => 20000; use constant WARN_INT => 30000; use constant ERROR_INT => 40000; use constant FATAL_INT => 50000; use constant OFF_INT => (2 ** 31) - 1; no strict qw(refs); use vars qw(%PRIORITY %LEVELS %SYSLOG %L4P_TO_LD); %PRIORITY = (); # unless (%PRIORITY); %LEVELS = () unless (%LEVELS); %SYSLOG = () unless (%SYSLOG); %L4P_TO_LD = () unless (%L4P_TO_LD); sub add_priority { my ($prio, $intval, $syslog, $log_dispatch_level) = @_; $prio = uc($prio); # just in case; $PRIORITY{$prio} = $intval; $LEVELS{$intval} = $prio; # Set up the mapping between Log4perl integer levels and # Log::Dispatch levels # Note: Log::Dispatch uses the following levels: # 0 debug # 1 info # 2 notice # 3 warning # 4 error # 5 critical # 6 alert # 7 emergency # The equivalent Log::Dispatch level is optional, set it to # the highest value (7=emerg) if it's not provided. $log_dispatch_level = 7 unless defined $log_dispatch_level; $L4P_TO_LD{$prio} = $log_dispatch_level; $SYSLOG{$prio} = $syslog if defined($syslog); } # create the basic priorities add_priority("OFF", OFF_INT, -1, 7); add_priority("FATAL", FATAL_INT, 0, 7); add_priority("ERROR", ERROR_INT, 3, 4); add_priority("WARN", WARN_INT, 4, 3); add_priority("INFO", INFO_INT, 6, 1); add_priority("DEBUG", DEBUG_INT, 7, 0); add_priority("TRACE", TRACE_INT, 8, 0); add_priority("ALL", ALL_INT, 8, 0); # we often sort numerically, so a helper func for readability sub numerically {$a <=> $b} ########################################### sub import { ########################################### my($class, $namespace) = @_; if(defined $namespace) { # Export $OFF, $FATAL, $ERROR etc. to # the given namespace $namespace .= "::" unless $namespace =~ /::$/; } else { # Export $OFF, $FATAL, $ERROR etc. to # the caller's namespace $namespace = caller(0) . "::"; } for my $key (keys %PRIORITY) { my $name = "$namespace$key"; my $value = $PRIORITY{$key}; *{"$name"} = \$value; my $nameint = "$namespace${key}_INT"; my $func = uc($key) . "_INT"; *{"$nameint"} = \&$func; } } ################################################## sub new { ################################################## # We don't need any of this class nonsense # in Perl, because we won't allow subclassing # from this. We're optimizing for raw speed. } ################################################## sub to_priority { # changes a level name string to a priority numeric ################################################## my($string) = @_; if(exists $PRIORITY{$string}) { return $PRIORITY{$string}; }else{ croak "level '$string' is not a valid error level (".join ('|', keys %PRIORITY),')'; } } ################################################## sub to_level { # changes a priority numeric constant to a level name string ################################################## my ($priority) = @_; if (exists $LEVELS{$priority}) { return $LEVELS{$priority} }else { croak("priority '$priority' is not a valid error level number (", join("|", sort numerically keys %LEVELS), " )"); } } ################################################## sub to_LogDispatch_string { # translates into strings that Log::Dispatch recognizes ################################################## my($priority) = @_; confess "do what? no priority?" unless defined $priority; my $string; if(exists $LEVELS{$priority}) { $string = $LEVELS{$priority}; } # Log::Dispatch idiosyncrasies if($priority == $PRIORITY{WARN}) { $string = "WARNING"; } if($priority == $PRIORITY{FATAL}) { $string = "EMERGENCY"; } return $string; } ################################################### sub is_valid { ################################################### my $q = shift; if ($q =~ /[A-Z]/) { return exists $PRIORITY{$q}; }else{ return $LEVELS{$q}; } } sub get_higher_level { my ($old_priority, $delta) = @_; $delta ||= 1; my $new_priority = 0; foreach (1..$delta){ #so the list is TRACE, DEBUG, INFO, WARN, ERROR, FATAL # but remember, the numbers go in reverse order! foreach my $p (sort numerically keys %LEVELS){ if ($p > $old_priority) { $new_priority = $p; last; } } $old_priority = $new_priority; } return $new_priority; } sub get_lower_level { my ($old_priority, $delta) = @_; $delta ||= 1; my $new_priority = 0; foreach (1..$delta){ #so the list is FATAL, ERROR, WARN, INFO, DEBUG, TRACE # but remember, the numbers go in reverse order! foreach my $p (reverse sort numerically keys %LEVELS){ if ($p < $old_priority) { $new_priority = $p; last; } } $old_priority = $new_priority; } return $new_priority; } sub isGreaterOrEqual { my $lval = shift; my $rval = shift; # in theory, we should check if the above really ARE valid levels. # but we just use numeric comparison, since they aren't really classes. # oh, yeah, and 'cuz level ints go from 0 .. N with 0 being highest, # these are reversed. return $lval <= $rval; } ###################################################################### # # since the integer representation of levels is reversed from what # we normally want, we don't want to use < and >... instead, we # want to use this comparison function 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Level - Predefined log levels =head1 SYNOPSIS use Log::Log4perl::Level; print $ERROR, "\n"; # -- or -- use Log::Log4perl qw(:levels); print $ERROR, "\n"; =head1 DESCRIPTION C simply exports a predefined set of I log levels into the caller's name space. It is used internally by C. The following scalars are defined: $OFF $FATAL $ERROR $WARN $INFO $DEBUG $TRACE $ALL C also exports these constants into the caller's namespace if you pull it in providing the C<:levels> tag: use Log::Log4perl qw(:levels); This is the preferred way, there's usually no need to call C explicitely. The numerical values assigned to these constants are purely virtual, only used by Log::Log4perl internally and can change at any time, so please don't make any assumptions. You can test for numerical equality by directly comparing two level values, that's ok: if( get_logger()->level() == $DEBUG ) { print "The logger's level is DEBUG\n"; } But if you want to figure out which of two levels is more verbose, use Log4perl's own comparator: if( Log::Log4perl::Level::isGreaterOrEqual( $level1, $level2 ) ) { print Log::Log4perl::Level::to_level( $level1 ), " is equal or more verbose than ", Log::Log4perl::Level::to_level( $level2 ), "\n"; } If the caller wants to import level constants into a different namespace, it can be provided with the C command: use Log::Log4perl::Level qw(MyNameSpace); After this C<$MyNameSpace::ERROR>, C<$MyNameSpace::INFO> etc. will be defined accordingly. =head2 Numeric levels and Strings Level variables like $DEBUG or $WARN have numeric values that are internal to Log4perl. Transform them to strings that can be used in a Log4perl configuration file, use the c function provided by Log::Log4perl::Level: use Log::Log4perl qw(:easy); use Log::Log4perl::Level; # prints "DEBUG" print Log::Log4perl::Level::to_level( $DEBUG ), "\n"; To perform the reverse transformation, which takes a string like "DEBUG" and converts it into a constant like C<$DEBUG>, use the to_priority() function: use Log::Log4perl qw(:easy); use Log::Log4perl::Level; my $numval = Log::Log4perl::Level::to_priority( "DEBUG" ); after which $numval could be used where a numerical value is required: Log::Log4perl->easy_init( $numval ); =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZE  !Layout/PatternLayout/Multiline.pmnu[#!/usr/bin/perl package Log::Log4perl::Layout::PatternLayout::Multiline; use base qw(Log::Log4perl::Layout::PatternLayout); ########################################### sub render { ########################################### my($self, $message, $category, $priority, $caller_level) = @_; my @messages = split /\r?\n/, $message; $caller_level = 0 unless defined $caller_level; my $result = ''; for my $msg ( @messages ) { $result .= $self->SUPER::render( $msg, $category, $priority, $caller_level + 1 ); } return $result; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Layout::PatternLayout::Multiline =head1 SYNOPSIS use Log::Log4perl::Layout::PatternLayout::Multiline; my $layout = Log::Log4perl::Layout::PatternLayout::Multiline->new( "%d (%F:%L)> %m"); =head1 DESCRIPTION C is a subclass of Log4perl's PatternLayout and is helpful if you send multiline messages to your appenders which appear as 2007/04/04 23:59:01 This is a message with multiple lines and you want them to appear as 2007/04/04 23:59:01 This is 2007/04/04 23:59:01 a message with 2007/04/04 23:59:01 multiple lines instead. This layout class simply splits up the incoming message into several chunks split by line breaks and renders them with PatternLayout just as if it had arrived in separate chunks in the first place. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZy Layout/SimpleLayout.pmnu[################################################## package Log::Log4perl::Layout::SimpleLayout; ################################################## # as documented in # http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/SimpleLayout.html ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Level; no strict qw(refs); use base qw(Log::Log4perl::Layout); ################################################## sub new { ################################################## my $class = shift; $class = ref ($class) || $class; my $self = { format => undef, info_needed => {}, stack => [], }; bless $self, $class; return $self; } ################################################## sub render { ################################################## my($self, $message, $category, $priority, $caller_level) = @_; return "$priority - $message\n"; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Layout::SimpleLayout - Simple Layout =head1 SYNOPSIS use Log::Log4perl::Layout::SimpleLayout; my $layout = Log::Log4perl::Layout::SimpleLayout->new(); =head1 DESCRIPTION This class implements the C simple layout format -- it basically just prints the message priority and the message, that's all. Check http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/SimpleLayout.html for details. =head1 SEE ALSO =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ'<<Layout/NoopLayout.pmnu[################################################## package Log::Log4perl::Layout::NoopLayout; ################################################## ################################################## sub new { ################################################## my $class = shift; $class = ref ($class) || $class; my $self = { format => undef, info_needed => {}, stack => [], }; bless $self, $class; return $self; } ################################################## sub render { ################################################## #my($self, $message, $category, $priority, $caller_level) = @_; return $_[1];; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Layout::NoopLayout - Pass-thru Layout =head1 SYNOPSIS use Log::Log4perl::Layout::NoopLayout; my $layout = Log::Log4perl::Layout::NoopLayout->new(); =head1 DESCRIPTION This is a no-op layout, returns the logging message unaltered, useful for implementing the DBI logger. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZH+Y3k3kLayout/PatternLayout.pmnu[################################################## package Log::Log4perl::Layout::PatternLayout; ################################################## use 5.006; use strict; use warnings; use constant _INTERNAL_DEBUG => 0; use Carp; use Log::Log4perl; use Log::Log4perl::Util; use Log::Log4perl::Level; use Log::Log4perl::DateFormat; use Log::Log4perl::NDC; use Log::Log4perl::MDC; use Log::Log4perl::Util::TimeTracker; use File::Spec; use File::Basename; our $TIME_HIRES_AVAILABLE_WARNED = 0; our $HOSTNAME; our %GLOBAL_USER_DEFINED_CSPECS = (); our $CSPECS = 'cCdFHIlLmMnpPrRtTxX%'; BEGIN { # Check if we've got Sys::Hostname. If not, just punt. $HOSTNAME = "unknown.host"; if(Log::Log4perl::Util::module_available("Sys::Hostname")) { require Sys::Hostname; $HOSTNAME = Sys::Hostname::hostname(); } } use base qw(Log::Log4perl::Layout); no strict qw(refs); ################################################## sub new { ################################################## my $class = shift; $class = ref ($class) || $class; my $options = ref $_[0] eq "HASH" ? shift : {}; my $layout_string = @_ ? shift : '%m%n'; my $self = { format => undef, info_needed => {}, stack => [], CSPECS => $CSPECS, dontCollapseArrayRefs => $options->{dontCollapseArrayRefs}{value}, last_time => undef, undef_column_value => (exists $options->{ undef_column_value } ? $options->{ undef_column_value } : "[undef]"), }; $self->{timer} = Log::Log4perl::Util::TimeTracker->new( time_function => $options->{time_function} ); if(exists $options->{ConversionPattern}->{value}) { $layout_string = $options->{ConversionPattern}->{value}; } if(exists $options->{message_chomp_before_newline}) { $self->{message_chomp_before_newline} = $options->{message_chomp_before_newline}->{value}; } else { $self->{message_chomp_before_newline} = 1; } bless $self, $class; #add the global user-defined cspecs foreach my $f (keys %GLOBAL_USER_DEFINED_CSPECS){ #add it to the list of letters $self->{CSPECS} .= $f; #for globals, the coderef is already evaled, $self->{USER_DEFINED_CSPECS}{$f} = $GLOBAL_USER_DEFINED_CSPECS{$f}; } #add the user-defined cspecs local to this appender foreach my $f (keys %{$options->{cspec}}){ $self->add_layout_cspec($f, $options->{cspec}{$f}{value}); } # non-portable line breaks $layout_string =~ s/\\n/\n/g; $layout_string =~ s/\\r/\r/g; $self->define($layout_string); return $self; } ################################################## sub define { ################################################## my($self, $format) = @_; # If the message contains a %m followed by a newline, # make a note of that so that we can cut a superfluous # \n off the message later on if($self->{message_chomp_before_newline} and $format =~ /%m%n/) { $self->{message_chompable} = 1; } else { $self->{message_chompable} = 0; } # Parse the format $format =~ s/%(-?\d*(?:\.\d+)?) ([$self->{CSPECS}]) (?:{(.*?)})*/ rep($self, $1, $2, $3); /gex; $self->{printformat} = $format; } ################################################## sub rep { ################################################## my($self, $num, $op, $curlies) = @_; return "%%" if $op eq "%"; # If it's a %d{...} construct, initialize a simple date # format formatter, so that we can quickly render later on. # If it's just %d, assume %d{yyyy/MM/dd HH:mm:ss} my $sdf; if($op eq "d") { if(defined $curlies) { $sdf = Log::Log4perl::DateFormat->new($curlies); } else { $sdf = Log::Log4perl::DateFormat->new("yyyy/MM/dd HH:mm:ss"); } } push @{$self->{stack}}, [$op, $sdf || $curlies]; $self->{info_needed}->{$op}++; return "%${num}s"; } ################################################## sub render { ################################################## my($self, $message, $category, $priority, $caller_level) = @_; $caller_level = 0 unless defined $caller_level; my %info = (); $info{m} = $message; # See 'define' chomp $info{m} if $self->{message_chompable}; my @results = (); my $caller_offset = Log::Log4perl::caller_depth_offset( $caller_level ); if($self->{info_needed}->{L} or $self->{info_needed}->{F} or $self->{info_needed}->{C} or $self->{info_needed}->{l} or $self->{info_needed}->{M} or $self->{info_needed}->{T} or 0 ) { my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($caller_offset); # If caller() choked because of a whacko caller level, # correct undefined values to '[undef]' in order to prevent # warning messages when interpolating later unless(defined $bitmask) { for($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask) { $_ = '[undef]' unless defined $_; } } $info{L} = $line; $info{F} = $filename; $info{C} = $package; if($self->{info_needed}->{M} or $self->{info_needed}->{l} or 0) { # To obtain the name of the subroutine which triggered the # logger, we need to go one additional level up. my $levels_up = 1; { my @callinfo = caller($caller_offset+$levels_up); if(_INTERNAL_DEBUG) { callinfo_dump( $caller_offset, \@callinfo ); } $subroutine = $callinfo[3]; # If we're inside an eval, go up one level further. if(defined $subroutine and $subroutine eq "(eval)") { print "Inside an eval, one up\n" if _INTERNAL_DEBUG; $levels_up++; redo; } } $subroutine = "main::" unless $subroutine; print "Subroutine is '$subroutine'\n" if _INTERNAL_DEBUG; $info{M} = $subroutine; $info{l} = "$subroutine $filename ($line)"; } } $info{X} = "[No curlies defined]"; $info{x} = Log::Log4perl::NDC->get() if $self->{info_needed}->{x}; $info{c} = $category; $info{d} = 1; # Dummy value, corrected later $info{n} = "\n"; $info{p} = $priority; $info{P} = $$; $info{H} = $HOSTNAME; my $current_time; if($self->{info_needed}->{r} or $self->{info_needed}->{R}) { if(!$TIME_HIRES_AVAILABLE_WARNED++ and !$self->{timer}->hires_available()) { warn "Requested %r/%R pattern without installed Time::HiRes\n"; } $current_time = [$self->{timer}->gettimeofday()]; } if($self->{info_needed}->{r}) { $info{r} = $self->{timer}->milliseconds( $current_time ); } if($self->{info_needed}->{R}) { $info{R} = $self->{timer}->delta_milliseconds( $current_time ); } # Stack trace wanted? if($self->{info_needed}->{T}) { local $Carp::CarpLevel = $Carp::CarpLevel + $caller_offset; my $mess = Carp::longmess(); chomp($mess); # $mess =~ s/(?:\A\s*at.*\n|^\s*Log::Log4perl.*\n|^\s*)//mg; $mess =~ s/(?:\A\s*at.*\n|^\s*)//mg; $mess =~ s/\n/, /g; $info{T} = $mess; } # As long as they're not implemented yet .. $info{t} = "N/A"; # Iterate over all info fields on the stack for my $e (@{$self->{stack}}) { my($op, $curlies) = @$e; my $result; if(exists $self->{USER_DEFINED_CSPECS}->{$op}) { next unless $self->{info_needed}->{$op}; $self->{curlies} = $curlies; $result = $self->{USER_DEFINED_CSPECS}->{$op}->($self, $message, $category, $priority, $caller_offset+1); } elsif(exists $info{$op}) { $result = $info{$op}; if($curlies) { $result = $self->curly_action($op, $curlies, $info{$op}); } else { # just for %d if($op eq 'd') { $result = $info{$op}->format($self->{timer}->gettimeofday()); } } } else { warn "Format %'$op' not implemented (yet)"; $result = "FORMAT-ERROR"; } $result = $self->{undef_column_value} unless defined $result; push @results, $result; } # dbi appender needs that if( scalar @results == 1 and !defined $results[0] ) { return undef; } return (sprintf $self->{printformat}, @results); } ################################################## sub curly_action { ################################################## my($self, $ops, $curlies, $data) = @_; if($ops eq "c") { $data = shrink_category($data, $curlies); } elsif($ops eq "C") { $data = shrink_category($data, $curlies); } elsif($ops eq "X") { $data = Log::Log4perl::MDC->get($curlies); } elsif($ops eq "d") { $data = $curlies->format( $self->{timer}->gettimeofday() ); } elsif($ops eq "M") { $data = shrink_category($data, $curlies); } elsif($ops eq "m") { if($curlies eq "chomp") { chomp $data; } } elsif($ops eq "F") { my @parts = File::Spec->splitdir($data); # Limit it to max curlies entries if(@parts > $curlies) { splice @parts, 0, @parts - $curlies; } $data = File::Spec->catfile(@parts); } elsif($ops eq "p") { $data = substr $data, 0, $curlies; } return $data; } ################################################## sub shrink_category { ################################################## my($category, $len) = @_; my @components = split /\.|::/, $category; if(@components > $len) { splice @components, 0, @components - $len; $category = join '.', @components; } return $category; } ################################################## sub add_global_cspec { ################################################## # This is a Class method. # Accepts a coderef or text ################################################## unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . "prohibits user defined cspecs"; } my ($letter, $perlcode) = @_; croak "Illegal value '$letter' in call to add_global_cspec()" unless ($letter =~ /^[a-zA-Z]$/); croak "Missing argument for perlcode for 'cspec.$letter' ". "in call to add_global_cspec()" unless $perlcode; croak "Please don't redefine built-in cspecs [$CSPECS]\n". "like you do for \"cspec.$letter\"\n " if ($CSPECS =~/$letter/); if (ref $perlcode eq 'CODE') { $GLOBAL_USER_DEFINED_CSPECS{$letter} = $perlcode; }elsif (! ref $perlcode){ $GLOBAL_USER_DEFINED_CSPECS{$letter} = Log::Log4perl::Config::compile_if_perl($perlcode); if ($@) { die qq{Compilation failed for your perl code for }. qq{"log4j.PatternLayout.cspec.$letter":\n}. qq{This is the error message: \t$@\n}. qq{This is the code that failed: \n$perlcode\n}; } croak "eval'ing your perlcode for 'log4j.PatternLayout.cspec.$letter' ". "doesn't return a coderef \n". "Here is the perl code: \n\t$perlcode\n " unless (ref $GLOBAL_USER_DEFINED_CSPECS{$letter} eq 'CODE'); }else{ croak "I don't know how to handle perlcode=$perlcode ". "for 'cspec.$letter' in call to add_global_cspec()"; } } ################################################## sub add_layout_cspec { ################################################## # object method # adds a cspec just for this layout ################################################## my ($self, $letter, $perlcode) = @_; unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . "prohibits user defined cspecs"; } croak "Illegal value '$letter' in call to add_layout_cspec()" unless ($letter =~ /^[a-zA-Z]$/); croak "Missing argument for perlcode for 'cspec.$letter' ". "in call to add_layout_cspec()" unless $perlcode; croak "Please don't redefine built-in cspecs [$CSPECS] \n". "like you do for 'cspec.$letter'" if ($CSPECS =~/$letter/); if (ref $perlcode eq 'CODE') { $self->{USER_DEFINED_CSPECS}{$letter} = $perlcode; }elsif (! ref $perlcode){ $self->{USER_DEFINED_CSPECS}{$letter} = Log::Log4perl::Config::compile_if_perl($perlcode); if ($@) { die qq{Compilation failed for your perl code for }. qq{"cspec.$letter":\n}. qq{This is the error message: \t$@\n}. qq{This is the code that failed: \n$perlcode\n}; } croak "eval'ing your perlcode for 'cspec.$letter' ". "doesn't return a coderef \n". "Here is the perl code: \n\t$perlcode\n " unless (ref $self->{USER_DEFINED_CSPECS}{$letter} eq 'CODE'); }else{ croak "I don't know how to handle perlcode=$perlcode ". "for 'cspec.$letter' in call to add_layout_cspec()"; } $self->{CSPECS} .= $letter; } ########################################### sub callinfo_dump { ########################################### my($level, $info) = @_; my @called_by = caller(0); # Just for internal debugging $called_by[1] = basename $called_by[1]; print "caller($level) at $called_by[1]-$called_by[2] returned "; my @by_idx; # $info->[1] = basename $info->[1] if defined $info->[1]; my $i = 0; for my $field (qw(package filename line subroutine hasargs wantarray evaltext is_require hints bitmask)) { $by_idx[$i] = $field; $i++; } $i = 0; for my $value (@$info) { my $field = $by_idx[ $i ]; print "$field=", (defined $info->[$i] ? $info->[$i] : "[undef]"), " "; $i++; } print "\n"; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Layout::PatternLayout - Pattern Layout =head1 SYNOPSIS use Log::Log4perl::Layout::PatternLayout; my $layout = Log::Log4perl::Layout::PatternLayout->new( "%d (%F:%L)> %m"); =head1 DESCRIPTION Creates a pattern layout according to http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/PatternLayout.html and a couple of Log::Log4perl-specific extensions. The C method creates a new PatternLayout, specifying its log format. The format string can contain a number of placeholders which will be replaced by the logging engine when it's time to log the message: %c Category of the logging event. %C Fully qualified package (or class) name of the caller %d Current date in yyyy/MM/dd hh:mm:ss format %d{...} Current date in customized format (see below) %F File where the logging event occurred %H Hostname (if Sys::Hostname is available) %l Fully qualified name of the calling method followed by the callers source the file name and line number between parentheses. %L Line number within the file where the log statement was issued %m The message to be logged %m{chomp} The message to be logged, stripped off a trailing newline %M Method or function where the logging request was issued %n Newline (OS-independent) %p Priority of the logging event (%p{1} shows the first letter) %P pid of the current process %r Number of milliseconds elapsed from program start to logging event %R Number of milliseconds elapsed from last logging event to current logging event %T A stack trace of functions called %x The topmost NDC (see below) %X{key} The entry 'key' of the MDC (see below) %% A literal percent (%) sign NDC and MDC are explained in L and L. The granularity of time values is milliseconds if Time::HiRes is available. If not, only full seconds are used. Every once in a while, someone uses the "%m%n" pattern and additionally provides an extra newline in the log message (e.g. C<-Elog("message\n")>. To avoid printing an extra newline in this case, the PatternLayout will chomp the message, printing only one newline. This option can be controlled by PatternLayout's C option. See L for details. =head2 Quantify placeholders All placeholders can be extended with formatting instructions, just like in I: %20c Reserve 20 chars for the category, right-justify and fill with blanks if it is shorter %-20c Same as %20c, but left-justify and fill the right side with blanks %09r Zero-pad the number of milliseconds to 9 digits %.8c Specify the maximum field with and have the formatter cut off the rest of the value =head2 Fine-tuning with curlies Some placeholders have special functions defined if you add curlies with content after them: %c{1} Just show the right-most category compontent, useful in large class hierarchies (Foo::Baz::Bar -> Bar) %c{2} Just show the two right most category components (Foo::Baz::Bar -> Baz::Bar) %F Display source file including full path %F{1} Just display filename %F{2} Display filename and last path component (dir/test.log) %F{3} Display filename and last two path components (d1/d2/test.log) %M Display fully qualified method/function name %M{1} Just display method name (foo) %M{2} Display method name and last path component (main::foo) In this way, you're able to shrink the displayed category or limit file/path components to save space in your logs. =head2 Fine-tune the date If you're not happy with the default %d format for the date which looks like yyyy/MM/DD HH:mm:ss (which is slightly different from Log4j which uses C) you're free to fine-tune it in order to display only certain characteristics of a date, according to the SimpleDateFormat in the Java World (http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.html): %d{HH:mm} "23:45" -- Just display hours and minutes %d{yy, EEEE} "02, Monday" -- Just display two-digit year and spelled-out weekday Here's the symbols and their meaning, according to the SimpleDateFormat specification: Symbol Meaning Presentation Example ------ ------- ------------ ------- G era designator (Text) AD y year (Number) 1996 M month in year (Text & Number) July & 07 d day in month (Number) 10 h hour in am/pm (1-12) (Number) 12 H hour in day (0-23) (Number) 0 m minute in hour (Number) 30 s second in minute (Number) 55 E day in week (Text) Tuesday D day in year (Number) 189 a am/pm marker (Text) PM e epoch seconds (Number) 1315011604 (Text): 4 or more pattern letters--use full form, < 4--use short or abbreviated form if one exists. (Number): the minimum number of digits. Shorter numbers are zero-padded to this amount. Year is handled specially; that is, if the count of 'y' is 2, the Year will be truncated to 2 digits. (Text & Number): 3 or over, use text, otherwise use number. There's also a bunch of pre-defined formats: %d{ABSOLUTE} "HH:mm:ss,SSS" %d{DATE} "dd MMM yyyy HH:mm:ss,SSS" %d{ISO8601} "yyyy-MM-dd HH:mm:ss,SSS" =head2 Custom cspecs First of all, "cspecs" is short for "conversion specifiers", which is the log4j and the printf(3) term for what Mike is calling "placeholders." I suggested "cspecs" for this part of the api before I saw that Mike was using "placeholders" consistently in the log4perl documentation. Ah, the joys of collaboration ;=) --kg If the existing corpus of placeholders/cspecs isn't good enough for you, you can easily roll your own: #'U' a global user-defined cspec log4j.PatternLayout.cspec.U = sub { return "UID: $< "} #'K' cspec local to appndr1 (pid in hex) log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} #and now you can use them log4j.appender.appndr1.layout.ConversionPattern = %K %U %m%n The benefit of this approach is that you can define and use the cspecs right next to each other in the config file. If you're an API kind of person, there's also this call: Log::Log4perl::Layout::PatternLayout:: add_global_cspec('Z', sub {'zzzzzzzz'}); #snooze? When the log message is being put together, your anonymous sub will be called with these arguments: ($layout, $message, $category, $priority, $caller_level); layout: the PatternLayout object that called it message: the logging message (%m) category: e.g. groceries.beverages.adult.beer.schlitz priority: e.g. DEBUG|WARN|INFO|ERROR|FATAL caller_level: how many levels back up the call stack you have to go to find the caller Please note that the subroutines you're defining in this way are going to be run in the C

namespace, so be sure to fully qualify functions and variables if they're located in different packages. I With Log4perl 1.20 and better, cspecs can be written with parameters in curly braces. Writing something like log4perl.appender.Screen.layout.ConversionPattern = %U{user} %U{id} %m%n will cause the cspec function defined for %U to be called twice, once with the parameter 'user' and then again with the parameter 'id', and the placeholders in the cspec string will be replaced with the respective return values. The parameter value is available in the 'curlies' entry of the first parameter passed to the subroutine (the layout object reference). So, if you wanted to map %U{xxx} to entries in the POE session hash, you'd write something like: log4perl.PatternLayout.cspec.U = sub { \ POE::Kernel->get_active_session->get_heap()->{ $_[0]->{curlies} } } B This feature means arbitrary perl code can be embedded in the config file. In the rare case where the people who have access to your config file are different from the people who write your code and shouldn't have execute rights, you might want to set $Log::Log4perl::Config->allow_code(0); before you call init(). Alternatively you can supply a restricted set of Perl opcodes that can be embedded in the config file as described in L. =head2 Advanced Options The constructor of the C class takes an optional hash reference as a first argument to specify additional options in order to (ab)use it in creative ways: my $layout = Log::Log4perl::Layout::PatternLayout->new( { time_function => \&my_time_func, }, "%d (%F:%L)> %m"); Here's a list of parameters: =over 4 =item time_function Takes a reference to a function returning the time for the time/date fields, either in seconds since the epoch or as an array, carrying seconds and microseconds, just like C does. =item message_chomp_before_newline If a layout contains the pattern "%m%n" and the message ends with a newline, PatternLayout will chomp the message, to prevent printing two newlines. If this is not desired, and you want two newlines in this case, the feature can be turned off by setting the C option to a false value: my $layout = Log::Log4perl::Layout::PatternLayout->new( { message_chomp_before_newline => 0 }, "%d (%F:%L)> %m%n"); In a Log4perl configuration file, the feature can be turned off like this: log4perl.appender.App.layout = PatternLayout log4perl.appender.App.layout.ConversionPattern = %d %m%n # Yes, I want two newlines log4perl.appender.App.layout.message_chomp_before_newline = 0 =back =head2 Getting rid of newlines If your code contains logging statements like # WRONG, don't do that! $logger->debug("Some message\n"); then it's usually best to strip the newlines from these calls. As explained in L, logging statements should never contain newlines, but rely on appender layouts to add necessary newlines instead. If changing the code is not an option, use the special PatternLayout placeholder %m{chomp} to refer to the message excluding a trailing newline: log4perl.appender.App.layout.ConversionPattern = %d %m{chomp}%n This will add a single newline to every message, regardless if it complies with the Log4perl newline guidelines or not (thanks to Tim Bunce for this idea). =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZO JavaMap.pmnu[package Log::Log4perl::JavaMap; use Carp; use strict; use constant _INTERNAL_DEBUG => 0; our %translate = ( 'org.apache.log4j.ConsoleAppender' => 'Log::Log4perl::JavaMap::ConsoleAppender', 'org.apache.log4j.FileAppender' => 'Log::Log4perl::JavaMap::FileAppender', 'org.apache.log4j.RollingFileAppender' => 'Log::Log4perl::JavaMap::RollingFileAppender', 'org.apache.log4j.TestBuffer' => 'Log::Log4perl::JavaMap::TestBuffer', 'org.apache.log4j.jdbc.JDBCAppender' => 'Log::Log4perl::JavaMap::JDBCAppender', 'org.apache.log4j.SyslogAppender' => 'Log::Log4perl::JavaMap::SyslogAppender', 'org.apache.log4j.NTEventLogAppender' => 'Log::Log4perl::JavaMap::NTEventLogAppender', ); our %user_defined; sub get { my ($appender_name, $appender_data) = @_; print "Trying to map $appender_name\n" if _INTERNAL_DEBUG; $appender_data->{value} || die "ERROR: you didn't tell me how to implement your appender " . "'$appender_name'"; my $perl_class = $translate{$appender_data->{value}} || $user_defined{$appender_data->{value}} || die "ERROR: I don't know how to make a '$appender_data->{value}' " . "to implement your appender '$appender_name', that's not a " . "supported class\n"; eval { eval "require $perl_class"; #see 'perldoc -f require' for why two evals die $@ if $@; }; $@ and die "ERROR: trying to set appender for $appender_name to " . "$appender_data->{value} using $perl_class failed\n$@ \n"; my $app = $perl_class->new($appender_name, $appender_data); return $app; } #an external api to the two hashes sub translate { my $java_class = shift; return $translate{$java_class} || $user_defined{$java_class}; } 1; =encoding utf8 =head1 NAME Log::Log4perl::JavaMap - maps java log4j appenders to Log::Dispatch classes =head1 SYNOPSIS ############################### log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender log4j.appender.FileAppndr1.File = /var/log/onetime.log log4j.appender.FileAppndr1.Append = false log4j.appender.FileAppndr1.layout = org.apache.log4j.PatternLayout log4j.appender.FileAppndr1.layout.ConversionPattern=%d %4r [%t] %-5p %c %x - %m%n ############################### =head1 DESCRIPTION If somebody wants to create an appender called C, we want to translate it to Log::Dispatch::Screen, and then translate the log4j options into Log::Dispatch parameters.. =head2 What's Implemented (Note that you can always use the Log::Dispatch::* module. By 'implemented' I mean having a translation class that translates log4j options into the Log::Dispatch options so you can use log4j rather than log4perl syntax in your config file.) Here's the list of appenders I see on the current (6/2002) log4j site. These are implemented ConsoleAppender - Log::Dispatch::Screen FileAppender - Log::Dispatch::File RollingFileAppender - Log::Dispatch::FileRotate (by Mark Pfeiffer) JDBCAppender - Log::Log4perl::Appender::DBI SyslogAppender - Log::Dispatch::Syslog NTEventLogAppender - Log::Dispatch::Win32EventLog These should/will/might be implemented DailyRollingFileAppender - SMTPAppender - Log::Dispatch::Email::MailSender These might be implemented but they don't have corresponding classes in Log::Dispatch (yet): NullAppender TelnetAppender These might be simulated LF5Appender - use Tk? ExternallyRolledFileAppender - catch a HUP instead? These will probably not be implemented AsyncAppender JMSAppender SocketAppender - (ships a serialized LoggingEvent to the server side) SocketHubAppender =head1 ROLL YOUR OWN Let's say you've in a mixed Java/Perl enviroment and you've come up with some custom Java appender with behavior you want to use in both worlds, C. You write a Perl appender with the same behavior C. You want to use one config file accross both applications, so the config file will have to say 'myorg.customAppender'. But the mapping from C to C isn't in this JavaMap class, so what do you do? In your Perl code, before you call Log::Log4perl::init(), do this: $Log::Log4perl::JavaMap::user_defined{'myorg.customAppender'} = 'Myorg::CustomAppender'; and you can use 'myorg.customAppender' in your config file with impunity. =head1 SEE ALSO http://jakarta.apache.org/log4j/docs/ =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZr (7(7 DateFormat.pmnu[########################################### package Log::Log4perl::DateFormat; ########################################### use warnings; use strict; use Carp qw( croak ); our $GMTIME = 0; my @MONTH_NAMES = qw( January February March April May June July August September October November December); my @WEEK_DAYS = qw( Sunday Monday Tuesday Wednesday Thursday Friday Saturday); ########################################### sub new { ########################################### my($class, $format) = @_; my $self = { stack => [], fmt => undef, }; bless $self, $class; # Predefined formats if($format eq "ABSOLUTE") { $format = "HH:mm:ss,SSS"; } elsif($format eq "DATE") { $format = "dd MMM yyyy HH:mm:ss,SSS"; } elsif($format eq "ISO8601") { $format = "yyyy-MM-dd HH:mm:ss,SSS"; } elsif($format eq "APACHE") { $format = "[EEE MMM dd HH:mm:ss yyyy]"; } if($format) { $self->prepare($format); } return $self; } ########################################### sub prepare { ########################################### my($self, $format) = @_; # the actual DateTime spec allows for literal text delimited by # single quotes; a single quote can be embedded in the literal # text by using two single quotes. # # my strategy here is to split the format into active and literal # "chunks"; active chunks are prepared using $self->rep() as # before, while literal chunks get transformed to accomodate # single quotes and to protect percent signs. # # motivation: the "recommended" ISO-8601 date spec for a time in # UTC is actually: # # YYYY-mm-dd'T'hh:mm:ss.SSS'Z' my $fmt = ""; foreach my $chunk ( split /('(?:''|[^'])*')/, $format ) { if ( $chunk =~ /\A'(.*)'\z/ ) { # literal text my $literal = $1; $literal =~ s/''/'/g; $literal =~ s/\%/\%\%/g; $fmt .= $literal; } elsif ( $chunk =~ /'/ ) { # single quotes should always be in a literal croak "bad date format \"$format\": " . "unmatched single quote in chunk \"$chunk\""; } else { # handle active chunks just like before $chunk =~ s/(([GyMdhHmsSEeDFwWakKzZ])\2*)/$self->rep($1)/ge; $fmt .= $chunk; } } return $self->{fmt} = $fmt; } ########################################### sub rep { ########################################### my ($self, $string) = @_; my $first = substr $string, 0, 1; my $len = length $string; my $time=time(); my @g = gmtime($time); my @t = localtime($time); my $z = $t[1]-$g[1]+($t[2]-$g[2])*60+($t[7]-$g[7])*1440+ ($t[5]-$g[5])*(525600+(abs($t[7]-$g[7])>364)*1440); my $offset = sprintf("%+.2d%.2d", $z/60, "00"); #my ($s,$mi,$h,$d,$mo,$y,$wd,$yd,$dst) = localtime($time); # Here's how this works: # Detect what kind of parameter we're dealing with and determine # what type of sprintf-placeholder to return (%d, %02d, %s or whatever). # Then, we're setting up an array, specific to the current format, # that can be used later on to compute the components of the placeholders # one by one when we get the components of the current time later on # via localtime. # So, we're parsing the "yyyy/MM" format once, replace it by, say # "%04d:%02d" and store an array that says "for the first placeholder, # get the localtime-parameter on index #5 (which is years since the # epoch), add 1900 to it and pass it on to sprintf(). For the 2nd # placeholder, get the localtime component at index #2 (which is hours) # and pass it on unmodified to sprintf. # So, the array to compute the time format at logtime contains # as many elements as the original SimpleDateFormat contained. Each # entry is a arrary ref, holding an array with 2 elements: The index # into the localtime to obtain the value and a reference to a subroutine # to do computations eventually. The subroutine expects the orginal # localtime() time component (like year since the epoch) and returns # the desired value for sprintf (like y+1900). # This way, we're parsing the original format only once (during system # startup) and during runtime all we do is call localtime *once* and # run a number of blazingly fast computations, according to the number # of placeholders in the format. ########### #G - epoch# ########### if($first eq "G") { # Always constant return "AD"; ################### #e - epoch seconds# ################### } elsif($first eq "e") { # index (0) irrelevant, but we return time() which # comes in as 2nd parameter push @{$self->{stack}}, [0, sub { return $_[1] }]; return "%d"; ########## #y - year# ########## } elsif($first eq "y") { if($len >= 4) { # 4-digit year push @{$self->{stack}}, [5, sub { return $_[0] + 1900 }]; return "%04d"; } else { # 2-digit year push @{$self->{stack}}, [5, sub { $_[0] % 100 }]; return "%02d"; } ########### #M - month# ########### } elsif($first eq "M") { if($len >= 3) { # Use month name push @{$self->{stack}}, [4, sub { return $MONTH_NAMES[$_[0]] }]; if($len >= 4) { return "%s"; } else { return "%.3s"; } } elsif($len == 2) { # Use zero-padded month number push @{$self->{stack}}, [4, sub { $_[0]+1 }]; return "%02d"; } else { # Use zero-padded month number push @{$self->{stack}}, [4, sub { $_[0]+1 }]; return "%d"; } ################## #d - day of month# ################## } elsif($first eq "d") { push @{$self->{stack}}, [3, sub { return $_[0] }]; return "%0" . $len . "d"; ################## #h - am/pm hour# ################## } elsif($first eq "h") { push @{$self->{stack}}, [2, sub { ($_[0] % 12) || 12 }]; return "%0" . $len . "d"; ################## #H - 24 hour# ################## } elsif($first eq "H") { push @{$self->{stack}}, [2, sub { return $_[0] }]; return "%0" . $len . "d"; ################## #m - minute# ################## } elsif($first eq "m") { push @{$self->{stack}}, [1, sub { return $_[0] }]; return "%0" . $len . "d"; ################## #s - second# ################## } elsif($first eq "s") { push @{$self->{stack}}, [0, sub { return $_[0] }]; return "%0" . $len . "d"; ################## #E - day of week # ################## } elsif($first eq "E") { push @{$self->{stack}}, [6, sub { $WEEK_DAYS[$_[0]] }]; if($len >= 4) { return "%${len}s"; } else { return "%.3s"; } ###################### #D - day of the year # ###################### } elsif($first eq "D") { push @{$self->{stack}}, [7, sub { $_[0] + 1}]; return "%0" . $len . "d"; ###################### #a - am/pm marker # ###################### } elsif($first eq "a") { push @{$self->{stack}}, [2, sub { $_[0] < 12 ? "AM" : "PM" }]; return "%${len}s"; ###################### #S - milliseconds # ###################### } elsif($first eq "S") { push @{$self->{stack}}, [9, sub { substr sprintf("%06d", $_[0]), 0, $len }]; return "%s"; ############################### #Z - RFC 822 time zone -0800 # ############################### } elsif($first eq "Z") { push @{$self->{stack}}, [10, sub { $offset }]; return "$offset"; ############################# #Something that's not defined #(F=day of week in month # w=week in year W=week in month # k=hour in day K=hour in am/pm # z=timezone ############################# } else { return "-- '$first' not (yet) implemented --"; } return $string; } ########################################### sub format { ########################################### my($self, $secs, $msecs) = @_; $msecs = 0 unless defined $msecs; my @time; if($GMTIME) { @time = gmtime($secs); } else { @time = localtime($secs); } # add milliseconds push @time, $msecs; my @values = (); for(@{$self->{stack}}) { my($val, $code) = @$_; if($code) { push @values, $code->($time[$val], $secs); } else { push @values, $time[$val]; } } return sprintf($self->{fmt}, @values); } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::DateFormat - Log4perl advanced date formatter helper class =head1 SYNOPSIS use Log::Log4perl::DateFormat; my $format = Log::Log4perl::DateFormat->new("HH:mm:ss,SSS"); # Simple time, resolution in seconds my $time = time(); print $format->format($time), "\n"; # => "17:02:39,000" # Advanced time, resultion in milliseconds use Time::HiRes; my ($secs, $msecs) = Time::HiRes::gettimeofday(); print $format->format($secs, $msecs), "\n"; # => "17:02:39,959" =head1 DESCRIPTION C is a low-level helper class for the advanced date formatting functions in C. Unless you're writing your own Layout class like L, there's probably not much use for you to read this. C is a formatter which allows dates to be formatted according to the log4j spec on http://download.oracle.com/javase/1.4.2/docs/api/java/text/SimpleDateFormat.html which allows the following placeholders to be recognized and processed: Symbol Meaning Presentation Example ------ ------- ------------ ------- G era designator (Text) AD e epoch seconds (Number) 1315011604 y year (Number) 1996 M month in year (Text & Number) July & 07 d day in month (Number) 10 h hour in am/pm (1~12) (Number) 12 H hour in day (0~23) (Number) 0 m minute in hour (Number) 30 s second in minute (Number) 55 S millisecond (Number) 978 E day in week (Text) Tuesday D day in year (Number) 189 F day of week in month (Number) 2 (2nd Wed in July) w week in year (Number) 27 W week in month (Number) 2 a am/pm marker (Text) PM k hour in day (1~24) (Number) 24 K hour in am/pm (0~11) (Number) 0 z time zone (Text) Pacific Standard Time Z RFC 822 time zone (Text) -0800 ' escape for text (Delimiter) '' single quote (Literal) ' For example, if you want to format the current Unix time in C<"MM/dd HH:mm"> format, all you have to do is this: use Log::Log4perl::DateFormat; my $format = Log::Log4perl::DateFormat->new("MM/dd HH:mm"); my $time = time(); print $format->format($time), "\n"; While the C method is expensive, because it parses the format strings and sets up all kinds of structures behind the scenes, followup calls to C are fast, because C will just call C and C once to return the formatted date/time string. So, typically, you would initialize the formatter once and then reuse it over and over again to display all kinds of time values. Also, for your convenience, the following predefined formats are available, just as outlined in the log4j spec: Format Equivalent Example ABSOLUTE "HH:mm:ss,SSS" "15:49:37,459" DATE "dd MMM yyyy HH:mm:ss,SSS" "06 Nov 1994 15:49:37,459" ISO8601 "yyyy-MM-dd HH:mm:ss,SSS" "1999-11-27 15:49:37,459" APACHE "[EEE MMM dd HH:mm:ss yyyy]" "[Wed Mar 16 15:49:37 2005]" So, instead of passing Log::Log4perl::DateFormat->new("HH:mm:ss,SSS"); you could just as well say Log::Log4perl::DateFormat->new("ABSOLUTE"); and get the same result later on. =head2 Known Shortcomings The following placeholders are currently I recognized, unless someone (and that could be you :) implements them: F day of week in month w week in year W week in month k hour in day K hour in am/pm z timezone (but we got 'Z' for the numeric time zone value) Also, C just knows about English week and month names, internationalization support has to be added. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ9z z Layout.pmnu[package Log::Log4perl::Layout; use Log::Log4perl::Layout::SimpleLayout; use Log::Log4perl::Layout::PatternLayout; use Log::Log4perl::Layout::PatternLayout::Multiline; #################################################### sub appender_name { #################################################### my ($self, $arg) = @_; if ($arg) { die "setting appender_name unimplemented until it makes sense"; } return $self->{appender_name}; } ################################################## sub define { ################################################## ; #subclasses may implement } ################################################## sub render { ################################################## die "subclass must implement render"; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Layout - Log4perl Layout Virtual Base Class =head1 SYNOPSIS # Not to be used directly, see below =head1 DESCRIPTION C is a virtual base class for the two currently implemented layout types Log::Log4perl::Layout::SimpleLayout Log::Log4perl::Layout::PatternLayout Unless you're implementing a new layout class for Log4perl, you shouldn't use this class directly, but rather refer to L or L. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ,ax Logger.pmnu[################################################## package Log::Log4perl::Logger; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl; use Log::Log4perl::Level; use Log::Log4perl::Layout; use Log::Log4perl::Appender; use Log::Log4perl::Appender::String; use Log::Log4perl::Filter; use Carp; $Carp::Internal{"Log::Log4perl"}++; $Carp::Internal{"Log::Log4perl::Logger"}++; use constant _INTERNAL_DEBUG => 0; # Initialization our $ROOT_LOGGER; our $LOGGERS_BY_NAME = {}; our %APPENDER_BY_NAME = (); our $INITIALIZED = 0; our $NON_INIT_WARNED; our $DIE_DEBUG = 0; our $DIE_DEBUG_BUFFER = ""; # Define the default appender that's used for formatting # warn/die/croak etc. messages. our $STRING_APP_NAME = "_l4p_warn"; our $STRING_APP = Log::Log4perl::Appender->new( "Log::Log4perl::Appender::String", name => $STRING_APP_NAME); $STRING_APP->layout(Log::Log4perl::Layout::PatternLayout->new("%m")); our $STRING_APP_CODEREF = generate_coderef([[$STRING_APP_NAME, $STRING_APP]]); __PACKAGE__->reset(); ########################################### sub warning_render { ########################################### my($logger, @message) = @_; $STRING_APP->string(""); $STRING_APP_CODEREF->($logger, @message, Log::Log4perl::Level::to_level($ALL)); return $STRING_APP->string(); } ################################################## sub cleanup { ################################################## # warn "Logger cleanup"; # Nuke all convenience loggers to avoid them causing cleanup to # be delayed until global destruction. Problem is that something like # *{"DEBUG"} = sub { $logger->debug }; # ties up a reference to $logger until global destruction, so we # need to clean up all :easy shortcuts, hence freeing the last # logger references, to then rely on the garbage collector for cleaning # up the loggers. Log::Log4perl->easy_closure_global_cleanup(); # Delete all loggers $LOGGERS_BY_NAME = {}; # Delete the root logger undef $ROOT_LOGGER; # Delete all appenders %APPENDER_BY_NAME = (); undef $INITIALIZED; } ################################################## sub DESTROY { ################################################## CORE::warn "Destroying logger $_[0] ($_[0]->{category})" if $Log::Log4perl::CHATTY_DESTROY_METHODS; } ################################################## sub reset { ################################################## $ROOT_LOGGER = __PACKAGE__->_new("", $OFF); # $LOGGERS_BY_NAME = {}; #leave this alone, it's used by #reset_all_output_methods when #the config changes %APPENDER_BY_NAME = (); undef $INITIALIZED; undef $NON_INIT_WARNED; Log::Log4perl::Appender::reset(); #clear out all the existing appenders foreach my $logger (values %$LOGGERS_BY_NAME){ $logger->{appender_names} = []; #this next bit deals with an init_and_watch case where a category #is deleted from the config file, we need to zero out the existing #loggers so ones not in the config file not continue with their old #behavior --kg next if $logger eq $ROOT_LOGGER; $logger->{level} = undef; $logger->level(); #set it from the hierarchy } # Clear all filters Log::Log4perl::Filter::reset(); } ################################################## sub _new { ################################################## my($class, $category, $level) = @_; print("_new: $class/$category/", defined $level ? $level : "undef", "\n") if _INTERNAL_DEBUG; die "usage: __PACKAGE__->_new(category)" unless defined $category; $category =~ s/::/./g; # Have we created it previously? if(exists $LOGGERS_BY_NAME->{$category}) { print "_new: exists already\n" if _INTERNAL_DEBUG; return $LOGGERS_BY_NAME->{$category}; } my $self = { category => $category, num_appenders => 0, additivity => 1, level => $level, layout => undef, }; bless $self, $class; $level ||= $self->level(); # Save it in global structure $LOGGERS_BY_NAME->{$category} = $self; $self->set_output_methods; print("Created logger $self ($category)\n") if _INTERNAL_DEBUG; return $self; } ################################################## sub category { ################################################## my ($self) = @_; return $self->{ category }; } ################################################## sub reset_all_output_methods { ################################################## print "reset_all_output_methods: \n" if _INTERNAL_DEBUG; foreach my $loggername ( keys %$LOGGERS_BY_NAME){ $LOGGERS_BY_NAME->{$loggername}->set_output_methods; } $ROOT_LOGGER->set_output_methods; } ################################################## sub set_output_methods { # Here's a big performance increase. Instead of having the logger # calculate whether to log and whom to log to every time log() is called, # we calculcate it once when the logger is created, and recalculate # it if the config information ever changes. # ################################################## my ($self) = @_; my (@appenders, %seen); my ($level) = $self->level(); print "set_output_methods: $self->{category}/$level\n" if _INTERNAL_DEBUG; #collect the appenders in effect for this category for(my $logger = $self; $logger; $logger = parent_logger($logger)) { foreach my $appender_name (@{$logger->{appender_names}}){ #only one message per appender, (configurable) next if $seen{$appender_name} ++ && $Log::Log4perl::one_message_per_appender; push (@appenders, [$appender_name, $APPENDER_BY_NAME{$appender_name}, ] ); } last unless $logger->{additivity}; } #make a no-op coderef for inactive levels my $noop = generate_noop_coderef(); #make a coderef my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders)); my %priority = %Log::Log4perl::Level::PRIORITY; #convenience and cvs # changed to >= from <= as level ints were reversed foreach my $levelname (keys %priority){ if (Log::Log4perl::Level::isGreaterOrEqual($level, $priority{$levelname} )) { print " ($priority{$levelname} <= $level)\n" if _INTERNAL_DEBUG; $self->{$levelname} = $coderef; $self->{"is_$levelname"} = generate_is_xxx_coderef("1"); print "Setting is_$levelname to 1\n" if _INTERNAL_DEBUG; }else{ print " ($priority{$levelname} > $level)\n" if _INTERNAL_DEBUG; $self->{$levelname} = $noop; $self->{"is_$levelname"} = generate_is_xxx_coderef("0"); print "Setting is_$levelname to 0\n" if _INTERNAL_DEBUG; } print(" Setting [$self] $self->{category}.$levelname to ", ($self->{$levelname} == $noop ? "NOOP" : ("Coderef [$coderef]: " . scalar @appenders . " appenders")), "\n") if _INTERNAL_DEBUG; } } ################################################## sub generate_coderef { ################################################## my $appenders = shift; print "generate_coderef: ", scalar @$appenders, " appenders\n" if _INTERNAL_DEBUG; my $watch_check_code = generate_watch_code("logger", 1); return sub { my $logger = shift; my $level = pop; my $message; my $appenders_fired = 0; # Evaluate all parameters that need to be evaluated. Two kinds: # # (1) It's a hash like { filter => "filtername", # value => "value" } # => filtername(value) # # (2) It's a code ref # => coderef() # $message = [map { ref $_ eq "HASH" && exists $_->{filter} && ref $_->{filter} eq 'CODE' ? $_->{filter}->($_->{value}) : ref $_ eq "CODE" ? $_->() : $_ } @_]; print("coderef: $logger->{category}\n") if _INTERNAL_DEBUG; if(defined $Log::Log4perl::Config::WATCHER) { return unless $watch_check_code->($logger, @_, $level); } foreach my $a (@$appenders) { #note the closure here my ($appender_name, $appender) = @$a; print(" Sending message '<$message->[0]>' ($level) " . "to $appender_name\n") if _INTERNAL_DEBUG; $appender->log( #these get passed through to Log::Dispatch { name => $appender_name, level => $Log::Log4perl::Level::L4P_TO_LD{ $level}, message => $message, }, #these we need $logger->{category}, $level, ) and $appenders_fired++; # Only counting it if it returns a true value. Otherwise # the appender threshold might have suppressed it after all. } #end foreach appenders return $appenders_fired; }; #end coderef } ################################################## sub generate_noop_coderef { ################################################## my $watch_delay_code; # This might seem crazy at first, but even in a Log4perl noop, we # need to check if the configuration changed in a init_and_watch # situation. Why? Say, an application is running in a loop that # constantly tries to issue debug() messages, but they're suppressed by # the current Log4perl configuration. If debug() (which is a noop # here) wasn't watching the configuration for changes, it would never # catch the case where someone bumps up the log level and expects # the application to pick it up and start logging debug() statements. my $watch_check_code = generate_watch_code("logger", 1); my $coderef; if(defined $Log::Log4perl::Config::WATCHER) { $coderef = $watch_check_code; } else { $coderef = sub { undef }; } return $coderef; } ################################################## sub generate_is_xxx_coderef { ################################################## my($return_token) = @_; return generate_watch_code("checker", $return_token); } ################################################## sub generate_watch_code { ################################################## my($type, $return_token) = @_; print "generate_watch_code:\n" if _INTERNAL_DEBUG; # No watcher configured, return a no-op as watch code. if(! defined $Log::Log4perl::Config::WATCHER) { return sub { $return_token }; } my $cond = generate_watch_conditional(); return sub { print "exe_watch_code:\n" if _INTERNAL_DEBUG; if(_INTERNAL_DEBUG) { print "Next check: ", "$Log::Log4perl::Config::Watch::NEXT_CHECK_TIME ", " Now: ", time(), " Mod: ", (stat($Log::Log4perl::Config::WATCHER->file()))[9], "\n"; } if( $cond->() ) { my $init_permitted = 1; if(exists $Log::Log4perl::Config::OPTS->{ preinit_callback } ) { print "Calling preinit_callback\n" if _INTERNAL_DEBUG; $init_permitted = $Log::Log4perl::Config::OPTS->{ preinit_callback }->( Log::Log4perl::Config->watcher()->file() ); print "Callback returned $init_permitted\n" if _INTERNAL_DEBUG; } if( $init_permitted ) { Log::Log4perl->init_and_watch(); } else { # It was time to reinit, but init wasn't permitted. # Return true, so that the logger continues as if # it wasn't time to reinit. return 1; } my $logger = shift; my $level = pop; # Forward call to new configuration if($type eq "checker") { return $logger->$level(); } elsif( $type eq "logger") { my $methodname = lc($level); # Bump up the caller level by three, since # we've artifically introduced additional levels. local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 3; # Get a new logger for the same category (the old # logger might be obsolete because of the re-init) $logger = Log::Log4perl::get_logger( $logger->{category} ); $logger->$methodname(@_); # send the message # to the new configuration return undef; # Return false, so the logger finishes # prematurely and doesn't log the same # message again. } else { die "internal error: unknown type"; } } else { if(_INTERNAL_DEBUG) { print "Conditional returned false\n"; } return $return_token; } }; } ################################################## sub generate_watch_conditional { ################################################## if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { # In this mode, we just check for the variable indicating # that the signal has been caught return sub { return $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT; }; } return sub { return ( time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME and $Log::Log4perl::Config::WATCHER->change_detected() ); }; } ################################################## sub parent_string { ################################################## my($string) = @_; if($string eq "") { return undef; # root doesn't have a parent. } my @components = split /\./, $string; if(@components == 1) { return ""; } pop @components; return join('.', @components); } ################################################## sub level { ################################################## my($self, $level, $dont_reset_all) = @_; # 'Set' function if(defined $level) { croak "invalid level '$level'" unless Log::Log4perl::Level::is_valid($level); if ($level =~ /\D/){ $level = Log::Log4perl::Level::to_priority($level); } $self->{level} = $level; &reset_all_output_methods unless $dont_reset_all; #keep us from getting overworked #if it's the config file calling us return $level; } # 'Get' function if(defined $self->{level}) { return $self->{level}; } for(my $logger = $self; $logger; $logger = parent_logger($logger)) { # Does the current logger have the level defined? if($logger->{category} eq "") { # It's the root logger return $ROOT_LOGGER->{level}; } if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) { return $LOGGERS_BY_NAME->{$logger->{category}}->{level}; } } # We should never get here because at least the root logger should # have a level defined die "We should never get here."; } ################################################## sub parent_logger { # Get the parent of the current logger or undef ################################################## my($logger) = @_; # Is it the root logger? if($logger->{category} eq "") { # Root has no parent return undef; } # Go to the next defined (!) parent my $parent_class = parent_string($logger->{category}); while($parent_class ne "" and ! exists $LOGGERS_BY_NAME->{$parent_class}) { $parent_class = parent_string($parent_class); $logger = $LOGGERS_BY_NAME->{$parent_class}; } if($parent_class eq "") { $logger = $ROOT_LOGGER; } else { $logger = $LOGGERS_BY_NAME->{$parent_class}; } return $logger; } ################################################## sub get_root_logger { ################################################## my($class) = @_; return $ROOT_LOGGER; } ################################################## sub additivity { ################################################## my($self, $onoff, $no_reinit) = @_; if(defined $onoff) { $self->{additivity} = $onoff; } if( ! $no_reinit ) { $self->set_output_methods(); } return $self->{additivity}; } ################################################## sub get_logger { ################################################## my($class, $category) = @_; unless(defined $ROOT_LOGGER) { Carp::confess "Internal error: Root Logger not initialized."; } return $ROOT_LOGGER if $category eq ""; my $logger = $class->_new($category); return $logger; } ################################################## sub add_appender { ################################################## my($self, $appender, $dont_reset_all) = @_; # We take this as an indicator that we're initialized. $INITIALIZED = 1; my $appender_name = $appender->name(); $self->{num_appenders}++; #should this be inside the unless? # Add newly created appender to the end of the appender array unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){ $self->{appender_names} = [sort @{$self->{appender_names}}, $appender_name]; } $APPENDER_BY_NAME{$appender_name} = $appender; reset_all_output_methods unless $dont_reset_all; # keep us from getting overworked # if it's the config file calling us # For chaining calls ... return $appender; } ################################################## sub remove_appender { ################################################## my($self, $appender_name, $dont_reset_all, $sloppy) = @_; my %appender_names = map { $_ => 1 } @{$self->{appender_names}}; if(!exists $appender_names{$appender_name}) { die "No such appender: $appender_name" unless $sloppy; return undef; } delete $appender_names{$appender_name}; $self->{num_appenders}--; $self->{appender_names} = [sort keys %appender_names]; &reset_all_output_methods unless $dont_reset_all; } ################################################## sub eradicate_appender { ################################################## # If someone calls Logger->... and not Logger::... shift if $_[0] eq __PACKAGE__; my($appender_name, $dont_reset_all) = @_; return 0 unless exists $APPENDER_BY_NAME{$appender_name}; # Remove the given appender from all loggers # and delete all references to it, causing # its DESTROY method to be called. foreach my $logger (values %$LOGGERS_BY_NAME){ $logger->remove_appender($appender_name, 0, 1); } # Also remove it from the root logger $ROOT_LOGGER->remove_appender($appender_name, 0, 1); delete $APPENDER_BY_NAME{$appender_name}; &reset_all_output_methods unless $dont_reset_all; return 1; } ################################################## sub has_appenders { ################################################## my($self) = @_; return $self->{num_appenders}; } ################################################## sub log { # external api ################################################## my ($self, $priority, @messages) = @_; confess("log: No priority given!") unless defined($priority); # Just in case of 'init_and_watch' -- see Changes 0.21 $_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if defined $Log::Log4perl::Config::WATCHER; init_warn() unless $INITIALIZED or $NON_INIT_WARNED; croak "priority $priority isn't numeric" if ($priority =~ /\D/); my $which = Log::Log4perl::Level::to_level($priority); $self->{$which}->($self, @messages, Log::Log4perl::Level::to_level($priority)); } ###################################################################### # # create_custom_level # creates a custom level # in theory, could be used to create the default ones ###################################################################### sub create_custom_level { ###################################################################### my $level = shift || die("create_custom_level: " . "forgot to pass in a level string!"); my $after = shift || die("create_custom_level: " . "forgot to pass in a level after which to " . "place the new level!"); my $syslog_equiv = shift; # can be undef my $log_dispatch_level = shift; # optional ## only let users create custom levels before initialization die("create_custom_level must be called before init or " . "first get_logger() call") if ($INITIALIZED); my %PRIORITY = %Log::Log4perl::Level::PRIORITY; #convenience die("create_custom_level: no such level \"$after\"! Use one of: ", join(", ", sort keys %PRIORITY)) unless $PRIORITY{$after}; # figure out new int value by AFTER + (AFTER+ 1) / 2 my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1); my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2); die(qq{create_custom_level: Calculated level of $cust_prio already exists! This should only happen if you've made some insane number of custom levels (like 15 one after another) You can usually fix this by re-arranging your code from: create_custom_level("cust1", X); create_custom_level("cust2", X); create_custom_level("cust3", X); create_custom_level("cust4", X); create_custom_level("cust5", X); into: create_custom_level("cust3", X); create_custom_level("cust5", X); create_custom_level("cust4", 4); create_custom_level("cust2", cust3); create_custom_level("cust1", cust2); }) if (${Log::Log4perl::Level::LEVELS{$cust_prio}}); Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv, $log_dispatch_level); print("Adding prio $level at $cust_prio\n") if _INTERNAL_DEBUG; # get $LEVEL into namespace of Log::Log4perl::Logger to # create $logger->foo nd $logger->is_foo my $name = "Log::Log4perl::Logger::"; my $key = $level; no strict qw(refs); # be sure to use ${Log...} as CVS adds log entries for Log *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; # now, stick it in the caller's namespace $name = caller(0) . "::"; *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; use strict qw(refs); create_log_level_methods($level); return 0; } ######################################## # # if we were hackin' lisp (or scheme), we'd be returning some lambda # expressions. But we aren't. :) So we'll just create some strings and # eval them. ######################################## sub create_log_level_methods { ######################################## my $level = shift || die("create_log_level_methods: " . "forgot to pass in a level string!"); my $lclevel = lc($level); my $levelint = uc($level) . "_INT"; my $initial_cap = ucfirst($lclevel); no strict qw(refs); # This is a bit better way to create code on the fly than eval'ing strings. # -erik *{__PACKAGE__ . "::$lclevel"} = sub { if(_INTERNAL_DEBUG) { my $level_disp = (defined $_[0]->{level} ? $_[0]->{level} : "[undef]"); print "$lclevel: ($_[0]->{category}/$level_disp) [@_]\n"; } init_warn() unless $INITIALIZED or $NON_INIT_WARNED; $_[0]->{$level}->(@_, $level) if defined $_[0]->{$level}; }; # Added these to have is_xxx functions as fast as xxx functions # -ms my $islevel = "is_" . $level; my $islclevel = "is_" . $lclevel; *{__PACKAGE__ . "::is_$lclevel"} = sub { $_[0]->{$islevel}->($_[0], $islclevel); }; # Add the isXxxEnabled() methods as identical to the is_xxx # functions. - dviner *{__PACKAGE__ . "::is".$initial_cap."Enabled"} = \&{__PACKAGE__ . "::is_$lclevel"}; use strict qw(refs); return 0; } #now lets autogenerate the logger subs based on the defined priorities foreach my $level (keys %Log::Log4perl::Level::PRIORITY){ create_log_level_methods($level); } ################################################## sub init_warn { ################################################## CORE::warn "Log4perl: Seems like no initialization happened. " . "Forgot to call init()?\n"; # Only tell this once; $NON_INIT_WARNED = 1; } ####################################################### # call me from a sub-func to spew the sub-func's caller ####################################################### sub callerline { my $message = join ('', @_); my $caller_offset = Log::Log4perl::caller_depth_offset( $Log::Log4perl::caller_depth + 1 ); my ($pack, $file, $line) = caller($caller_offset); if (not chomp $message) { # no newline $message .= " at $file line $line"; # Someday, we'll use Threads. Really. if (defined &Thread::tid) { my $tid = Thread->self->tid; $message .= " thread $tid" if $tid; } } return ($message, "\n"); } ####################################################### sub and_warn { ####################################################### my $self = shift; CORE::warn(callerline($self->warning_render(@_))); } ####################################################### sub and_die { ####################################################### my $self = shift; my $arg = $_[0]; my($msg) = callerline($self->warning_render(@_)); if($DIE_DEBUG) { $DIE_DEBUG_BUFFER = "DIE_DEBUG: $msg"; } else { if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { die("$msg\n"); } die $arg; } } ################################################## sub logwarn { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if ($self->is_warn()) { # Since we're one caller level off now, compensate for that. my @chomped = @_; chomp($chomped[-1]); $self->warn(@chomped); } $self->and_warn(@_); } ################################################## sub logdie { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if ($self->is_fatal()) { # Since we're one caller level off now, compensate for that. my @chomped = @_; chomp($chomped[-1]); $self->fatal(@chomped); } $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? $self->and_die(@_) : exit($Log::Log4perl::LOGEXIT_CODE); } ################################################## sub logexit { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if ($self->is_fatal()) { # Since we're one caller level off now, compensate for that. my @chomped = @_; chomp($chomped[-1]); $self->fatal(@chomped); } exit $Log::Log4perl::LOGEXIT_CODE; } ################################################## # clucks and carps are WARN level sub logcluck { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; local $Carp::CarpLevel = $Carp::CarpLevel + 1; my $msg = $self->warning_render(@_); if ($self->is_warn()) { my $message = Carp::longmess($msg); foreach (split(/\n/, $message)) { $self->warn("$_\n"); } } Carp::cluck($msg); } ################################################## sub logcarp { ################################################## my $self = shift; local $Carp::CarpLevel = $Carp::CarpLevel + 1; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $msg = $self->warning_render(@_); if ($self->is_warn()) { my $message = Carp::shortmess($msg); foreach (split(/\n/, $message)) { $self->warn("$_\n"); } } Carp::carp($msg); } ################################################## # croaks and confess are FATAL level ################################################## sub logcroak { ################################################## my $self = shift; my $arg = $_[0]; my $msg = $self->warning_render(@_); local $Carp::CarpLevel = $Carp::CarpLevel + 1; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if ($self->is_fatal()) { my $message = Carp::shortmess($msg); foreach (split(/\n/, $message)) { $self->fatal("$_\n"); } } my $croak_msg = $arg; if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { $croak_msg = $msg; } $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? Carp::croak($croak_msg) : exit($Log::Log4perl::LOGEXIT_CODE); } ################################################## sub logconfess { ################################################## my $self = shift; my $arg = $_[0]; local $Carp::CarpLevel = $Carp::CarpLevel + 1; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $msg = $self->warning_render(@_); if ($self->is_fatal()) { my $message = Carp::longmess($msg); foreach (split(/\n/, $message)) { $self->fatal("$_\n"); } } my $confess_msg = $arg; if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { $confess_msg = $msg; } $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? confess($confess_msg) : exit($Log::Log4perl::LOGEXIT_CODE); } ################################################## # in case people prefer to use error for warning ################################################## sub error_warn { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; if ($self->is_error()) { $self->error(@_); } $self->and_warn(@_); } ################################################## sub error_die { ################################################## my $self = shift; local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; my $msg = $self->warning_render(@_); if ($self->is_error()) { $self->error($msg); } $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? $self->and_die($msg) : exit($Log::Log4perl::LOGEXIT_CODE); } ################################################## sub more_logging { ################################################## my ($self) = shift; return $self->dec_level(@_); } ################################################## sub inc_level { ################################################## my ($self, $delta) = @_; $delta ||= 1; $self->level(Log::Log4perl::Level::get_higher_level($self->level(), $delta)); $self->set_output_methods; } ################################################## sub less_logging { ################################################## my ($self) = shift; return $self->inc_level(@_); } ################################################## sub dec_level { ################################################## my ($self, $delta) = @_; $delta ||= 1; $self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta)); $self->set_output_methods; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Logger - Main Logger Class =head1 SYNOPSIS # It's not here =head1 DESCRIPTION While everything that makes Log4perl tick is implemented here, please refer to L for documentation. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZNf&00 Filter.pmnu[################################################## package Log::Log4perl::Filter; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Level; use Log::Log4perl::Config; use constant _INTERNAL_DEBUG => 0; our %FILTERS_DEFINED = (); ################################################## sub new { ################################################## my($class, $name, $action) = @_; print "Creating filter $name\n" if _INTERNAL_DEBUG; my $self = { name => $name }; bless $self, $class; if(ref($action) eq "CODE") { # it's a code ref $self->{ok} = $action; } else { # it's something else die "Code for ($name/$action) not properly defined"; } return $self; } ################################################## sub register { # Register a filter by name # (Passed on to subclasses) ################################################## my($self) = @_; by_name($self->{name}, $self); } ################################################## sub by_name { # Get/Set a filter object by name ################################################## my($name, $value) = @_; if(defined $value) { $FILTERS_DEFINED{$name} = $value; } if(exists $FILTERS_DEFINED{$name}) { return $FILTERS_DEFINED{$name}; } else { return undef; } } ################################################## sub reset { ################################################## %FILTERS_DEFINED = (); } ################################################## sub ok { ################################################## my($self, %p) = @_; print "Calling $self->{name}'s ok method\n" if _INTERNAL_DEBUG; # Force filter classes to define their own # ok(). Exempt are only sub {..} ok functions, # defined in the conf file. die "This is to be overridden by the filter" unless defined $self->{ok}; # What should we set the message in $_ to? The most logical # approach seems to be to concat all parts together. If some # filter wants to dissect the parts, it still can examine %p, # which gets passed to the subroutine and contains the chunks # in $p{message}. # Split because of CVS local($_) = join $ Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p{message}}; print "\$_ is '$_'\n" if _INTERNAL_DEBUG; my $decision = $self->{ok}->(%p); print "$self->{name}'s ok'ed: ", ($decision ? "yes" : "no"), "\n" if _INTERNAL_DEBUG; return $decision; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Filter - Log4perl Custom Filter Base Class =head1 SYNOPSIS use Log::Log4perl; Log::Log4perl->init(\ <<'EOT'); log4perl.logger = INFO, Screen log4perl.filter.MyFilter = sub { /let this through/ } log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.Filter = MyFilter log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout EOT # Define a logger my $logger = Log::Log4perl->get_logger("Some"); # Let this through $logger->info("Here's the info, let this through!"); # Suppress this $logger->info("Here's the info, suppress this!"); ################################################################# # StringMatch Filter: ################################################################# log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch log4perl.filter.M1.StringToMatch = let this through log4perl.filter.M1.AcceptOnMatch = true ################################################################# # LevelMatch Filter: ################################################################# log4perl.filter.M1 = Log::Log4perl::Filter::LevelMatch log4perl.filter.M1.LevelToMatch = INFO log4perl.filter.M1.AcceptOnMatch = true =head1 DESCRIPTION Log4perl allows the use of customized filters in its appenders to control the output of messages. These filters might grep for certain text chunks in a message, verify that its priority matches or exceeds a certain level or that this is the 10th time the same message has been submitted -- and come to a log/no log decision based upon these circumstantial facts. Filters have names and can be specified in two different ways in the Log4perl configuration file: As subroutines or as filter classes. Here's a simple filter named C which just verifies that the oncoming message matches the regular expression C: log4perl.filter.MyFilter = sub { /let this through/i } It exploits the fact that when the subroutine defined above is called on a message, Perl's special C<$_> variable will be set to the message text (prerendered, i.e. concatenated but not layouted) to be logged. The subroutine is expected to return a true value if it wants the message to be logged or a false value if doesn't. Also, Log::Log4perl will pass a hash to the subroutine, containing all key/value pairs that it would pass to the corresponding appender, as specified in Log::Log4perl::Appender. Here's an example of a filter checking the priority of the oncoming message: log4perl.filter.MyFilter = sub { \ my %p = @_; \ if($p{log4p_level} eq "WARN" or \ $p{log4p_level} eq "INFO") { \ return 1; \ } \ return 0; \ } If the message priority equals C or C, it returns a true value, causing the message to be logged. =head2 Predefined Filters For common tasks like verifying that the message priority matches a certain priority, there's already a set of predefined filters available. To perform an exact level match, it's much cleaner to use Log4perl's C filter instead: log4perl.filter.M1 = Log::Log4perl::Filter::LevelMatch log4perl.filter.M1.LevelToMatch = INFO log4perl.filter.M1.AcceptOnMatch = true This will let the message through if its priority is INFO and suppress it otherwise. The statement can be negated by saying log4perl.filter.M1.AcceptOnMatch = false instead. This way, the message will be logged if its priority is anything but INFO. On a similar note, Log4perl's C filter will check the oncoming message for strings or regular expressions: log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch log4perl.filter.M1.StringToMatch = bl.. bl.. log4perl.filter.M1.AcceptOnMatch = true This will open the gate for messages like C because the regular expression in the C matches them. Again, the setting of C determines if the filter is defined in a positive or negative way. All class filter entries in the configuration file have to adhere to the following rule: Only after a filter has been defined by name and class/subroutine, its attribute values can be assigned, just like the C value above gets assigned to the C attribute I the filter C has been defined. =head2 Attaching a filter to an appender Attaching a filter to an appender is as easy as assigning its name to the appender's C attribute: log4perl.appender.MyAppender.Filter = MyFilter This will cause C to call the filter subroutine/method every time a message is supposed to be passed to the appender. Depending on the filter's return value, C will either continue as planned or withdraw immediately. =head2 Combining filters with Log::Log4perl::Filter::Boolean Sometimes, it's useful to combine the output of various filters to arrive at a log/no log decision. While Log4j, Log4perl's mother ship, has chosen to implement this feature as a filter chain, similar to Linux' IP chains, Log4perl tries a different approach. Typically, filter results will not need to be bumped along chains but combined in a programmatic manner using boolean logic. "Log if this filter says 'yes' and that filter says 'no'" is a fairly common requirement, but hard to implement as a chain. C is a specially predefined custom filter for Log4perl. It combines the results of other custom filters in arbitrary ways, using boolean expressions: log4perl.logger = WARN, AppWarn, AppError log4perl.filter.Match1 = sub { /let this through/ } log4perl.filter.Match2 = sub { /and that, too/ } log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean log4perl.filter.MyBoolean.logic = Match1 || Match2 log4perl.appender.Screen = Log::Log4perl::Appender::Screen log4perl.appender.Screen.Filter = MyBoolean log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout C's boolean expressions allow for combining different appenders by name using AND (&& or &), OR (|| or |) and NOT (!) as logical expressions. Also, parentheses can be used for defining precedences. Operator precedence follows standard Perl conventions. Here's a bunch of examples: Match1 && !Match2 # Match1 and not Match2 !(Match1 || Match2) # Neither Match1 nor Match2 (Match1 && Match2) || Match3 # Both Match1 and Match2 or Match3 =head2 Writing your own filter classes If none of Log::Log4perl's predefined filter classes fits your needs, you can easily roll your own: Just define a new class, derive it from the baseclass C, and define its C and C methods like this: package Log::Log4perl::Filter::MyFilter; use base Log::Log4perl::Filter; sub new { my ($class, %options) = @_; my $self = { %options, }; bless $self, $class; return $self; } sub ok { my ($self, %p) = @_; # ... decide and return 1 or 0 } 1; Log4perl will call the ok() method to determine if the filter should let the message pass or not. A true return value indicates the message will be logged by the appender, a false value blocks it. Values you've defined for its attributes in Log4perl's configuration file, will be received through its C method: log4perl.filter.MyFilter = Log::Log4perl::Filter::MyFilter log4perl.filter.MyFilter.color = red will cause C's constructor to be called like this: Log::Log4perl::Filter::MyFilter->new( name => "MyFilter", color => "red" ); The custom filter class should use this to set the object's attributes, to have them available later to base log/nolog decisions on it. C is the filter's method to tell if it agrees or disagrees with logging the message. It will be called by Log::Log4perl whenever it needs the filter to decide. A false value returned by C will block messages, a true value will let them through. =head2 A Practical Example: Level Matching See L for this. =head1 SEE ALSO L, L, L, L =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZMwwResurrector.pmnu[package Log::Log4perl::Resurrector; use warnings; use strict; use File::Temp qw(tempfile); use File::Spec; use constant INTERNAL_DEBUG => 0; ########################################### sub import { ########################################### resurrector_init(); } ################################################## sub resurrector_fh { ################################################## my($file) = @_; local($/) = undef; open FILE, "<$file" or die "Cannot open $file"; my $text = ; close FILE; print "Read ", length($text), " bytes from $file\n" if INTERNAL_DEBUG; my($tmp_fh, $tmpfile) = tempfile( UNLINK => 1 ); print "Opened tmpfile $tmpfile\n" if INTERNAL_DEBUG; $text =~ s/^\s*###l4p//mg; print "Text=[$text]\n" if INTERNAL_DEBUG; print $tmp_fh $text; seek $tmp_fh, 0, 0; return $tmp_fh; } ########################################### sub resurrector_loader { ########################################### my ($code, $module) = @_; print "resurrector_loader called with $module\n" if INTERNAL_DEBUG; # Skip Log4perl appenders if($module =~ m#^Log/Log4perl/Appender#) { print "Ignoring $module (Log4perl-internal)\n" if INTERNAL_DEBUG; return undef; } my $path = $module; # Skip unknown files if(!-f $module) { # We might have a 'use lib' statement that modified the # INC path, search again. $path = pm_search($module); if(! defined $path) { print "File $module not found\n" if INTERNAL_DEBUG; return undef; } print "File $module found in $path\n" if INTERNAL_DEBUG; } print "Resurrecting module $path\n" if INTERNAL_DEBUG; my $fh = resurrector_fh($path); my $abs_path = File::Spec->rel2abs( $path ); print "Setting %INC entry of $module to $abs_path\n" if INTERNAL_DEBUG; $INC{$module} = $abs_path; return $fh; } ########################################### sub pm_search { ########################################### my($pmfile) = @_; for(@INC) { # Skip subrefs next if ref($_); my $path = File::Spec->catfile($_, $pmfile); return $path if -f $path; } return undef; } ########################################### sub resurrector_init { ########################################### unshift @INC, \&resurrector_loader; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Resurrector - Dark Magic to resurrect hidden L4p statements =head1 DESCRIPTION Loading C causes subsequently loaded modules to have their hidden ###l4p use Log::Log4perl qw(:easy); ###l4p DEBUG(...) ###l4p INFO(...) ... statements uncommented and therefore 'resurrected', i.e. activated. This allows for a module C to be written with Log4perl statements commented out and running at full speed in normal mode. When loaded via use Foobar; all hidden Log4perl statements will be ignored. However, if a script loads the module C I loading C, as in use Log::Log4perl::Resurrector; use Foobar; then C will have put a source filter in place that will extract all hidden Log4perl statements in C before C actually gets loaded. Therefore, C will then behave as if the ###l4p use Log::Log4perl qw(:easy); ###l4p DEBUG(...) ###l4p INFO(...) ... statements were actually written like use Log::Log4perl qw(:easy); DEBUG(...) INFO(...) ... and the module C will indeed be Log4perl-enabled. Whether any activated Log4perl statement will actually trigger log messages, is up to the Log4perl configuration, of course. There's a startup cost to using C (all subsequently loaded modules are examined) but once the compilation phase has finished, the perl program will run at full speed. Some of the techniques used in this module have been stolen from the C CPAN module, written by I. Long live CPAN! =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZRN| | InternalDebug.pmnu[package Log::Log4perl::InternalDebug; use warnings; use strict; use File::Temp qw(tempfile); use File::Spec; require Log::Log4perl::Resurrector; ########################################### sub enable { ########################################### unshift @INC, \&internal_debug_loader; } ################################################## sub internal_debug_fh { ################################################## my($file) = @_; local($/) = undef; open FILE, "<$file" or die "Cannot open $file"; my $text = ; close FILE; my($tmp_fh, $tmpfile) = tempfile( UNLINK => 1 ); $text =~ s/_INTERNAL_DEBUG(?!\s*=>)/1/g; print $tmp_fh $text; seek $tmp_fh, 0, 0; return $tmp_fh; } ########################################### sub internal_debug_loader { ########################################### my ($code, $module) = @_; # Skip non-Log4perl modules if($module !~ m#^Log/Log4perl#) { return undef; } my $path = $module; if(!-f $path) { $path = Log::Log4perl::Resurrector::pm_search( $module ); } my $fh = internal_debug_fh($path); my $abs_path = File::Spec->rel2abs( $path ); $INC{$module} = $abs_path; return $fh; } ########################################### sub resurrector_init { ########################################### unshift @INC, \&resurrector_loader; } ########################################### sub import { ########################################### # enable it on import enable(); } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::InternalDebug - Dark Magic to enable _INTERNAL_DEBUG =head1 DESCRIPTION When called with perl -MLog::Log4perl::InternalDebug t/001Test.t scripts will run with _INTERNAL_DEBUG set to a true value and hence print internal Log4perl debugging information. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ_[#NDC.pmnu[################################################## package Log::Log4perl::NDC; ################################################## use 5.006; use strict; use warnings; our @NDC_STACK = (); our $MAX_SIZE = 5; ########################################### sub get { ########################################### if(@NDC_STACK) { # Return elements blank separated return join " ", @NDC_STACK; } else { return "[undef]"; } } ########################################### sub pop { ########################################### if(@NDC_STACK) { return pop @NDC_STACK; } else { return undef; } } ########################################### sub push { ########################################### my($self, $text) = @_; unless(defined $text) { # Somebody called us via Log::Log4perl::NDC::push("blah") ? $text = $self; } if(@NDC_STACK >= $MAX_SIZE) { CORE::pop(@NDC_STACK); } return push @NDC_STACK, $text; } ########################################### sub remove { ########################################### @NDC_STACK = (); } __END__ =encoding utf8 =head1 NAME Log::Log4perl::NDC - Nested Diagnostic Context =head1 DESCRIPTION Log::Log4perl allows loggers to maintain global thread-specific data, called the Nested Diagnostic Context (NDC). At some point, the application might decide to push a piece of data onto the NDC stack, which other parts of the application might want to reuse. For example, at the beginning of a web request in a server, the application might decide to push the IP address of the client onto the stack to provide it for other loggers down the road without having to pass the data from function to function. The Log::Log4perl::Layout::PatternLayout class even provides the handy C<%x> placeholder which is replaced by the blank-separated list of elements currently on the stack. This module maintains a simple stack which you can push data on to, query what's on top, pop it off again or delete the entire stack. Its purpose is to provide a thread-specific context which all Log::Log4perl loggers can refer to without the application having to pass around the context data between its functions. Since in 5.8.0 perl's threads don't share data only upon request, global data is by definition thread-specific. =over 4 =item Log::Log4perl::NDC->push($text); Push an item onto the stack. If the stack grows beyond the defined limit (C<$Log::Log4perl::NDC::MAX_SIZE>), just the topmost element will be replated. This is typically done when a context is entered. =item Log::Log4perl::NDC->pop(); Discard the upmost element of the stack. This is typically done when a context is left. =item my $text = Log::Log4perl::NDC->get(); Retrieve the content of the stack as a string of blank-separated values without disrupting the stack structure. Typically done by C<%x>. If the stack is empty the value C<"[undef]"> is being returned. =item Log::Log4perl::NDC->remove(); Reset the stack, remove all items. =back Please note that all of the methods above are class methods, there's no instances of this class. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ)ܴUtil/TimeTracker.pmnu[################################################## package Log::Log4perl::Util::TimeTracker; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Util; use Carp; our $TIME_HIRES_AVAILABLE; BEGIN { # Check if we've got Time::HiRes. If not, don't make a big fuss, # just set a flag so we know later on that we can't have fine-grained # time stamps $TIME_HIRES_AVAILABLE = 0; if(Log::Log4perl::Util::module_available("Time::HiRes")) { require Time::HiRes; $TIME_HIRES_AVAILABLE = 1; } } ################################################## sub new { ################################################## my $class = shift; $class = ref ($class) || $class; my $self = { reset_time => undef, @_, }; $self->{time_function} = \&_gettimeofday unless defined $self->{time_function}; bless $self, $class; $self->reset(); return $self; } ################################################## sub hires_available { ################################################## return $TIME_HIRES_AVAILABLE; } ################################################## sub _gettimeofday { ################################################## # Return secs and optionally msecs if we have Time::HiRes if($TIME_HIRES_AVAILABLE) { return (Time::HiRes::gettimeofday()); } else { return (time(), 0); } } ################################################## sub gettimeofday { ################################################## my($self) = @_; my($seconds, $microseconds) = $self->{time_function}->(); $microseconds = 0 if ! defined $microseconds; return($seconds, $microseconds); } ################################################## sub reset { ################################################## my($self) = @_; my $current_time = [$self->gettimeofday()]; $self->{reset_time} = $current_time; $self->{last_call_time} = $current_time; return $current_time; } ################################################## sub time_diff { ################################################## my($time_from, $time_to) = @_; my $seconds = $time_to->[0] - $time_from->[0]; my $milliseconds = int(( $time_to->[1] - $time_from->[1] ) / 1000); if($milliseconds < 0) { $milliseconds = 1000 + $milliseconds; $seconds--; } return($seconds, $milliseconds); } ################################################## sub milliseconds { ################################################## my($self, $current_time) = @_; $current_time = [ $self->gettimeofday() ] unless defined $current_time; my($seconds, $milliseconds) = time_diff( $self->{reset_time}, $current_time); return $seconds*1000 + $milliseconds; } ################################################## sub delta_milliseconds { ################################################## my($self, $current_time) = @_; $current_time = [ $self->gettimeofday() ] unless defined $current_time; my($seconds, $milliseconds) = time_diff( $self->{last_call_time}, $current_time); $self->{last_call_time} = $current_time; return $seconds*1000 + $milliseconds; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Util::TimeTracker - Track time elapsed =head1 SYNOPSIS use Log::Log4perl::Util::TimeTracker; my $timer = Log::Log4perl::Util::TimeTracker->new(); # equivalent to Time::HiRes::gettimeofday(), regardless # if Time::HiRes is present or not. my($seconds, $microseconds) = $timer->gettimeofday(); # reset internal timer $timer->reset(); # return milliseconds since last reset $msecs = $timer->milliseconds(); # return milliseconds since last call $msecs = $timer->delta_milliseconds(); =head1 DESCRIPTION This utility module helps tracking time elapsed for PatternLayout's date and time placeholders. Its accuracy depends on the availability of the Time::HiRes module. If it's available, its granularity is milliseconds, if not, seconds. The most common use of this module is calling the gettimeofday() method: my($seconds, $microseconds) = $timer->gettimeofday(); It returns seconds and microseconds of the current epoch time. If Time::HiRes is installed, it will simply defer to its gettimeofday() function, if it's missing, time() will be called instead and $microseconds will always be 0. To measure time elapsed in milliseconds, use the reset() method to reset the timer to the current time, followed by one or more calls to the milliseconds() method: # reset internal timer $timer->reset(); # return milliseconds since last reset $msecs = $timer->milliseconds(); On top of the time span between the last reset and the current time, the module keeps track of the time between calls to delta_milliseconds(): $msecs = $timer->delta_milliseconds(); On the first call, this will return the number of milliseconds since the last reset(), on subsequent calls, it will return the time elapsed in milliseconds since the last call to delta_milliseconds() instead. Note that reset() also resets the time of the last call. The internal timer of this module gets its time input from the POSIX time() function, or, if the Time::HiRes module is available, from its gettimeofday() function. To figure out which one it is, use if( $timer->hires_available() ) { print "Hooray, we get real milliseconds!\n"; } else { print "Milliseconds are just bogus\n"; } For testing purposes, a different time source can be provided, so test suites can simulate time passing by without actually having to wait: my $start_time = time(); my $timer = Log::Log4perl::Util::TimeTracker->new( time_function => sub { return $start_time++; }, ); Every call to $timer->epoch() will then return a time value that is one second ahead of the the value returned on the previous call. This also means that every call to delta_milliseconds() will return a value that exceeds the value returned on the previous call by 1000. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZȥL;;Util/Semaphore.pmnu[#////////////////////////////////////////// package Log::Log4perl::Util::Semaphore; #////////////////////////////////////////// use IPC::SysV qw(IPC_RMID IPC_CREAT IPC_EXCL SEM_UNDO IPC_NOWAIT IPC_SET IPC_STAT SETVAL); use IPC::Semaphore; use POSIX qw(EEXIST); use strict; use warnings; use constant INTERNAL_DEBUG => 0; ########################################### sub new { ########################################### my($class, %options) = @_; my $self = { key => undef, mode => undef, uid => undef, gid => undef, destroy => undef, semop_wait => .1, semop_retries => 1, creator => $$, %options, }; $self->{ikey} = unpack("i", pack("A4", $self->{key})); # Accept usernames in the uid field as well if(defined $self->{uid} and $self->{uid} =~ /\D/) { $self->{uid} = (getpwnam $self->{uid})[2]; } bless $self, $class; $self->init(); my @values = (); for my $param (qw(mode uid gid)) { push @values, $param, $self->{$param} if defined $self->{$param}; } $self->semset(@values) if @values; return $self; } ########################################### sub init { ########################################### my($self) = @_; print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG; $self->{id} = semget( $self->{ikey}, 1, &IPC_EXCL|&IPC_CREAT|($self->{mode}||0777), ); if(! defined $self->{id} and $! == EEXIST) { print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG; $self->{id} = semget( $self->{ikey}, 1, 0 ) or die "semget($self->{ikey}) failed: $!"; } elsif($!) { die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)"; } } ########################################### sub status_as_string { ########################################### my($self, @values) = @_; my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); my $values = join('/', $sem->getall()); my $ncnt = $sem->getncnt(0); my $pidlast = $sem->getpid(0); my $zcnt = $sem->getzcnt(0); my $id = $sem->id(); return <{key} iKey ..................................... $self->{ikey} Id ....................................... $id Values ................................... $values Processes waiting for counter increase ... $ncnt Processes waiting for counter to hit 0 ... $zcnt Last process to perform an operation ..... $pidlast EOT } ########################################### sub semsetval { ########################################### my($self, %keyvalues) = @_; my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); $sem->setval(%keyvalues); } ########################################### sub semset { ########################################### my($self, @values) = @_; print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if INTERNAL_DEBUG; my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); $sem->set(@values); } ########################################### sub semlock { ########################################### my($self) = @_; my $operation = pack("s!*", # wait until it's 0 0, 0, 0, # increment by 1 0, 1, SEM_UNDO ); print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; $self->semop($self->{id}, $operation); } ########################################### sub semunlock { ########################################### my($self) = @_; # my $operation = pack("s!*", # # decrement by 1 # 0, -1, SEM_UNDO # ); # print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; # # ignore errors, as they might result from trying to unlock an # # already unlocked semaphor. # semop($self->{id}, $operation); semctl $self->{id}, 0, SETVAL, 0; } ########################################### sub remove { ########################################### my($self) = @_; print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG; semctl ($self->{id}, 0, &IPC_RMID, 0) or die "Removing semaphore $self->{key} failed: $!"; } ########################################### sub DESTROY { ########################################### my($self) = @_; if($self->{destroy} && $$==$self->{creator}) { $self->remove(); } } ########################################### sub semop { ########################################### my($self, @args) = @_; my $retries = $self->{semop_retries}; my $rc; { $rc = semop($args[0], $args[1]); if(!$rc and $! =~ /temporarily unavailable/ and $retries-- > 0) { $rc = 'undef' unless defined $rc; print "semop failed (rc=$rc), retrying\n", $self->status_as_string if INTERNAL_DEBUG; select undef, undef, undef, $self->{semop_wait}; redo; } } $rc or die "semop(@args) failed: $! "; $rc; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Util::Semaphore - Easy to use semaphores =head1 SYNOPSIS use Log::Log4perl::Util::Semaphore; my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" ); $sem->semlock(); # ... critical section $sem->semunlock(); $sem->semset( uid => (getpwnam("hugo"))[2], gid => 102, mode => 0644 ); =head1 DESCRIPTION Log::Log4perl::Util::Semaphore provides the synchronisation mechanism for the Synchronized.pm appender in Log4perl, but can be used independently of Log4perl. As a convenience, the C field accepts user names as well, which it translates into the corresponding uid by running C. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZ$h h Util.pmnu[package Log::Log4perl::Util; require Exporter; our @EXPORT_OK = qw( params_check ); our @ISA = qw( Exporter ); use File::Spec; ########################################### sub params_check { ########################################### my( $hash, $required, $optional ) = @_; my $pkg = caller(); my %hash_copy = %$hash; if( defined $required ) { for my $p ( @$required ) { if( !exists $hash->{ $p } or !defined $hash->{ $p } ) { die "$pkg: Required parameter $p missing."; } delete $hash_copy{ $p }; } } if( defined $optional ) { for my $p ( @$optional ) { delete $hash_copy{ $p }; } if( scalar keys %hash_copy ) { die "$pkg: Unknown parameter: ", join( ",", keys %hash_copy ); } } } ################################################## sub module_available { # Check if a module is available ################################################## my($full_name) = @_; # Weird cases like "strict;" (including the semicolon) would # succeed with the eval below, so check those up front. # I can't believe Perl doesn't have a proper way to check if a # module is available or not! return 0 if $full_name =~ /[^\w:]/; local $SIG{__DIE__} = sub {}; eval "require $full_name"; if($@) { return 0; } return 1; } ################################################## sub tmpfile_name { # File::Temp without the bells and whistles ################################################## my $name = File::Spec->catfile(File::Spec->tmpdir(), 'l4p-tmpfile-' . "$$-" . int(rand(9999999))); # Some crazy versions of File::Spec use backslashes on Win32 $name =~ s#\\#/#g; return $name; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Util - Internal utility functions =head1 DESCRIPTION Only internal functions here. Don't peek. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZWL)^^ Appender.pmnu[################################################## package Log::Log4perl::Appender; ################################################## use 5.006; use strict; use warnings; use Log::Log4perl::Config; use Log::Log4perl::Level; use Carp; use constant _INTERNAL_DEBUG => 0; our $unique_counter = 0; ################################################## sub reset { ################################################## $unique_counter = 0; } ################################################## sub unique_name { ################################################## # THREADS: Need to lock here to make it thread safe $unique_counter++; my $unique_name = sprintf("app%03d", $unique_counter); # THREADS: Need to unlock here to make it thread safe return $unique_name; } ################################################## sub new { ################################################## my($class, $appenderclass, %params) = @_; # Pull in the specified Log::Log4perl::Appender object eval { # Eval erroneously succeeds on unknown appender classes if # the eval string just consists of valid perl code (e.g. an # appended ';' in $appenderclass variable). Fail if we see # anything in there that can't be class name. die "'$appenderclass' not a valid class name " if $appenderclass =~ /[^:\w]/; # Check if the class/package is already available because # something like Class::Prototyped injected it previously. # Use UNIVERSAL::can to check the appender's new() method # [RT 28987] if( ! $appenderclass->can('new') ) { # Not available yet, try to pull it in. # see 'perldoc -f require' for why two evals eval "require $appenderclass"; #unless ${$appenderclass.'::IS_LOADED'}; #for unit tests, #see 004Config die $@ if $@; } }; $@ and die "ERROR: can't load appenderclass '$appenderclass'\n$@"; $params{name} = unique_name() unless exists $params{name}; # If it's a Log::Dispatch::File appender, default to append # mode (Log::Dispatch::File defaults to 'clobber') -- consensus 9/2002 # (Log::Log4perl::Appender::File already defaults to 'append') if ($appenderclass eq 'Log::Dispatch::File' && ! exists $params{mode}) { $params{mode} = 'append'; } my $appender = $appenderclass->new( # Set min_level to the lowest setting. *we* are # controlling this now, the appender should just # log it with no questions asked. min_level => 'debug', # Set 'name' and other parameters map { $_ => $params{$_} } keys %params, ); my $self = { appender => $appender, name => $params{name}, layout => undef, level => $ALL, composite => 0, }; #whether to collapse arrays, etc. $self->{warp_message} = $params{warp_message}; if($self->{warp_message} and my $cref = Log::Log4perl::Config::compile_if_perl($self->{warp_message})) { $self->{warp_message} = $cref; } bless $self, $class; return $self; } ################################################## sub composite { # Set/Get the composite flag ################################################## my ($self, $flag) = @_; $self->{composite} = $flag if defined $flag; return $self->{composite}; } ################################################## sub threshold { # Set/Get the appender threshold ################################################## my ($self, $level) = @_; print "Setting threshold to $level\n" if _INTERNAL_DEBUG; if(defined $level) { # Checking for \d makes for a faster regex(p) $self->{level} = ($level =~ /^(\d+)$/) ? $level : # Take advantage of &to_priority's error reporting Log::Log4perl::Level::to_priority($level); } return $self->{level}; } ################################################## sub log { ################################################## # Relay this call to Log::Log4perl::Appender:* or # Log::Dispatch::* ################################################## my ($self, $p, $category, $level, $cache) = @_; # Check if the appender has a last-minute veto in form # of an "appender threshold" if($self->{level} > $ Log::Log4perl::Level::PRIORITY{$level}) { print "$self->{level} > $level, aborting\n" if _INTERNAL_DEBUG; return undef; } # Run against the (yes only one) customized filter (which in turn # might call other filters via the Boolean filter) and check if its # ok() method approves the message or blocks it. if($self->{filter}) { if($self->{filter}->ok(%$p, log4p_category => $category, log4p_level => $level )) { print "Filter $self->{filter}->{name} passes\n" if _INTERNAL_DEBUG; } else { print "Filter $self->{filter}->{name} blocks\n" if _INTERNAL_DEBUG; return undef; } } unless($self->composite()) { #not defined, the normal case if (! defined $self->{warp_message} ){ #join any message elements if (ref $p->{message} eq "ARRAY") { for my $i (0..$#{$p->{message}}) { if( !defined $p->{message}->[ $i ] ) { local $Carp::CarpLevel = $Carp::CarpLevel + $Log::Log4perl::caller_depth + 1; carp "Warning: Log message argument #" . ($i+1) . " undefined"; } } $p->{message} = join($Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p->{message}} ); } #defined but false, e.g. Appender::DBI } elsif (! $self->{warp_message}) { ; #leave the message alone } elsif (ref($self->{warp_message}) eq "CODE") { #defined and a subref $p->{message} = [$self->{warp_message}->(@{$p->{message}})]; } else { #defined and a function name? no strict qw(refs); $p->{message} = [$self->{warp_message}->(@{$p->{message}})]; } $p->{message} = $self->{layout}->render($p->{message}, $category, $level, 3 + $Log::Log4perl::caller_depth, ) if $self->layout(); } my $args = [%$p, log4p_category => $category, log4p_level => $level]; if(defined $cache) { $$cache = $args; } else { $self->{appender}->log(@$args); } return 1; } ########################################### sub log_cached { ########################################### my ($self, $cache) = @_; $self->{appender}->log(@$cache); } ################################################## sub name { # Set/Get the name ################################################## my($self, $name) = @_; # Somebody wants to *set* the name? if($name) { $self->{name} = $name; } return $self->{name}; } ########################################### sub layout { # Set/Get the layout object # associated with this appender ########################################### my($self, $layout) = @_; # Somebody wants to *set* the layout? if($layout) { $self->{layout} = $layout; # somebody wants a layout, but not set yet, so give 'em default }elsif (! $self->{layout}) { $self->{layout} = Log::Log4perl::Layout::SimpleLayout ->new($self->{name}); } return $self->{layout}; } ################################################## sub filter { # Set filter ################################################## my ($self, $filter) = @_; if($filter) { print "Setting filter to $filter->{name}\n" if _INTERNAL_DEBUG; $self->{filter} = $filter; } return $self->{filter}; } ################################################## sub AUTOLOAD { ################################################## # Relay everything else to the underlying # Log::Log4perl::Appender::* or Log::Dispatch::* # object ################################################## my $self = shift; no strict qw(vars); $AUTOLOAD =~ s/.*:://; if(! defined $self->{appender}) { die "Can't locate object method $AUTOLOAD() in ", __PACKAGE__; } return $self->{appender}->$AUTOLOAD(@_); } ################################################## sub DESTROY { ################################################## foreach my $key (keys %{$_[0]}) { # print "deleting $key\n"; delete $_[0]->{$key}; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Appender - Log appender class =head1 SYNOPSIS use Log::Log4perl; # Define a logger my $logger = Log::Log4perl->get_logger("abc.def.ghi"); # Define a layout my $layout = Log::Log4perl::Layout::PatternLayout->new( "%d (%F:%L)> %m"); # Define an appender my $appender = Log::Log4perl::Appender->new( "Log::Log4perl::Appender::Screen", name => 'dumpy'); # Set the appender's layout $appender->layout($layout); $logger->add_appender($appender); =head1 DESCRIPTION This class is a wrapper around the C appender set. It also supports the collections of appenders. The module hides the idiosyncrasies of C (e.g. every dispatcher gotta have a name, but there's no accessor to retrieve it) from C and yet re-uses the extremely useful variety of dispatchers already created and tested in C. =head1 FUNCTIONS =head2 Log::Log4perl::Appender->new($dispatcher_class_name, ...); The constructor C takes the name of the appender class to be created as a I (!) argument, optionally followed by a number of appender-specific parameters, for example: # Define an appender my $appender = Log::Log4perl::Appender->new( "Log::Log4perl::Appender::File" filename => 'out.log'); In case of C appenders, if no C parameter is specified, the appender object will create a unique one (format C), which can be retrieved later via the C method: print "The appender's name is ", $appender->name(), "\n"; Other parameters are specific to the appender class being used. In the case above, the C parameter specifies the name of the C dispatcher used. However, if, for instance, you're using a C dispatcher to send you email, you'll have to specify C and C email addresses. Every dispatcher is different. Please check the C documentation for the appender used for details on specific requirements. The C method will just pass these parameters on to a newly created C object of the specified type. When it comes to logging, the C will transparently relay all messages to the C object it carries in its womb. =head2 $appender->layout($layout); The C method sets the log layout used by the appender to the format specified by the C object which is passed to it as a reference. Currently there's two layouts available: Log::Log4perl::Layout::SimpleLayout Log::Log4perl::Layout::PatternLayout Please check the L and L manual pages for details. =head1 Supported Appenders Here's the list of appender modules currently available via C, if not noted otherwise, written by Dave Rolsky: Log::Dispatch::ApacheLog Log::Dispatch::DBI (by Tatsuhiko Miyagawa) Log::Dispatch::Email, Log::Dispatch::Email::MailSend, Log::Dispatch::Email::MailSendmail, Log::Dispatch::Email::MIMELite Log::Dispatch::File Log::Dispatch::FileRotate (by Mark Pfeiffer) Log::Dispatch::Handle Log::Dispatch::Screen Log::Dispatch::Syslog Log::Dispatch::Tk (by Dominique Dumont) C doesn't care which ones you use, they're all handled in the same way via the C interface. Please check the well-written manual pages of the C hierarchy on how to use each one of them. =head1 Parameters passed on to the appender's log() method When calling the appender's log()-Funktion, Log::Log4perl will submit a list of key/value pairs. Entries to the following keys are guaranteed to be present: =over 4 =item message Text of the rendered message =item log4p_category Name of the category of the logger that triggered the event. =item log4p_level Log::Log4perl level of the event =back =head1 Pitfalls Since the C appender truncates log files by default, and most of the time this is I what you want, we've instructed C to change this behavior by slipping it the C append> parameter behind the scenes. So, effectively with C 0.23, a configuration like log4perl.category = INFO, FileAppndr log4perl.appender.FileAppndr = Log::Dispatch::File log4perl.appender.FileAppndr.filename = test.log log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout will always I to an existing logfile C while if you specifically request clobbering like in log4perl.category = INFO, FileAppndr log4perl.appender.FileAppndr = Log::Dispatch::File log4perl.appender.FileAppndr.filename = test.log log4perl.appender.FileAppndr.mode = write log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout it will overwrite an existing log file C and start from scratch. =head1 Appenders Expecting Message Chunks Instead of simple strings, certain appenders are expecting multiple fields as log messages. If a statement like $logger->debug($ip, $user, "signed in"); causes an off-the-shelf C appender to fire, the appender will just concatenate the three message chunks passed to it in order to form a single string. The chunks will be separated by a string defined in C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (defaults to the empty string ""). However, different appenders might choose to interpret the message above differently: An appender like C might take the three arguments passed to the logger and put them in three separate rows into the DB. The C appender option is used to specify the desired behavior. If no setting for the appender property # *** Not defined *** # log4perl.appender.SomeApp.warp_message is defined in the Log4perl configuration file, the appender referenced by C will fall back to the standard behavior and join all message chunks together, separating them by C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR>. If, on the other hand, it is set to a false value, like in log4perl.appender.SomeApp.layout=NoopLayout log4perl.appender.SomeApp.warp_message = 0 then the message chunks are passed unmodified to the appender as an array reference. Please note that you need to set the appender's layout to C which just leaves the messages chunks alone instead of formatting them or replacing conversion specifiers. B (or the function name syntax defined below) on them. Only special appenders like Log::Log4perl::Appender::DBI can deal with this.> If (and now we're getting fancy) an appender expects message chunks, but we would like to pre-inspect and probably modify them before they're actually passed to the appender's C method, an inspection subroutine can be defined with the appender's C property: log4perl.appender.SomeApp.layout=NoopLayout log4perl.appender.SomeApp.warp_message = sub { \ $#_ = 2 if @_ > 3; \ return @_; } The inspection subroutine defined by the C property will receive the list of message chunks, like they were passed to the logger and is expected to return a corrected list. The example above simply limits the argument list to a maximum of three by cutting off excess elements and returning the shortened list. Also, the warp function can be specified by name like in log4perl.appender.SomeApp.layout=NoopLayout log4perl.appender.SomeApp.warp_message = main::filter_my_message In this example, C is a function in the C
package, defined like this: my $COUNTER = 0; sub filter_my_message { my @chunks = @_; unshift @chunks, ++$COUNTER; return @chunks; } The subroutine above will add an ever increasing counter as an additional first field to every message passed to the C appender -- but not to any other appender in the system. =head2 Composite Appenders Composite appenders relay their messages to sub-appenders after providing some filtering or synchronizing functionality on incoming messages. Examples are Log::Log4perl::Appender::Synchronized, Log::Log4perl::Appender::Limit, and Log::Log4perl::Appender::Buffer. Check their manual pages for details. Composite appender objects are regular Log::Log4perl::Appender objects, but they have the composite flag set: $app->composite(1); and they define a post_init() method, which sets the appender it relays its messages to: ########################################### 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; } The reason for this post-processing step is that the relay appender might not be defined yet when the composite appender gets defined. This can happen if Log4perl is initialized with a configuration file (which is the most common way to initialize Log4perl), because appenders spring into existance in unpredictable order. For example, if you define a Synchronized appender like log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized log4perl.appender.Syncer.appender = Logfile then Log4perl will set the appender's C attribute to the I of the appender to finally relay messages to. After the Log4perl configuration file has been processed, Log4perl will remember to call the composite appender's post_init() method, which will grab the relay appender instance referred to by the name (Logfile) and set it in its C attribute. This is exactly what the code snippet above does. But if you initialize Log4perl by its API, you need to remember to perform these steps. Here's the lineup: use Log::Log4perl qw(get_logger :levels); my $fileApp = Log::Log4perl::Appender->new( 'Log::Log4perl::Appender::File', name => 'MyFileApp', filename => 'mylog', mode => 'append', ); $fileApp->layout( Log::Log4perl::Layout::PatternLayout::Multiline->new( '%d{yyyy-MM-dd HH:mm:ss} %p [%c] #%P> %m%n') ); # Make the appender known to the system (without assigning it to # any logger Log::Log4perl->add_appender( $fileApp ); my $syncApp = Log::Log4perl::Appender->new( 'Log::Log4perl::Appender::Synchronized', name => 'MySyncApp', appender => 'MyFileApp', key => 'nem', ); $syncApp->post_init(); $syncApp->composite(1); # The Synchronized appender is now ready, assign it to a logger # and start logging. get_logger("")->add_appender($syncApp); get_logger("")->level($DEBUG); get_logger("wonk")->debug("waah!"); The composite appender's log() function will typically cache incoming messages until a certain trigger condition is met and then forward a bulk of messages to the relay appender. Caching messages is surprisingly tricky, because you want them to look like they came from the code location they were originally issued from and not from the location that triggers the flush. Luckily, Log4perl offers a cache mechanism for messages, all you need to do is call the base class' log() function with an additional reference to a scalar, and then save its content to your composite appender's message buffer afterwards: ########################################### sub log { ########################################### my($self, %params) = @_; # ... some logic to decide whether to cache or flush # Adjust the caller stack local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2; # We need to cache. # Ask the appender to save a cached message in $cache $self->{relay_app}->SUPER::log(\%params, $params{log4p_category}, $params{log4p_level}, \my $cache); # Save it in the appender's message buffer push @{ $self->{buffer} }, $cache; } Note that before calling the log() method of the relay appender's base class (and thus introducing two additional levels on the call stack), we need to adjust the call stack to allow Log4perl to render cspecs like the %M or %L correctly. The cache will then contain a correctly rendered message, according to the layout of the target appender. Later, when the time comes to flush the cached messages, a call to the relay appender's base class' log_cached() method with the cached message as an argument will forward the correctly rendered message: ########################################### sub log { ########################################### my($self, %params) = @_; # ... some logic to decide whether to cache or flush # Flush pending messages if we have any for my $cache (@{$self->{buffer}}) { $self->{relay_app}->SUPER::log_cached($cache); } } =head1 SEE ALSO Log::Dispatch =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. PK jZqg** Catalyst.pmnu[PK jZv9I*I*T*Appender/Limit.pmnu[PK jZITAppender/ScreenColoredLevels.pmnu[PK jZ, q7i i 0lAppender/Screen.pmnu[PK jZnN((xAppender/Synchronized.pmnu[PK jZ%XO O ١Appender/TestFileCreeper.pmnu[PK jZWWsAppender/Socket.pmnu[PK jZ_8  Appender/Buffer.pmnu[PK jZso o :Appender/TestArrayBuffer.pmnu[PK jZ!yAppender/RRDs.pmnu[PK jZs'Appender/TestBuffer.pmnu[PK jZ Appender/String.pmnu[PK jZ!ht|;|;Appender/File.pmnu[PK jZ0JNJN{ZAppender/DBI.pmnu[PK jZT<__ Config.pmnu[PK jZh-YYCConfig/PropertyConfigurator.pmnu[PK jZW!!C[Config/BaseConfigurator.pmnu[PK jZjj^}Config/DOMConfigurator.pmnu[PK jZPQ@(@(UConfig/Watch.pmnu[PK jZ,JavaMap/RollingFileAppender.pmnu[PK jZ= JavaMap/ConsoleAppender.pmnu[PK jZJJ)JavaMap/JDBCAppender.pmnu[PK jZ:p g8JavaMap/FileAppender.pmnu[PK jZ=!YY`EJavaMap/NTEventLogAppender.pmnu[PK jZw2Ƅ NJavaMap/SyslogAppender.pmnu[PK jZ2XJavaMap/TestBuffer.pmnu[PK jZL _MDC.pmnu[PK jZ}E))mFilter/LevelRange.pmnu[PK jZcj j )|Filter/MDC.pmnu[PK jZO OzzЅFilter/Boolean.pmnu[PK jZ[g* Filter/LevelMatch.pmnu[PK jZNټ rFilter/StringMatch.pmnu[PK jZAoosFAQ.pmnu[PK jZ~װ&&*Level.pmnu[PK jZE  ![QLayout/PatternLayout/Multiline.pmnu[PK jZy [Layout/SimpleLayout.pmnu[PK jZ'<<eLayout/NoopLayout.pmnu[PK jZH+Y3k3kenLayout/PatternLayout.pmnu[PK jZO JavaMap.pmnu[PK jZr (7(7 DateFormat.pmnu[PK jZ9z z A(Layout.pmnu[PK jZ,ax 1Logger.pmnu[PK jZNf&00 Filter.pmnu[PK jZMwwResurrector.pmnu[PK jZRN| | InternalDebug.pmnu[PK jZ_[#bNDC.pmnu[PK jZ)ܴ4Util/TimeTracker.pmnu[PK jZȥL;;+6Util/Semaphore.pmnu[PK jZ$h h RUtil.pmnu[PK jZWL)^^ F_Appender.pmnu[PK22 b