use 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' );
}