Log-Log4perl-1.46HEADLog-Log4perl-1.46master

1 files changed, 733 insertions, 0 deletions

diff --git a/lib/Log/Log4perl/Appender.pm b/lib/Log/Log4perl/Appender.pm
new file mode 100644
index 0000000..af925ac
--- /dev/null
+++ b/lib/Log/Log4perl/Appender.pm
@@ -0,0 +1,733 @@
+##################################################
+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<Log::Log4perl::Appender>
+appender set. 
+
+It also supports the <Log::Dispatch::*> collections of appenders. The
+module hides the idiosyncrasies of C<Log::Dispatch> (e.g. every
+dispatcher gotta have a name, but there's no accessor to retrieve it)
+from C<Log::Log4perl> and yet re-uses the extremely useful variety of
+dispatchers already created and tested in C<Log::Dispatch>.
+
+=head1 FUNCTIONS
+
+=head2 Log::Log4perl::Appender->new($dispatcher_class_name, ...);
+
+The constructor C<new()> takes the name of the appender
+class to be created as a I<string> (!) 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<Log::Dispatch> appenders,
+if no C<name> parameter is specified, the appender object will create
+a unique one (format C<appNNN>), which can be retrieved later via
+the C<name()> 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<filename> parameter specifies the name of 
+the C<Log::Log4perl::Appender::File> dispatcher used. 
+
+However, if, for instance, 
+you're using a C<Log::Dispatch::Email> dispatcher to send you 
+email, you'll have to specify C<from> and C<to> email addresses.
+Every dispatcher is different.
+Please check the C<Log::Dispatch::*> documentation for the appender used
+for details on specific requirements.
+
+The C<new()> method will just pass these parameters on to a newly created
+C<Log::Dispatch::*> object of the specified type.
+
+When it comes to logging, the C<Log::Log4perl::Appender> will transparently
+relay all messages to the C<Log::Dispatch::*> object it carries 
+in its womb.
+
+=head2 $appender->layout($layout);
+
+The C<layout()> method sets the log layout
+used by the appender to the format specified by the 
+C<Log::Log4perl::Layout::*> 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<Log::Log4perl::Layout::SimpleLayout> and 
+L<Log::Log4perl::Layout::PatternLayout> manual pages for details.
+
+=head1 Supported Appenders 
+
+Here's the list of appender modules currently available via C<Log::Dispatch>,
+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<Log4perl> doesn't care which ones you use, they're all handled in 
+the same way via the C<Log::Log4perl::Appender> interface.
+Please check the well-written manual pages of the 
+C<Log::Dispatch> 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<Log::Dispatch::File> appender truncates log files by default,
+and most of the time this is I<not> what you want, we've instructed 
+C<Log::Log4perl> to change this behavior by slipping it the 
+C<mode =E<gt> append> parameter behind the scenes. So, effectively
+with C<Log::Log4perl> 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<append> to an existing logfile C<test.log> 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<test.log> 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<Log::Log4perl::Appender::Screen> 
+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<Log::Log4perl::Appender::DBI> might take the
+three arguments passed to the logger and put them in three separate
+rows into the DB.
+
+The  C<warp_message> 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<SomeApp> 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<Log::Log4perl::Layout::NoopLayout> which just leaves 
+the messages chunks alone instead of formatting them or replacing
+conversion specifiers.
+
+B<Please note that the standard appenders in the Log::Dispatch hierarchy
+will choke on a bunch of messages passed to them as an array reference. 
+You can't use C<warp_message = 0> (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<log>
+method, an inspection subroutine can be defined with the
+appender's C<warp_message> property:
+
+    log4perl.appender.SomeApp.layout=NoopLayout
+    log4perl.appender.SomeApp.warp_message = sub { \
+                                           $#_ = 2 if @_ > 3; \
+                                           return @_; }
+
+The inspection subroutine defined by the C<warp_message> 
+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<filter_my_message> is a function in the C<main> 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<SomeApp> 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 existence 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<appender> attribute to the
+I<name> 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<app> 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 E<lt>m@perlmeister.comE<gt> 
+and Kevin Goess E<lt>cpan@goess.orgE<gt>.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=head1 AUTHOR
+
+Please contribute patches to the project on Github:
+
+    http://github.com/mschilli/log4perl
+
+Send bug reports or requests for enhancements to the authors via our
+
+MAILING LIST (questions, bug reports, suggestions/patches): 
+log4perl-devel@lists.sourceforge.net
+
+Authors (please contact them via the list above, not directly):
+Mike Schilli <m@perlmeister.com>,
+Kevin Goess <cpan@goess.org>
+
+Contributors (in alphabetical order):
+Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
+Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
+Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
+Grundman, Paul Harrington, Alexander Hartmaier  David Hull, 
+Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, 
+Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, 
+Lars Thegler, David Viner, Mac Yang.
+