Log-Dispatch-2.41/0000775000175000017500000000000012173250731013561 5ustar autarchautarchLog-Dispatch-2.41/lib/0000775000175000017500000000000012173250731014327 5ustar autarchautarchLog-Dispatch-2.41/lib/Log/0000775000175000017500000000000012173250731015050 5ustar autarchautarchLog-Dispatch-2.41/lib/Log/Dispatch/0000775000175000017500000000000012173250731016607 5ustar autarchautarchLog-Dispatch-2.41/lib/Log/Dispatch/File.pm0000644000175000017500000001404712173250731020030 0ustar autarchautarchpackage Log::Dispatch::File; { $Log::Dispatch::File::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate SCALAR BOOLEAN); Params::Validate::validation_options( allow_extra => 1 ); use Scalar::Util qw( openhandle ); # Prevents death later on if IO::File can't export this constant. *O_APPEND = \&APPEND unless defined &O_APPEND; sub APPEND { 0 } sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = @_; my $self = bless {}, $class; $self->_basic_init(%p); $self->_make_handle; return $self; } sub _basic_init { my $self = shift; $self->SUPER::_basic_init(@_); my %p = validate( @_, { filename => { type => SCALAR }, mode => { type => SCALAR, default => '>' }, binmode => { type => SCALAR, default => undef }, autoflush => { type => BOOLEAN, default => 1 }, close_after_write => { type => BOOLEAN, default => 0 }, permissions => { type => SCALAR, optional => 1 }, syswrite => { type => BOOLEAN, default => 0 }, } ); $self->{filename} = $p{filename}; $self->{binmode} = $p{binmode}; $self->{autoflush} = $p{autoflush}; $self->{close} = $p{close_after_write}; $self->{permissions} = $p{permissions}; $self->{syswrite} = $p{syswrite}; if ( $self->{close} ) { $self->{mode} = '>>'; } elsif ( exists $p{mode} && defined $p{mode} && ( $p{mode} =~ /^(?:>>|append)$/ || ( $p{mode} =~ /^\d+$/ && $p{mode} == O_APPEND() ) ) ) { $self->{mode} = '>>'; } else { $self->{mode} = '>'; } } sub _make_handle { my $self = shift; $self->_open_file() unless $self->{close}; } sub _open_file { my $self = shift; open my $fh, $self->{mode}, $self->{filename} or die "Cannot write to '$self->{filename}': $!"; if ( $self->{autoflush} ) { my $oldfh = select $fh; $| = 1; select $oldfh; } if ( $self->{permissions} && !$self->{chmodded} ) { my $current_mode = ( stat $self->{filename} )[2] & 07777; if ( $current_mode ne $self->{permissions} ) { chmod $self->{permissions}, $self->{filename} or die "Cannot chmod $self->{filename} to $self->{permissions}: $!"; } $self->{chmodded} = 1; } if ( $self->{binmode} ) { binmode $fh, $self->{binmode}; } $self->{fh} = $fh; } sub log_message { my $self = shift; my %p = @_; if ( $self->{close} ) { $self->_open_file; } my $fh = $self->{fh}; if ( $self->{syswrite} ) { defined syswrite( $fh, $p{message} ) or die "Cannot write to '$self->{filename}': $!"; } else { print $fh $p{message} or die "Cannot write to '$self->{filename}': $!"; } if ( $self->{close} ) { close $fh or die "Cannot close '$self->{filename}': $!"; } } sub DESTROY { my $self = shift; if ( $self->{fh} ) { my $fh = $self->{fh}; close $fh if openhandle($fh); } } 1; # ABSTRACT: Object for logging to files __END__ =pod =head1 NAME Log::Dispatch::File - Object for logging to files =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'File', min_level => 'info', filename => 'Somefile.log', mode => '>>', newline => 1 ] ], ); $log->emerg("I've fallen and I can't get up"); =head1 DESCRIPTION This module provides a simple object for logging to files under the Log::Dispatch::* system. Note that a newline will I be added automatically at the end of a message by default. To do that, pass C<< newline => 1 >>. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * filename ($) The filename to be opened for writing. =item * mode ($) The mode the file should be opened with. Valid options are 'write', '>', 'append', '>>', or the relevant constants from Fcntl. The default is 'write'. =item * binmode ($) A layer name to be passed to binmode, like ":encoding(UTF-8)" or ":raw". =item * close_after_write ($) Whether or not the file should be closed after each write. This defaults to false. If this is true, then the mode will always be append, so that the file is not re-written for each new message. =item * autoflush ($) Whether or not the file should be autoflushed. This defaults to true. =item * syswrite ($) Whether or not to perform the write using L(), as opposed to L(). This defaults to false. The usual caveats and warnings as documented in L apply. =item * permissions ($) If the file does not already exist, the permissions that it should be created with. Optional. The argument passed must be a valid octal value, such as 0600 or the constants available from Fcntl, like S_IRUSR|S_IWUSR. See L for more on potential traps when passing octal values around. Most importantly, remember that if you pass a string that looks like an octal value, like this: my $mode = '0644'; Then the resulting file will end up with permissions like this: --w----r-T which is probably not what you want. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/ApacheLog.pm0000644000175000017500000000372412173250731020774 0ustar autarchautarchpackage Log::Dispatch::ApacheLog; { $Log::Dispatch::ApacheLog::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate); Params::Validate::validation_options( allow_extra => 1 ); BEGIN { if ( $ENV{MOD_PERL} && $ENV{MOD_PERL} =~ /2\./ ) { require Apache2::Log; } else { require Apache::Log; } } sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate( @_, { apache => { can => 'log' } } ); my $self = bless {}, $class; $self->_basic_init(%p); $self->{apache_log} = $p{apache}->log; return $self; } { my %methods = ( emergency => 'emerg', critical => 'crit', warning => 'warn', ); sub log_message { my $self = shift; my %p = @_; my $level = $self->_level_as_name( $p{level} ); my $method = $methods{$level} || $level; $self->{apache_log}->$method( $p{message} ); } } 1; # ABSTRACT: Object for logging to Apache::Log objects __END__ =pod =head1 NAME Log::Dispatch::ApacheLog - Object for logging to Apache::Log objects =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'ApacheLog', apache => $r ], ], ); $log->emerg('Kaboom'); =head1 DESCRIPTION This module allows you to pass messages to Apache's log object, represented by the L class. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * apache ($) An object of either the L or L classes. Required. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Base.pm0000644000175000017500000000257712173250731020030 0ustar autarchautarchpackage Log::Dispatch::Base; { $Log::Dispatch::Base::VERSION = '2.41'; } use strict; use warnings; sub _get_callbacks { shift; my %p = @_; return unless exists $p{callbacks}; return @{ $p{callbacks} } if ref $p{callbacks} eq 'ARRAY'; return $p{callbacks} if ref $p{callbacks} eq 'CODE'; return; } sub _apply_callbacks { my $self = shift; my %p = @_; my $msg = delete $p{message}; foreach my $cb ( @{ $self->{callbacks} } ) { $msg = $cb->( message => $msg, %p ); } return $msg; } sub add_callback { my $self = shift; my $value = shift; Carp::carp("given value $value is not a valid callback") unless ref $value eq 'CODE'; $self->{callbacks} ||= []; push @{ $self->{callbacks} }, $value; return; } 1; # ABSTRACT: Code shared by dispatch and output objects. __END__ =pod =head1 NAME Log::Dispatch::Base - Code shared by dispatch and output objects. =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch::Base; ... @ISA = qw(Log::Dispatch::Base); =head1 DESCRIPTION Unless you are me, you probably don't need to know what this class does. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/File/0000775000175000017500000000000012173250731017466 5ustar autarchautarchLog-Dispatch-2.41/lib/Log/Dispatch/File/Locked.pm0000644000175000017500000000373712173250731021235 0ustar autarchautarchpackage Log::Dispatch::File::Locked; { $Log::Dispatch::File::Locked::VERSION = '2.41'; } use strict; use warnings; use base qw( Log::Dispatch::File ); use Fcntl qw(:DEFAULT :flock); sub _open_file { my $self = shift; $self->SUPER::_open_file(); my $fh = $self->{fh}; flock( $fh, LOCK_EX ) or die "Cannot lock '$self->{filename}' for writing: $!"; # just in case there was an append while we waited for the lock seek( $fh, 0, 2 ) or die "Cannot seek to end of '$self->{filename}': $!"; } 1; # ABSTRACT: Subclass of Log::Dispatch::File to facilitate locking __END__ =pod =head1 NAME Log::Dispatch::File::Locked - Subclass of Log::Dispatch::File to facilitate locking =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'File::Locked', min_level => 'info', filename => 'Somefile.log', mode => '>>', newline => 1 ] ], ); $log->emerg("I've fallen and I can't get up"); =head1 DESCRIPTION This module acts exactly like L except that it obtains an exclusive lock on the file while opening it. =head1 CAVEATS B Use very carefully in multi-process environments. Because the lock is obtained at file open time, not at write time, you may experience deadlocks in your system. You can partially work around this by using the C option, which causes the file to be re-opened every time a log message is written. Alternatively, the C option does atomic writes, which may mean that you don't need locking at all. See L) for details on these options. =head1 SEE ALSO L =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Email.pm0000644000175000017500000000750212173250731020176 0ustar autarchautarchpackage Log::Dispatch::Email; { $Log::Dispatch::Email::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate SCALAR ARRAYREF BOOLEAN); Params::Validate::validation_options( allow_extra => 1 ); # need to untaint this value my ($program) = $0 =~ /(.+)/; sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate( @_, { subject => { type => SCALAR, default => "$program: log email" }, to => { type => SCALAR | ARRAYREF }, from => { type => SCALAR, optional => 1 }, buffered => { type => BOOLEAN, default => 1 }, } ); my $self = bless {}, $class; $self->_basic_init(%p); $self->{subject} = $p{subject} || "$0: log email"; $self->{to} = ref $p{to} ? $p{to} : [ $p{to} ]; $self->{from} = $p{from}; # Default to buffered for obvious reasons! $self->{buffered} = $p{buffered}; $self->{buffer} = [] if $self->{buffered}; return $self; } sub log_message { my $self = shift; my %p = @_; if ( $self->{buffered} ) { push @{ $self->{buffer} }, $p{message}; } else { $self->send_email(@_); } } sub send_email { my $self = shift; my $class = ref $self; die "The send_email method must be overridden in the $class subclass"; } sub flush { my $self = shift; if ( $self->{buffered} && @{ $self->{buffer} } ) { my $message = join '', @{ $self->{buffer} }; $self->send_email( message => $message ); $self->{buffer} = []; } } sub DESTROY { my $self = shift; $self->flush; } 1; # ABSTRACT: Base class for objects that send log messages via email __END__ =pod =head1 NAME Log::Dispatch::Email - Base class for objects that send log messages via email =head1 VERSION version 2.41 =head1 SYNOPSIS package Log::Dispatch::Email::MySender; use Log::Dispatch::Email; use base qw( Log::Dispatch::Email ); sub send_email { my $self = shift; my %p = @_; # Send email somehow. Message is in $p{message} } =head1 DESCRIPTION This module should be used as a base class to implement Log::Dispatch::* objects that send their log messages via email. Implementing a subclass simply requires the code shown in the L with a real implementation of the C method. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * subject ($) The subject of the email messages which are sent. Defaults to "$0: log email" =item * to ($ or \@) Either a string or a list reference of strings containing email addresses. Required. =item * from ($) A string containing an email address. This is optional and may not work with all mail sending methods. =item * buffered (0 or 1) This determines whether the object sends one email per message it is given or whether it stores them up and sends them all at once. The default is to buffer messages. =back =head1 METHODS =over 4 =item * send_email(%p) This is the method that must be subclassed. For now the only parameter in the hash is 'message'. =item * flush If the object is buffered, then this method will call the C method to send the contents of the buffer and then clear the buffer. =item * DESTROY On destruction, the object will call C to send any pending email. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Code.pm0000644000175000017500000000354312173250731020022 0ustar autarchautarchpackage Log::Dispatch::Code; { $Log::Dispatch::Code::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate CODEREF); Params::Validate::validation_options( allow_extra => 1 ); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate( @_, { code => CODEREF } ); my $self = bless {}, $class; $self->_basic_init(%p); $self->{code} = $p{code}; return $self; } sub log_message { my $self = shift; my %p = @_; delete $p{name}; $self->{code}->(%p); } 1; # ABSTRACT: Object for logging to a subroutine reference __END__ =pod =head1 NAME Log::Dispatch::Code - Object for logging to a subroutine reference =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Code', min_level => 'emerg', code => \&_log_it, ], ] ); sub _log_it { my %p = @_; warn $p{message}; } =head1 DESCRIPTION This module supplies a simple object for logging to a subroutine reference. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * code ($) The subroutine reference. =back =head1 HOW IT WORKS The subroutine you provide will be called with a hash of named arguments. The two arguments are: =over 4 =item * level The log level of the message. This will be a string like "info" or "error". =item * message The message being logged. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Screen.pm0000644000175000017500000000406512173250731020367 0ustar autarchautarchpackage Log::Dispatch::Screen; { $Log::Dispatch::Screen::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate BOOLEAN); Params::Validate::validation_options( allow_extra => 1 ); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate( @_, { stderr => { type => BOOLEAN, default => 1 }, } ); my $self = bless {}, $class; $self->_basic_init(%p); $self->{stderr} = exists $p{stderr} ? $p{stderr} : 1; return $self; } sub log_message { my $self = shift; my %p = @_; if ( $self->{stderr} ) { print STDERR $p{message}; } else { print STDOUT $p{message}; } } 1; # ABSTRACT: Object for logging to the screen __END__ =pod =head1 NAME Log::Dispatch::Screen - Object for logging to the screen =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Screen', min_level => 'debug', stderr => 1, newline => 1 ] ], ); $log->alert("I'm searching the city for sci-fi wasabi"); =head1 DESCRIPTION This module provides an object for logging to the screen (really STDOUT or STDERR). Note that a newline will I be added automatically at the end of a message by default. To do that, pass C 1>. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * stderr (0 or 1) Indicates whether or not logging information should go to STDERR. If false, logging information is printed to STDOUT instead. This defaults to true. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Email/0000775000175000017500000000000012173250731017636 5ustar autarchautarchLog-Dispatch-2.41/lib/Log/Dispatch/Email/MailSendmail.pm0000644000175000017500000000315112173250731022531 0ustar autarchautarchpackage Log::Dispatch::Email::MailSendmail; { $Log::Dispatch::Email::MailSendmail::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Email; use base qw( Log::Dispatch::Email ); use Mail::Sendmail (); sub send_email { my $self = shift; my %p = @_; my %mail = ( To => ( join ',', @{ $self->{to} } ), Subject => $self->{subject}, Message => $p{message}, # Mail::Sendmail insists on having this parameter. From => $self->{from} || 'LogDispatch@foo.bar', ); local $?; unless ( Mail::Sendmail::sendmail(%mail) ) { warn "Error sending mail: $Mail::Sendmail::error"; } } 1; # ABSTRACT: Subclass of Log::Dispatch::Email that uses the Mail::Sendmail module __END__ =pod =head1 NAME Log::Dispatch::Email::MailSendmail - Subclass of Log::Dispatch::Email that uses the Mail::Sendmail module =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Email::MailSendmail', min_level => 'emerg', to => [qw( foo@example.com bar@example.org )], subject => 'Big error!' ] ], ); $log->emerg("Something bad is happening"); =head1 DESCRIPTION This is a subclass of L that implements the send_email method using the L module. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Email/MIMELite.pm0000644000175000017500000000303512173250731021540 0ustar autarchautarchpackage Log::Dispatch::Email::MIMELite; { $Log::Dispatch::Email::MIMELite::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Email; use base qw( Log::Dispatch::Email ); use MIME::Lite; sub send_email { my $self = shift; my %p = @_; my %mail = ( To => ( join ',', @{ $self->{to} } ), Subject => $self->{subject}, Type => 'TEXT', Data => $p{message}, ); $mail{From} = $self->{from} if defined $self->{from}; local $?; unless ( MIME::Lite->new(%mail)->send ) { warn "Error sending mail with MIME::Lite"; } } 1; # ABSTRACT: Subclass of Log::Dispatch::Email that uses the MIME::Lite module __END__ =pod =head1 NAME Log::Dispatch::Email::MIMELite - Subclass of Log::Dispatch::Email that uses the MIME::Lite module =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Email::MIMELite', min_level => 'emerg', to => [qw( foo@example.com bar@example.org )], subject => 'Big error!' ] ], ); $log->emerg("Something bad is happening"); =head1 DESCRIPTION This is a subclass of L that implements the send_email method using the L module. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Email/MailSender.pm0000644000175000017500000000506012173250731022216 0ustar autarchautarchpackage Log::Dispatch::Email::MailSender; { $Log::Dispatch::Email::MailSender::VERSION = '2.41'; } # By: Joseph Annino # (c) 2002 # Licensed under the same terms as Perl # use strict; use warnings; use Log::Dispatch::Email; use base qw( Log::Dispatch::Email ); use Mail::Sender (); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = @_; my $smtp = delete $p{smtp} || 'localhost'; my $port = delete $p{port} || '25'; my $self = $class->SUPER::new(%p); $self->{smtp} = $smtp; $self->{port} = $port; return $self; } sub send_email { my $self = shift; my %p = @_; local $?; eval { my $sender = Mail::Sender->new( { from => $self->{from} || 'LogDispatch@foo.bar', replyto => $self->{from} || 'LogDispatch@foo.bar', to => ( join ',', @{ $self->{to} } ), subject => $self->{subject}, smtp => $self->{smtp}, port => $self->{port}, } ); die "Error sending mail ($sender): $Mail::Sender::Error" unless ref $sender; ref $sender->MailMsg( { msg => $p{message} } ) or die "Error sending mail: $Mail::Sender::Error"; }; warn $@ if $@; } 1; # ABSTRACT: Subclass of Log::Dispatch::Email that uses the Mail::Sender module __END__ =pod =head1 NAME Log::Dispatch::Email::MailSender - Subclass of Log::Dispatch::Email that uses the Mail::Sender module =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Email::MailSender', min_level => 'emerg', to => [qw( foo@example.com bar@example.org )], subject => 'Big error!' ] ], ); $log->emerg("Something bad is happening"); =head1 DESCRIPTION This is a subclass of L that implements the send_email method using the L module. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the parameters documented in L and L: =over 4 =item * smtp ($) The smtp server to connect to. This defaults to "localhost". =item * port ($) The port to use when connecting. This defaults to 25. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Email/MailSend.pm0000644000175000017500000000410312173250731021664 0ustar autarchautarchpackage Log::Dispatch::Email::MailSend; { $Log::Dispatch::Email::MailSend::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Email; use base qw( Log::Dispatch::Email ); use Mail::Send; sub send_email { my $self = shift; my %p = @_; my $msg = Mail::Send->new; $msg->to( join ',', @{ $self->{to} } ); $msg->subject( $self->{subject} ); # Does this ever work for this module? $msg->set( 'From', $self->{from} ) if $self->{from}; local $?; eval { my $fh = $msg->open or die "Cannot open handle to mail program"; $fh->print( $p{message} ) or die "Cannot print message to mail program handle"; $fh->close or die "Cannot close handle to mail program"; }; warn $@ if $@; } 1; # ABSTRACT: Subclass of Log::Dispatch::Email that uses the Mail::Send module __END__ =pod =head1 NAME Log::Dispatch::Email::MailSend - Subclass of Log::Dispatch::Email that uses the Mail::Send module =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Email::MailSend', min_level => 'emerg', to => [qw( foo@example.com bar@example.org )], subject => 'Big error!' ] ], ); $log->emerg("Something bad is happening"); =head1 DESCRIPTION This is a subclass of L that implements the send_email method using the L module. =head1 CHANGING HOW MAIL IS SENT Since L is a subclass of L, you can change how mail is sent from this module by simply Cing L in your code before mail is sent. For example, to send mail via smtp, you could do: use Mail::Mailer 'smtp', Server => 'foo.example.com'; For more details, see the L docs. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Conflicts.pm0000644000175000017500000000121212173250731021063 0ustar autarchautarchpackage # hide from PAUSE Log::Dispatch::Conflicts; use strict; use warnings; use Dist::CheckConflicts -dist => 'Log::Dispatch', -conflicts => { 'Log::Dispatch::File::Stamped' => '0.10', }, ; 1; # ABSTRACT: Provide information on conflicts for Log::Dispatch __END__ =pod =head1 NAME Log::Dispatch::Conflicts - Provide information on conflicts for Log::Dispatch =head1 VERSION version 2.41 =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Null.pm0000644000175000017500000000205612173250731020060 0ustar autarchautarchpackage Log::Dispatch::Null; { $Log::Dispatch::Null::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); sub new { my $proto = shift; my $class = ref $proto || $proto; my $self = bless {}, $class; $self->_basic_init(@_); return $self; } sub log_message { } 1; # ABSTRACT: Object that accepts messages and does nothing __END__ =pod =head1 NAME Log::Dispatch::Null - Object that accepts messages and does nothing =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $null = Log::Dispatch->new( outputs => [ [ 'Null', min_level => 'debug' ] ] ); $null->emerg( "I've fallen and I can't get up" ); =head1 DESCRIPTION This class provides a null logging object. Messages can be sent to the object but it does nothing with them. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Syslog.pm0000644000175000017500000000750712173250731020434 0ustar autarchautarchpackage Log::Dispatch::Syslog; { $Log::Dispatch::Syslog::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate ARRAYREF SCALAR); Params::Validate::validation_options( allow_extra => 1 ); use Sys::Syslog 0.25 (); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = @_; my $self = bless {}, $class; $self->_basic_init(%p); $self->_init(%p); return $self; } my ($Ident) = $0 =~ /(.+)/; sub _init { my $self = shift; my %p = validate( @_, { ident => { type => SCALAR, default => $Ident }, logopt => { type => SCALAR, default => '' }, facility => { type => SCALAR, default => 'user' }, socket => { type => SCALAR | ARRAYREF, default => undef }, } ); $self->{ident} = $p{ident}; $self->{logopt} = $p{logopt}; $self->{facility} = $p{facility}; $self->{socket} = $p{socket}; $self->{priorities} = [ 'DEBUG', 'INFO', 'NOTICE', 'WARNING', 'ERR', 'CRIT', 'ALERT', 'EMERG' ]; Sys::Syslog::setlogsock( ref $self->{socket} ? @{ $self->{socket} } : $self->{socket} ) if defined $self->{socket}; } sub log_message { my $self = shift; my %p = @_; my $pri = $self->_level_as_number( $p{level} ); eval { Sys::Syslog::openlog( $self->{ident}, $self->{logopt}, $self->{facility} ); Sys::Syslog::syslog( $self->{priorities}[$pri], $p{message} ); Sys::Syslog::closelog; }; warn $@ if $@ and $^W; } 1; # ABSTRACT: Object for logging to system log. __END__ =pod =head1 NAME Log::Dispatch::Syslog - Object for logging to system log. =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Syslog', min_level => 'info', ident => 'Yadda yadda' ] ] ); $log->emerg("Time to die."); =head1 DESCRIPTION This module provides a simple object for sending messages to the system log (via UNIX syslog calls). Note that logging may fail if you try to pass UTF-8 characters in the log message. If logging fails and warnings are enabled, the error message will be output using Perl's C. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * ident ($) This string will be prepended to all messages in the system log. Defaults to $0. =item * logopt ($) A string containing the log options (separated by any separator you like). See the openlog(3) and Sys::Syslog docs for more details. Defaults to ''. =item * facility ($) Specifies what type of program is doing the logging to the system log. Valid options are 'auth', 'authpriv', 'cron', 'daemon', 'kern', 'local0' through 'local7', 'mail, 'news', 'syslog', 'user', 'uucp'. Defaults to 'user' =item * socket ($ or \@) Tells what type of socket to use for sending syslog messages. Valid options are listed in C. If you don't provide this, then we let C simply pick one that works, which is the preferred option, as it makes your code more portable. If you pass an array reference, it is dereferenced and passed to C. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Handle.pm0000644000175000017500000000346512173250731020346 0ustar autarchautarchpackage Log::Dispatch::Handle; { $Log::Dispatch::Handle::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); use Params::Validate qw(validate SCALAR ARRAYREF BOOLEAN); Params::Validate::validation_options( allow_extra => 1 ); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate( @_, { handle => { can => 'print' } } ); my $self = bless {}, $class; $self->_basic_init(%p); $self->{handle} = $p{handle}; return $self; } sub log_message { my $self = shift; my %p = @_; $self->{handle}->print( $p{message} ) or die "Cannot write to handle: $!"; } 1; # ABSTRACT: Object for logging to IO::Handle classes __END__ =pod =head1 NAME Log::Dispatch::Handle - Object for logging to IO::Handle classes =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; my $log = Log::Dispatch->new( outputs => [ [ 'Handle', min_level => 'emerg', handle => $io_socket_object, ], ] ); $log->emerg('I am the Lizard King!'); =head1 DESCRIPTION This module supplies a very simple object for logging to some sort of handle object. Basically, anything that implements a C method can be passed the object constructor and it should work. =head1 CONSTRUCTOR The constructor takes the following parameters in addition to the standard parameters documented in L: =over 4 =item * handle ($) The handle object. This object must implement a C method. =back =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch/Output.pm0000644000175000017500000001600612173250731020446 0ustar autarchautarchpackage Log::Dispatch::Output; { $Log::Dispatch::Output::VERSION = '2.41'; } use strict; use warnings; use Log::Dispatch; use base qw( Log::Dispatch::Base ); use Params::Validate qw(validate SCALAR ARRAYREF CODEREF BOOLEAN); Params::Validate::validation_options( allow_extra => 1 ); use Carp (); my $level_names = [qw( debug info notice warning error critical alert emergency )]; my $ln = 0; my $level_numbers = { ( map { $_ => $ln++ } @{$level_names} ), warn => 3, err => 4, crit => 5, emerg => 7 }; sub new { my $proto = shift; my $class = ref $proto || $proto; die "The new method must be overridden in the $class subclass"; } sub log { my $self = shift; my %p = validate( @_, { level => { type => SCALAR }, message => { type => SCALAR }, } ); return unless $self->_should_log( $p{level} ); $p{message} = $self->_apply_callbacks(%p) if $self->{callbacks}; $self->log_message(%p); } sub _basic_init { my $self = shift; my %p = validate( @_, { name => { type => SCALAR, optional => 1 }, min_level => { type => SCALAR, required => 1 }, max_level => { type => SCALAR, optional => 1 }, callbacks => { type => ARRAYREF | CODEREF, optional => 1 }, newline => { type => BOOLEAN, optional => 1 }, } ); $self->{level_names} = $level_names; $self->{level_numbers} = $level_numbers; $self->{name} = $p{name} || $self->_unique_name(); $self->{min_level} = $self->_level_as_number( $p{min_level} ); die "Invalid level specified for min_level" unless defined $self->{min_level}; # Either use the parameter supplied or just the highest possible level. $self->{max_level} = ( exists $p{max_level} ? $self->_level_as_number( $p{max_level} ) : $#{ $self->{level_names} } ); die "Invalid level specified for max_level" unless defined $self->{max_level}; my @cb = $self->_get_callbacks(%p); $self->{callbacks} = \@cb if @cb; if ( $p{newline} ) { push @{ $self->{callbacks} }, \&_add_newline_callback; } } sub name { my $self = shift; return $self->{name}; } sub min_level { my $self = shift; return $self->{level_names}[ $self->{min_level} ]; } sub max_level { my $self = shift; return $self->{level_names}[ $self->{max_level} ]; } sub accepted_levels { my $self = shift; return @{ $self->{level_names} } [ $self->{min_level} .. $self->{max_level} ]; } sub _should_log { my $self = shift; my $msg_level = $self->_level_as_number(shift); return ( ( $msg_level >= $self->{min_level} ) && ( $msg_level <= $self->{max_level} ) ); } sub _level_as_number { my $self = shift; my $level = shift; unless ( defined $level ) { Carp::croak "undefined value provided for log level"; } return $level if $level =~ /^\d$/; unless ( Log::Dispatch->level_is_valid($level) ) { Carp::croak "$level is not a valid Log::Dispatch log level"; } return $self->{level_numbers}{$level}; } sub _level_as_name { my $self = shift; my $level = shift; unless ( defined $level ) { Carp::croak "undefined value provided for log level"; } return $level unless $level =~ /^\d$/; return $self->{level_names}[$level]; } my $_unique_name_counter = 0; sub _unique_name { my $self = shift; return '_anon_' . $_unique_name_counter++; } sub _add_newline_callback { my %p = @_; return $p{message} . "\n"; } 1; # ABSTRACT: Base class for all Log::Dispatch::* objects __END__ =pod =head1 NAME Log::Dispatch::Output - Base class for all Log::Dispatch::* objects =head1 VERSION version 2.41 =head1 SYNOPSIS package Log::Dispatch::MySubclass; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = @_; my $self = bless {}, $class; $self->_basic_init(%p); # Do more if you like return $self; } sub log_message { my $self = shift; my %p = @_; # Do something with message in $p{message} } 1; =head1 DESCRIPTION This module is the base class from which all Log::Dispatch::* objects should be derived. =head1 CONSTRUCTOR The constructor, C, must be overridden in a subclass. See L for a description of the common parameters accepted by this constructor. =head1 METHODS =over 4 =item * _basic_init(%p) This should be called from a subclass's constructor. Make sure to pass the arguments in @_ to it. It sets the object's name and minimum level from the passed parameters It also sets up two other attributes which are used by other Log::Dispatch::Output methods, level_names and level_numbers. Subclasses will perform parameter validation in this method, and must also call the superclass's method. =item * name Returns the object's name. =item * min_level Returns the object's minimum log level. =item * max_level Returns the object's maximum log level. =item * accepted_levels Returns a list of the object's accepted levels (by name) from minimum to maximum. =item * log( level => $, message => $ ) Sends a message if the level is greater than or equal to the object's minimum level. This method applies any message formatting callbacks that the object may have. =item * _should_log ($) This method is called from the C method with the log level of the message to be logged as an argument. It returns a boolean value indicating whether or not the message should be logged by this particular object. The C method will not process the message if the return value is false. =item * _level_as_number ($) This method will take a log level as a string (or a number) and return the number of that log level. If not given an argument, it returns the calling object's log level instead. If it cannot determine the level then it will croak. =item * add_callback( $code ) Adds a callback (like those given during construction). It is added to the end of the list of callbacks. =back =head2 Subclassing This class should be used as the base class for all logging objects you create that you would like to work under the Log::Dispatch architecture. Subclassing is fairly trivial. For most subclasses, if you simply copy the code in the SYNOPSIS and then put some functionality into the C method then you should be all set. Please make sure to use the C<_basic_init> method as described above. The actual logging implementation should be done in a C method that you write. B!>. =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/lib/Log/Dispatch.pm0000644000175000017500000004400712173250731017150 0ustar autarchautarchpackage Log::Dispatch; { $Log::Dispatch::VERSION = '2.41'; } use 5.006; use strict; use warnings; use base qw( Log::Dispatch::Base ); use Class::Load qw( load_class ); use Params::Validate 0.15 qw(validate_with ARRAYREF CODEREF); use Carp (); our %LEVELS; BEGIN { my %level_map = ( ( map { $_ => $_ } qw( debug info notice warning error critical alert emergency ) ), warn => 'warning', err => 'error', crit => 'critical', emerg => 'emergency', ); foreach my $l ( keys %level_map ) { my $sub = sub { my $self = shift; $self->log( level => $level_map{$l}, message => @_ > 1 ? "@_" : $_[0], ); }; $LEVELS{$l} = 1; no strict 'refs'; *{$l} = $sub; } } sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = validate_with( params => \@_, spec => { outputs => { type => ARRAYREF, optional => 1 }, callbacks => { type => ARRAYREF | CODEREF, optional => 1 } }, allow_extra => 1, # for backward compatibility ); my $self = bless {}, $class; my @cb = $self->_get_callbacks(%p); $self->{callbacks} = \@cb if @cb; if ( my $outputs = $p{outputs} ) { if ( ref $outputs->[1] eq 'HASH' ) { # 2.23 API # outputs => [ # File => { min_level => 'debug', filename => 'logfile' }, # Screen => { min_level => 'warning' } # ] while ( my ( $class, $params ) = splice @$outputs, 0, 2 ) { $self->_add_output( $class, %$params ); } } else { # 2.24+ syntax # outputs => [ # [ 'File', min_level => 'debug', filename => 'logfile' ], # [ 'Screen', min_level => 'warning' ] # ] foreach my $arr (@$outputs) { die "expected arrayref, not '$arr'" unless ref $arr eq 'ARRAY'; $self->_add_output(@$arr); } } } return $self; } sub _add_output { my $self = shift; my $class = shift; my $full_class = substr( $class, 0, 1 ) eq '+' ? substr( $class, 1 ) : "Log::Dispatch::$class"; load_class($full_class); $self->add( $full_class->new(@_) ); } sub add { my $self = shift; my $object = shift; # Once 5.6 is more established start using the warnings module. if ( exists $self->{outputs}{ $object->name } && $^W ) { Carp::carp( "Log::Dispatch::* object ", $object->name, " already exists." ); } $self->{outputs}{ $object->name } = $object; } sub remove { my $self = shift; my $name = shift; return delete $self->{outputs}{$name}; } sub log { my $self = shift; my %p = @_; return unless $self->would_log( $p{level} ); $self->_log_to_outputs( $self->_prepare_message(%p) ); } sub _prepare_message { my $self = shift; my %p = @_; $p{message} = $p{message}->() if ref $p{message} eq 'CODE'; $p{message} = $self->_apply_callbacks(%p) if $self->{callbacks}; return %p; } sub _log_to_outputs { my $self = shift; my %p = @_; foreach ( keys %{ $self->{outputs} } ) { $p{name} = $_; $self->_log_to(%p); } } sub log_and_die { my $self = shift; my %p = $self->_prepare_message(@_); $self->_log_to_outputs(%p) if $self->would_log( $p{level} ); $self->_die_with_message(%p); } sub log_and_croak { my $self = shift; $self->log_and_die( @_, carp_level => 3 ); } sub _die_with_message { my $self = shift; my %p = @_; my $msg = $p{message}; local $Carp::CarpLevel = ( $Carp::CarpLevel || 0 ) + $p{carp_level} if exists $p{carp_level}; Carp::croak($msg); } sub log_to { my $self = shift; my %p = @_; $p{message} = $self->_apply_callbacks(%p) if $self->{callbacks}; $self->_log_to(%p); } sub _log_to { my $self = shift; my %p = @_; my $name = $p{name}; if ( exists $self->{outputs}{$name} ) { $self->{outputs}{$name}->log(@_); } elsif ($^W) { Carp::carp( "Log::Dispatch::* object named '$name' not in dispatcher\n"); } } sub output { my $self = shift; my $name = shift; return unless exists $self->{outputs}{$name}; return $self->{outputs}{$name}; } sub level_is_valid { shift; my $level = shift or Carp::croak('Logging level was not provided'); return $LEVELS{$level}; } sub would_log { my $self = shift; my $level = shift; return 0 unless $self->level_is_valid($level); foreach ( values %{ $self->{outputs} } ) { return 1 if $_->_should_log($level); } return 0; } sub is_debug { $_[0]->would_log('debug') } sub is_info { $_[0]->would_log('info') } sub is_notice { $_[0]->would_log('notice') } sub is_warning { $_[0]->would_log('warning') } sub is_warn { $_[0]->would_log('warn') } sub is_error { $_[0]->would_log('error') } sub is_err { $_[0]->would_log('err') } sub is_critical { $_[0]->would_log('critical') } sub is_crit { $_[0]->would_log('crit') } sub is_alert { $_[0]->would_log('alert') } sub is_emerg { $_[0]->would_log('emerg') } sub is_emergency { $_[0]->would_log('emergency') } 1; # ABSTRACT: Dispatches messages to one or more outputs __END__ =pod =head1 NAME Log::Dispatch - Dispatches messages to one or more outputs =head1 VERSION version 2.41 =head1 SYNOPSIS use Log::Dispatch; # Simple API # my $log = Log::Dispatch->new( outputs => [ [ 'File', min_level => 'debug', filename => 'logfile' ], [ 'Screen', min_level => 'warning' ], ], ); $log->info('Blah, blah'); # More verbose API # my $log = Log::Dispatch->new(); $log->add( Log::Dispatch::File->new( name => 'file1', min_level => 'debug', filename => 'logfile' ) ); $log->add( Log::Dispatch::Screen->new( name => 'screen', min_level => 'warning', ) ); $log->log( level => 'info', message => 'Blah, blah' ); my $sub = sub { my %p = @_; return reverse $p{message}; }; my $reversing_dispatcher = Log::Dispatch->new( callbacks => $sub ); =head1 DESCRIPTION This module manages a set of Log::Dispatch::* output objects that can be logged to via a unified interface. The idea is that you create a Log::Dispatch object and then add various logging objects to it (such as a file logger or screen logger). Then you call the C method of the dispatch object, which passes the message to each of the objects, which in turn decide whether or not to accept the message and what to do with it. This makes it possible to call single method and send a message to a log file, via email, to the screen, and anywhere else, all with very little code needed on your part, once the dispatching object has been created. =head1 CONSTRUCTOR The constructor (C) takes the following parameters: =over 4 =item * outputs( [ [ class, params, ... ], [ class, params, ... ], ... ] ) This parameter is a reference to a list of lists. Each inner list consists of a class name and a set of constructor params. The class is automatically prefixed with 'Log::Dispatch::' unless it begins with '+', in which case the string following '+' is taken to be a full classname. e.g. outputs => [ [ 'File', min_level => 'debug', filename => 'logfile' ], [ '+My::Dispatch', min_level => 'info' ] ] For each inner list, a new output object is created and added to the dispatcher (via the C). See L for the parameters that can be used when creating an output object. =item * callbacks( \& or [ \&, \&, ... ] ) This parameter may be a single subroutine reference or an array reference of subroutine references. These callbacks will be called in the order they are given and passed a hash containing the following keys: ( message => $log_message, level => $log_level ) In addition, any key/value pairs passed to a logging method will be passed onto your callback. The callbacks are expected to modify the message and then return a single scalar containing that modified message. These callbacks will be called when either the C or C methods are called and will only be applied to a given message once. If they do not return the message then you will get no output. Make sure to return the message! =back =head1 METHODS =head2 Logging =over 4 =item * log( level => $, message => $ or \& ) Sends the message (at the appropriate level) to all the output objects that the dispatcher contains (by calling the C method repeatedly). This method also accepts a subroutine reference as the message argument. This reference will be called only if there is an output that will accept a message of the specified level. =item * debug (message), info (message), ... You may call any valid log level (including valid abbreviations) as a method with a single argument that is the message to be logged. This is converted into a call to the C method with the appropriate level. For example: $log->alert('Strange data in incoming request'); translates to: $log->log( level => 'alert', message => 'Strange data in incoming request' ); If you pass an array to these methods, it will be stringified as is: my @array = ('Something', 'bad', 'is', here'); $log->alert(@array); # is equivalent to $log->alert("@array"); You can also pass a subroutine reference, just like passing one to the C method. =item * log_and_die( level => $, message => $ or \& ) Has the same behavior as calling C but calls C<_die_with_message()> at the end. =item * log_and_croak( level => $, message => $ or \& ) This method adjusts the C<$Carp::CarpLevel> scalar so that the croak comes from the context in which it is called. =item * _die_with_message( message => $, carp_level => $ ) This method is used by C and will either die() or croak() depending on the value of C: if it's a reference or it ends with a new line then a plain die will be used, otherwise it will croak. You can throw exception objects by subclassing this method. If the C parameter is present its value will be added to the current value of C<$Carp::CarpLevel>. =item * log_to( name => $, level => $, message => $ ) Sends the message only to the named object. Note: this will not properly handle a subroutine reference as the message. =item * add_callback( $code ) Adds a callback (like those given during construction). It is added to the end of the list of callbacks. Note that this can also be called on individual output objects. =back =head2 Log levels =over 4 =item * level_is_valid( $string ) Returns true or false to indicate whether or not the given string is a valid log level. Can be called as either a class or object method. =item * would_log( $string ) Given a log level, returns true or false to indicate whether or not anything would be logged for that log level. =item * is_C<$level> There are methods for every log level: C, C, etc. This returns true if the logger will log a message at the given level. =back =head2 Output objects =over =item * add( Log::Dispatch::* OBJECT ) Adds a new L to the dispatcher. If an object of the same name already exists, then that object is replaced, with a warning if C<$^W> is true. =item * remove($) Removes the object that matches the name given to the remove method. The return value is the object being removed or undef if no object matched this. =item * output( $name ) Returns the output object of the given name. Returns undef or an empty list, depending on context, if the given output does not exist. =back =head1 OUTPUT CLASSES An output class - e.g. L or L - implements a particular way of dispatching logs. Many output classes come with this distribution, and others are available separately on CPAN. The following common parameters can be used when creating an output class. All are optional. Most output classes will have additional parameters beyond these, see their documentation for details. =over 4 =item * name ($) A name for the object (not the filename!). This is useful if you want to refer to the object later, e.g. to log specifically to it or remove it. By default a unique name will be generated. You should not depend on the form of generated names, as they may change. =item * min_level ($) The minimum L this object will accept. Required. =item * max_level ($) The maximum L this object will accept. By default the maximum is the highest possible level (which means functionally that the object has no maximum). =item * callbacks( \& or [ \&, \&, ... ] ) This parameter may be a single subroutine reference or an array reference of subroutine references. These callbacks will be called in the order they are given and passed a hash containing the following keys: ( message => $log_message, level => $log_level ) The callbacks are expected to modify the message and then return a single scalar containing that modified message. These callbacks will be called when either the C or C methods are called and will only be applied to a given message once. If they do not return the message then you will get no output. Make sure to return the message! =item * newline (0|1) If true, a callback will be added to the end of the callbacks list that adds a newline to the end of each message. Default is false, but some output classes may decide to make the default true. =back =head1 LOG LEVELS The log levels that Log::Dispatch uses are taken directly from the syslog man pages (except that I expanded them to full words). Valid levels are: =over 4 =item debug =item info =item notice =item warning =item error =item critical =item alert =item emergency =back Alternately, the numbers 0 through 7 may be used (debug is 0 and emergency is 7). The syslog standard of 'err', 'crit', and 'emerg' is also acceptable. We also allow 'warn' as a synonym for 'warning'. =head1 SUBCLASSING This module was designed to be easy to subclass. If you want to handle messaging in a way not implemented in this package, you should be able to add this with minimal effort. It is generally as simple as subclassing Log::Dispatch::Output and overriding the C and C methods. See the L docs for more details. If you would like to create your own subclass for sending email then it is even simpler. Simply subclass L and override the C method. See the L docs for more details. The logging levels that Log::Dispatch uses are borrowed from the standard UNIX syslog levels, except that where syslog uses partial words ("err") Log::Dispatch also allows the use of the full word as well ("error"). =head1 RELATED MODULES =head2 Log::Dispatch::DBI Written by Tatsuhiko Miyagawa. Log output to a database table. =head2 Log::Dispatch::FileRotate Written by Mark Pfeiffer. Rotates log files periodically as part of its usage. =head2 Log::Dispatch::File::Stamped Written by Eric Cholet. Stamps log files with date and time information. =head2 Log::Dispatch::Jabber Written by Aaron Straup Cope. Logs messages via Jabber. =head2 Log::Dispatch::Tk Written by Dominique Dumont. Logs messages to a Tk window. =head2 Log::Dispatch::Win32EventLog Written by Arthur Bergman. Logs messages to the Windows event log. =head2 Log::Log4perl An implementation of Java's log4j API in Perl. Log messages can be limited by fine-grained controls, and if they end up being logged, both native Log4perl and Log::Dispatch appenders can be used to perform the actual logging job. Created by Mike Schilli and Kevin Goess. =head2 Log::Dispatch::Config Written by Tatsuhiko Miyagawa. Allows configuration of logging via a text file similar (or so I'm told) to how it is done with log4j. Simpler than Log::Log4perl. =head2 Log::Agent A very different API for doing many of the same things that Log::Dispatch does. Originally written by Raphael Manfredi. =head1 SUPPORT Please submit bugs and patches to the CPAN RT system at http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Log%3A%3ADispatch or via email at bug-log-dispatch@rt.cpan.org. Support questions can be sent to me at my email address, shown below. =head1 DONATIONS If you'd like to thank me for the work I've done on this module, please consider making a "donation" to me via PayPal. I spend a lot of free time creating free software, and would appreciate any support you'd care to offer. Please note that B in order for me to continue working on this particular software. I will continue to do so, inasmuch as I have in the past, for as long as it interests me. Similarly, a donation made in this way will probably not make me work on this software much more, unless I get so many donations that I can consider working on free software full time, which seems unlikely at best. To donate, log into PayPal and send money to autarch@urth.org or use the button on this page: L =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut Log-Dispatch-2.41/README0000644000175000017500000000037712173250731014446 0ustar autarchautarch This archive contains the distribution Log-Dispatch, version 2.41: Dispatches messages to one or more outputs This software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) Log-Dispatch-2.41/INSTALL0000644000175000017500000000167212173250731014616 0ustar autarchautarch This is the Perl distribution Log-Dispatch. Installing Log-Dispatch is straightforward. ## Installation with cpanm If you have cpanm, you only need one line: % cpanm Log::Dispatch If you are installing into a system-wide directory, you may need to pass the "-S" flag to cpanm, which uses sudo to install the module: % cpanm -S Log::Dispatch ## Installing with the CPAN shell Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan Log::Dispatch ## Manual installation As a last resort, you can manually install it. Download the tarball, untar it, then build it: % perl Makefile.PL % make && make test Then install it: % make install If you are installing into a system-wide directory, you may need to run: % sudo make install ## Documentation Log-Dispatch documentation is available as POD. You can run perldoc from a shell to read the documentation: % perldoc Log::Dispatch Log-Dispatch-2.41/LICENSE0000644000175000017500000002152012173250731014564 0ustar autarchautarchThis software is Copyright (c) 2013 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Log-Dispatch-2.41/Changes0000644000175000017500000004003012173250731015047 0ustar autarchautarch2.41 2013-07-22 - An error is now thrown if you call Log::Dispatch->log without a level. Previously you'd just get a warning and then execution would continue (without logging anything). Patch by Ross Attrill. RT #87133. 2.40 2013-07-01 - Added a conflict entry for older Log::Dispatch::File::Stamped to the metadata. Patch by Karen Etheridge. RT #86215. 2.39 2013-04-21 - You can now pass a port option to the MailSender output. Patch by Whitney Jackson. 2.38 2013-04-14 - Fix test that used undeclared prereqs so it does not do that. 2.37 2013-04-14 - Moved Log::Dispatch::File constructor parameter validation moved to _basic_init() to facilitate proper subclassing. Patch by ether. RT #84545. 2.36 2013-04-08 - Added a very simple Log::Dispatch::Code output. This lets you log to a subroutine reference. - Added Sys::Syslog 0.25 as a prereq. This is a temporary fix to the problem of Log::Dispatch shipping lots of output modules with undeclared prereqs (so as not to require mod_perl, four email sending modules, etc.). In the future Log::Dispatch will be split into a core distro and a set of distros, one for each output that has prereqs. Reported by Michael Schwern. RT #84481. 2.35 2013-01-20 - Added a big warning about the potential for deadlocks in the documentation for Log::Dispatch::File::Locked. Patch by ether. 2.34 2012-12-08 - Fix a test bug that caused the tests to fail on all Perls before 5.16.0. 2.33 2012-12-07 - Added a 'syswrite' option to Log::Dispatch::File which causes all writes to use syswrite (so they're atomic). Patched by ether. RT #81669. - The File output's DESTROY method now checks to see if it's associated handle is open before trying to close it. Patch by Jeffrey Thalhammer. 2.32 2012-05-24 - Fix a test failure - test failed if you had 0.16 <= Sys::Syslog < 0.25 installed. - Added a kludgey test failure fix for failure on Cygwin. Patch by Christian Carey. RT #77364. 2.31 2012-05-21 - Added missing prereq - Class::Load. 2.30 2012-05-20 - Remove Sys::Syslog as a prereq, since you can use this distro perfectly well without it. Fixes RT #52065. - You can now pass a subroutine reference to the sugar methods like $dispatch->debug() and friends. Requested by Jeffrey Thalhammer. RT #77308. - Calling sugar methods like $dispatch->warn or $dispatch->crit did not normalize the log level, so the level would be passed to the outputs as "warn", not "warning". Reported by Karen Etheridge. RT #77203. 2.29 2011-03-18 - Add is_$level methods for compatibility with Log::Contextual. Patch by frew. 2.28 2010-12-13 - The Log::Dispatch module still had version 2.26 in the last release. Reported by Øyvind Skaar. RT #63876. 2.27 2010-10-16 - Fix docs on handling of arrays passed to ->debug, ->error, etc. Requested by Andrew Hanenkamp. RT #61400. - Allow an arrayref for the Syslog socket option. Requested by Paul Bennett. RT #57631. - License is now Artistic 2.0. 2.26 2009-09-22 - Doc updates. The 2.23 constructor API was still shown in all the output subclasses. Fixed by Jon Swartz. 2.25 2009-09-15 - Added a workaround for a weird tainting issue with Params::Validate. This caused a taint exception when a Log::Dispatch::Syslog was created under taint mode. Note that there is still a problem in Params::Validate itself, this is just a hack. 2.24 2009-09-13 - Simplified new constructor API (the 2.23 API is still silently supported but not documented): Log::Dispatch->new( outputs => [ [ 'File', ... ], [ 'Screen', ... ], ] ); Implemented by Jon Swartz. - All of the mail sending modules now warn unconditionally if sending mail fails. This removes the incorrect use of warnings::enabled() in some modules. RT #43516. 2.23 2009-09-12 - New constructor API that simplifies creating your Log::Dispatch object. Implemented by Jon Swartz. - Made name parameter optional. We now auto-generate a unique name if one is not given. Implemented by Jon Swartz. - Added a newline parameter that causes a newline to be added to each message, and updated the documentation regarding newlines. Implemented by Jon Swartz. - Removed repetitive boilerplate documentation from each output class. Implemented by Jon Swartz. - The level_names and level_numbers used internally are now computed once and shared between output objects. Implemented by Jon Swartz. - Updated repo url - now at http://hg.urth.org/hg/Log-Dispatch - Explicitly depend on Sys::Syslog 0.16. - Added warn as a synonym for warning. RT #44821. Requested by Dylan Martin. - Added an add_callback method to Log::Dispatch and Log::Dispatch::Output. This lets you add a new formatting callback after an object is created. Based on a patch from Ricardo Signes. RT #48283. - The Log::Dispatch docs mistakenly told you to provide a log() method when creating a new output class. RT #40561. - Made all modules have the same version as Log::Dispatch itself. 2.22 2008-11-11 - Fixed a bug where Log::Dispatch::Email would die when it tried to log under taint mode. Patch by Neil Hemingway. RT #40042. - Fixed a misuse of warnings::enabled(). Reported by Darian Patrick. RT #39784. - Syslog logging now requires Sys::Syslog 0.16+. - If you don't pass a socket argument to Log::Dispatch::Syslog, it does not call Sys::Syslog::setlogsock(), which is the preferred option for portability. * If any of the syslog calls die, this is trapped and the error is output as a warning if warnings are on. This is mostly a workaround for Sys::Sylog not handling utf-8. RT #35270 & #37397. This isn't backwards-compatible, but it's probably wrong for the logging code to die because it can't log (even though some other output modules still do). 2.21 2008-02-06 - Added log_and_die() and log_and_croak() methods. Patch by Yuval Kogman. 2.20 2007-11-02 - One of the tests failed on Perl 5.6.x. Thanks to Slaven Rezic for the report. 2.19 2007-11-01 - Switched to providing a traditional Makefile.PL as well as a Build.PL file. RT #27208. - When permissions are specified for a Log::Dispatch::File object, don't try to chmod the file unless the permissions of the file differ from what the file already has. Based on a patch by Kevin. RT #28151. - Require at least Perl 5.6.0. - Remove the tests for the email sending and exit codes, since the test had a heisenbug I could not understand. I _think_ the code in the email modules is correct, but the test isn't proving anything. - Added a binmode parameter for Log::Dispatch::File. Based on a patch by Angelo. RT #26063. 2.18 2007-05-12 - Log::Dispatch::ApacheLog should really now work under mod_perl 2, as well as mod_perl 1. RT #26910. 2.17 2007-03-31 - Log::Dispatch::ApacheLog should now work under mod_perl 2, as well as mod_perl 1. 2.16 2010-10-16 - Don't require IO::String for running the tests. Reported by Andreas Koenig. RT #23973. - Moved Test::More to build_requires. Suggested by Andreas Koenig. RT #23973. 2.15 2006-12-16 - Don't try to test compilation of L::D::Syslog unless Sys::Syslog is available. Patch by Kenichi Ishigaki. RT #23751. - Allow a subroutine reference as a log message when callin Log::Dispatch->log(). Suggested by Craig Manley. RT #23913. - Added Log::Dispatch::Null output, primarily for testing. 2.14 2006-11-18 This release only involves changes to the test suite. - Make sure we don't fail if Apache::Log is not installed on the system. RT #22791. Reported by Lee Goddard. - Separated out compilation tests from other tests. 2.13 2006-09-25 - No code changes, just added a SUPPORT section to the docs referring folks to RT for bug reports & patches. 2.12 2006-08-09 - The various email sending modules could overwrite if they were in buffered mode and they sent mail as a script exited. Reported by Dean Kopesky. - Doc tweaks. Make reference to "Log Levels" section in output module docs more explicit. RT #11224. 2.11 2005-07-27 - In tests, make sure filehandles are closed before reading or unlinking the file. Patch from Ron Savage. 2.10 2004-02-11 - No changes to the core code, just a change to the included Makefile.PL so it works with Module::Build 0.23, which breaks backwards compatibility (grr). - Fix a doc bug in Log::Dispatch::Syslog. It defaults to using a unix socket, not an inet socket. 2.09 2004-01-09 - Fix a test failure on Win32 platforms. The problem was in the test, not the code. Patch by David Viner. - Distro is now signed with Module::Signature. 2.08 2003-11-27 - Added Log::Dispatch->would_log method, which indicates whether logging will be done for a given log level. Suggested by Ruslan Zakirov. - Switched tests to use Test::More. 2.07 2003-09-27 - Added Log::Dispatch::File::Locked. Based on code from JAA Klunder. - Check all system call return values. - Fix warning from Log::Dispatch::File if it was loaded after Attribute::Handlers. Reported by Mike Schilli. - Fixed up POD to pass pod tests. 2.06 2003-05-01 "Arise ye workers from your slumbers Arise ye criminals of want For reason in revolt now thunders and at last ends the age of cant." - Added a permissions parameter to Log::Dispatch::File->new. Based on a patch from James FitzGibbon. 2.05 2003-04-18 - Changed a code construct that seems to provoke a bug for Meng Wong, but no one else ;) - Switched to Module::Build and removed interactive portion of installation process. - Log::Dispatch::Email::MailSender was causing Mail::Sender to send debug output to STDERR if warnings were on. Now it's not. 2.04 2003-03-21 - The close_after_write option didn't actually do anything. Fixed by JAA Klunder. 2.03 2003-02-27 - Log::Dispatch::ApacheLog would break if a log level was specified as a number. Reported by Kevin Goess. 2.02 2003-02-20 - Added close_after_write option to Log::Dispatch::File. Based on patch from JAA Klunder. 2.01 2002-06-21 - Added new module Log::Dispatch::Email::MailSender, provided by Joseph Annino. - Log::Dispatch::Output now contains "use Log::Dispatch". - Now requires Params::Validate, which is used to validate parameter for constructors and some other methods. - Add an 'autoflush' option to Log::Dispatch::File objects. Suggested by Jerrad Pierce. - Added some error checking to ::Email::MailSend. - Changed a carp to a warn in ::Email::MailSendmail. - Only warn if $^W is true. 2.00 2002-04-11 ** BACKWARDS INCOMPATIBILITY ALERT ** - Use a standard hash reference for objects instead of pseudo-hashes. ** THIS MAY BREAK EXISTING SUBCLASSES **. - Log::Dispatch::Screen claimed it defaulted to using STDERR but it was lying, it defaulted to using STDOUT. This has been changed so that it really does default to STDERR. Reported by James FitzGibbon. 1.80 2001-10-27 - Log::Dispatch::Syslog no longer requires syslog.ph for Perl >= 5.006. Patch by Benoit Beausejour. - If you passed a mode parameter to Log::Dispatch::File it always thought the mode was append, no matter what was passed. Patch from Luke Bakken. - Log::Dispatch::File no longer uses IO::File internally. 1.79 2001-05-15 - Don't use $, internally. Apparently this is usually undefined. Instead, the convenience methods now simply take an array of messages and turn it into a scalar by doing "@_". Thanks to Dean Kopesky for the bug report. 1.78 2001-04-19 - Allow ApacheLog to take either an Apache or Apache::Server object. - Fix callback documentation in Log::Dispatch::Output. Thanks to Rob Napier. - Add flush method to Log::Dispatch::Email. Patch submitted by Rob Napier. 1.77 2001-01-02 - The convenience methods named after the log levels ($log->debug, $log->alert, etc.) can now take a list of scalars. These are joined together just like Perl's print function does. Suggested by Tim Ayers. 1.76 2000-10-10 - New method: Log::Dispatch->level_is_valid($string). Suggested by Jeff Hamman. - Fix for version issues between CPAN versions of Log::Dispatch::ApacheLog. Reported by Jost Krieger. 1.75 2000-09-28 - Additional argument 'level' passed to message processing callbacks. Suggested by Jeff MacDonald. - Log/Dispatch.pm: added docs section on Log::Dispatch::Tk. 1.7 2000-08-30 - Added Log/Dispatch/ApacheLog.pm. This logs to the Apache error log. This is for use under mod_perl. 1.6 2000-07-04 NOTE: 1.5 was never released to CPAN. - Log/Dispatch.pm: Added convenience methods for log levels like $dispatcher->alert($message). Suggested by Dominique Dumont. - This version introduces some changes into the interface that will cause incompatibility with any Log::Dispatch::Output interface you may have created. However, it is fairly simple to fix. Simply change the method in your subclass named 'log' to be called 'log_message'. You can also remove the line: return unless $self->_should_log($params{level}); This is now done before the message ever gets to the Output subclass (which is what it should have done in the first place, really.) This was done so that I could allow per-Output object callbacks, a feature which several people have requested and which seems useful enough to warrant the breakage. NOTE: This change is transparent if you are only using the Output objects included with this distribution. - Many: Changed the interface to allow per-Output object level callbacks and documented this. - Log/Dispatch/Base.pm: new base class for both Log::Dispatch and Log::Dispatch::Output objects (contains callback related code). You should never need to deal with this class unless you are me. - Log/Dispatch/Output.pm: document _accepted_levels. - Log/Dispatch/Output.pm: Fix _accepted_levels so that emergency level is returned as 'emergency', not 'emerg'. - Log/Dispatch.pm: Fix doc bug (change 'file' to 'filename'). Thanks to Clayton Scott. - Log/Dispatch/File.pm: Do compile time check for O_APPEND constant rather than run time check. 1.2 2000-05-05 - Log/Dispatch.pm: Added callbacks parameter to Log::Dispatch->new. I will also be adding this to the Log::Dispatch::* classes via Log::Dispatch::Output but I wanted to get this new version out there because I think there are people out there who would benefit from this. - Log/Dispatch.pm: Added docs section on why Log::Dispatch doesn't add newlines to outgoing messages. 1.11 2000-02-24 - Realized I need to tweak the $VERSION in Log::Dispatch 1.1 2000-02-24 - Upped version to 1.1 to indicate my confidence in this release (I'm just asking for bug reports, I know). - Added accepted_levels method to Log::Dispatch::Output based on discussions with Dominique Dumont (author of the Log::Dispatch::Tk suite). - Canonical names for log levels are now the unabbreviated form (though the abbreviated ones used by syslog are still fine and there is no plan to deprecate them). This really only affects what is returned by the new accepted_levels method. 1.010 2000-01-17 - Fixed a bug in the DESTROY method of Log::Dispatch::Email that caused an annoying error and may have caused spurious emails to be sent (thanks to Radu Greab). - Fixed a bug in Log::Dispatch::Email::MailSendmail. For some reason this module demands a 'from' address. 1.009 2000-01-02 - Created this version simply to address an issue with CPAN and my internal version numbers having a conflict. This has no changes from 1.008. 1.008 1999-12-30 - Fixed a bug causing unitialized value warnings with -w (oops). - Fixed a minor mistake in Log::Dispatch::Syslog docs (thanks to Ilya Martynov) - Put newlines into messages in SYNOPSIS sections for some modules. This is to clarify that you need to do this. Just to be clear, Log::Dispatch does not alter message content in any manner whatsoever (and never will). However, it would be trivial to subclass Log::Dispatch to do this. 1.007 1999-12-01 - First public release. It passes its own test suite so it should work (he says hopefully). Log-Dispatch-2.41/META.json0000644000175000017500000000275712173250731015213 0ustar autarchautarch{ "abstract" : "Dispatches messages to one or more outputs", "author" : [ "Dave Rolsky " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Log-Dispatch", "prereqs" : { "configure" : { "requires" : { "Dist::CheckConflicts" : "0.02", "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "Class::Load" : "0", "Dist::CheckConflicts" : "0.02", "Params::Validate" : "0.15", "Sys::Syslog" : "0.25" } }, "test" : { "requires" : { "File::Temp" : "0", "Test::More" : "0.88" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-log-dispatch@rt.cpan.org", "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Dispatch" }, "repository" : { "type" : "git", "url" : "git://git.urth.org/Log-Dispatch.git", "web" : "http://git.urth.org/Log-Dispatch.git" } }, "version" : "2.41", "x_breaks" : { "Log::Dispatch::File::Stamped" : "0.10" } } Log-Dispatch-2.41/dist.ini0000644000175000017500000000152712173250731015230 0ustar autarchautarchname = Log-Dispatch author = Dave Rolsky license = Artistic_2_0 copyright_holder = Dave Rolsky version = 2.41 [NextRelease] format = %-8v %{yyyy-MM-dd}d [@Basic] [InstallGuide] [MetaJSON] [MetaResources] bugtracker.web = http://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Dispatch bugtracker.mailto = bug-log-dispatch@rt.cpan.org repository.url = git://git.urth.org/Log-Dispatch.git repository.web = http://git.urth.org/Log-Dispatch.git repository.type = git [SurgicalPodWeaver] [PkgVersion] [EOLTests] [NoTabsTests] [PodSyntaxTests] [Test::CPAN::Changes] ;[Test::Pod::LinkCheck] [Test::Pod::No404s] [Prereqs] Class::Load = 0 Params::Validate = 0.15 Sys::Syslog = 0.25 [Prereqs / TestRequires] File::Temp = 0 Test::More = 0.88 [CheckPrereqsIndexed] [@Git] [Conflicts] Log::Dispatch::File::Stamped = 0.10 Log-Dispatch-2.41/MANIFEST0000644000175000017500000000160112173250731014706 0ustar autarchautarchChanges INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini lib/Log/Dispatch.pm lib/Log/Dispatch/ApacheLog.pm lib/Log/Dispatch/Base.pm lib/Log/Dispatch/Code.pm lib/Log/Dispatch/Conflicts.pm lib/Log/Dispatch/Email.pm lib/Log/Dispatch/Email/MIMELite.pm lib/Log/Dispatch/Email/MailSend.pm lib/Log/Dispatch/Email/MailSender.pm lib/Log/Dispatch/Email/MailSendmail.pm lib/Log/Dispatch/File.pm lib/Log/Dispatch/File/Locked.pm lib/Log/Dispatch/Handle.pm lib/Log/Dispatch/Null.pm lib/Log/Dispatch/Output.pm lib/Log/Dispatch/Screen.pm lib/Log/Dispatch/Syslog.pm t/00-compile.t t/01-basic.t t/02-email-exit.t t/03-short-syntax.t t/04-binmode.t t/05-close-after-write.t t/email-exit-helper.pl t/lib/Log/Dispatch/TestUtil.pm t/release-cpan-changes.t t/release-eol.t t/release-no-tabs.t t/release-pod-coverage.t t/release-pod-no404s.t t/release-pod-spell.t t/release-pod-syntax.t t/sendmail Log-Dispatch-2.41/META.yml0000644000175000017500000000136212173250731015032 0ustar autarchautarch--- abstract: 'Dispatches messages to one or more outputs' author: - 'Dave Rolsky ' build_requires: File::Temp: 0 Test::More: 0.88 configure_requires: Dist::CheckConflicts: 0.02 ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.300034, CPAN::Meta::Converter version 2.120921' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Log-Dispatch requires: Class::Load: 0 Dist::CheckConflicts: 0.02 Params::Validate: 0.15 Sys::Syslog: 0.25 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Dispatch repository: git://git.urth.org/Log-Dispatch.git version: 2.41 x_breaks: Log::Dispatch::File::Stamped: 0.10 Log-Dispatch-2.41/t/0000775000175000017500000000000012173250731014024 5ustar autarchautarchLog-Dispatch-2.41/t/04-binmode.t0000644000175000017500000000234212173250731016046 0ustar autarchautarchuse strict; use warnings; use File::Spec; use File::Temp qw( tempdir ); use Test::More 0.88; use Log::Dispatch; use Log::Dispatch::File; plan skip_all => "Cannot test utf8 files with this version of Perl ($])" unless $] >= 5.008; my $dir = tempdir( CLEANUP => 1 ); my %params = ( name => 'file', min_level => 'debug', filename => File::Spec->catfile( $dir, 'logfile_X.txt' ), ); my @tests = ( { params => { %params, 'binmode' => ':utf8' }, message => "foo bar\x{20AC}", expected_message => "foo bar\xe2\x82\xac", }, ); my $count = 0; for my $t (@tests) { my $dispatcher = Log::Dispatch->new(); ok( $dispatcher, 'got a logger object' ); $t->{params}{filename} =~ s/X\.txt$/$count++ . '.txt'/e; my $file = $t->{params}{filename}; my $logger = Log::Dispatch::File->new( %{ $t->{params} } ); ok( $logger, 'got a file output object' ); $dispatcher->add($logger); $dispatcher->log( level => 'info', message => $t->{message} ); ok( -e $file, "$file exists" ); open my $fh, '<', $file; my $line = do { local $/; <$fh> }; close $fh; is( $line, $t->{expected_message}, 'output contains UTF-8 bytes' ); } done_testing(); Log-Dispatch-2.41/t/lib/0000775000175000017500000000000012173250731014572 5ustar autarchautarchLog-Dispatch-2.41/t/lib/Log/0000775000175000017500000000000012173250731015313 5ustar autarchautarchLog-Dispatch-2.41/t/lib/Log/Dispatch/0000775000175000017500000000000012173250731017052 5ustar autarchautarchLog-Dispatch-2.41/t/lib/Log/Dispatch/TestUtil.pm0000644000175000017500000000131512173250731021163 0ustar autarchautarchpackage Log::Dispatch::TestUtil; use Data::Dumper; use strict; use warnings; use base qw(Exporter); our @EXPORT_OK = qw( cmp_deeply dump_one_line ); sub cmp_deeply { my ( $ref1, $ref2, $name ) = @_; my $tb = Test::Builder->new(); $tb->is_eq( dump_one_line($ref1), dump_one_line($ref2), $name ); } sub dump_one_line { my ($value) = @_; return Data::Dumper->new( [$value] )->Indent(0)->Sortkeys(1)->Quotekeys(0) ->Terse(1)->Dump(); } 1; # ABSTRACT: Utilities used internally by Log::Dispatch for testing __END__ =head1 METHODS =over =item cmp_deeply A cheap version of Test::Deep::cmp_deeply. =item dump_one_line Dump a value to a single line using Data::Dumper. =cut Log-Dispatch-2.41/t/release-pod-no404s.t0000644000175000017500000000076512173250731017444 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; foreach my $env_skip ( qw( SKIP_POD_NO404S AUTOMATED_TESTING ) ){ plan skip_all => "\$ENV{$env_skip} is set, skipping" if $ENV{$env_skip}; } eval "use Test::Pod::No404s"; if ( $@ ) { plan skip_all => 'Test::Pod::No404s required for testing POD'; } else { all_pod_files_ok(); } Log-Dispatch-2.41/t/email-exit-helper.pl0000755000175000017500000000062212173250731017675 0ustar autarchautarch#!/usr/bin/perl -w use strict; use lib './lib', '../lib'; use Log::Dispatch::Email::MailSend; Mail::Mailer->import( sendmail => 't/sendmail' ); my $email = Log::Dispatch::Email::MailSend->new( name => 'email', min_level => 'emerg', to => 'foo@example.com', subject => 'Log this', ); $email->log( message => 'Something bad is happening', level => 'emerg' ); exit 5; Log-Dispatch-2.41/t/release-pod-syntax.t0000644000175000017500000000045012173250731017732 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); Log-Dispatch-2.41/t/03-short-syntax.t0000644000175000017500000000340412173250731017113 0ustar autarchautarchuse strict; use warnings; use lib qw(t/lib); use Test::More; use Log::Dispatch; use Log::Dispatch::TestUtil qw(cmp_deeply); use File::Temp qw( tempdir ); my $tempdir = tempdir( CLEANUP => 1 ); { my $emerg_log = File::Spec->catdir( $tempdir, 'emerg.log' ); # Short syntax my $dispatch0 = Log::Dispatch->new( outputs => [ [ 'File', name => 'file', min_level => 'emerg', filename => $emerg_log ], [ '+Log::Dispatch::Screen', name => 'screen', min_level => 'debug' ] ] ); # Short syntax alternate (2.23) my $dispatch1 = Log::Dispatch->new( outputs => [ 'File' => { name => 'file', min_level => 'emerg', filename => $emerg_log }, '+Log::Dispatch::Screen' => { name => 'screen', min_level => 'debug' } ] ); # Long syntax my $dispatch2 = Log::Dispatch->new; $dispatch2->add( Log::Dispatch::File->new( name => 'file', min_level => 'emerg', filename => $emerg_log ) ); $dispatch2->add( Log::Dispatch::Screen->new( name => 'screen', min_level => 'debug' ) ); cmp_deeply( $dispatch0, $dispatch2, "created equivalent dispatchers - 0" ); cmp_deeply( $dispatch1, $dispatch2, "created equivalent dispatchers - 1" ); } { eval { Log::Dispatch->new( outputs => ['File'] ) }; like( $@, qr/expected arrayref/, "got error for expected inner arrayref" ); } { eval { Log::Dispatch->new( outputs => 'File' ) }; like( $@, qr/not one of the allowed types: arrayref/, "got error for expected outer arrayref" ); } done_testing(); Log-Dispatch-2.41/t/05-close-after-write.t0000644000175000017500000000455612173250731017777 0ustar autarchautarchuse strict; use warnings FATAL => 'all'; use Test::More 0.88; use File::Spec; use File::Temp qw( tempdir ); use Log::Dispatch; my $dir = tempdir( CLEANUP => 1 ); # test that the same handle is returned if close-on-write is not set... { my $logger = Log::Dispatch->new( outputs => [ [ 'File', min_level => 'debug', newline => 1, name => 'no_caw', filename => File::Spec->catfile( $dir, 'no_caw.log' ), close_after_write => 0, ], [ 'File', min_level => 'debug', newline => 1, name => 'caw', filename => File::Spec->catfile( $dir, 'caw.log' ), close_after_write => 1, ], ], ); ok( $logger->output('no_caw')->{fh}, 'no_caw output has created a fh before first write' ); ok( !$logger->output('caw')->{fh}, 'caw output has not created a fh before first write' ); $logger->log( level => 'info', message => 'first message' ); is( _slurp( $logger->output('no_caw')->{filename} ), "first message\n", 'first line from no_caw output' ); is( _slurp( $logger->output('caw')->{filename} ), "first message\n", 'first line from caw output' ); my %handle = ( no_caw => $logger->output('no_caw')->{fh}, caw => $logger->output('caw')->{fh}, ); $logger->log( level => 'info', message => 'second message' ); is( _slurp( $logger->output('no_caw')->{filename} ), "first message\nsecond message\n", 'full content from no_caw output' ); is( _slurp( $logger->output('caw')->{filename} ), "first message\nsecond message\n", 'full content from caw output' ); # check the filehandles again... is( $logger->output('no_caw')->{fh}, $handle{no_caw}, 'handle has not changed when not using CAW' ); isnt( $logger->output('caw')->{fh}, $handle{caw}, 'handle has changed when using CAW' ); } done_testing(); sub _slurp { open my $fh, '<', $_[0] or die "Cannot read $_[0]: $!"; return do { local $/; <$fh>; }; } Log-Dispatch-2.41/t/release-cpan-changes.t0000644000175000017500000000047112173250731020156 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); done_testing(); Log-Dispatch-2.41/t/01-basic.t0000644000175000017500000006542412173250731015521 0ustar autarchautarchuse strict; use warnings; use Test::More 0.88; use File::Spec; use File::Temp qw( tempdir ); use Log::Dispatch; my %tests; BEGIN { foreach (qw( MailSend MIMELite MailSendmail MailSender )) { eval "use Log::Dispatch::Email::$_"; $tests{$_} = !$@; $tests{$_} = 0 if $ENV{LD_NO_MAIL}; } } my %TestConfig; if ( my $email_address = $ENV{LOG_DISPATCH_TEST_EMAIL} ) { %TestConfig = ( email_address => $email_address ); } my @syswrite_strs; BEGIN { if ( $] >= 5.016 ) { my $syswrite = \&CORE::syswrite; *CORE::GLOBAL::syswrite = sub { my ( $fh, $str, @other ) = @_; push @syswrite_strs, $_[1]; return $syswrite->( $fh, $str, @other ); }; } } use Log::Dispatch::File; use Log::Dispatch::Handle; use Log::Dispatch::Null; use Log::Dispatch::Screen; use IO::File; my $tempdir = tempdir( CLEANUP => 1 ); my $dispatch = Log::Dispatch->new; ok( $dispatch, "created Log::Dispatch object" ); # Test Log::Dispatch::File { my $emerg_log = File::Spec->catdir( $tempdir, 'emerg.log' ); $dispatch->add( Log::Dispatch::File->new( name => 'file1', min_level => 'emerg', filename => $emerg_log ) ); $dispatch->log( level => 'info', message => "info level 1\n" ); $dispatch->log( level => 'emerg', message => "emerg level 1\n" ); my $debug_log = File::Spec->catdir( $tempdir, 'debug.log' ); $dispatch->add( Log::Dispatch::File->new( name => 'file2', min_level => 'debug', syswrite => 1, filename => $debug_log ) ); $dispatch->log( level => 'info', message => "info level 2\n" ); $dispatch->log( level => 'emerg', message => "emerg level 2\n" ); # This'll close them filehandles! undef $dispatch; open my $emerg_fh, '<', $emerg_log or die "Can't read $emerg_log: $!"; open my $debug_fh, '<', $debug_log or die "Can't read $debug_log: $!"; my @log = <$emerg_fh>; is( $log[0], "emerg level 1\n", "First line in log file set to level 'emerg' is 'emerg level 1'" ); is( $log[1], "emerg level 2\n", "Second line in log file set to level 'emerg' is 'emerg level 2'" ); @log = <$debug_fh>; is( $log[0], "info level 2\n", "First line in log file set to level 'debug' is 'info level 2'" ); is( $log[1], "emerg level 2\n", "Second line in log file set to level 'debug' is 'emerg level 2'" ); SKIP: { skip 'This test requires Perl 5.16+', 1 unless $] >= 5.016; is_deeply( \@syswrite_strs, [ "info level 2\n", "emerg level 2\n", ], 'second LD object used syswrite', ); } } # max_level test { my $max_log = File::Spec->catfile( $tempdir, 'max.log' ); my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::File->new( name => 'file1', min_level => 'debug', max_level => 'crit', filename => $max_log ) ); $dispatch->log( level => 'emerg', message => "emergency\n" ); $dispatch->log( level => 'crit', message => "critical\n" ); undef $dispatch; # close file handles open my $fh, '<', $max_log or die "Can't read $max_log: $!"; my @log = <$fh>; is( $log[0], "critical\n", "First line in log file with a max level of 'crit' is 'critical'" ); } # Log::Dispatch::Handle test { my $handle_log = File::Spec->catfile( $tempdir, 'handle.log' ); my $fh = IO::File->new( $handle_log, 'w' ) or die "Can't write to $handle_log: $!"; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Handle->new( name => 'handle', min_level => 'debug', handle => $fh ) ); $dispatch->log( level => 'notice', message => "handle test\n" ); # close file handles undef $dispatch; undef $fh; open $fh, '<', $handle_log or die "Can't open $handle_log: $!"; my @log = <$fh>; close $fh; is( $log[0], "handle test\n", "Log::Dispatch::Handle created log file should contain 'handle test\\n'" ); } # Log::Dispatch::Email::MailSend SKIP: { skip "Cannot do MailSend tests", 1 unless $tests{MailSend} && $TestConfig{email_address}; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Email::MailSend->new( name => 'Mail::Send', min_level => 'debug', to => $TestConfig{email_address}, subject => 'Log::Dispatch test suite' ) ); $dispatch->log( level => 'emerg', message => "Mail::Send test - If you can read this then the test succeeded (PID $$)" ); diag( "Sending email with Mail::Send to $TestConfig{email_address}.\nIf you get it then the test succeeded (PID $$)\n" ); undef $dispatch; ok( 1, 'sent email via MailSend' ); } # Log::Dispatch::Email::MailSendmail SKIP: { skip "Cannot do MailSendmail tests", 1 unless $tests{MailSendmail} && $TestConfig{email_address}; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Email::MailSendmail->new( name => 'Mail::Sendmail', min_level => 'debug', to => $TestConfig{email_address}, subject => 'Log::Dispatch test suite' ) ); $dispatch->log( level => 'emerg', message => "Mail::Sendmail test - If you can read this then the test succeeded (PID $$)" ); diag( "Sending email with Mail::Sendmail to $TestConfig{email_address}.\nIf you get it then the test succeeded (PID $$)\n" ); undef $dispatch; ok( 1, 'sent email via MailSendmail' ); } # Log::Dispatch::Email::MIMELite SKIP: { skip "Cannot do MIMELite tests", 1 unless $tests{MIMELite} && $TestConfig{email_address}; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Email::MIMELite->new( name => 'Mime::Lite', min_level => 'debug', to => $TestConfig{email_address}, subject => 'Log::Dispatch test suite' ) ); $dispatch->log( level => 'emerg', message => "MIME::Lite - If you can read this then the test succeeded (PID $$)" ); diag( "Sending email with MIME::Lite to $TestConfig{email_address}.\nIf you get it then the test succeeded (PID $$)\n" ); undef $dispatch; ok( 1, 'sent mail via MIMELite' ); } # Log::Dispatch::Screen { my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Screen->new( name => 'screen', min_level => 'debug', stderr => 0 ) ); my $text; tie *STDOUT, 'Test::Tie::STDOUT', \$text; $dispatch->log( level => 'crit', message => 'testing screen' ); untie *STDOUT; is( $text, 'testing screen', "Log::Dispatch::Screen outputs to STDOUT" ); } # Log::Dispatch::Output->accepted_levels { my $l = Log::Dispatch::Screen->new( name => 'foo', min_level => 'warning', max_level => 'alert', stderr => 0 ); my @expected = qw(warning error critical alert); my @levels = $l->accepted_levels; my $pass = 1; for ( my $x = 0 ; $x < scalar @expected ; $x++ ) { $pass = 0 unless $expected[$x] eq $levels[$x]; } is( scalar @expected, scalar @levels, "number of levels matched" ); ok( $pass, "levels matched" ); } # Log::Dispatch single callback { my $reverse = sub { my %p = @_; return reverse $p{message}; }; my $dispatch = Log::Dispatch->new( callbacks => $reverse ); my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => 'warning', max_level => 'alert', ) ); $dispatch->log( level => 'warning', message => 'esrever' ); is( $string, 'reverse', "callback to reverse text" ); } # Log::Dispatch multiple callbacks { my $reverse = sub { my %p = @_; return reverse $p{message}; }; my $uc = sub { my %p = @_; return uc $p{message}; }; my $dispatch = Log::Dispatch->new( callbacks => [ $reverse, $uc ] ); my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => 'warning', max_level => 'alert', ) ); $dispatch->log( level => 'warning', message => 'esrever' ); is( $string, 'REVERSE', "callback to reverse and uppercase text" ); } # Log::Dispatch::Output single callback { my $reverse = sub { my %p = @_; return reverse $p{message}; }; my $dispatch = Log::Dispatch->new; my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => 'warning', max_level => 'alert', callbacks => $reverse ) ); $dispatch->log( level => 'warning', message => 'esrever' ); is( $string, 'reverse', "Log::Dispatch::Output callback to reverse text" ); } # Log::Dispatch::Output multiple callbacks { my $reverse = sub { my %p = @_; return reverse $p{message}; }; my $uc = sub { my %p = @_; return uc $p{message}; }; my $dispatch = Log::Dispatch->new; my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => 'warning', max_level => 'alert', callbacks => [ $reverse, $uc ] ) ); $dispatch->log( level => 'warning', message => 'esrever' ); is( $string, 'REVERSE', "Log::Dispatch::Output callbacks to reverse and uppercase text" ); } # test level parameter to callbacks { my $level = sub { my %p = @_; return uc $p{level}; }; my $dispatch = Log::Dispatch->new( callbacks => $level ); my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => 'warning', max_level => 'alert', stderr => 0 ) ); $dispatch->log( level => 'warning', message => 'esrever' ); is( $string, 'WARNING', "Log::Dispatch callback to uppercase the level parameter" ); } # Comprehensive test of new methods that match level names { my %levels = map { $_ => $_ } (qw( debug info notice warning error critical alert emergency )); @levels{qw( warn err crit emerg )} = (qw( warning error critical emergency )); foreach my $allowed_level ( qw( debug info notice warning error critical alert emergency )) { my $dispatch = Log::Dispatch->new; my $string; $dispatch->add( Log::Dispatch::String->new( name => 'foo', string => \$string, min_level => $allowed_level, max_level => $allowed_level, ) ); foreach my $test_level ( qw( debug info notice warn warning err error crit critical alert emerg emergency ) ) { $string = ''; $dispatch->$test_level( $test_level, 'test' ); if ( $levels{$test_level} eq $allowed_level ) { my $expect = join $", $test_level, 'test'; is( $string, $expect, "Calling $test_level method should send message '$expect'" ); } else { ok( !length $string, "Calling $test_level method should not log anything" ); } } } } { my $string; my $dispatch = Log::Dispatch->new( outputs => [ [ 'String', name => 'string', string => \$string, min_level => 'debug', ], ], ); $dispatch->debug( 'foo', 'bar' ); is( $string, 'foo bar', 'passing multiple elements to ->debug stringifies them like an array' ); $string = q{}; $dispatch->debug( sub { 'foo' } ); is( $string, 'foo', 'passing single sub ref to ->debug calls the sub ref' ); } # Log::Dispatch->level_is_valid method { foreach my $l ( qw( debug info notice warning err error crit critical alert emerg emergency ) ) { ok( Log::Dispatch->level_is_valid($l), "$l is valid level" ); } foreach my $l (qw( debu inf foo bar )) { ok( !Log::Dispatch->level_is_valid($l), "$l is not valid level" ); } # Provide calling line if level missing my $string; my $dispatch = Log::Dispatch->new( outputs => [ [ 'String', name => 'string', string => \$string, min_level => 'debug', ], ], ); eval { $dispatch->log( msg => "Message" ) }; like( $@, qr/Logging level was not provided at .* line \d+./, "Provide calling line if level not provided" ); } # make sure passing mode as write works { my $mode_log = File::Spec->catfile( $tempdir, 'mode.log' ); my $f1 = Log::Dispatch::File->new( name => 'file', min_level => 1, filename => $mode_log, mode => 'write', ); $f1->log( level => 'emerg', message => "test2\n" ); undef $f1; open my $fh, '<', $mode_log or die "Cannot read $mode_log: $!"; my $data = join '', <$fh>; close $fh; like( $data, qr/^test2/, "test write mode" ); } # Log::Dispatch::Email::MailSender SKIP: { skip "Cannot do MailSender tests", 1 unless $tests{MailSender} && $TestConfig{email_address}; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Email::MailSender->new( name => 'Mail::Sender', min_level => 'debug', smtp => 'localhost', to => $TestConfig{email_address}, subject => 'Log::Dispatch test suite' ) ); $dispatch->log( level => 'emerg', message => "Mail::Sender - If you can read this then the test succeeded (PID $$)" ); diag( "Sending email with Mail::Sender to $TestConfig{email_address}.\nIf you get it then the test succeeded (PID $$)\n" ); undef $dispatch; ok( 1, 'sent email via MailSender' ); } # dispatcher exists { my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Screen->new( name => 'yomama', min_level => 'alert' ) ); ok( $dispatch->output('yomama'), "yomama output should exist" ); ok( !$dispatch->output('nomama'), "nomama output should not exist" ); } # Test Log::Dispatch::File - close_after_write & permissions { my $dispatch = Log::Dispatch->new; my $close_log = File::Spec->catfile( $tempdir, 'close.log' ); $dispatch->add( Log::Dispatch::File->new( name => 'close', min_level => 'info', filename => $close_log, permissions => 0777, close_after_write => 1 ) ); $dispatch->log( level => 'info', message => "info\n" ); open my $fh, '<', $close_log or die "Can't read $close_log: $!"; my @log = <$fh>; close $fh; is( $log[0], "info\n", "First line in log file should be 'info\\n'" ); my $mode = ( stat $close_log )[2] or die "Cannot stat $close_log: $!"; my $mode_string = sprintf( '%04o', $mode & 07777 ); if ( $^O =~ /win32/i ) { ok( $mode_string == '0777' || $mode_string == '0666', "Mode should be 0777 or 0666" ); } elsif ( $^O =~ /cygwin/i ) { ok( $mode_string == '0777' || $mode_string == '0644', "Mode should be 0777 or 0644" ); } else { is( $mode_string, '0777', "Mode should be 0777" ); } } { my $dispatch = Log::Dispatch->new; my $chmod_log = File::Spec->catfile( $tempdir, 'chmod.log' ); open my $fh, '>', $chmod_log or die "Cannot write to $chmod_log: $!"; close $fh; chmod 0777, $chmod_log or die "Cannot chmod 0777 $chmod_log: $!"; my @chmod; no warnings 'once'; local *CORE::GLOBAL::chmod = sub { @chmod = @_; warn @chmod }; $dispatch->add( Log::Dispatch::File->new( name => 'chmod', min_level => 'info', filename => $chmod_log, permissions => 0777, ) ); $dispatch->warning('test'); ok( !scalar @chmod, 'chmod() was not called when permissions already matched what was specified' ); } SKIP: { skip "Cannot test utf8 files with this version of Perl ($])", 1 unless $] >= 5.008; my $dispatch = Log::Dispatch->new; my $utf8_log = File::Spec->catfile( $tempdir, 'utf8.log' ); $dispatch->add( Log::Dispatch::File->new( name => 'utf8', min_level => 'info', filename => $utf8_log, binmode => ':encoding(UTF-8)', ) ); my @warnings; { local $SIG{__WARN__} = sub { push @warnings, @_ }; $dispatch->warning("\x{999A}"); } ok( !scalar @warnings, 'utf8 binmode was applied to file and no warnings were issued' ); } # would_log { my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Null->new( name => 'null', min_level => 'warning', ) ); ok( !$dispatch->would_log('foo'), "will not log 'foo'" ); ok( !$dispatch->would_log('debug'), "will not log 'debug'" ); ok( !$dispatch->is_debug(), 'is_debug returns false' ); ok( $dispatch->is_warning(), 'is_warning returns true' ); ok( $dispatch->would_log('crit'), "will log 'crit'" ); ok( $dispatch->is_crit, "will log 'crit'" ); } { my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Null->new( name => 'null', min_level => 'info', max_level => 'critical', ) ); my $called = 0; my $message = sub { $called = 1 }; $dispatch->log( level => 'debug', message => $message ); ok( !$called, 'subref is not called if the message would not be logged' ); $called = 0; $dispatch->log( level => 'warning', message => $message ); ok( $called, 'subref is called when message is logged' ); $called = 0; $dispatch->log( level => 'emergency', message => $message ); ok( !$called, 'subref is not called when message would not be logged' ); } { my $string; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); $dispatch->log( level => 'debug', message => sub { 'this is my message' }, ); is( $string, 'this is my message', 'message returned by subref is logged' ); } { my $string; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', newline => 1, ) ); $dispatch->debug('hello'); $dispatch->debug('goodbye'); is( $string, "hello\ngoodbye\n", 'added newlines' ); } { my $string; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); eval { $dispatch->log_and_die( level => 'error', message => 'this is my message', ); }; my $e = $@; ok( $e, 'died when calling log_and_die()' ); like( $e, qr{this is my message}, 'error contains expected message' ); like( $e, qr{01-basic\.t line 8\d\d}, 'error croaked' ); is( $string, 'this is my message', 'message is logged' ); undef $string; eval { Croaker::croak($dispatch); }; $e = $@; ok( $e, 'died when calling log_and_croak()' ); like( $e, qr{croak}, 'error contains expected message' ); like( $e, qr{01-basic\.t line 10005}, 'error croaked from perspective of caller' ); is( $string, 'croak', 'message is logged' ); } { my $string; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'foo', 'first test w/o callback' ); $string = ''; $dispatch->add_callback( sub { return 'bar' } ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'bar', 'second call, callback overrides message' ); } { my $string; my $dispatch = Log::Dispatch->new( callbacks => sub { return 'baz' }, ); $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'baz', 'first test gets orig callback result' ); $string = ''; $dispatch->add_callback( sub { return 'bar' } ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'bar', 'second call, callback overrides message' ); } { my $string; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'foo', 'first test w/o callback' ); $string = ''; $dispatch->add_callback( sub { return 'bar' } ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'bar', 'second call, callback overrides message' ); } { my $string; my $dispatch = Log::Dispatch->new( callbacks => sub { return 'baz' }, ); $dispatch->add( Log::Dispatch::String->new( name => 'handle', string => \$string, min_level => 'debug', ) ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'baz', 'first test gets orig callback result' ); $string = ''; $dispatch->add_callback( sub { return 'bar' } ); $dispatch->log( level => 'debug', message => 'foo' ); is( $string, 'bar', 'second call, callback overrides message' ); } SKIP: { skip 'Cannot do syslog tests without Sys::Syslog 0.16+', 2 unless eval "use Log::Dispatch::Syslog; 1;"; no warnings 'redefine', 'once'; my @sock; local *Sys::Syslog::setlogsock = sub { @sock = @_ }; local *Sys::Syslog::openlog = sub { return 1 }; local *Sys::Syslog::closelog = sub { return 1 }; my @log; local *Sys::Syslog::syslog = sub { push @log, [@_] }; my $dispatch = Log::Dispatch->new; $dispatch->add( Log::Dispatch::Syslog->new( name => 'syslog', min_level => 'debug', ) ); ok( !@sock, 'no call to stelogsock unless socket is set explicitly' ); $dispatch->info('Foo'); is_deeply( \@log, [ [ 'INFO', 'Foo' ] ], 'passed message to syslog' ); } { # Test defaults my $dispatch = Log::Dispatch::Null->new( min_level => 'debug' ); like( $dispatch->name, qr/anon/, 'generated anon name' ); is( $dispatch->max_level, 'emergency', 'max_level is emergency' ); } { my $level; my $record_level = sub { my %p = @_; $level = $p{level}; return %p; }; my $dispatch = Log::Dispatch->new( callbacks => $record_level, outputs => [ [ 'Null', name => 'null', min_level => 'debug', ], ], ); $dispatch->warn('foo'); is( $level, 'warning', 'level for call to ->warn is warning' ); $dispatch->err('foo'); is( $level, 'error', 'level for call to ->err is error' ); $dispatch->crit('foo'); is( $level, 'critical', 'level for call to ->crit is critical' ); $dispatch->emerg('foo'); is( $level, 'emergency', 'level for call to ->emerg is emergency' ); } { my @calls; my $log = Log::Dispatch->new( outputs => [ [ 'Code', min_level => 'error', code => sub { push @calls, {@_} }, ], ] ); $log->error('foo'); $log->info('bar'); $log->critical('baz'); is_deeply( \@calls, [ { level => 'error', message => 'foo', }, { level => 'critical', message => 'baz', }, ], 'code received the expected messages' ); } done_testing(); package Log::Dispatch::String; use strict; use Log::Dispatch::Output; use base qw( Log::Dispatch::Output ); sub new { my $proto = shift; my $class = ref $proto || $proto; my %p = @_; my $self = bless { string => $p{string} }, $class; $self->_basic_init(%p); return $self; } sub log_message { my $self = shift; my %p = @_; ${ $self->{string} } .= $p{message}; } # Used for testing Log::Dispatch::Screen package Test::Tie::STDOUT; sub TIEHANDLE { my $class = shift; my $self = {}; $self->{string} = shift; ${ $self->{string} } ||= ''; return bless $self, $class; } sub PRINT { my $self = shift; ${ $self->{string} } .= join '', @_; } sub PRINTF { my $self = shift; my $format = shift; ${ $self->{string} } .= sprintf( $format, @_ ); } #line 10000 package Croaker; sub croak { my $log = shift; $log->log_and_croak( level => 'error', message => 'croak' ); } Log-Dispatch-2.41/t/release-no-tabs.t0000644000175000017500000000045012173250731017167 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::NoTabs'; plan skip_all => 'Test::NoTabs required' if $@; all_perl_files_ok(); Log-Dispatch-2.41/t/02-email-exit.t0000644000175000017500000000037212173250731016466 0ustar autarchautarchuse strict; use warnings; use Test::More; unless ( -d '.git' ) { plan skip_all => 'This test only runs for the maintainer'; exit; } system( $^X, 't/email-exit-helper.pl' ); is( $? >> 8, 5, 'exit code of helper was 5' ); done_testing(); Log-Dispatch-2.41/t/release-pod-coverage.t0000644000175000017500000000107712173250731020205 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok( { trustme => [ qr/^(?:warn|err|crit|emerg)$/, qr/^send_email|log_message|new$/, qr/^add_callback$/, qr/^(?:O_)?APPEND$/, qr/^is_\w+$/ ] } ); Log-Dispatch-2.41/t/sendmail0000755000175000017500000000002512173250731015541 0ustar autarchautarch#!/bin/bash exit 0; Log-Dispatch-2.41/t/release-eol.t0000644000175000017500000000047612173250731016413 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::EOL'; plan skip_all => 'Test::EOL required' if $@; all_perl_files_ok({ trailing_whitespace => 1 }); Log-Dispatch-2.41/t/release-pod-spell.t0000644000175000017500000000155012173250731017525 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::Spelling; my @stopwords; for () { chomp; push @stopwords, $_ unless /\A (?: \# | \s* \z)/msx; # skip comments, whitespace } add_stopwords(@stopwords); set_spell_cmd('aspell list -l en'); # This prevents a weird segfault from the aspell command - see # https://bugs.launchpad.net/ubuntu/+source/aspell/+bug/71322 local $ENV{LC_ALL} = 'C'; all_pod_files_spelling_ok; __DATA__ API CPAN Cholet Dumont Goess Manfredi Miyagawa PayPal Pfeiffer Rolsky STDERR STDOUT Schilli Straup Subclasses Swartz Tatsuhiko UTF apache appenders auth authpriv autoflushed classname crit emerg filename ident kern logopt multi params smtp stderr subclass's subclasses uucp Log-Dispatch-2.41/t/00-compile.t0000644000175000017500000000151512173250731016056 0ustar autarchautarchuse strict; use warnings; use Test::More; my %deps = ( ApacheLog => 'Apache::Log', File => '', 'File::Locked' => '', Handle => '', Screen => '', Syslog => 'Sys::Syslog 0.25', 'Email::MailSend' => 'Mail::Send', 'Email::MIMELite' => 'MIME::Lite', 'Email::MailSendmail' => 'Mail::Sendmail', 'Email::MailSender' => 'Mail::Sender', ); plan tests => 1 + scalar keys %deps; use_ok('Log::Dispatch'); for my $subclass ( sort keys %deps ) { my $module = "Log::Dispatch::$subclass"; if ( !$deps{$subclass} || ( eval "use $deps{$subclass}; 1" && !$@ ) ) { use_ok($module); } else { SKIP: { skip "Cannot load $module without $deps{$subclass}", 1; } } } Log-Dispatch-2.41/Makefile.PL0000644000175000017500000000464112173250731015536 0ustar autarchautarch use strict; use warnings; use ExtUtils::MakeMaker 6.30; check_conflicts(); my %WriteMakefileArgs = ( "ABSTRACT" => "Dispatches messages to one or more outputs", "AUTHOR" => "Dave Rolsky ", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "Dist::CheckConflicts" => "0.02", "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "Log-Dispatch", "EXE_FILES" => [], "LICENSE" => "artistic_2", "NAME" => "Log::Dispatch", "PREREQ_PM" => { "Class::Load" => 0, "Dist::CheckConflicts" => "0.02", "Params::Validate" => "0.15", "Sys::Syslog" => "0.25" }, "TEST_REQUIRES" => { "File::Temp" => 0, "Test::More" => "0.88" }, "VERSION" => "2.41", "test" => { "TESTS" => "t/*.t" } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { my $tr = delete $WriteMakefileArgs{TEST_REQUIRES}; my $br = $WriteMakefileArgs{BUILD_REQUIRES}; for my $mod ( keys %$tr ) { if ( exists $br->{$mod} ) { $br->{$mod} = $tr->{$mod} if $tr->{$mod} > $br->{$mod}; } else { $br->{$mod} = $tr->{$mod}; } } } unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); sub check_conflicts { if ( eval { require 'lib/Log/Dispatch/Conflicts.pm'; 1; } ) { if ( eval { Log::Dispatch::Conflicts->check_conflicts; 1 } ) { return; } else { my $err = $@; $err =~ s/^/ /mg; warn "***\n$err***\n"; } } else { print <<'EOF'; *** Your toolchain doesn't support configure_requires, so Dist::CheckConflicts hasn't been installed yet. You should check for conflicting modules manually by examining the list of conflicts in Log::Dispatch::Conflicts once the installation finishes. *** EOF } return if $ENV{AUTOMATED_TESTING} || $ENV{NONINTERACTIVE_TESTING}; # More or less copied from Module::Build return if $ENV{PERL_MM_USE_DEFAULT}; return unless -t STDIN && ( -t STDOUT || !( -f STDOUT || -c STDOUT ) ); sleep 4; }