1package Log::Dispatch; 2{ 3 $Log::Dispatch::VERSION = '2.34'; 4} 5 6use 5.006; 7 8use strict; 9use warnings; 10 11use base qw( Log::Dispatch::Base ); 12use Class::Load qw( load_class ); 13use Params::Validate 0.15 qw(validate_with ARRAYREF CODEREF); 14use Carp (); 15 16our %LEVELS; 17 18BEGIN { 19 my %level_map = ( 20 ( 21 map { $_ => $_ } 22 qw( 23 debug 24 info 25 notice 26 warning 27 error 28 critical 29 alert 30 emergency 31 ) 32 ), 33 warn => 'warning', 34 err => 'error', 35 crit => 'critical', 36 emerg => 'emergency', 37 ); 38 39 foreach my $l ( keys %level_map ) { 40 my $sub = sub { 41 my $self = shift; 42 $self->log( 43 level => $level_map{$l}, 44 message => @_ > 1 ? "@_" : $_[0], 45 ); 46 }; 47 48 $LEVELS{$l} = 1; 49 50 no strict 'refs'; 51 *{$l} = $sub; 52 } 53} 54 55sub new { 56 my $proto = shift; 57 my $class = ref $proto || $proto; 58 59 my %p = validate_with( 60 params => \@_, 61 spec => { 62 outputs => { type => ARRAYREF, optional => 1 }, 63 callbacks => { type => ARRAYREF | CODEREF, optional => 1 } 64 }, 65 allow_extra => 1, # for backward compatibility 66 ); 67 68 my $self = bless {}, $class; 69 70 my @cb = $self->_get_callbacks(%p); 71 $self->{callbacks} = \@cb if @cb; 72 73 if ( my $outputs = $p{outputs} ) { 74 if ( ref $outputs->[1] eq 'HASH' ) { 75 76 # 2.23 API 77 # outputs => [ 78 # File => { min_level => 'debug', filename => 'logfile' }, 79 # Screen => { min_level => 'warning' } 80 # ] 81 while ( my ( $class, $params ) = splice @$outputs, 0, 2 ) { 82 $self->_add_output( $class, %$params ); 83 } 84 } 85 else { 86 87 # 2.24+ syntax 88 # outputs => [ 89 # [ 'File', min_level => 'debug', filename => 'logfile' ], 90 # [ 'Screen', min_level => 'warning' ] 91 # ] 92 foreach my $arr (@$outputs) { 93 die "expected arrayref, not '$arr'" 94 unless ref $arr eq 'ARRAY'; 95 $self->_add_output(@$arr); 96 } 97 } 98 } 99 100 return $self; 101} 102 103sub _add_output { 104 my $self = shift; 105 my $class = shift; 106 107 my $full_class 108 = substr( $class, 0, 1 ) eq '+' 109 ? substr( $class, 1 ) 110 : "Log::Dispatch::$class"; 111 112 load_class($full_class); 113 114 $self->add( $full_class->new(@_) ); 115} 116 117sub add { 118 my $self = shift; 119 my $object = shift; 120 121 # Once 5.6 is more established start using the warnings module. 122 if ( exists $self->{outputs}{ $object->name } && $^W ) { 123 Carp::carp( 124 "Log::Dispatch::* object ", $object->name, 125 " already exists." 126 ); 127 } 128 129 $self->{outputs}{ $object->name } = $object; 130} 131 132sub remove { 133 my $self = shift; 134 my $name = shift; 135 136 return delete $self->{outputs}{$name}; 137} 138 139sub log { 140 my $self = shift; 141 my %p = @_; 142 143 return unless $self->would_log( $p{level} ); 144 145 $self->_log_to_outputs( $self->_prepare_message(%p) ); 146} 147 148sub _prepare_message { 149 my $self = shift; 150 my %p = @_; 151 152 $p{message} = $p{message}->() 153 if ref $p{message} eq 'CODE'; 154 155 $p{message} = $self->_apply_callbacks(%p) 156 if $self->{callbacks}; 157 158 return %p; 159} 160 161sub _log_to_outputs { 162 my $self = shift; 163 my %p = @_; 164 165 foreach ( keys %{ $self->{outputs} } ) { 166 $p{name} = $_; 167 $self->_log_to(%p); 168 } 169} 170 171sub log_and_die { 172 my $self = shift; 173 174 my %p = $self->_prepare_message(@_); 175 176 $self->_log_to_outputs(%p) if $self->would_log( $p{level} ); 177 178 $self->_die_with_message(%p); 179} 180 181sub log_and_croak { 182 my $self = shift; 183 184 $self->log_and_die( @_, carp_level => 3 ); 185} 186 187sub _die_with_message { 188 my $self = shift; 189 my %p = @_; 190 191 my $msg = $p{message}; 192 193 local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $p{carp_level} 194 if exists $p{carp_level}; 195 196 Carp::croak($msg); 197} 198 199sub log_to { 200 my $self = shift; 201 my %p = @_; 202 203 $p{message} = $self->_apply_callbacks(%p) 204 if $self->{callbacks}; 205 206 $self->_log_to(%p); 207} 208 209sub _log_to { 210 my $self = shift; 211 my %p = @_; 212 my $name = $p{name}; 213 214 if ( exists $self->{outputs}{$name} ) { 215 $self->{outputs}{$name}->log(@_); 216 } 217 elsif ($^W) { 218 Carp::carp( 219 "Log::Dispatch::* object named '$name' not in dispatcher\n"); 220 } 221} 222 223sub output { 224 my $self = shift; 225 my $name = shift; 226 227 return unless exists $self->{outputs}{$name}; 228 229 return $self->{outputs}{$name}; 230} 231 232sub level_is_valid { 233 shift; 234 return $LEVELS{ shift() }; 235} 236 237sub would_log { 238 my $self = shift; 239 my $level = shift; 240 241 return 0 unless $self->level_is_valid($level); 242 243 foreach ( values %{ $self->{outputs} } ) { 244 return 1 if $_->_should_log($level); 245 } 246 247 return 0; 248} 249 250sub is_debug { $_[0]->would_log('debug') } 251sub is_info { $_[0]->would_log('info') } 252sub is_notice { $_[0]->would_log('notice') } 253sub is_warning { $_[0]->would_log('warning') } 254sub is_warn { $_[0]->would_log('warn') } 255sub is_error { $_[0]->would_log('error') } 256sub is_err { $_[0]->would_log('err') } 257sub is_critical { $_[0]->would_log('critical') } 258sub is_crit { $_[0]->would_log('crit') } 259sub is_alert { $_[0]->would_log('alert') } 260sub is_emerg { $_[0]->would_log('emerg') } 261sub is_emergency { $_[0]->would_log('emergency') } 262 2631; 264 265# ABSTRACT: Dispatches messages to one or more outputs 266 267__END__ 268 269=pod 270 271=head1 NAME 272 273Log::Dispatch - Dispatches messages to one or more outputs 274 275=head1 VERSION 276 277version 2.34 278 279=head1 SYNOPSIS 280 281 use Log::Dispatch; 282 283 # Simple API 284 # 285 my $log = Log::Dispatch->new( 286 outputs => [ 287 [ 'File', min_level => 'debug', filename => 'logfile' ], 288 [ 'Screen', min_level => 'warning' ], 289 ], 290 ); 291 292 $log->info('Blah, blah'); 293 294 # More verbose API 295 # 296 my $log = Log::Dispatch->new(); 297 $log->add( 298 Log::Dispatch::File->new( 299 name => 'file1', 300 min_level => 'debug', 301 filename => 'logfile' 302 ) 303 ); 304 $log->add( 305 Log::Dispatch::Screen->new( 306 name => 'screen', 307 min_level => 'warning', 308 ) 309 ); 310 311 $log->log( level => 'info', message => 'Blah, blah' ); 312 313 my $sub = sub { my %p = @_; return reverse $p{message}; }; 314 my $reversing_dispatcher = Log::Dispatch->new( callbacks => $sub ); 315 316=head1 DESCRIPTION 317 318This module manages a set of Log::Dispatch::* output objects that can be 319logged to via a unified interface. 320 321The idea is that you create a Log::Dispatch object and then add various 322logging objects to it (such as a file logger or screen logger). Then you 323call the C<log> method of the dispatch object, which passes the message to 324each of the objects, which in turn decide whether or not to accept the 325message and what to do with it. 326 327This makes it possible to call single method and send a message to a 328log file, via email, to the screen, and anywhere else, all with very 329little code needed on your part, once the dispatching object has been 330created. 331 332=head1 CONSTRUCTOR 333 334The constructor (C<new>) takes the following parameters: 335 336=over 4 337 338=item * outputs( [ [ class, params, ... ], [ class, params, ... ], ... ] ) 339 340This parameter is a reference to a list of lists. Each inner list consists of 341a class name and a set of constructor params. The class is automatically 342prefixed with 'Log::Dispatch::' unless it begins with '+', in which case the 343string following '+' is taken to be a full classname. e.g. 344 345 outputs => [ [ 'File', min_level => 'debug', filename => 'logfile' ], 346 [ '+My::Dispatch', min_level => 'info' ] ] 347 348For each inner list, a new output object is created and added to the 349dispatcher (via the C<add() method>). 350 351See L<OUTPUT CLASSES> for the parameters that can be used when creating an 352output object. 353 354=item * callbacks( \& or [ \&, \&, ... ] ) 355 356This parameter may be a single subroutine reference or an array 357reference of subroutine references. These callbacks will be called in 358the order they are given and passed a hash containing the following keys: 359 360 ( message => $log_message, level => $log_level ) 361 362In addition, any key/value pairs passed to a logging method will be 363passed onto your callback. 364 365The callbacks are expected to modify the message and then return a 366single scalar containing that modified message. These callbacks will 367be called when either the C<log> or C<log_to> methods are called and 368will only be applied to a given message once. If they do not return 369the message then you will get no output. Make sure to return the 370message! 371 372=back 373 374=head1 METHODS 375 376=head2 Logging 377 378=over 4 379 380=item * log( level => $, message => $ or \& ) 381 382Sends the message (at the appropriate level) to all the 383output objects that the dispatcher contains (by calling the 384C<log_to> method repeatedly). 385 386This method also accepts a subroutine reference as the message 387argument. This reference will be called only if there is an output 388that will accept a message of the specified level. 389 390=item * debug (message), info (message), ... 391 392You may call any valid log level (including valid abbreviations) as a method 393with a single argument that is the message to be logged. This is converted 394into a call to the C<log> method with the appropriate level. 395 396For example: 397 398 $log->alert('Strange data in incoming request'); 399 400translates to: 401 402 $log->log( level => 'alert', message => 'Strange data in incoming request' ); 403 404If you pass an array to these methods, it will be stringified as is: 405 406 my @array = ('Something', 'bad', 'is', here'); 407 $log->alert(@array); 408 409 # is equivalent to 410 411 $log->alert("@array"); 412 413You can also pass a subroutine reference, just like passing one to the 414C<log()> method. 415 416=item * log_and_die( level => $, message => $ or \& ) 417 418Has the same behavior as calling C<log()> but calls 419C<_die_with_message()> at the end. 420 421=item * log_and_croak( level => $, message => $ or \& ) 422 423This method adjusts the C<$Carp::CarpLevel> scalar so that the croak 424comes from the context in which it is called. 425 426=item * _die_with_message( message => $, carp_level => $ ) 427 428This method is used by C<log_and_die> and will either die() or croak() 429depending on the value of C<message>: if it's a reference or it ends 430with a new line then a plain die will be used, otherwise it will 431croak. 432 433You can throw exception objects by subclassing this method. 434 435If the C<carp_level> parameter is present its value will be added to 436the current value of C<$Carp::CarpLevel>. 437 438=item * log_to( name => $, level => $, message => $ ) 439 440Sends the message only to the named object. Note: this will not properly 441handle a subroutine reference as the message. 442 443=item * add_callback( $code ) 444 445Adds a callback (like those given during construction). It is added to the end 446of the list of callbacks. Note that this can also be called on individual 447output objects. 448 449=back 450 451=head2 Log levels 452 453=over 4 454 455=item * level_is_valid( $string ) 456 457Returns true or false to indicate whether or not the given string is a 458valid log level. Can be called as either a class or object method. 459 460=item * would_log( $string ) 461 462Given a log level, returns true or false to indicate whether or not 463anything would be logged for that log level. 464 465=item * is_C<$level> 466 467There are methods for every log level: C<is_debug()>, C<is_warning()>, etc. 468 469This returns true if the logger will log a message at the given level. 470 471=back 472 473=head2 Output objects 474 475=over 476 477=item * add( Log::Dispatch::* OBJECT ) 478 479Adds a new L<output object|OUTPUT CLASSES> to the dispatcher. If an object 480of the same name already exists, then that object is replaced, with 481a warning if C<$^W> is true. 482 483=item * remove($) 484 485Removes the object that matches the name given to the remove method. 486The return value is the object being removed or undef if no object 487matched this. 488 489=item * output( $name ) 490 491Returns the output object of the given name. Returns undef or an empty 492list, depending on context, if the given output does not exist. 493 494=back 495 496=head1 OUTPUT CLASSES 497 498An output class - e.g. L<Log::Dispatch::File> or 499L<Log::Dispatch::Screen> - implements a particular way 500of dispatching logs. Many output classes come with this distribution, 501and others are available separately on CPAN. 502 503The following common parameters can be used when creating an output class. 504All are optional. Most output classes will have additional parameters beyond 505these, see their documentation for details. 506 507=over 4 508 509=item * name ($) 510 511A name for the object (not the filename!). This is useful if you want to 512refer to the object later, e.g. to log specifically to it or remove it. 513 514By default a unique name will be generated. You should not depend on the 515form of generated names, as they may change. 516 517=item * min_level ($) 518 519The minimum L<logging level|LOG LEVELS> this object will accept. Required. 520 521=item * max_level ($) 522 523The maximum L<logging level|LOG LEVELS> this object will accept. By default 524the maximum is the highest possible level (which means functionally that the 525object has no maximum). 526 527=item * callbacks( \& or [ \&, \&, ... ] ) 528 529This parameter may be a single subroutine reference or an array 530reference of subroutine references. These callbacks will be called in 531the order they are given and passed a hash containing the following keys: 532 533 ( message => $log_message, level => $log_level ) 534 535The callbacks are expected to modify the message and then return a 536single scalar containing that modified message. These callbacks will 537be called when either the C<log> or C<log_to> methods are called and 538will only be applied to a given message once. If they do not return 539the message then you will get no output. Make sure to return the 540message! 541 542=item * newline (0|1) 543 544If true, a callback will be added to the end of the callbacks list that adds 545a newline to the end of each message. Default is false, but some 546output classes may decide to make the default true. 547 548=back 549 550=head1 LOG LEVELS 551 552The log levels that Log::Dispatch uses are taken directly from the 553syslog man pages (except that I expanded them to full words). Valid 554levels are: 555 556=over 4 557 558=item debug 559 560=item info 561 562=item notice 563 564=item warning 565 566=item error 567 568=item critical 569 570=item alert 571 572=item emergency 573 574=back 575 576Alternately, the numbers 0 through 7 may be used (debug is 0 and emergency is 5777). The syslog standard of 'err', 'crit', and 'emerg' is also acceptable. We 578also allow 'warn' as a synonym for 'warning'. 579 580=head1 SUBCLASSING 581 582This module was designed to be easy to subclass. If you want to handle 583messaging in a way not implemented in this package, you should be able to add 584this with minimal effort. It is generally as simple as subclassing 585Log::Dispatch::Output and overriding the C<new> and C<log_message> 586methods. See the L<Log::Dispatch::Output> docs for more details. 587 588If you would like to create your own subclass for sending email then 589it is even simpler. Simply subclass L<Log::Dispatch::Email> and 590override the C<send_email> method. See the L<Log::Dispatch::Email> 591docs for more details. 592 593The logging levels that Log::Dispatch uses are borrowed from the standard 594UNIX syslog levels, except that where syslog uses partial words ("err") 595Log::Dispatch also allows the use of the full word as well ("error"). 596 597=head1 RELATED MODULES 598 599=head2 Log::Dispatch::DBI 600 601Written by Tatsuhiko Miyagawa. Log output to a database table. 602 603=head2 Log::Dispatch::FileRotate 604 605Written by Mark Pfeiffer. Rotates log files periodically as part of 606its usage. 607 608=head2 Log::Dispatch::File::Stamped 609 610Written by Eric Cholet. Stamps log files with date and time 611information. 612 613=head2 Log::Dispatch::Jabber 614 615Written by Aaron Straup Cope. Logs messages via Jabber. 616 617=head2 Log::Dispatch::Tk 618 619Written by Dominique Dumont. Logs messages to a Tk window. 620 621=head2 Log::Dispatch::Win32EventLog 622 623Written by Arthur Bergman. Logs messages to the Windows event log. 624 625=head2 Log::Log4perl 626 627An implementation of Java's log4j API in Perl. Log messages can be limited by 628fine-grained controls, and if they end up being logged, both native Log4perl 629and Log::Dispatch appenders can be used to perform the actual logging 630job. Created by Mike Schilli and Kevin Goess. 631 632=head2 Log::Dispatch::Config 633 634Written by Tatsuhiko Miyagawa. Allows configuration of logging via a 635text file similar (or so I'm told) to how it is done with log4j. 636Simpler than Log::Log4perl. 637 638=head2 Log::Agent 639 640A very different API for doing many of the same things that 641Log::Dispatch does. Originally written by Raphael Manfredi. 642 643=head1 SUPPORT 644 645Please submit bugs and patches to the CPAN RT system at 646http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Log%3A%3ADispatch 647or via email at bug-log-dispatch@rt.cpan.org. 648 649Support questions can be sent to me at my email address, shown below. 650 651=head1 DONATIONS 652 653If you'd like to thank me for the work I've done on this module, 654please consider making a "donation" to me via PayPal. I spend a lot of 655free time creating free software, and would appreciate any support 656you'd care to offer. 657 658Please note that B<I am not suggesting that you must do this> in order 659for me to continue working on this particular software. I will 660continue to do so, inasmuch as I have in the past, for as long as it 661interests me. 662 663Similarly, a donation made in this way will probably not make me work 664on this software much more, unless I get so many donations that I can 665consider working on free software full time, which seems unlikely at 666best. 667 668To donate, log into PayPal and send money to autarch@urth.org or use 669the button on this page: 670L<http://www.urth.org/~autarch/fs-donation.html> 671 672=head1 SEE ALSO 673 674L<Log::Dispatch::ApacheLog>, L<Log::Dispatch::Email>, 675L<Log::Dispatch::Email::MailSend>, L<Log::Dispatch::Email::MailSender>, 676L<Log::Dispatch::Email::MailSendmail>, L<Log::Dispatch::Email::MIMELite>, 677L<Log::Dispatch::File>, L<Log::Dispatch::File::Locked>, 678L<Log::Dispatch::Handle>, L<Log::Dispatch::Output>, L<Log::Dispatch::Screen>, 679L<Log::Dispatch::Syslog> 680 681=head1 AUTHOR 682 683Dave Rolsky <autarch@urth.org> 684 685=head1 COPYRIGHT AND LICENSE 686 687This software is Copyright (c) 2011 by Dave Rolsky. 688 689This is free software, licensed under: 690 691 The Artistic License 2.0 (GPL Compatible) 692 693=cut 694