1################################################## 2package Log::Log4perl::Appender; 3################################################## 4 5use 5.006; 6use strict; 7use warnings; 8 9use Log::Log4perl::Config; 10use Log::Log4perl::Level; 11use Carp; 12 13use constant _INTERNAL_DEBUG => 0; 14 15our $unique_counter = 0; 16 17################################################## 18sub reset { 19################################################## 20 $unique_counter = 0; 21} 22 23################################################## 24sub unique_name { 25################################################## 26 # THREADS: Need to lock here to make it thread safe 27 $unique_counter++; 28 my $unique_name = sprintf("app%03d", $unique_counter); 29 # THREADS: Need to unlock here to make it thread safe 30 return $unique_name; 31} 32 33################################################## 34sub new { 35################################################## 36 my($class, $appenderclass, %params) = @_; 37 38 # Pull in the specified Log::Log4perl::Appender object 39 eval { 40 41 # Eval erroneously succeeds on unknown appender classes if 42 # the eval string just consists of valid perl code (e.g. an 43 # appended ';' in $appenderclass variable). Fail if we see 44 # anything in there that can't be class name. 45 die "'$appenderclass' not a valid class name " if 46 $appenderclass =~ /[^:\w]/; 47 48 # Check if the class/package is already available because 49 # something like Class::Prototyped injected it previously. 50 51 # Use UNIVERSAL::can to check the appender's new() method 52 # [RT 28987] 53 if( ! $appenderclass->can('new') ) { 54 # Not available yet, try to pull it in. 55 # see 'perldoc -f require' for why two evals 56 eval "require $appenderclass"; 57 #unless ${$appenderclass.'::IS_LOADED'}; #for unit tests, 58 #see 004Config 59 die $@ if $@; 60 } 61 }; 62 63 $@ and die "ERROR: can't load appenderclass '$appenderclass'\n$@"; 64 65 $params{name} = unique_name() unless exists $params{name}; 66 67 # If it's a Log::Dispatch::File appender, default to append 68 # mode (Log::Dispatch::File defaults to 'clobber') -- consensus 9/2002 69 # (Log::Log4perl::Appender::File already defaults to 'append') 70 if ($appenderclass eq 'Log::Dispatch::File' && 71 ! exists $params{mode}) { 72 $params{mode} = 'append'; 73 } 74 75 my $appender = $appenderclass->new( 76 # Set min_level to the lowest setting. *we* are 77 # controlling this now, the appender should just 78 # log it with no questions asked. 79 min_level => 'debug', 80 # Set 'name' and other parameters 81 map { $_ => $params{$_} } keys %params, 82 ); 83 84 my $self = { 85 appender => $appender, 86 name => $params{name}, 87 layout => undef, 88 level => $ALL, 89 composite => 0, 90 }; 91 92 #whether to collapse arrays, etc. 93 $self->{warp_message} = $params{warp_message}; 94 if($self->{warp_message} and 95 my $cref = 96 Log::Log4perl::Config::compile_if_perl($self->{warp_message})) { 97 $self->{warp_message} = $cref; 98 } 99 100 bless $self, $class; 101 102 return $self; 103} 104 105################################################## 106sub composite { # Set/Get the composite flag 107################################################## 108 my ($self, $flag) = @_; 109 110 $self->{composite} = $flag if defined $flag; 111 return $self->{composite}; 112} 113 114################################################## 115sub threshold { # Set/Get the appender threshold 116################################################## 117 my ($self, $level) = @_; 118 119 print "Setting threshold to $level\n" if _INTERNAL_DEBUG; 120 121 if(defined $level) { 122 # Checking for \d makes for a faster regex(p) 123 $self->{level} = ($level =~ /^(\d+)$/) ? $level : 124 # Take advantage of &to_priority's error reporting 125 Log::Log4perl::Level::to_priority($level); 126 } 127 128 return $self->{level}; 129} 130 131################################################## 132sub log { 133################################################## 134# Relay this call to Log::Log4perl::Appender:* or 135# Log::Dispatch::* 136################################################## 137 my ($self, $p, $category, $level, $cache) = @_; 138 139 # Check if the appender has a last-minute veto in form 140 # of an "appender threshold" 141 if($self->{level} > $ 142 Log::Log4perl::Level::PRIORITY{$level}) { 143 print "$self->{level} > $level, aborting\n" if _INTERNAL_DEBUG; 144 return undef; 145 } 146 147 # Run against the (yes only one) customized filter (which in turn 148 # might call other filters via the Boolean filter) and check if its 149 # ok() method approves the message or blocks it. 150 if($self->{filter}) { 151 if($self->{filter}->ok(%$p, 152 log4p_category => $category, 153 log4p_level => $level )) { 154 print "Filter $self->{filter}->{name} passes\n" if _INTERNAL_DEBUG; 155 } else { 156 print "Filter $self->{filter}->{name} blocks\n" if _INTERNAL_DEBUG; 157 return undef; 158 } 159 } 160 161 unless($self->composite()) { 162 163 #not defined, the normal case 164 if (! defined $self->{warp_message} ){ 165 #join any message elements 166 if (ref $p->{message} eq "ARRAY") { 167 for my $i (0..$#{$p->{message}}) { 168 if( !defined $p->{message}->[ $i ] ) { 169 local $Carp::CarpLevel = 170 $Carp::CarpLevel + $Log::Log4perl::caller_depth + 1; 171 carp "Warning: Log message argument #" . 172 ($i+1) . " undefined"; 173 } 174 } 175 $p->{message} = 176 join($Log::Log4perl::JOIN_MSG_ARRAY_CHAR, 177 @{$p->{message}} 178 ); 179 } 180 181 #defined but false, e.g. Appender::DBI 182 } elsif (! $self->{warp_message}) { 183 ; #leave the message alone 184 185 } elsif (ref($self->{warp_message}) eq "CODE") { 186 #defined and a subref 187 $p->{message} = 188 [$self->{warp_message}->(@{$p->{message}})]; 189 } else { 190 #defined and a function name? 191 no strict qw(refs); 192 $p->{message} = 193 [$self->{warp_message}->(@{$p->{message}})]; 194 } 195 196 $p->{message} = $self->{layout}->render($p->{message}, 197 $category, 198 $level, 199 3 + $Log::Log4perl::caller_depth, 200 ) if $self->layout(); 201 } 202 203 my $args = [%$p, log4p_category => $category, log4p_level => $level]; 204 205 if(defined $cache) { 206 $$cache = $args; 207 } else { 208 $self->{appender}->log(@$args); 209 } 210 211 return 1; 212} 213 214########################################### 215sub log_cached { 216########################################### 217 my ($self, $cache) = @_; 218 219 $self->{appender}->log(@$cache); 220} 221 222################################################## 223sub name { # Set/Get the name 224################################################## 225 my($self, $name) = @_; 226 227 # Somebody wants to *set* the name? 228 if($name) { 229 $self->{name} = $name; 230 } 231 232 return $self->{name}; 233} 234 235########################################### 236sub layout { # Set/Get the layout object 237 # associated with this appender 238########################################### 239 my($self, $layout) = @_; 240 241 # Somebody wants to *set* the layout? 242 if($layout) { 243 $self->{layout} = $layout; 244 245 # somebody wants a layout, but not set yet, so give 'em default 246 }elsif (! $self->{layout}) { 247 $self->{layout} = Log::Log4perl::Layout::SimpleLayout 248 ->new($self->{name}); 249 250 } 251 252 return $self->{layout}; 253} 254 255################################################## 256sub filter { # Set filter 257################################################## 258 my ($self, $filter) = @_; 259 260 if($filter) { 261 print "Setting filter to $filter->{name}\n" if _INTERNAL_DEBUG; 262 $self->{filter} = $filter; 263 } 264 265 return $self->{filter}; 266} 267 268################################################## 269sub AUTOLOAD { 270################################################## 271# Relay everything else to the underlying 272# Log::Log4perl::Appender::* or Log::Dispatch::* 273# object 274################################################## 275 my $self = shift; 276 277 no strict qw(vars); 278 279 $AUTOLOAD =~ s/.*:://; 280 281 if(! defined $self->{appender}) { 282 die "Can't locate object method $AUTOLOAD() in ", __PACKAGE__; 283 } 284 285 return $self->{appender}->$AUTOLOAD(@_); 286} 287 288################################################## 289sub DESTROY { 290################################################## 291 foreach my $key (keys %{$_[0]}) { 292 # print "deleting $key\n"; 293 delete $_[0]->{$key}; 294 } 295} 296 2971; 298 299__END__ 300 301=head1 NAME 302 303Log::Log4perl::Appender - Log appender class 304 305=head1 SYNOPSIS 306 307 use Log::Log4perl; 308 309 # Define a logger 310 my $logger = Log::Log4perl->get_logger("abc.def.ghi"); 311 312 # Define a layout 313 my $layout = Log::Log4perl::Layout::PatternLayout->new( 314 "%d (%F:%L)> %m"); 315 316 # Define an appender 317 my $appender = Log::Log4perl::Appender->new( 318 "Log::Log4perl::Appender::Screen", 319 name => 'dumpy'); 320 321 # Set the appender's layout 322 $appender->layout($layout); 323 $logger->add_appender($appender); 324 325=head1 DESCRIPTION 326 327This class is a wrapper around the C<Log::Log4perl::Appender> 328appender set. 329 330It also supports the <Log::Dispatch::*> collections of appenders. The 331module hides the idiosyncrasies of C<Log::Dispatch> (e.g. every 332dispatcher gotta have a name, but there's no accessor to retrieve it) 333from C<Log::Log4perl> and yet re-uses the extremely useful variety of 334dispatchers already created and tested in C<Log::Dispatch>. 335 336=head1 FUNCTIONS 337 338=head2 Log::Log4perl::Appender->new($dispatcher_class_name, ...); 339 340The constructor C<new()> takes the name of the appender 341class to be created as a I<string> (!) argument, optionally followed by 342a number of appender-specific parameters, 343for example: 344 345 # Define an appender 346 my $appender = Log::Log4perl::Appender->new( 347 "Log::Log4perl::Appender::File" 348 filename => 'out.log'); 349 350In case of C<Log::Dispatch> appenders, 351if no C<name> parameter is specified, the appender object will create 352a unique one (format C<appNNN>), which can be retrieved later via 353the C<name()> method: 354 355 print "The appender's name is ", $appender->name(), "\n"; 356 357Other parameters are specific to the appender class being used. 358In the case above, the C<filename> parameter specifies the name of 359the C<Log::Log4perl::Appender::File> dispatcher used. 360 361However, if, for instance, 362you're using a C<Log::Dispatch::Email> dispatcher to send you 363email, you'll have to specify C<from> and C<to> email addresses. 364Every dispatcher is different. 365Please check the C<Log::Dispatch::*> documentation for the appender used 366for details on specific requirements. 367 368The C<new()> method will just pass these parameters on to a newly created 369C<Log::Dispatch::*> object of the specified type. 370 371When it comes to logging, the C<Log::Log4perl::Appender> will transparently 372relay all messages to the C<Log::Dispatch::*> object it carries 373in its womb. 374 375=head2 $appender->layout($layout); 376 377The C<layout()> method sets the log layout 378used by the appender to the format specified by the 379C<Log::Log4perl::Layout::*> object which is passed to it as a reference. 380Currently there's two layouts available: 381 382 Log::Log4perl::Layout::SimpleLayout 383 Log::Log4perl::Layout::PatternLayout 384 385Please check the L<Log::Log4perl::Layout::SimpleLayout> and 386L<Log::Log4perl::Layout::PatternLayout> manual pages for details. 387 388=head1 Supported Appenders 389 390Here's the list of appender modules currently available via C<Log::Dispatch>, 391if not noted otherwise, written by Dave Rolsky: 392 393 Log::Dispatch::ApacheLog 394 Log::Dispatch::DBI (by Tatsuhiko Miyagawa) 395 Log::Dispatch::Email, 396 Log::Dispatch::Email::MailSend, 397 Log::Dispatch::Email::MailSendmail, 398 Log::Dispatch::Email::MIMELite 399 Log::Dispatch::File 400 Log::Dispatch::FileRotate (by Mark Pfeiffer) 401 Log::Dispatch::Handle 402 Log::Dispatch::Screen 403 Log::Dispatch::Syslog 404 Log::Dispatch::Tk (by Dominique Dumont) 405 406C<Log4perl> doesn't care which ones you use, they're all handled in 407the same way via the C<Log::Log4perl::Appender> interface. 408Please check the well-written manual pages of the 409C<Log::Dispatch> hierarchy on how to use each one of them. 410 411=head1 Parameters passed on to the appender's log() method 412 413When calling the appender's log()-Funktion, Log::Log4perl will 414submit a list of key/value pairs. Entries to the following keys are 415guaranteed to be present: 416 417=over 4 418 419=item message 420 421Text of the rendered message 422 423=item log4p_category 424 425Name of the category of the logger that triggered the event. 426 427=item log4p_level 428 429Log::Log4perl level of the event 430 431=back 432 433=head1 Pitfalls 434 435Since the C<Log::Dispatch::File> appender truncates log files by default, 436and most of the time this is I<not> what you want, we've instructed 437C<Log::Log4perl> to change this behavior by slipping it the 438C<mode =E<gt> append> parameter behind the scenes. So, effectively 439with C<Log::Log4perl> 0.23, a configuration like 440 441 log4perl.category = INFO, FileAppndr 442 log4perl.appender.FileAppndr = Log::Dispatch::File 443 log4perl.appender.FileAppndr.filename = test.log 444 log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout 445 446will always I<append> to an existing logfile C<test.log> while if you 447specifically request clobbering like in 448 449 log4perl.category = INFO, FileAppndr 450 log4perl.appender.FileAppndr = Log::Dispatch::File 451 log4perl.appender.FileAppndr.filename = test.log 452 log4perl.appender.FileAppndr.mode = write 453 log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout 454 455it will overwrite an existing log file C<test.log> and start from scratch. 456 457=head1 Appenders Expecting Message Chunks 458 459Instead of simple strings, certain appenders are expecting multiple fields 460as log messages. If a statement like 461 462 $logger->debug($ip, $user, "signed in"); 463 464causes an off-the-shelf C<Log::Log4perl::Appender::Screen> 465appender to fire, the appender will 466just concatenate the three message chunks passed to it 467in order to form a single string. 468The chunks will be separated by a string defined in 469C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (defaults to the empty string 470""). 471 472However, different appenders might choose to 473interpret the message above differently: An 474appender like C<Log::Log4perl::Appender::DBI> might take the 475three arguments passed to the logger and put them in three separate 476rows into the DB. 477 478The C<warp_message> appender option is used to specify the desired 479behavior. 480If no setting for the appender property 481 482 # *** Not defined *** 483 # log4perl.appender.SomeApp.warp_message 484 485is defined in the Log4perl configuration file, the 486appender referenced by C<SomeApp> will fall back to the standard behavior 487and join all message chunks together, separating them by 488C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR>. 489 490If, on the other hand, it is set to a false value, like in 491 492 log4perl.appender.SomeApp.layout=NoopLayout 493 log4perl.appender.SomeApp.warp_message = 0 494 495then the message chunks are passed unmodified to the appender as an 496array reference. Please note that you need to set the appender's 497layout to C<Log::Log4perl::Layout::NoopLayout> which just leaves 498the messages chunks alone instead of formatting them or replacing 499conversion specifiers. 500 501B<Please note that the standard appenders in the Log::Dispatch hierarchy 502will choke on a bunch of messages passed to them as an array reference. 503You can't use C<warp_message = 0> (or the function name syntax 504defined below) on them. 505Only special appenders like Log::Log4perl::Appender::DBI can deal with 506this.> 507 508If (and now we're getting fancy) 509an appender expects message chunks, but we would 510like to pre-inspect and probably modify them before they're 511actually passed to the appender's C<log> 512method, an inspection subroutine can be defined with the 513appender's C<warp_message> property: 514 515 log4perl.appender.SomeApp.layout=NoopLayout 516 log4perl.appender.SomeApp.warp_message = sub { \ 517 $#_ = 2 if @_ > 3; \ 518 return @_; } 519 520The inspection subroutine defined by the C<warp_message> 521property will receive the list of message chunks, like they were 522passed to the logger and is expected to return a corrected list. 523The example above simply limits the argument list to a maximum of 524three by cutting off excess elements and returning the shortened list. 525 526Also, the warp function can be specified by name like in 527 528 log4perl.appender.SomeApp.layout=NoopLayout 529 log4perl.appender.SomeApp.warp_message = main::filter_my_message 530 531In this example, 532C<filter_my_message> is a function in the C<main> package, 533defined like this: 534 535 my $COUNTER = 0; 536 537 sub filter_my_message { 538 my @chunks = @_; 539 unshift @chunks, ++$COUNTER; 540 return @chunks; 541 } 542 543The subroutine above will add an ever increasing counter 544as an additional first field to 545every message passed to the C<SomeApp> appender -- but not to 546any other appender in the system. 547 548=head2 Composite Appenders 549 550Composite appenders relay their messages to sub-appenders after providing 551some filtering or synchronizing functionality on incoming messages. 552Examples are 553Log::Log4perl::Appender::Synchronized, 554Log::Log4perl::Appender::Limit, and 555Log::Log4perl::Appender::Buffer. Check their manual pages for details. 556 557Composite appender objects are regular Log::Log4perl::Appender objects, 558but they have the composite flag set: 559 560 $app->composite(1); 561 562and they define a post_init() method, which sets the appender it relays 563its messages to: 564 565 ########################################### 566 sub post_init { 567 ############################################ 568 my($self) = @_; 569 570 if(! exists $self->{appender}) { 571 die "No appender defined for " . __PACKAGE__; 572 } 573 574 my $appenders = Log::Log4perl->appenders(); 575 my $appender = Log::Log4perl->appenders()->{$self->{appender}}; 576 577 if(! defined $appender) { 578 die "Appender $self->{appender} not defined (yet) when " . 579 __PACKAGE__ . " needed it"; 580 } 581 582 $self->{app} = $appender; 583 } 584 585The reason for this post-processing step is that the relay appender 586might not be defined yet when the composite appender gets defined. 587This can happen if Log4perl is initialized with a configuration file 588(which is the most common way to initialize Log4perl), because 589appenders spring into existance in unpredictable order. 590 591For example, if you define a Synchronized appender like 592 593 log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized 594 log4perl.appender.Syncer.appender = Logfile 595 596then Log4perl will set the appender's C<appender> attribute to the 597I<name> of the appender to finally relay messages to. After the 598Log4perl configuration file has been processed, Log4perl will remember to 599call the composite appender's post_init() method, which will grab 600the relay appender instance referred to by the name (Logfile) 601and set it in its C<app> attribute. This is exactly what the 602code snippet above does. 603 604But if you initialize Log4perl by its API, you need to remember to 605perform these steps. Here's the lineup: 606 607 use Log::Log4perl qw(get_logger :levels); 608 609 my $fileApp = Log::Log4perl::Appender->new( 610 'Log::Log4perl::Appender::File', 611 name => 'MyFileApp', 612 filename => 'mylog', 613 mode => 'append', 614 ); 615 $fileApp->layout( 616 Log::Log4perl::Layout::PatternLayout::Multiline->new( 617 '%d{yyyy-MM-dd HH:mm:ss} %p [%c] #%P> %m%n') 618 ); 619 # Make the appender known to the system (without assigning it to 620 # any logger 621 Log::Log4perl->add_appender( $fileApp ); 622 623 my $syncApp = Log::Log4perl::Appender->new( 624 'Log::Log4perl::Appender::Synchronized', 625 name => 'MySyncApp', 626 appender => 'MyFileApp', 627 key => 'nem', 628 ); 629 $syncApp->post_init(); 630 $syncApp->composite(1); 631 632 # The Synchronized appender is now ready, assign it to a logger 633 # and start logging. 634 get_logger("")->add_appender($syncApp); 635 636 get_logger("")->level($DEBUG); 637 get_logger("wonk")->debug("waah!"); 638 639The composite appender's log() function will typically cache incoming 640messages until a certain trigger condition is met and then forward a bulk 641of messages to the relay appender. 642 643Caching messages is surprisingly tricky, because you want them to look 644like they came from the code location they were originally issued from 645and not from the location that triggers the flush. Luckily, Log4perl 646offers a cache mechanism for messages, all you need to do is call the 647base class' log() function with an additional reference to a scalar, 648and then save its content to your composite appender's message buffer 649afterwards: 650 651 ########################################### 652 sub log { 653 ########################################### 654 my($self, %params) = @_; 655 656 # ... some logic to decide whether to cache or flush 657 658 # Adjust the caller stack 659 local $Log::Log4perl::caller_depth = 660 $Log::Log4perl::caller_depth + 2; 661 662 # We need to cache. 663 # Ask the appender to save a cached message in $cache 664 $self->{relay_app}->SUPER::log(\%params, 665 $params{log4p_category}, 666 $params{log4p_level}, \my $cache); 667 668 # Save it in the appender's message buffer 669 push @{ $self->{buffer} }, $cache; 670 } 671 672Note that before calling the log() method of the relay appender's base class 673(and thus introducing two additional levels on the call stack), we need to 674adjust the call stack to allow Log4perl to render cspecs like the %M or %L 675correctly. The cache will then contain a correctly rendered message, according 676to the layout of the target appender. 677 678Later, when the time comes to flush the cached messages, a call to the relay 679appender's base class' log_cached() method with the cached message as 680an argument will forward the correctly rendered message: 681 682 ########################################### 683 sub log { 684 ########################################### 685 my($self, %params) = @_; 686 687 # ... some logic to decide whether to cache or flush 688 689 # Flush pending messages if we have any 690 for my $cache (@{$self->{buffer}}) { 691 $self->{relay_app}->SUPER::log_cached($cache); 692 } 693 } 694 695 696=head1 SEE ALSO 697 698Log::Dispatch 699 700=head1 LICENSE 701 702Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt> 703and Kevin Goess E<lt>cpan@goess.orgE<gt>. 704 705This library is free software; you can redistribute it and/or modify 706it under the same terms as Perl itself. 707 708=head1 AUTHOR 709 710Please contribute patches to the project on Github: 711 712 http://github.com/mschilli/log4perl 713 714Send bug reports or requests for enhancements to the authors via our 715 716MAILING LIST (questions, bug reports, suggestions/patches): 717log4perl-devel@lists.sourceforge.net 718 719Authors (please contact them via the list above, not directly): 720Mike Schilli <m@perlmeister.com>, 721Kevin Goess <cpan@goess.org> 722 723Contributors (in alphabetical order): 724Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton 725Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony 726Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy 727Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles, 728Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik 729Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang. 730 731