diff options
Diffstat (limited to 't')
79 files changed, 11132 insertions, 0 deletions
diff --git a/t/001Level.t b/t/001Level.t new file mode 100644 index 0000000..381d3f1 --- /dev/null +++ b/t/001Level.t @@ -0,0 +1,61 @@ +########################################### +# Test Suite for Log::Log4perl::Level +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +use strict; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { plan tests => 34 }; +use Log::Log4perl::Level; +BEGIN { + Log::Log4perl::Level->import("Level"); + Log::Log4perl::Level->import("My::Level"); +} +ok(1); # If we made it this far, we're ok. + +# Import them into the 'main' namespace; +foreach ($TRACE, $DEBUG, $INFO, $WARN, $ERROR, $FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# Import them into the 'Level' namespace; +foreach ($Level::TRACE, $Level::DEBUG, $Level::INFO, $Level::WARN, $Level::ERROR, $Level::FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# Import them into the 'My::Level' namespace; +foreach ($My::Level::DEBUG, $My::Level::DEBUG, $My::Level::INFO, $My::Level::WARN, $My::Level::ERROR, $My::Level::FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# ok, now let's check to make sure the relative order is correct. + +ok(Log::Log4perl::Level::isGreaterOrEqual($TRACE, $DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($DEBUG, $INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($INFO, $WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($WARN, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($ERROR, $FATAL)); + +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::TRACE, $Level::DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::DEBUG, $Level::INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::INFO, $Level::WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::WARN, $Level::ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::ERROR, $Level::FATAL)); + +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::TRACE, + $My::Level::DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::DEBUG, $My::Level::INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::INFO, $My::Level::WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::WARN, $My::Level::ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::ERROR, $My::Level::FATAL)); diff --git a/t/002Logger.t b/t/002Logger.t new file mode 100755 index 0000000..fd6df46 --- /dev/null +++ b/t/002Logger.t @@ -0,0 +1,403 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +#use Data::Dump qw(dump); + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +######################### +# used Test::Simple to help debug the test script +use Test::More tests => 74; + +use Log::Log4perl; +use Log::Log4perl::Level; +use Log::Log4perl::Util; + +ok(1); # If we made it this far, we're ok. + +# Check unintialized case +my $logger = Log::Log4perl::get_logger(""); +is $logger->is_trace, 0, "is_trace false when L4p is uninitialized"; +is $logger->is_debug, 0, "is_debug false when L4p is uninitialized"; +is $logger->is_error, 0, "is_error false when L4p is uninitialized"; + +my $log0 = Log::Log4perl->get_logger("abc.def"); +is $log0->category(), "abc.def", "category accessor"; +my $log1 = Log::Log4perl->get_logger("abc.def"); +my $log2 = Log::Log4perl->get_logger("abc.def"); +my $log3 = Log::Log4perl->get_logger("abc.def.ghi"); +my $log4 = Log::Log4perl->get_logger("def.abc.def"); +my $log5 = Log::Log4perl->get_logger("def.abc.def"); +my $log6 = Log::Log4perl->get_logger(""); +my $log7 = Log::Log4perl->get_logger(""); +my $log8 = Log::Log4perl->get_logger("abc.def"); +my $log9 = Log::Log4perl->get_logger("abc::def::ghi"); + +# Loggers for the same namespace have to be identical +ok($log1 == $log2, "Log1 same as Log2"); +ok($log4 == $log5, "Log4 same as Log5"); +ok($log6 == $log7, "Log6 same as Log7"); +ok($log1 == $log8, "Log1 same as Log8"); +ok($log3 == $log9, "log3 same as Log9"); + +# Loggers for different namespaces have to be different +ok($log1 != $log3, "Log1 not Log3"); +ok($log3 != $log4, "Log3 not Log4"); +ok($log1 != $log6, "Log1 not Log6"); +ok($log3 != $log6, "Log3 not Log6"); +ok($log5 != $log6, "Log5 not Log6"); +ok($log5 != $log7, "Log5 not Log7"); +ok($log5 != $log1, "Log5 not Log1"); +ok($log7 != $log8, "Log7 not Log8"); +ok($log8 != $log9, "Log8 not Log9"); + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +################################################## +# Suppress debug +################################################## +$log1->add_appender($app); +$log1->level($ERROR); + +# warn "level is: ", $log1->level(), "\n"; + +my $ret; + +$ret = $log1->error("Error Message"); +ok($ret == 1); + +$ret = $log1->debug("Debug Message"); +ok(!defined $ret); + +ok($app->buffer() eq "ERROR - Error Message\n", "log1 app buffer contains ERROR - Error Message"); + +# warn "app buffer is: \"", $app->buffer(), "\"\n"; + +################################################## +# Allow debug +################################################## +$log1->level($DEBUG); +$app->buffer(""); +$log1->error("Error Message"); +$log1->debug("Debug Message"); +ok($app->buffer() eq "ERROR - Error Message\nDEBUG - Debug Message\n", + "app buffer contains both ERROR and DEBUG message"); + +# warn "app buffer is: \"", $app->buffer(), "\"\n"; + +################################################## +# Multiple Appenders +################################################## +my $app2 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +my $app3 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +$app->buffer(""); +$app2->buffer(""); + # 2nd appender to $log1 +$log1->add_appender($app2); +$log1->level($ERROR); +$log1->error("Error Message"); +#TODO +ok($app->buffer() eq "ERROR - Error Message\n", "app buffer contains ERROR only"); +ok($app2->buffer() eq "ERROR - Error Message\n", "app2 buffer contains ERROR only"); + +################################################## +# Multiple Appenders in different hierarchy levels +################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1 = Log::Log4perl->get_logger("xxx.yyy.zzz"); +$log2 = Log::Log4perl->get_logger("xxx"); +$log3 = Log::Log4perl->get_logger(""); + + # Root logger +$log3->add_appender($app3); + +$log3->level($ERROR); + + ################################################## + # Log to lower level, check if gets propagated up to root + ################################################## +$log1->error("Error Message"); + + # Should be distributed to root +ok($app3->buffer() eq "ERROR - Error Message\n", "app3 buffer contains ERROR"); + ################################################## + # Log in lower levels and propagate to root + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->add_appender($app); +$log2->add_appender($app2); +# log3 already has app3 attached +$ret = $log1->error("Error Message"); +ok($ret == 3); +ok($app->buffer() eq "ERROR - Error Message\n", "app buffer contains ERROR"); +ok($app2->buffer() eq "ERROR - Error Message\n", "app2 buffer contains ERROR"); +ok($app3->buffer() eq "ERROR - Error Message\n", "app3 buffer contains ERROR"); + + ################################################## + # Block appenders via priority + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($ERROR); +$log2->level($DEBUG); +$log3->level($DEBUG); + +$log1->debug("Debug Message"); +ok($app->buffer() eq "", "app buffer is empty"); +ok($app2->buffer() eq "", "app2 buffer is empty"); +ok($app3->buffer() eq "", "app3 buffer is empty"); + + ################################################## + # Block via 'false' additivity + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($DEBUG); +$log2->additivity(0); +$log2->level($DEBUG); +$log3->level($DEBUG); + +$log1->debug("Debug Message"); +ok($app->buffer() eq "DEBUG - Debug Message\n", "app buffer contains DEBUG"); +ok($app2->buffer() eq "DEBUG - Debug Message\n", "app2 buffer contains DEBUG"); +ok($app3->buffer() eq "", "app3 buffer is empty"); + + ################################################## + # Check is_*() functions + ################################################## +$log0->level($TRACE); +$log1->level($DEBUG); +$log2->level($ERROR); +$log3->level($INFO); + +ok($log0->is_trace(), "log0 is_trace == 1"); +ok($log0->is_error(), "log0 is_error == 1"); + +ok($log1->is_error(), "log1 is_error == 1"); +ok($log1->is_info(), "log1 is_info == 1"); +ok($log1->is_fatal(), "log1 is_fatal == 1"); +ok($log1->is_debug(), "log1 is_debug == 1"); + +ok($log2->is_error(), "log2 is_error == 1"); +ok(!$log2->is_info(), "log2 is_info == 0"); +ok($log2->is_fatal(), "log2 is_fatal == 1"); +ok(!$log2->is_debug(), "log2 is_debug == 0"); + +ok($log3->is_error(), "log3 is_error == 1"); +ok($log3->is_info(), "log3 is_info == 1"); +ok($log3->is_fatal(), "log3 is_fatal == 1"); +ok(!$log3->is_debug(), "log3 is_debug == 0"); + + + ################################################## + # Check is_*() functions with text + ################################################## +$log3->level('DEBUG'); +$log2->level('ERROR'); +$log1->level('INFO'); + +ok($log3->is_error(), "log3 is_error == 1"); +ok($log3->is_info(), "log3 is_info == 1"); +ok($log3->is_fatal(), "log3 is_fatal == 1"); +ok($log3->is_debug(), "log3 is_debug == 1"); + +ok($log2->is_error(), "log2 is_error == 1"); +ok(!$log2->is_info(), "log2 is_info == 0"); +ok($log2->is_fatal(), "log2 is_fatal == 1"); +ok(!$log2->is_debug(), "log2 is_debug == 0"); + +ok($log1->is_error(), "log1 is_error == 1"); +ok($log1->is_info(), "log1 is_info == 1"); +ok($log1->is_fatal(), "log1 is_fatal == 1"); +ok(!$log1->is_debug(), "log1 is_debug == 0"); + + + ################################################## + # Check log->(<level_const>,<msg>) + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($DEBUG); +$log2->level($ERROR); +$log3->level($INFO); + +$log1->log($DEBUG, "debug message"); +$log1->log($INFO, "info message "); + +$log2->log($DEBUG, "debug message"); +$log2->log($INFO, "info message "); + +$log3->log($DEBUG, "debug message"); +$log3->log($INFO, "info message "); + +ok($app->buffer() eq "DEBUG - debug message\nINFO - info message \n", + "app buffer contains DEBUG and INFO"); +ok($app2->buffer() eq "DEBUG - debug message\nINFO - info message \n", + "app2 buffer contains DEBUG"); +ok($app3->buffer() eq "INFO - info message \n", + "app3 buffer contains INFO"); + + ################################################## + # Check several messages concatenated + ################################################## +$app->buffer(""); + +$log1->level($DEBUG); + +$log1->log($DEBUG, "1", " ", "2", " "); +$log1->debug("3 ", "4 "); +$log1->info("5 ", "6 "); +$log1->warn("7 ", "8 "); +$log1->error("9 ", "10 "); +$log1->fatal("11 ", "12 ", "13 "); + +my $got = $app->buffer(); +my $expected = <<EOT; +DEBUG - 1 2 +DEBUG - 3 4 +INFO - 5 6 +WARN - 7 8 +ERROR - 9 10 +FATAL - 11 12 13 +EOT + +ok($got eq $expected) || print STDERR "got $got\n expected $expected"; + + +#ok($app->buffer() eq <<EOT, "app buffer six lines"); +#DEBUG - 1 2 +#DEBUG - 3 4 +#INFO - 5 6 +#WARN - 7 8 +#ERROR - 9 10 +#FATAL - 11 12 13 +#EOT + + ################################################## + # Check several messages concatenated + ################################################## +$app->buffer(""); + +$log1->level($DEBUG); + +$log1->log($DEBUG, sub { "1" . " " . "2" } ); +$log1->info( + sub { "3 " . "4 " }, # subroutine + # filter (throw out blanks) + { filter => sub { my $v = shift; + $v =~ s/\s+//g; + return $v; + }, + value => " 5 6 " }, + " 7" ); + +is($app->buffer(), <<EOT, "app buffer contains 2 lines"); +DEBUG - 1 2 +INFO - 3 4 56 7 +EOT + +# warn("app buffer is: ", $app->buffer(), "\n"); + +############################################################ +# testing multiple parameters, nested hashes +############################################################ + +our $stub_hook; + +# ----------------------------------- +# here/s a stub +package Log::Log4perl::AppenderTester; +sub new { + my($class, %params) = @_; + my $self = {}; + bless $self, $class; + + $self->{P} = \%params; + + $main::stub_hook = $self; + + return $self; +} +package main; +# ----------------------------------- + +$app = Log::Log4perl::Appender->new( + "Log::Log4perl::AppenderTester", + name => 'dumpy', + login => { hostname => 'a.jabber.server', + port => 5222, + username => "bugs", + password => "bunny", + resource => "logger" }, + to => [ 'elmer@a.jabber.server', 'sam@another.jabber.server' ], +); + +ok($stub_hook->{P}{login}{hostname}, 'a.jabber.server'); +ok($stub_hook->{P}{login}{password}, 'bunny'); +ok($stub_hook->{P}{to}[0], 'elmer@a.jabber.server'); +ok($stub_hook->{P}{to}[1], 'sam@another.jabber.server'); + +# ------------------------------------ +# Check if we get all appenders + +my $href = Log::Log4perl->appenders(); +my $result = ""; + +for(sort keys %$href) { + $result .= "$_ => " . ref($href->{$_}->{appender}); +} + +like($result, qr/(app\d+.*?Log::Log4perl::Appender::TestBuffer){3}/, + "all appenders"); + + +################################################## +# Bug reported by Brian Edwards: add_appender() +# with screen/file appender fails because of missing +# base class declaration +################################################## +my $log10 = Log::Log4perl->get_logger("xxx.yyy.zzz"); + +use Log::Log4perl::Appender::Screen; +use Log::Log4perl::Appender::File; + +my $app_screen = Log::Log4perl::Appender::Screen->new(); + +my $tmpfile = Log::Log4perl::Util::tmpfile_name(); +END { unlink $tmpfile if defined $tmpfile }; + +my $app_file = Log::Log4perl::Appender::File->new( + filename => $tmpfile +); + +eval { $log10->add_appender($app_file); }; +is($@, "", "Adding file appender"); +eval { $log10->add_appender($app_screen); }; +is($@, "", "Adding screen appender"); + diff --git a/t/003Layout-Rr.t b/t/003Layout-Rr.t new file mode 100644 index 0000000..ba2b564 --- /dev/null +++ b/t/003Layout-Rr.t @@ -0,0 +1,154 @@ +#!/usr/bin/perl + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use warnings; + +use Test::More tests => 2; +use File::Spec; + +use Log::Log4perl; +use Log::Log4perl::Layout::PatternLayout; +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +my ($SECONDS, $MICRO_SECONDS) = ($^T, 100_000); # Script's startup time +my $DEBUG = 0; + + +# Pretend that the script was at sleep +sub fake_sleep ($) { + my ($seconds) = @_; + $SECONDS += $seconds; + $MICRO_SECONDS = ($MICRO_SECONDS + 1_000) % 1_000_000; +} + +sub fake_time { + return ($SECONDS, $MICRO_SECONDS); +} + + + +my $logger = create_logger(); + + +# Start some logging +$logger->info("Start"); + +fake_sleep(1); +$logger->debug("Pause: 1 sec"); + +fake_sleep(2); +$logger->info("Pause: 2 secs"); + +fake_sleep(1); +$logger->debug("Pause: 1 sec"); + +$logger->warn("End"); + +# Debug traces to be turned on when troubleshooting +if ($DEBUG) { + # Get the contents of the buffers + foreach my $appender (qw(A B)) { + my $buffer = Log::Log4perl::Appender::TestBuffer->by_name($appender)->buffer(); + diag("========= $appender =========="); + diag($buffer); + } +} + +# Get the elapsed times so far +my @a = get_all_elapsed_ms('A'); +my @b = get_all_elapsed_ms('B'); + +is_deeply( + \@a, + [ + 'A 0ms Start [0ms]', + 'A 1001ms Pause: 1 sec [1001ms]', + 'A 2001ms Pause: 2 secs [3002ms]', + 'A 1001ms Pause: 1 sec [4003ms]', + 'A 0ms End [4003ms]', + ] +); + +is_deeply( + \@b, + [ + 'B 0ms Start [0ms]', + 'B 3002ms Pause: 2 secs [3002ms]', + 'B 1001ms End [4003ms]', + ] +); + + +# +# Returns the elapsed times logged so far. +# +sub get_all_elapsed_ms { + my ($categoty) = @_; + + return split /\n/, + Log::Log4perl::Appender::TestBuffer->by_name($categoty)->buffer() + ; +} + + +# +# Initialize the logging system with a twist. Here we inject our own time +# function into the appenders. This way we will be able to control time and +# ensure a deterministic behaviour that can always be reproduced which is ideal +# for unit tests. +# +# We need to create the appenders by hand in order to add a custom time +# function. The final outcome should be something similar to the following +# configuration: +# +# log4perl.logger.test = ALL, A, B +# +# log4perl.appender.A = Log::Log4perl::Appender::TestBuffer +# log4perl.appender.A.layout = Log::Log4perl::Layout::PatternLayout +# log4perl.appender.A.layout.ConversionPattern = A %Rms %m [%rms]%n +# log4perl.appender.A.Threshold = ALL +# +# log4perl.appender.B = Log::Log4perl::Appender::TestBuffer +# log4perl.appender.B.layout = Log::Log4perl::Layout::PatternLayout +# log4perl.appender.B.layout.ConversionPattern = B %Rms %m [%rms]%n +# log4perl.appender.B.Threshold = INFO +# +sub create_logger { + + my $logger = Log::Log4perl->get_logger("test"); + $logger->level($ALL); + + my %appenders = ( + A => $ALL, + B => $INFO, + ); + + # Inject the time function into the appenders + while (my ($name, $threshold) = each %appenders) { + my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => $name, + ); + if ($name eq 'B') { + $appender->threshold($INFO); + } + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + {time_function => \&fake_time}, + "$name %Rms %m [%rms]%n" + ); + $appender->layout($layout); + $logger->add_appender($appender); + } + + return $logger; +} + diff --git a/t/003Layout.t b/t/003Layout.t new file mode 100755 index 0000000..0b4db86 --- /dev/null +++ b/t/003Layout.t @@ -0,0 +1,285 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 24 }; + +use Log::Log4perl; +use Log::Log4perl::Layout; + +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +ok(1); # If we made it this far, we/re ok. + +my $logger = Log::Log4perl->get_logger("abc.def.ghi"); +$logger->level($DEBUG); +$logger->add_appender($app); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "bugo %% %c{2} %-17F{2} %L hugo"); +$app->layout($layout); +my $line = __LINE__ + 1; +$logger->debug("That's the message"); + +is($app->buffer(), "bugo % def.ghi " . + File::Spec->catfile(qw(t 003Layout.t)) . + " $line hugo"); + +############################################################ +# Log the message +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + "The message is here: %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "The message is here: That's the message"); + +############################################################ +# Log the time +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("[%r] %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +like($app->buffer(), qr/^\[\d+\] That's the message$/); + +############################################################ +# Log the date/time +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%d> %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +like($app->buffer(), + qr#^\d{4}/\d\d/\d\d \d\d:\d\d:\d\d> That\'s the message$#); + +############################################################ +# Log the date/time with own timer function +############################################################ +sub mytimer1 { + # 2 days after 1/1/1970 to compensate for time zones + return 180000; +} + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + { time_function => \&mytimer1 }, "%d{MM/yyyy}> %m"); +$app->layout($layout); +$logger->debug("That's the message"); +like($app->buffer(), qr{01/1970}); + + # epoch format +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + { time_function => \&mytimer1 }, "%d{e}> %m"); +$app->layout($layout); +$logger->debug("That's the message"); +like($app->buffer(), qr/^180000/); + +############################################################ +# Check SimpleLayout +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::SimpleLayout->new(); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "DEBUG - That\'s the message\n"); + +############################################################ +# Check depth level of %M - with debug(...) +############################################################ + +sub mysubroutine { + $app->buffer(""); + $layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); + $app->layout($layout); + $logger->debug("That's the message"); +} + +mysubroutine(); +is($app->buffer(), 'main::mysubroutine: That\'s the message'); + +############################################################ +# Check depth level of %M - with debug(...) +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), 'main::: That\'s the message'); + +############################################################ +# Check Filename and Line # +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%F-%L %m"); +$app->layout($layout); +$line = __LINE__ + 1; +$logger->debug("That's the message"); + +like($app->buffer(), qr/003Layout.t-$line That's the message/); + +############################################################ +# Don't append a newline if the message already contains one +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m%n"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +is($app->buffer(), "That\'s the message\n"); + +############################################################ +# But don't suppress other %ns +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("a%nb%n%m%n"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +is($app->buffer(), "a\nb\nThat\'s the message\n"); + +############################################################ +# Test if the process ID works +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%P:%m"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +like($app->buffer(), qr/^\d+:That's the message$/); + +############################################################ +# Test if the hostname placeholder %H works +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%H:%m"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +like($app->buffer(), qr/^[^:]+:That's the message$/); + +############################################################ +# Test max width in the format specifiers +############################################################ +#min width +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%5.5m"); +$app->layout($layout); +$logger->debug("123"); +is($app->buffer(), ' 123'); + +#max width +$app->buffer(""); +$logger->debug("1234567"); +is($app->buffer(), '12345'); + +#left justify +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%-5.5m"); +$app->layout($layout); +$logger->debug("123"); +is($app->buffer(), '123 '); + +############################################################ +# Check depth level of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +sub foo { + eval { + $logger->debug("Thats the message"); + }; +} +foo(); +is($app->buffer(), 'main::foo: Thats the message'); + +############################################################ +# Check two levels of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +sub foo2 { + eval { + eval { + $logger->debug("Thats the message"); + }; + }; +} +foo2(); +is($app->buffer(), 'main::foo2: Thats the message'); + +############################################################ +# Check depth level of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), 'main::: Thats the message'); + +############################################################ +# Non-portable line breaks +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m\\n"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), "Thats the message\n"); + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m\\r\\n"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), "Thats the message\r\n"); + +############################################################ +# Render a multiline message +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout::Multiline->new("%M: %m%n"); +$app->layout($layout); +eval { + $logger->debug("Thats the\nmultiline\nmessage"); +}; +is($app->buffer(), "main::: Thats the\nmain::: multiline\nmain::: message\n"); + diff --git a/t/004Config.t b/t/004Config.t new file mode 100644 index 0000000..9f1b615 --- /dev/null +++ b/t/004Config.t @@ -0,0 +1,406 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 28 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $TMP_FILE = File::Spec->catfile($EG_DIR, "warnings"); + +ok(1, "Startup"); # If we made it this far, we are ok. + +###################################################################### +# Test the root logger on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG N/A - Gurgel$#, "Root logger"); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo N/A - Gurgel$#, "Root logger inherited"); + +###################################################################### +# Test init with a string +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c - %m%n +EOT + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo - Gurgel$#, "Init via string"); + +###################################################################### +# Test init with a hashref +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +my %hash = ( + "log4j.rootLogger" => "DEBUG, A1", + "log4j.appender.A1" => "Log::Log4perl::Appender::TestBuffer", + "log4j.appender.A1.layout" => "org.apache.log4j.PatternLayout", + "log4j.appender.A1.layout.ConversionPattern" => + "%-4r [%t] %-5p %c - %m%n" + ); + +Log::Log4perl->init(\%hash); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo - Gurgel$#, "Init via hashref"); + + +############################################################ +# testing multiple parameters, nested hashes +############################################################ + +our $stub_hook; + +# ----------------------------------- +# here is a stub +package Log::Log4perl::AppenderTester; +sub new { + my($class, %params) = @_; + my $self = {}; + bless $self, $class; + + $self->{P} = \%params; + + $main::stub_hook = $self; + + return $self; +} +package main; +# ----------------------------------- + +Log::Log4perl->init(\ <<'EOT'); +#here is an example of using Log::Dispatch::Jabber + +log4j.category.animal.dog = INFO, jabbender + +log4j.appender.jabbender = Log::Log4perl::AppenderTester +log4j.appender.jabbender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.jabbender.login.hostname = a.jabber.server +log4j.appender.jabbender.login.port = 5222 +log4j.appender.jabbender.login.username = bugs +log4j.appender.jabbender.login.password = bunny +log4j.appender.jabbender.login.resource = logger +log4j.appender.jabbender.to = elmer@a.jabber.server +log4j.appender.jabbender.to = sam@another.jabber.server + +EOT + +#should produce this: +#{ +# login => { +# hostname => "a.jabber.server", +# password => "bunny", +# port => 5222, +# resource => "logger", +# username => "bugs", +# }, +# to => ["elmer\@a.jabber.server", "sam\@another.jabber.server"], +# }, + + +is($stub_hook->{P}{login}{hostname}, 'a.jabber.server', "Config and Jabber"); +is($stub_hook->{P}{login}{password}, 'bunny', "Config and Jabber"); +is($stub_hook->{P}{to}[0], 'elmer@a.jabber.server', "Config and Jabber"); +is($stub_hook->{P}{to}[1], 'sam@another.jabber.server', "Config and Jabber"); + +########################################################################## +# Test what happens if we define a PatternLayout without ConversionPattern +########################################################################## +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; + log4perl.logger.Twix.Bar = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + #log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT + +eval { Log::Log4perl->init(\$conf); }; + + +#actually, it turns out that log4j handles this, if no ConversionPattern +#specified is uses DEFAULT_LAYOUT_PATTERN, %m%n +#ok($@, '/No ConversionPattern given for PatternLayout/'); +is($@, '', 'PatternLayout without ConversionPattern'); + +###################################################################### +# Test with $/ set to undef +###################################################################### +$/ = undef; +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG N/A - Gurgel$#, "Config in slurp mode"); + +###################################################################### +# Test init with a config parser object +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +my $parser = Log::Log4perl::Config::PropertyConfigurator->new(); +my @lines = split "\n", <<EOT; +log4j.rootLogger = DEBUG, A1 +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +EOT +$parser->text(\@lines); + +Log::Log4perl->init($parser); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "objectGurgel\n", "Init with parser object"); + +###################################################################### +# Test integrity check +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return (scalar <IN>) || ''; } +END { close IN } + +Log::Log4perl->init(\ <<EOT); + # Just an empty configuration +EOT + +like(readwarn(), qr/looks suspicious: No loggers/, + "Test integrity check on empty conf file"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# Misspelled 'rootlogger' (needs to be rootLogger) +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <<EOT); + log4perl.rootlogger=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::Screen + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m %n +EOT + +is(readwarn(), "", "Autocorrecting rootLogger/rootlogger typo"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# Totally misspelled rootLogger +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <<EOT); + log4perl.schtonk=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::Screen + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m %n +EOT + +like(readwarn(), qr/looks suspicious: No loggers/, + "Test integrity check on totally misspelled rootLogger typo"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# PatternLayout %m{} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%M%m +EOT + +########################################### +sub somefunc { +########################################### + $logger = Log::Log4perl->get_logger("foo"); + $logger->debug("Gurgel"); +} + +package SomePackage; +########################################### +sub somepackagefunc { +########################################### + $logger = Log::Log4perl->get_logger("foo"); + $logger->debug("Gurgel"); +} +package main; + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "main::somefuncGurgel", "%M main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "SomePackage::somepackagefuncGurgel", "%M in package"); + +###################################################################### +# PatternLayout %m{1} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%M{1}%m +EOT + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "somefuncGurgel", "%M{1} main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "somepackagefuncGurgel", "%M{1} package"); + +###################################################################### +# PatternLayout %p{1} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=-%p{1}- %m +EOT + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "-D- Gurgel", "%p{1} main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "-D- Gurgel", "%p{1} package"); + +###################################################################### +# Test accessors +###################################################################### +$parser = Log::Log4perl::Config::PropertyConfigurator->new(); +@lines = split "\n", <<EOT; +log4j.rootLogger = DEBUG, A1 +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +EOT +$parser->text(\@lines); +$parser->parse(); +is($parser->value("log4j.rootLogger"), "DEBUG, A1", "value() accessor"); +is($parser->value("log4j.foobar"), undef, "value() accessor undef"); + +is($parser->value("log4j.appender.A1"), + "Log::Log4perl::Appender::TestBuffer", "value() accessor"); + +is($parser->value("log4perl.appender.A1.layout.ConversionPattern"), + "object%m%n", "value() accessor log4perl"); + +###################################################################### +# Test accessors +###################################################################### +my $conf = q{ +log4perl.category.pf.trigger = DEBUG +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +}; + +eval { Log::Log4perl->init( \$conf ); }; + +is $@, "", "'trigger' category [rt.cpan.org #50495]"; + +###################################################################### +# Test alternate comment syntax +###################################################################### + +$conf = <<'END_CONF'; +log4perl.MyParam = MyVal +; log4perl.MyParam = AnotherVal +END_CONF + +eval { Log::Log4perl->init( \$conf ); }; +is $@, "", "support semi-colon comment character [github.com #24]"; + +$conf = <<'END_CONF'; +log4perl.MyParam = MyVal +! log4perl.MyParam = AnotherVal +END_CONF + +eval { Log::Log4perl->init( \$conf ); }; +is $@, "", "support exclamation comment character [github.com #24]"; + diff --git a/t/005Config-Perl.t b/t/005Config-Perl.t new file mode 100644 index 0000000..88ac4fb --- /dev/null +++ b/t/005Config-Perl.t @@ -0,0 +1,58 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 3 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-perl.log"; +unlink $LOGFILE; + +Log::Log4perl->init(File::Spec->catfile($EG_DIR, 'log4j-file-append-perl.conf')); + +my $logger = Log::Log4perl->get_logger(""); +my $line = __LINE__ + 1; +$logger->debug("Gurgel"); + +open LOG, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = <LOG>; + +END { close LOG; unlink $LOGFILE; } + +is($data, "005Config-Perl.t $line DEBUG N/A - Gurgel\n"); + +############################################### +# Check reading a config file via a file handle +############################################### +Log::Log4perl->reset(); +open FILE, File::Spec->catfile($EG_DIR, 'log4j-file-append-perl.conf') or + die "cannot open log4j-file-append-perl.conf"; +Log::Log4perl->init(\*FILE); + +$logger = Log::Log4perl->get_logger(""); +$line = __LINE__ + 1; +$logger->debug("Gurgel"); + +$data = <LOG>; + +is($data, "005Config-Perl.t $line DEBUG N/A - Gurgel\n"); diff --git a/t/006Config-Java.t b/t/006Config-Java.t new file mode 100644 index 0000000..bf252fe --- /dev/null +++ b/t/006Config-Java.t @@ -0,0 +1,74 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 2; + } +}; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-java.log"; +unlink $LOGFILE; + +#Log::Log4perl->init( +# File::Spec->catfile($EG_DIR, 'log4j-file-append-java.conf')); +Log::Log4perl->init("$EG_DIR/log4j-file-append-java.conf"); + + +my $logger = Log::Log4perl->get_logger(""); +my $lines = (); +my $line = __LINE__ + 1; +push @lines, $line++; $logger->debug("Gurgel"); +push @lines, $line++; $logger->info("Gurgel"); +push @lines, $line++; $logger->warn("Gurgel"); +push @lines, $line++; $logger->error("Gurgel"); +push @lines, $line++; $logger->fatal("Gurgel"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = join '', <FILE>; +close FILE; + +my $file = "t/006Config-Java.t"; + +my $exp = <<EOT; +$file $lines[0] DEBUG N/A - Gurgel +$file $lines[1] INFO N/A - Gurgel +$file $lines[2] WARN N/A - Gurgel +$file $lines[3] ERROR N/A - Gurgel +$file $lines[4] FATAL N/A - Gurgel +EOT + + # Adapt Win32 paths +$data =~ s#\\#/#g; + +unlink $LOGFILE; +is($data, "$exp"); diff --git a/t/007LogPrio.t b/t/007LogPrio.t new file mode 100644 index 0000000..76834cd --- /dev/null +++ b/t/007LogPrio.t @@ -0,0 +1,67 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 2 }; + + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-perl2.log"; +unlink $LOGFILE; + +Log::Log4perl->init( \ <<EOT ); +log4j.rootLogger=DEBUG, LOGFILE + +log4j.appender.LOGFILE=Log::Log4perl::Appender::File +log4j.appender.LOGFILE.filename=$LOGFILE +log4j.appender.LOGFILE.mode=append + +log4j.appender.LOGFILE.layout=org.apache.log4j.PatternLayout +log4j.appender.LOGFILE.layout.ConversionPattern=%F{1} %L %p %t %c - %m%n +EOT + +my $logger = Log::Log4perl->get_logger(""); +my @lines = (); +my $line = __LINE__ + 1; +push @lines, $line++; $logger->debug("Gurgel"); +push @lines, $line++; $logger->info("Gurgel"); +push @lines, $line++; $logger->warn("Gurgel"); +push @lines, $line++; $logger->error("Gurgel"); +push @lines, $line++; $logger->fatal("Gurgel"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = join '', <FILE>; +close FILE; + +my $file = "007LogPrio.t"; + +my $exp = <<EOT; +$file $lines[0] DEBUG N/A - Gurgel +$file $lines[1] INFO N/A - Gurgel +$file $lines[2] WARN N/A - Gurgel +$file $lines[3] ERROR N/A - Gurgel +$file $lines[4] FATAL N/A - Gurgel +EOT + +unlink $LOGFILE; +ok($data, "$exp"); diff --git a/t/008ConfCat.t b/t/008ConfCat.t new file mode 100644 index 0000000..98afbca --- /dev/null +++ b/t/008ConfCat.t @@ -0,0 +1,56 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 3 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $date_regex = qr(\d{4}/\d\d/\d\d \d\d:\d\d:\d\d); + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Test a 'foo.bar.baz' logger which inherits level from foo.bar +# and calls both "foo.bar" and "root" appenders with their respective +# formats +# on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-2.conf"); + +my $logger = Log::Log4perl->get_logger("foo.bar.baz"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "m#$date_regex \\[N/A\\] DEBUG foo.bar.baz - Gurgel#"); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl->reset(); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-2.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "m#$date_regex \\[N/A\\] DEBUG foo - Gurgel#"); diff --git a/t/009Deuce.t b/t/009Deuce.t new file mode 100644 index 0000000..b8116ac --- /dev/null +++ b/t/009Deuce.t @@ -0,0 +1,55 @@ +########################################### +# Test Suite for Log::Log4perl +# Test two appenders in one category +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 5 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Test the root logger on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-3.conf"); + +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("stdout")->buffer(), + 'm#^\S+\s+\[N/A\] \(\S+?:\d+\) - Gurgel$#'); +ok(Log::Log4perl::Appender::TestBuffer->by_name("R")->buffer(), + 'm#^\S+\s+N/A\s+\'\' - Gurgel$#'); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl->reset(); +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-3.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("stdout")->buffer(), + 'm#^\S+\s+\[N/A\] \(\S+?:\d+\) - Gurgel$#'); +ok(Log::Log4perl::Appender::TestBuffer->by_name("R")->buffer(), + 'm#^\S+\s+N/A \'foo\' - Gurgel$#'); diff --git a/t/010JConsole.t b/t/010JConsole.t new file mode 100644 index 0000000..532cf47 --- /dev/null +++ b/t/010JConsole.t @@ -0,0 +1,93 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::Appender::File; +use File::Spec; +use Test::More; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles $test_logfile); +$test_logfile = File::Spec->catfile($WORK_DIR,'test1.log'); +@outfiles = ($test_logfile,); +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.ConsoleAppender +log4j.appender.myAppender.Target=System.out +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +#hmm, I wonder how portable this is, maybe check $^O first? +use vars qw($OLDOUT); #for -w +open(OLDOUT, ">&STDOUT"); +open (TOUCH, ">>$test_logfile");# `touch $test_logfile`; +close TOUCH; +open(STDOUT, ">$test_logfile") || die "Can't redirect stdout $test_logfile $!"; +select(STDOUT); $| = 1; # make unbuffered + + + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + + +close(STDOUT); +open(STDOUT, ">&OLDOUT"); + + +my ($result, $expected); + +$expected = <<EOL; +INFO cat1 - info message 1 +WARN cat1 - warning message 1 +FATAL cat1 - fatal message 1 +EOL + +{local $/ = undef; + open (F, "$test_logfile") || die $!; + $result = <F>; + close F; +} +is ($result, $expected); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + diff --git a/t/011JFile.t b/t/011JFile.t new file mode 100644 index 0000000..869102a --- /dev/null +++ b/t/011JFile.t @@ -0,0 +1,77 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles $test_logfile); +$test_logfile = File::Spec->catfile($WORK_DIR, 'test2.log'); +@outfiles = ($test_logfile); +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.FileAppender +log4j.appender.myAppender.File=$test_logfile +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + + +my ($result, $expected); + +$expected = <<EOL; +INFO cat1 - info message 1 +WARN cat1 - warning message 1 +FATAL cat1 - fatal message 1 +EOL + +{local $/ = undef; + open (F, "$test_logfile") || die $!; + $result = <F>; + close F; +} +is ($result, $expected); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + diff --git a/t/012Deeper.t b/t/012Deeper.t new file mode 100644 index 0000000..a3a9557 --- /dev/null +++ b/t/012Deeper.t @@ -0,0 +1,212 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 3; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); +my $today = sprintf("%4.4d%2.2d%2.2d",$year+1900, $mon+1, $mday); +use vars qw($logfile1 $logfile6 $logfile7); +$logfile1 = File::Spec->catfile(qw(t tmp deeper1.log)); +$logfile6 = File::Spec->catfile(qw(t tmp deeper6.log)); +$logfile7 = File::Spec->catfile(qw(t tmp deeper7.log)); +our @outfiles = ($logfile1, $logfile6, $logfile7); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $config = <<EOL; +#specify LOGLEVEL, appender1, appender2, ... +log4j.category.plant = INFO, FileAppndr1 +log4j.category.animal = INFO, FileAppndr1 +log4j.category.animal.dog = DEBUG, FileAppndr1 + +log4j.oneMessagePerAppender = 1 + + +# --------------------------------------------- +# FileAppndr1 +log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender +log4j.appender.FileAppndr1.File = $logfile1 + +log4j.appender.FileAppndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.FileAppndr1.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + + +# --------------------------------------------------- +#2nd set of tests,inheritance +log4j.category.a = INFO, l2 +log4j.category.a.b.c.d = WARN, l2 + +log4j.appender.l2 = org.apache.log4j.FileAppender +log4j.appender.l2.File = $logfile6 +log4j.appender.l2.layout = org.apache.log4j.PatternLayout +log4j.appender.l2.layout.ConversionPattern=%d %4r [%t] %-5p %c - %m%n + + +# -------------------------------------- +#inheritance the other way +log4j.category.xa = WARN, l3 +log4j.category.xa.b.c.d = INFO, l3 + +log4j.appender.l3 = org.apache.log4j.FileAppender +log4j.appender.l3.File = $logfile7 +log4j.appender.l3.layout= org.apache.log4j.PatternLayout +log4j.appender.l3.layout.ConversionPattern=%d %4r 666 [%t] %-5p %c - %m%n + +EOL + + +Log::Log4perl->init(\$config); + + +# ----------------------------------------------------- +# (1) shotgun test +#set to INFO + +my $logger = Log::Log4perl->get_logger('plant'); + +#set to INFO +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + +#set to DEBUG +my $doglogger = Log::Log4perl->get_logger('animal.dog'); +$doglogger->debug("debugging message 2 "); +$doglogger->info("info message 2 "); +$doglogger->warn("warning message 2 "); +$doglogger->fatal("fatal message 2 "); + +#set to INFO +my $animallogger = Log::Log4perl->get_logger('animal'); +$animallogger->debug("debugging message 3 "); +$animallogger->info("info message 3 "); +$animallogger->warn("warning message 3 "); +$animallogger->fatal("fatal message 3 "); + +#should default to animal::dog +my $deeptreelogger = Log::Log4perl->get_logger('animal.dog.leg.toenail'); +$deeptreelogger->debug("debug message"); +$animallogger->info("info message"); +$deeptreelogger->warn("warning message"); +$animallogger->fatal("fatal message"); + +my ($result, $expected); + +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper1.expected))) || die $!; + $expected = <F>; + open (F, $logfile1) || die $!; + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is ($result, $expected); + + +# ------------------------------------ +# (6) test inheritance +#a=INFO, a.b.c.d=WARN, a.b and a.b.c are undefined +my $la = Log::Log4perl->get_logger('a'); +my $lab = Log::Log4perl->get_logger('a.b'); +my $labc = Log::Log4perl->get_logger('a.b.c'); +my $labcd = Log::Log4perl->get_logger('a.b.c.d'); +my $labcde = Log::Log4perl->get_logger('a.b.c.d.e'); + +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->debug("should not print"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->info("should print for a, a.b, a.b.c"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->warn("should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->fatal("should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e"); +} +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper6.expected))); + $expected = <F>; + open (F, $logfile6); + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is($result, $expected); + + +# ------------------------------------ +# (7) test inheritance the other way +#xa=WARN, xa.b.c.d=INFO, xa.b and xa.b.c are undefined +my $xla = Log::Log4perl->get_logger('xa'); +my $xlab = Log::Log4perl->get_logger('xa.b'); +my $xlabc = Log::Log4perl->get_logger('xa.b.c'); +my $xlabcd = Log::Log4perl->get_logger('xa.b.c.d'); +my $xlabcde = Log::Log4perl->get_logger('xa.b.c.d.e'); + +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->debug("should not print"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->info("should print for xa.b.c.d, xa.b.c.d.e"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->warn("should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->fatal("should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e"); +} +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper7.expected))); + $expected = <F>; + open (F, $logfile7); + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is($result, $expected); + + + +END{ + foreach my $f (@outfiles){ + unlink $f if (-e $f); + } +} diff --git a/t/013Bench.t b/t/013Bench.t new file mode 100644 index 0000000..a37267a --- /dev/null +++ b/t/013Bench.t @@ -0,0 +1,144 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; +use Benchmark qw/timeit timestr/; +use Log::Log4perl; + +$count = 100_000; + +unless ($ENV{LOG4PERL_BENCH}) { + print "set \$ENV{LOG4PERL_BENCH} to a true value to run benchmarks, skipping...\n"; + ok(1); + exit; +} + +$conf = <<EOL; + +#specify LOGLEVEL, appender1, appender2, ... +log4j.category.simplelayout = INFO, simpleLayoutAppndr + +log4j.category.patternlayout = INFO, PatternLayoutAppndr + +log4j.category.multiappender = INFO, PatternLayoutAppndr, 2ndPatternLayoutAppndr, +log4j.category.multiappender.c1 = INFO, 3rdPatternLayoutAppndr +log4j.category.multiappender.c1.c2 = INFO, 2ndPatternLayoutAppndr + + + +# --------------------------------------------- +# PatternLayoutAppndr +log4j.appender.PatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.PatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.PatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + +# --------------------------------------------- +# 2ndPatternLayoutAppndr +log4j.appender.2ndPatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.2ndPatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.2ndPatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + +# --------------------------------------------- +# 3rdPatternLayoutAppndr +log4j.appender.3rdPatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.3rdPatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.3rdPatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + + +# --------------------------------------------- +# a SimpleLayout +log4j.appender.simpleLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.simpleLayoutAppndr.layout = org.apache.log4j.SimpleLayout + + + + +EOL + +Log::Log4perl::init(\$conf); + +$simplelayout = Log::Log4perl->get_logger('simplelayout'); + +$basecategory = Log::Log4perl->get_logger('patternlayout'); + +$firstlevelcategory = Log::Log4perl->get_logger('patternlayout.foo'); + +$secondlevelcategory = Log::Log4perl->get_logger('patternlayout.foo.bar'); + +print "Iterations: $count\n\n"; + + +print "Just is_debug/info/warn/error/fatal() methods: \n"; +$t = timeit $count, sub{my $v = $basecategory->is_debug(); + $v = $basecategory->is_info(); + $v = $basecategory->is_warn(); + $v = $basecategory->is_error(); + $v = $basecategory->is_fatal(); + }; +print timestr($t),"\n\n"; + +print "no logging: \n"; +$t = timeit $count, sub{$basecategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "a simple layout: \n"; +$t = timeit $count, sub{$simplelayout->info('info message')}; +print timestr($t),"\n\n"; + +print "pattern layout: \n"; +$t = timeit $count, sub {$basecategory->info('info message')}; +print timestr($t),"\n\n"; + +print "one level inheritance, no logging: \n"; +$t = timeit $count, sub {$firstlevelcategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "one level inheritance, logging: \n"; +$t = timeit $count, sub {$firstlevelcategory->info('info message')}; +print timestr($t),"\n\n"; + +print "two level inheritance, no logging: \n"; +$t = timeit $count, sub {$secondlevelcategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "two level inheritance, logging \n"; +$t = timeit $count, sub {$secondlevelcategory->info('info message')}; +print timestr($t),"\n\n"; + +#free up some memory? +undef($basecategory); +undef ($firstlevelcategory); +undef($secondlevelcategory); + + +$multi1 = Log::Log4perl->get_logger('multiappender'); +$multi2 = Log::Log4perl->get_logger('multiappender.c1'); +$multi3 = Log::Log4perl->get_logger('multiappender.c1.c2'); + +print "two appenders: \n"; +$t = timeit $count, sub {$multi1->info('info message')}; +print timestr($t),"\n\n"; + +print "three appenders, one level of inheritance: \n"; +$t = timeit $count, sub {$multi2->info('info message')}; +print timestr($t),"\n\n"; + +print "same appenders, two levels of inheritance: \n"; +$t = timeit $count, sub {$multi3->info('info message')}; +print timestr($t),"\n\n"; + + + + + + +print + + +ok(1); + +BEGIN { plan tests => 1, } diff --git a/t/014ConfErrs.t b/t/014ConfErrs.t new file mode 100644 index 0000000..2e431d0 --- /dev/null +++ b/t/014ConfErrs.t @@ -0,0 +1,252 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; + +$testfile = 't/tmp/test12.log'; + +unlink $testfile if (-e $testfile); + +# ***************************************************** +# nonexistent appender class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppenderx +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::FileAppenderx'/); + + +# ***************************************************** +# nonexistent layout class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayoutx +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayoutx' failed/); + +# ***************************************************** +# nonexistent appender class containing a ';' +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer; +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::TestBuffer;'/); + +# ***************************************************** +# nonexistent layout class containing a ';' +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout; +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayout;' failed/); + +# ***************************************************** +# Relative Layout class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; + # It's supposed to find it. +is($@, '', 'relative layout class'); + +# ***************************************************** +# bad priority +$conf = <<EOL; +log4j.category.simplelayout.test=xxINFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, qr/level 'xxINFO' is not a valid error level/); + +# ***************************************************** +# nonsense conf file 1 +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::Screen +log4j.appender.myAppender.nolayout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/Layout not specified for appender myAppender at/, + "nonsense conf file 1"); + +# ***************************************************** +# nonsense conf file 2 +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppender +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender = $testfile +EOL + +eval{ + + Log::Log4perl->init(\$conf); + +}; +like($@, qr/log4j.appender.myAppender redefined/); + + + +# ***************************************************** +# never define an appender +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, XXmyAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, + qr/ERROR: you didn't tell me how to implement your appender 'XXmyAppender'/); + + +# ***************************************************** +# never define a layout +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer + +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, qr/Layout not specified for appender myAppender/, 'no layout defined'); + + +# ************************************ +# check continuation chars, this should parse fine +$conf = <<EOL; +log4j.category.simplelayout.test=\\ + INFO, \\ + myAppender + +log4j.appender.myAppender \\ + = Log::Log4perl::Appender::TestBuffer + #this is stupid, I know +log4j.appender.myAppender.layout = Log::Log4perl::Lay\\ + out::SimpleL\\ + ayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +is($@,""); + +# ***************************************************** +# init_once +# ***************************************************** +Log::Log4perl->reset(); +$conf = <<EOL; +log4perl.category = INFO, myAppender + +log4perl.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4perl.appender.myAppender.layout = SimpleLayout +EOL + +Log::Log4perl->init_once(\$conf); +my $logger = Log::Log4perl::get_logger(""); +$logger->error("foobar"); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +#print "BUFFER: [", $buffer->buffer(), "]\n"; +is($buffer->buffer(),"ERROR - foobar\n"); + +$conf = <<EOL; +log4perl.category = FATAL, myAppender + +log4perl.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4perl.appender.myAppender.layout = SimpleLayout +EOL + + # change config, call init_once(), which should ignore the new + # settings. +$buffer->buffer(""); +Log::Log4perl->init_once(\$conf); +$logger = Log::Log4perl::get_logger(""); +$logger->error("foobar"); +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +#print "BUFFER: [", $buffer->buffer(), "]\n"; +is($buffer->buffer(),"ERROR - foobar\n"); + +$conf = <<EOL; +log4perl.logger.Foo.Bar = INFO, Screen +log4perl.logger.Foo.Bar = INFO, Screen +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = SimpleLayout +EOL +eval { + Log::Log4perl::init( \$conf ); +}; +like($@, qr/log4perl.logger.Foo.Bar redefined/); + +BEGIN { plan tests => 14, } + +END{ + unlink $testfile if (-e $testfile); +} + diff --git a/t/015fltmsg.t b/t/015fltmsg.t new file mode 100644 index 0000000..928403f --- /dev/null +++ b/t/015fltmsg.t @@ -0,0 +1,120 @@ +########################################### +# Test Suite for Log::Log4perl +# warp_message cases +# Mike Schilli, 2003 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More tests => 5; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +###################################################################### +# warp_message undef: Concatenation +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m%n +EOT + +my $app = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "Chunk1Chunk2Chunk3\n", "warp_message undef"); + +###################################################################### +# warp_message undef: Concatenation plus JOIN_MSG_ARRAY_CHAR +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m%n +EOT + +$Log::Log4perl::JOIN_MSG_ARRAY_CHAR = "bang!"; + +$app = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "Chunk1bang!Chunk2bang!Chunk3\n", + "warp_message undef (JOIN_MSG_ARRAY_CHAR)"); + +$Log::Log4perl::JOIN_MSG_ARRAY_CHAR = ""; # back to default + +###################################################################### +# warp_message 0 +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message=0 +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "[Chunk1,Chunk2,Chunk3]", + "warp_message 0 (NoopLayout)"); + +###################################################################### +# warp_message = code ref +###################################################################### +Log::Log4perl->init( \ <<'EOT' ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message = sub { $#_ = 2 if @_ > 3; \ + return @_; } +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3", "Chunk4"); + +is($app->buffer(), "[Chunk1,Chunk2,Chunk3]", + "warp_message = function (by cref)"); + + +###################################################################### +# warp_message = function +###################################################################### +my $COUNTER = 0; +sub warp_my_message { + my @chunks = @_; + unshift @chunks, ++$COUNTER; + return @chunks; +} + +Log::Log4perl->init( \ <<'EOT' ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message = main::warp_my_message +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "[1,Chunk1,Chunk2,Chunk3]", + "warp_message = function (by name)"); diff --git a/t/016Export.t b/t/016Export.t new file mode 100644 index 0000000..89fa5da --- /dev/null +++ b/t/016Export.t @@ -0,0 +1,140 @@ +########################################### +# Test Suite for Log::Log4perl +# Test all shortcuts (exported symbols) +# +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Log::Log4perl::Appender::TestBuffer; + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 16 }; + +use Log::Log4perl qw(get_logger :levels); + +ok(1); + +ok(Log::Log4perl::Level::isGreaterOrEqual($DEBUG, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($INFO, $WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($WARN, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($ERROR, $FATAL)); + +################################################## +# Init logger +################################################## +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => "A1"); +my $logger = get_logger("abc.def"); +$logger->add_appender($app); +$logger->level($DEBUG); + + # Let the next logger assume the default category, + # which defaults to the current package, which + # is 'main' in this case. +my $logger_main = get_logger(); +$logger_main->add_appender($app); +$logger_main->level($DEBUG); +ok(2); + +################################################## +# Use logger +################################################## +my $log2 = get_logger("abc.def"); +$log2->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use other logger +################################################## +my $log3 = get_logger("main"); +$log3->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use main logger +################################################## +my $log4 = get_logger("main"); +$log4->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use other logger +################################################## +my $log5 = get_logger("main"); +$log5->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log6 = get_logger(); +$log6->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log7 = Log::Log4perl->get_logger(); +$log7->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log8 = Log::Log4perl::get_logger(); +$log8->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Remove appender +################################################## +$logger->remove_appender("A1"); +$logger_main->remove_appender("A1"); +$log8->debug("Is this it?"); + +$app = Log::Log4perl->appenders()->{"A1"}; + +ok($app->buffer(), ""); +$app->buffer(""); + +################################################## +# Eradicate appender +################################################## +$Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGE = ""; +Log::Log4perl->eradicate_appender("A1"); +ok($Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGE, "", + "destroy message before"); + +undef $app; + # Special for TestBuffer: remove circ ref +delete ${Log::Log4perl::Appender::TestBuffer::POPULATION}{A1}; + +ok($Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGES, + "Log::Log4perl::Appender::TestBuffer destroyed", + "destroy message after destruction"); diff --git a/t/017Watch.t b/t/017Watch.t new file mode 100644 index 0000000..beffdb3 --- /dev/null +++ b/t/017Watch.t @@ -0,0 +1,391 @@ +#testing init_and_watch + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; + +sub trunc { + open FILE, ">$_[0]" or die "Cannot open $_[0]"; + close FILE; +} + +sub is_like_windows { + if( $^O eq "MSWin32" or + $^O eq "cygwin" ) { + return 1; + } + + return 0; +} + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 34; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} + +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfile = File::Spec->catfile($WORK_DIR, "test17.log"); +my $testfile2 = File::Spec->catfile($WORK_DIR, "test17b.log"); +my $testconf = File::Spec->catfile($WORK_DIR, "test17.conf"); + +END { + unlink $testfile if (-e $testfile); + unlink $testfile2 if (-e $testfile2); + unlink $testconf if (-e $testconf); + rmdir $WORK_DIR; +} + +trunc($testfile); +trunc($testconf); + +my $conf1 = <<EOL; +log4j.category.animal.dog = INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +Log::Log4perl->init_and_watch($testconf, 1); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('debug message'); +$logger->info('info message'); + +ok(! $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +# ********************************************************************* +# Check if we really dont re-read the conf file if nothing has changed +# ********************************************************************* + +my $how_many_reads = $Log::Log4perl::Config::CONFIG_FILE_READS; +print "sleeping for 2 secs\n"; +sleep 2; +$logger->is_debug(); +is($how_many_reads, $Log::Log4perl::Config::CONFIG_FILE_READS, + "no re-read until config has changed"); + + # Need to sleep for at least a sec, otherwise the watcher + # wont check +print "sleeping for 2 secs\n"; +sleep 2; + +# ********************************************************************* +# Now, lets check what happens if the config changes +# ********************************************************************* + +my $conf2 = <<EOL; +log4j.category.animal.dog = DEBUG, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n + +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append +EOL + +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf2; +close CONF; + +$logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('2nd debug message'); +is($Log::Log4perl::Config::CONFIG_FILE_READS, + $how_many_reads + 1, + "re-read if config has changed, even if no logger has fired"); + +$logger->info('2nd info message'); +print "sleeping for 2 secs\n"; +sleep 2; +$logger->info('2nd info message again'); + +is($Log::Log4perl::Config::CONFIG_FILE_READS, + $how_many_reads + 1, + "no re-read unless config has changed"); + +open (LOG, $testfile) or die "can't open $testfile $!"; +my @log = <LOG>; +close LOG; +my $log = join('',@log); + +is($log, "INFO - info message\nDEBUG animal.dog - 2nd debug message\nINFO animal.dog - 2nd info message\nINFO animal.dog - 2nd info message again\n", "1st init"); +ok( $logger->is_debug(), "is_debug - false"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +# *************************************************************** +# do it 3rd time + +print "sleeping for 2 secs\n"; +sleep 2; + +$conf2 = <<EOL; +log4j.category.animal.dog = INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf2; +close CONF; + +$logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('2nd debug message'); +$logger->info('3rd info message'); + +ok(! $logger->is_debug(), "is_debug - false"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +open (LOG, $testfile) or die "can't open $testfile $!"; +@log = <LOG>; +close LOG; +$log = join('',@log); + +is($log, "INFO - info message\nDEBUG animal.dog - 2nd debug message\nINFO animal.dog - 2nd info message\nINFO animal.dog - 2nd info message again\nINFO - 3rd info message\n", "after reload"); + +SKIP: { + skip "Signal handling not supported on Win32", 2 if is_like_windows(); + # *************************************************************** + # Check the 'recreate' feature + + trunc($testfile); + my $conf4 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 0 + log4j.appender.myAppender.mode = append +EOL + + Log::Log4perl->init(\$conf4); + + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test1\n", "Before recreate"); + close LOG; + + unlink $testfile or die "Cannot unlink $testfile: $!"; + $logger->info("test2"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test2\n", "After recreate"); + close LOG; + + trunc($testfile); + trunc($testconf); +}; + + +# *************************************************************** +# Check the 'recreate' feature with signal handling + +SKIP: { + skip "File recreation not supported on Win32", 9 if is_like_windows(); + + # Use two appenders to confirm that both files are recreated when the + # signal is received, rather than just whichever watcher was created + # last. + + my $conf5 = <<EOL; + log4j.category.animal.dog = INFO, myAppender1 + log4j.category.animal.cat = INFO, myAppender2 + + log4j.appender.myAppender1 = Log::Log4perl::Appender::File + log4j.appender.myAppender1.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender1.filename = $testfile + log4j.appender.myAppender1.recreate = 1 + log4j.appender.myAppender1.recreate_check_signal = USR1 + + log4j.appender.myAppender2 = Log::Log4perl::Appender::File + log4j.appender.myAppender2.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender2.filename = $testfile2 + log4j.appender.myAppender2.recreate = 1 + log4j.appender.myAppender2.recreate_check_signal = USR1 +EOL + + Log::Log4perl->init(\$conf5); + + my $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + ok(-f $testfile, "recreate_signal - testfile created"); + + my $logger2 = Log::Log4perl::get_logger('animal.cat'); + $logger2->info("test1"); + ok(-f $testfile2, "recreate_signal - testfile created"); + + + unlink $testfile, $testfile2; + ok(!-f $testfile, "recreate_signal - testfile deleted"); + ok(!-f $testfile2, "recreate_signal - testfile2 deleted"); + + $logger->info("test1"); + $logger2->info("test1"); + ok(!-f $testfile, "recreate_signal - testfile still missing"); + ok(!-f $testfile2, "recreate_signal - testfile2 still missing"); + + ok(kill('USR1', $$), "sending signal"); + $logger->info("test1"); + $logger2->info("test1"); + ok(-f $testfile, "recreate_signal - testfile reinstated"); + ok(-f $testfile2, "recreate_signal - testfile2 reinstated"); +}; + + +SKIP: { + skip "Removing busy files not supported on Win32", 1 if is_like_windows(); + + # *************************************************************** + # Check the 'recreate' feature with check_interval + + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + # ... and immediately remove it + unlink $testfile or die "cannot remove file $testfile ($!)"; + + print "sleeping for 2 secs\n"; + sleep(2); + + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test1\n", "recreate before first write"); + close LOG; +} + +# *************************************************************** +# Check the 'recreate' feature with check_interval (2nd write) + +SKIP: { + skip "Signal handling not supported on Win32", 1 if is_like_windows(); + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + + # Write to it + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + + # ... remove it (stupid windoze cannot remove an open file) + rename $testfile, "$testfile.old"; + unlink $testfile; + + print "sleeping for 2 secs\n"; + sleep(2); + + # ... write again + $logger->info("test2"); + + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test2\n", "recreate before 2nd write"); + close LOG; + unlink "$testfile.old"; +}; + +# *************************************************************** +# Check the 'recreate' feature with moved/recreated file + +SKIP: { + skip "Moving busy files not supported on Win32", 1 if is_like_windows(); + + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + + # Get a logger, but dont write to it + $logger = Log::Log4perl::get_logger('animal.dog'); + + rename "$testfile", "$testfile.old" or die "Cannot rename ($!)"; + # recreate it + trunc($testfile); + + print "sleeping for 2 secs\n"; + sleep(2); + + # ... write to (hopefully) truncated file + $logger->info("test3"); + + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test3\n", "log to externally recreated file"); + close LOG; + + unlink "$testfile.old"; +}; diff --git a/t/018Init.t b/t/018Init.t new file mode 100644 index 0000000..3c5e23f --- /dev/null +++ b/t/018Init.t @@ -0,0 +1,70 @@ +#Testing double-init + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfilea = File::Spec->catfile(qw(t tmp test18a.log)); +unlink $testfilea if (-e $testfilea); + +my $testfileb = File::Spec->catfile(qw(t tmp test18b.log)); +unlink $testfileb if (-e $testfileb); + +BEGIN {plan tests => 2} +END { unlink $testfilea; + unlink $testfileb; + } + +#################################################### +# Double-Init, 2nd time with different log file name +#################################################### +my $data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfilea +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +my $log = Log::Log4perl::get_logger(""); + +$log->info("Shu-wa-chi!"); + +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfileb +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(); + +$log->info("Shu-wa-chi!"); + +# Check if both files contain one message each +for my $file ($testfilea, $testfileb) { + open FILE, "<$file" or die "Cannot open $file"; + my $content = join '', <FILE>; + close FILE; + ok($content, "INFO - Shu-wa-chi!\n"); +} diff --git a/t/019Warn.t b/t/019Warn.t new file mode 100644 index 0000000..d710140 --- /dev/null +++ b/t/019Warn.t @@ -0,0 +1,75 @@ +# Check if warnings are issued for weirdo configurations + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; +use Log::Log4perl; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp warnings)); +$TMP_FILE = "tmp/warnings" if ! -d "t"; + +BEGIN { plan tests => 2 } +END { close IN; + unlink $TMP_FILE; + } + +ok(1); # Initialized ok + +# Capture STDERR to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return scalar <IN>; } + +############################################################ +# Get a logger and use it without having called init() first +############################################################ +my $log = Log::Log4perl::get_logger("abc.def"); +$log->debug("hey there"); + +my $warn = readwarn(); +#print "'$warn'\n"; + +ok($warn, 'm#Forgot#'); + +__END__ + +############################################################ +# Check for single \'s on line ends -- they need to be +# \\ for perl to recognize it. But how? Perl swallows it. +############################################################ +my $conf = <<EOL; +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c %t - %m%n +log4j.category.simplelayout.test=INFO, \ + myAppender +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppenderx +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = abc +EOL + +Log::Log4perl->init(\$conf); + +my $err = readwarn(); + +ok($err, 'm#single \\#i'); + +print "$conf\n"; diff --git a/t/020Easy.t b/t/020Easy.t new file mode 100644 index 0000000..5b61f5a --- /dev/null +++ b/t/020Easy.t @@ -0,0 +1,235 @@ +# Tests for the lazy man:s logger with easy_init() + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(:easy); +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp easy)); +$TMP_FILE = "tmp/easy" if ! -d "t"; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 21; + } +} + +END { unlink $TMP_FILE; + close IN; + } + +ok(1); # Initialized ok +unlink $TMP_FILE; + +# Capture STDOUT to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readstderr { return join("", <IN>); } + +############################################################ +# Typical easy setup +############################################################ +Log::Log4perl->easy_init($INFO); +my $log = get_logger(); +$log->debug("We don't want to see this"); +$log->info("But this we want to see"); +$log->error("And this also"); +my $stderr = readstderr(); +#print "STDERR='$stderr'\n"; + +unlike($stderr, qr/don't/); +like($stderr, qr/this we want/); +like($stderr, qr/this also/); + +############################################################ +# Advanced easy setup +############################################################ +Log::Log4perl->reset(); +close IN; + # Reopen stderr +open STDERR, ">&1"; +unlink $TMP_FILE; + +package Bar::Twix; +use Log::Log4perl qw(:easy); +sub crunch { DEBUG("Twix Not shown"); + ERROR("Twix mjam"); } + +package Bar::Mars; +use Log::Log4perl qw(:easy); +my $line = __LINE__ + 1; +sub crunch { ERROR("Mars mjam"); + INFO("Mars not shown"); } +package main; + +Log::Log4perl->easy_init( + { level => $INFO, + category => "Bar::Twix", + file => ">>$TMP_FILE", + layout => '%m%n', + }, + { level => $WARN, + category => "Bar::Mars", + file => ">>$TMP_FILE", + layout => '%F{1}-%L-%M: %m%n', + }, +); + +Bar::Mars::crunch(); +Bar::Twix::crunch(); + +open FILE, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +my $data = join '', <FILE>; +close FILE; + +is($data, "020Easy.t-$line-Bar::Mars::crunch: Mars mjam\nTwix mjam\n"); + +############################################################ +# LOGDIE and LOGWARN +############################################################ +# redir STDERR again +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->easy_init($INFO); +$log = get_logger(); +$line = __LINE__ + 1; +eval { LOGDIE("logdie"); }; + +like($@, qr/logdie at .*?020Easy.t line $line/); +like(readstderr(), qr/^[\d:\/ ]+logdie$/m); + +LOGWARN("logwarn"); +like(readstderr(), qr/logwarn/); + +############################################################ +# Test logdie/logwarn with and without "\n"s +############################################################ +LOGWARN("message"); +like(readstderr(), qr/message at .*? line \d+/); + +LOGWARN("message\n"); +unlike(readstderr(), qr/message at .*? line \d+/); + +LOGWARN("message\nother"); +like(readstderr(), qr/other at .*? line \d+/); + +LOGWARN("message\nother\n"); +unlike(readstderr(), qr/other at .*? line \d+/); + + # logdie +eval { LOGDIE("logdie"); }; +like($@, qr/logdie at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\n"); }; +unlike($@, qr/at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\nother"); }; +like($@, qr/other at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\nother\n"); }; +unlike($@, qr/at .*?020Easy.t line \d+/); + +############################################################ +# Test %T stack traces +############################################################ +Log::Log4perl->easy_init({ level => $INFO, layout => "%T: %m%n"}); + +sub foo { + bar(); +} + +sub bar { + my $log = get_logger(); + $log->info("info!"); +} + +foo(); +like(readstderr(), qr(main::bar.*?main::foo)); +close IN; + +############################################################ +# LOGCARP and LOGCROAK +############################################################ +# redir STDERR again +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +package Whack; +use Log::Log4perl qw(:easy); +sub whack { + LOGCROAK("logcroak in whack"); +} + +package main; + +Log::Log4perl->easy_init($INFO); +$log = get_logger(); +$line = __LINE__ + 1; +eval { Whack::whack() }; + +like($@, qr/logcroak in whack at .*?020Easy.t line $line/); +like(readstderr(), qr/^[\d:\/ ]+logcroak in whack.*$line/m); + +$line = __LINE__ + 8; +package Junk1; +use Log::Log4perl qw(:easy); +sub foo { + LOGCARP("LOGCARP"); +} +package Junk2; +sub foo { + Junk1::foo(); +} +package main; +Junk2::foo(); +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + like(readstderr(), qr/LOGCARP.*020Easy.t line $line/); +} + +############################################################ +# LOGDIE and wrapper packages +############################################################ +package JunkWrapper; +use Log::Log4perl qw(:easy); +sub foo { + LOGDIE("Ahhh"); +} + +package main; + +Log::Log4perl->wrapper_register("JunkWrapper"); +$line = __LINE__ + 2; +eval { + JunkWrapper::foo(); +}; +like $@, qr/line $line/, "logdie with wrapper"; + +# Finally close +############################################################ +close IN; diff --git a/t/020Easy2.t b/t/020Easy2.t new file mode 100644 index 0000000..abaf450 --- /dev/null +++ b/t/020Easy2.t @@ -0,0 +1,63 @@ +########################################### +# 020Easy2.t - more Easy tests +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Log::Log4perl::Appender::TestBuffer; + +my $stderr = ""; + +$SIG{__WARN__} = sub { + #print "warn: <$_[0]>\n"; + $stderr .= $_[0]; +}; + +use Test::More tests => 3; + +use Log::Log4perl qw(:easy); + +Log::Log4perl->init(\ q{ +log4perl.category.Bar.Twix = WARN, Term +log4perl.appender.Term = Log::Log4perl::Appender::Screen +log4perl.appender.Term.layout = Log::Log4perl::Layout::SimpleLayout +}); + + # This case caused a warning L4p 0.47 +INFO "Boo!"; + +is($stderr, "", "no warning"); + +# Test new level TRACE + +Log::Log4perl->init(\ q{ +log4perl.category = TRACE, Buf +log4perl.appender.Buf = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buf.layout = Log::Log4perl::Layout::SimpleLayout +}); + +my $appenders = Log::Log4perl->appenders(); +my $bufapp = Log::Log4perl::Appender::TestBuffer->by_name("Buf"); + +TRACE("foobar"); +is($bufapp->buffer(), "TRACE - foobar\n", "TRACE check"); + +Log::Log4perl->init(\ q{ +log4perl.category = DEBUG, Buf +log4perl.appender.Buf = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buf.layout = Log::Log4perl::Layout::SimpleLayout +}); +$bufapp = Log::Log4perl::Appender::TestBuffer->by_name("Buf"); + +my $log = Log::Log4perl::get_logger(""); +$log->trace("We don't want to see this"); +is($bufapp->buffer(), "", "Suppressed trace() check"); + diff --git a/t/021AppThres.t b/t/021AppThres.t new file mode 100644 index 0000000..492c4c4 --- /dev/null +++ b/t/021AppThres.t @@ -0,0 +1,240 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; + +BEGIN { plan tests => 24 } + +ok(1); # If we made it this far, we're ok. + +cmp_ok(Log::Log4perl->appender_thresholds_adjust(1), q{==}, 0, + q{Expect 0 appenders to be affected before first init since there are none} +); + +my $log0 = Log::Log4perl->get_logger(""); +my $log1 = Log::Log4perl->get_logger("abc.def"); +my $log2 = Log::Log4perl->get_logger("abc.def.ghi"); + +$log0->level($DEBUG); +$log1->level($DEBUG); +$log2->level($DEBUG); + +my $app0 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +my $app1 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +$app0->threshold($ERROR); # As integer value +$app1->threshold("WARN"); # As string + +$log0->add_appender($app0); +$log1->add_appender($app1); + +################################################## +# Root logger's appender +################################################## +$app0->buffer(""); +$app1->buffer(""); +$log0->warn("Don't want to see this"); +$log0->error("Yeah, log0"); + +is($app0->buffer(), "ERROR - Yeah, log0\n", "Threshold ERROR"); +is($app1->buffer(), "", "Threshold WARN"); + +################################################## +# Inherited appender +################################################## +my $ret; + +$app0->buffer(""); +$app1->buffer(""); + +$ret = $log1->info("Don't want to see this"); +is($ret, 0, "Info suppressed"); + +$ret = $log1->warn("Yeah, log1"); +is($ret, 1, "inherited"); + +is($app0->buffer(), "", "inherited"); +is($app1->buffer(), "WARN - Yeah, log1\n", "inherited"); + +################################################## +# Inherited appender over two hierarchies +################################################## +$app0->buffer(""); +$app1->buffer(""); +$log2->info("Don't want to see this"); +$log2->error("Yeah, log2"); + +is($app0->buffer(), "ERROR - Yeah, log2\n", "two hierarchies"); +is($app1->buffer(), "ERROR - Yeah, log2\n", "two hierarchies"); + +################################################## +# Appender threshold with config file +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ERROR, BUF0 +log4perl.logger.a = INFO, BUF1 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF0.Threshold = ERROR +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF1.Threshold = WARN +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +is($app0->buffer(), "ERROR - Yeah, loga\n", "appender threshold"); +is($app1->buffer(), "ERROR - Yeah, loga\n", "appender threshold"); + +################################################## +# Appender threshold with config file and a Java +# Class +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4j.logger = ERROR, BUF0 +log4j.logger.a = INFO, BUF1 +log4j.appender.BUF0 = org.apache.log4j.TestBuffer +log4j.appender.BUF0.layout = SimpleLayout +log4j.appender.BUF0.Threshold = ERROR +log4j.appender.BUF1 = org.apache.log4j.TestBuffer +log4j.appender.BUF1.layout = SimpleLayout +log4j.appender.BUF1.Threshold = WARN +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +is($app0->buffer(), "ERROR - Yeah, loga\n", "threshold/java"); +is($app1->buffer(), "ERROR - Yeah, loga\n", "threshold/java"); + +################################################## +# 'threshold' vs. 'Threshold' +################################################## +$conf = <<EOT; +log4j.logger = ERROR, BUF0 +log4j.logger.a = INFO, BUF1 +log4j.appender.BUF0 = org.apache.log4j.TestBuffer +log4j.appender.BUF0.layout = SimpleLayout +log4j.appender.BUF0.Threshold = ERROR +log4j.appender.BUF1 = org.apache.log4j.TestBuffer +log4j.appender.BUF1.layout = SimpleLayout +log4j.appender.BUF1.threshold = WARN +EOT + +eval { Log::Log4perl::init(\$conf); }; + +if($@) { + like($@, qr/perhaps you meant 'Threshold'/, + "warn on misspelled 'threshold'"); +} else { + ok(0, "Abort on misspelled 'threshold'"); +} + +################################################## +# Increase threshold of all appenders +################################################## +$conf = <<EOT; +log4perl.category = WARN, BUF0, BUF1 + +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF0.layout = SimpleLayout + +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.Threshold = ERROR +log4perl.appender.BUF1.layout = SimpleLayout +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $logger = get_logger(""); + +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "WARN - Warning\nERROR - Error\n", "appender threshold"); +is($app1->buffer(), "ERROR - Error\n", "appender threshold"); + +cmp_ok(Log::Log4perl->appender_thresholds_adjust(-1), + q{==}, 2, q{Expect 2 appenders to be affected}); + +$app0->buffer(""); +$app1->buffer(""); + +$logger->more_logging(); +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "INFO - Info\nWARN - Warning\nERROR - Error\n", + "adjusted appender threshold"); +is($app1->buffer(), "WARN - Warning\nERROR - Error\n", + "appender threshold"); + +$app0->buffer(""); +$app1->buffer(""); + + # reset previous thresholds +cmp_ok(Log::Log4perl->appender_thresholds_adjust(1), + q{==}, 2, q{Expect 2 appenders to be affected}); + +$app0->buffer(""); +$app1->buffer(""); + + # rig just one threshold +cmp_ok(Log::Log4perl->appender_thresholds_adjust(-1, ['BUF0']), + q{==}, 1, q{Expect 1 appender to be affected}); + +$logger->more_logging(); +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "INFO - Info\nWARN - Warning\nERROR - Error\n", + "adjusted appender threshold"); +is($app1->buffer(), "ERROR - Error\n", + "appender threshold"); + diff --git a/t/022Wrap.t b/t/022Wrap.t new file mode 100644 index 0000000..e9aa76f --- /dev/null +++ b/t/022Wrap.t @@ -0,0 +1,131 @@ +########################################### +# Tests for Log4perl used by a wrapper class +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use File::Basename; + +BEGIN { plan tests => 5 } + +################################################## +package Wrapper::Log4perl; + +use Log::Log4perl; +use Log::Log4perl::Level; + +our @ISA = qw(Log::Log4perl); + +sub get_logger { + # This is highly stupid (object duplication) and definitely not what we + # want anybody to do, but just to have a test case for a logger in a + # wrapper package + return Wrapper::Log4perl::Logger->new(@_); +} + +################################################## +package Wrapper::Log4perl::Logger; +Log::Log4perl->wrapper_register(__PACKAGE__); +sub new { + my $real_logger = Log::Log4perl::get_logger(@_); + bless { real_logger => $real_logger }, $_[0]; +} +sub AUTOLOAD { + no strict; + my $self = shift; + $AUTOLOAD =~ s/.*:://; + $self->{real_logger}->$AUTOLOAD(@_); +} +sub DESTROY {} + +################################################## +package main; + +use Log::Log4perl; +local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; +use Log::Log4perl::Level; + +my $log0 = Wrapper::Log4perl->get_logger(""); +$log0->level($DEBUG); + +my $app0 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "File: %F{1} Line number: %L package: %C trace: %T"); +$app0->layout($layout); +$log0->add_appender($app0); + +################################################## +my $rootlogger = Wrapper::Log4perl->get_logger(""); +my $line = __LINE__ + 1; +$rootlogger->debug("Hello"); + +my $buf = $app0->buffer(); +$buf =~ s#(\S+022Wrap\.t)#basename( $1 )#eg; + +# [rt 74836] Carp.pm added a dot at the end with 1.25. +# Be dot-agnostic. +$buf =~ s/\.$//; + +is($buf, + "File: 022Wrap.t Line number: $line package: main " . + "trace: at 022Wrap.t line $line", + "appender check"); + + # with the new wrapper_register in Log4perl 1.29, this will even work + # *without* modifying caller_depth +$Log::Log4perl::caller_depth--; +$app0->buffer(""); +$line = __LINE__ + 1; +$rootlogger->debug("Hello"); + + # Win32 +# [rt 74836] Carp.pm added a dot at the end with 1.25. +# Be dot-agnostic. +$buf = $app0->buffer(); +$buf =~ s/\.$//; +$buf =~ s#(\S+022Wrap\.t)#basename( $1 )#eg; + +is($buf, + "File: 022Wrap.t Line number: $line package: main " . + "trace: at 022Wrap.t line $line", + "appender check"); + +################################################## +package L4p::Wrapper; +Log::Log4perl->wrapper_register(__PACKAGE__); +no strict qw(refs); +*get_logger = sub { + + my @args = @_; + + if(defined $args[0] and $args[0] eq __PACKAGE__) { + $args[0] =~ s/__PACKAGE__/Log::Log4perl/g; + } + Log::Log4perl::get_logger( @args ); +}; + +package main; + +my $logger = L4p::Wrapper::get_logger(); +is $logger->{category}, "main", "cat on () is main"; + +$logger = L4p::Wrapper::get_logger(__PACKAGE__); +is $logger->{category}, "main", "cat on (__PACKAGE__) is main"; + +$logger = L4p::Wrapper->get_logger(); +is $logger->{category}, "main", "cat on ->() is main"; + +# use Data::Dumper; +# print Dumper($logger); diff --git a/t/023Date.t b/t/023Date.t new file mode 100755 index 0000000..8779fad --- /dev/null +++ b/t/023Date.t @@ -0,0 +1,184 @@ +########################################### +# Tests for Log4perl::DateFormat +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 36 } + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::DateFormat; +use Log::Log4perl::Appender::TestBuffer; + +$Log::Log4perl::DateFormat::GMTIME = 1; + +my $GMTIME = 1030429942 - 7*3600; + +########################################### +# Year +########################################### +my $formatter = Log::Log4perl::DateFormat->new("yyyy yy yyyy"); +is($formatter->format($GMTIME), "2002 02 2002"); + +########################################### +# Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("MM M MMMM yyyy"); +is($formatter->format($GMTIME), "08 8 August 2002"); + +########################################### +# Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("MMM yyyy"); +is($formatter->format($GMTIME), "Aug 2002"); + +########################################### +# Day-of-Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("d ddd dd dddd yyyy"); +is($formatter->format($GMTIME), "26 026 26 0026 2002"); + +########################################### +# am/pm Hour +########################################### +$formatter = Log::Log4perl::DateFormat->new("h hh hhh hhhh"); +is($formatter->format($GMTIME), "11 11 011 0011"); + +########################################### +# 24 Hour +########################################### +$formatter = Log::Log4perl::DateFormat->new("H HH HHH HHHH"); +is($formatter->format($GMTIME), "23 23 023 0023"); + +########################################### +# Minute +########################################### +$formatter = Log::Log4perl::DateFormat->new("m mm mmm mmmm"); +is($formatter->format($GMTIME), "32 32 032 0032"); + +########################################### +# Second +########################################### +$formatter = Log::Log4perl::DateFormat->new("s ss sss ssss"); +is($formatter->format($GMTIME), "22 22 022 0022"); + +########################################### +# Day of Week +########################################### +$formatter = Log::Log4perl::DateFormat->new("E EE EEE EEEE"); +is($formatter->format($GMTIME), "Mon Mon Mon Monday"); +is($formatter->format($GMTIME+24*60*60*1), "Tue Tue Tue Tuesday"); +is($formatter->format($GMTIME+24*60*60*2), "Wed Wed Wed Wednesday"); +is($formatter->format($GMTIME+24*60*60*3), "Thu Thu Thu Thursday"); +is($formatter->format($GMTIME+24*60*60*4), "Fri Fri Fri Friday"); +is($formatter->format($GMTIME+24*60*60*5), "Sat Sat Sat Saturday"); +is($formatter->format($GMTIME+24*60*60*6), "Sun Sun Sun Sunday"); + +########################################### +# Day of Year +########################################### +$formatter = Log::Log4perl::DateFormat->new("D DD DDD DDDD"); +is($formatter->format($GMTIME), "238 238 238 0238"); + +########################################### +# AM/PM +########################################### +$formatter = Log::Log4perl::DateFormat->new("a aa"); +is($formatter->format($GMTIME), "PM PM"); + +########################################### +# Milliseconds +########################################### +$formatter = Log::Log4perl::DateFormat->new("S SS SSS SSSS SSSSS SSSSSS"); +is($formatter->format($GMTIME, 123456), "1 12 123 1234 12345 123456"); + +########################################### +# Predefined formats +########################################### +$formatter = Log::Log4perl::DateFormat->new("DATE"); +is($formatter->format($GMTIME, 123456), "26 Aug 2002 23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("ISO8601"); +is($formatter->format($GMTIME, 123456), "2002-08-26 23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("ABSOLUTE"); +is($formatter->format($GMTIME, 123456), "23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("APACHE"); +is($formatter->format($GMTIME, 123456), "[Mon Aug 26 23:32:22 2002]"); + +########################################### +# Unknown +########################################### +$formatter = Log::Log4perl::DateFormat->new("xx K"); +is($formatter->format($GMTIME), "xx -- 'K' not (yet) implemented --"); + +########################################### +# DDD bugfix +########################################### +$formatter = Log::Log4perl::DateFormat->new("DDD"); + # 1/1/2006 +is($formatter->format(1136106000), "001"); +$formatter = Log::Log4perl::DateFormat->new("D"); + # 1/1/2006 +is($formatter->format(1136106000), "1"); + +########################################### +# In conjunction with Log4perl +########################################### +my $conf = q( +log4perl.category.Bar.Twix = WARN, Buffer +log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buffer.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.Buffer.layout.ConversionPattern = %d{HH:mm:ss} %p %m %n +); + +Log::Log4perl::init(\$conf); + +my $logger = get_logger("Bar::Twix"); +$logger->error("Blah"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("Buffer")->buffer(), + qr/\d\d:\d\d:\d\d ERROR Blah/); + +########################################### +# Allowing literal text in L4p >= 1.19 +########################################### +my @tests = ( + q!yyyy-MM-dd'T'HH:mm:ss.SSS'Z'! => q!%04d-%02d-%02dT%02d:%02d:%02d.%sZ!, + q!yyyy-MM-dd''HH:mm:ss.SSS''! => q!%04d-%02d-%02d%02d:%02d:%02d.%s!, + q!yyyy-MM-dd''''HH:mm:ss.SSS! => q!%04d-%02d-%02d'%02d:%02d:%02d.%s!, + q!yyyy-MM-dd''''''HH:mm:ss.SSS! => q!%04d-%02d-%02d''%02d:%02d:%02d.%s!, + q!yyyy-MM-dd,HH:mm:ss.SSS! => q!%04d-%02d-%02d,%02d:%02d:%02d.%s!, + q!HH:mm:ss,SSS! => q!%02d:%02d:%02d,%s!, + q!dd MMM yyyy HH:mm:ss,SSS! => q!%02d %.3s %04d %02d:%02d:%02d,%s!, + q!hh 'o''clock' a! => q!%02d o'clock %1s!, + q!hh 'o'clock' a! => q!(undef)!, + q!yyyy-MM-dd 'at' HH:mm:ss! => q!%04d-%02d-%02d at %02d:%02d:%02d!, +); + +#' calm down up vim syntax highlighting + +while ( my ( $src, $expected ) = splice @tests, 0, 2 ) { + my $df = eval { Log::Log4perl::DateFormat->new( $src ) }; + my $err = ''; + if ( $@ ) + { + chomp $@; + $err = "(error: $@)"; + } + my $got = $df->{fmt} || '(undef)'; + is($got, $expected, "literal $src"); +} diff --git a/t/024WarnDieCarp.t b/t/024WarnDieCarp.t new file mode 100755 index 0000000..21ced8b --- /dev/null +++ b/t/024WarnDieCarp.t @@ -0,0 +1,404 @@ +#!/usr/bin/perl + +# $Id: 024WarnDieCarp.t,v 1.1 2002/08/29 05:33:28 mschilli Exp $ + +# Check the various logFOO for FOO in {die, warn, Carp*} + +# note: I <erik@selberg.com> prefer Test::Simple to just Test. + +###################################################################### +# +# This is a fairly simply smoketest... it basically runs the gamut of +# the warn / die / croak / cluck / confess / carp family and makes sure +# that the log output contained the appropriate string and STDERR +# contains the appropriate string. +# +###################################################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(get_logger :easy); +use Log::Log4perl::Level; +use File::Spec; use Data::Dumper; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 73; + } +} + +my $warnstr; + +# this nullifies warns and dies here... so testing the testscript may suck. +local $SIG{__WARN__} = sub { $warnstr = join("", @_); }; +local $SIG{__DIE__} = sub { $warnstr = join("", @_); }; + +sub warndietest { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + like($warnstr, qr/$out_str/, + "$mname($in_str): STDERR contains \"$out_str\""); + like($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer contains \"$out_str\""); + $app->buffer(""); +} + +# same as above, just look for no output +sub warndietest_nooutput { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + unlike($warnstr, qr/\Q$out_str\E/, + "$mname($in_str): STDERR does NOT contain \"$out_str\""); + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\""); +} + +# warn() still prints to stderr, but nothing gets logged +sub warndietest_stderronly { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + my($pkg, $file, $line) = caller(); + + # it's in stderr + like($warnstr, qr/\Q$out_str\E/, + "$mname($in_str): STDERR does contain \"$out_str\" ($file:$line)"); + # but not logged by log4perl + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\" ($file:$line)"); +} + +# same as above, just look for no output in buffer, but output in STDERR +sub dietest_nooutput { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + like($warnstr, qr/$out_str/, "$mname($in_str): STDERR contains \"$out_str\""); + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\""); +} + + +ok(1, "Initialized OK"); + +############################################################ +# Get a logger and use it without having called init() first +############################################################ +my $log = Log::Log4perl::get_logger("abc.def"); +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +$log->add_appender($app); + +###################################################################### +# lets start testing! + +$log->level($DEBUG); + +my $test = 1; + +###################################################################### +# sanity: make sure the tests spit out FOO to the buffer and STDERR + +foreach my $f ("logwarn", "logdie", "logcarp", "logcroak", "logcluck", + "logconfess", "error_warn", "error_die") { + warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# change the log level to ERROR... warns should produce nothing in +# log4perl now, but logwarn still triggers warn() + +$log->level($ERROR); + +foreach my $f ("logdie", "logcroak", + "logconfess", "error_warn", "error_die") { + warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +foreach my $f ("logwarn", "logcarp", "logcluck", + ) { + warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# change logging to OFF... FATALs still produce output though. + +$log->level($OFF); # $OFF == $FATAL... although I suspect thats a bug in the log4j spec + +foreach my $f ("logwarn", "logcarp", "logcluck", "error_warn") { + warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +foreach my $f ("error_die", "logdie", "logcroak", "logconfess") { + dietest_nooutput(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# Check if logdie %F%L lists the right file/line +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m +EOT + +my $logger = get_logger("Twix::Bar"); + +my $line_number = __LINE__ + 1; +eval { $logger->logdie("Log and die!"); }; + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +# print "Buffer: ", $app0->buffer(), "\n"; + +like($app0->buffer(), qr/024WarnDieCarp.t-$line_number: Log and die!/, + "%F-%L adjustment"); + +###################################################################### +# Check if logcarp/cluck/croak are reporting the calling package, +# not the one the error happened in. +###################################################################### +$app0->buffer(""); + +package Weirdo; +our $foo_line; +our $bar_line; + +use Log::Log4perl qw(get_logger); +sub foo { + my $logger = get_logger("Twix::Bar"); + $foo_line = __LINE__ + 1; + $logger->logcroak("Inferno!"); +} +sub bar { + my $logger = get_logger("Twix::Bar"); + $bar_line = __LINE__ + 1; + $logger->logdie("Inferno!"); +} + +package main; +eval { Weirdo::foo(); }; + +like($app0->buffer(), qr/$Weirdo::foo_line/, + "Check logcroak/Carp"); + +$app0->buffer(""); +eval { Weirdo::bar(); }; + +like($app0->buffer(), qr/$Weirdo::bar_line/, + "Check logdie"); + +###################################################################### +# Check if logcarp/cluck/croak are reporting the calling package, +# when they are more than one hierarchy from the top. +###################################################################### +$app0->buffer(""); + +package Foo; +our $foo_line; +use Log::Log4perl qw(get_logger); +sub foo { + my $logger = get_logger("Twix::Bar"); + $foo_line = __LINE__ + 1; + $logger->logcarp("Inferno!"); +} + +package Bar; +sub bar { + Foo::foo(); +} + +package main; +eval { Bar::bar(); }; + +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + like($app0->buffer(), qr/$Foo::foo_line/, + "Check logcarp"); +} + +###################################################################### +# Test fix of bug that had logwarn/die/etc print unformatted messages. +###################################################################### +$logger = get_logger("Twix::Bar"); +$log->level($DEBUG); + +eval { $logger->logdie(sub { "a" . "-" . "b" }); }; +like($@, qr/a-b/, "bugfix: logdie with sub{} as argument"); + +$logger->logwarn(sub { "a" . "-" . "b" }); +like($warnstr, qr/a-b/, "bugfix: logwarn with sub{} as argument"); + +$logger->logwarn({ filter => \&Dumper, + value => "a-b" }); +like($warnstr, qr/a-b/, "bugfix: logwarn with sub{filter/value} as argument"); + +eval { $logger->logcroak({ filter => \&Dumper, + value => "a-b" }); }; +like($warnstr, qr/a-b/, "bugfix: logcroak with sub{} as argument"); + +###################################################################### +# logcroak/cluck/carp/confess level test +###################################################################### +our($carp_line, $call_line); + +package Foo1; +use Log::Log4perl qw(:easy); +sub foo { get_logger("Twix::Bar")->logcarp("foocarp"); $carp_line = __LINE__ } + +package Bar1; +sub bar { Foo1::foo(); $call_line = __LINE__; } + +package main; + +my $l4p_app = $Log::Log4perl::Logger::APPENDER_BY_NAME{"A1"}; +my $layout = Log::Log4perl::Layout::PatternLayout->new("%M#%L %m%n"); +$l4p_app->layout($layout); + +$app0->buffer(""); +Foo1::foo(); $call_line = __LINE__; + # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 +like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, + "carp in subfunction"); + # foocarp at 024WarnDieCarp.t line 250 +like($warnstr, qr/foocarp.*line $call_line/, "carp output"); + +$app0->buffer(""); +Bar1::bar(); + +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + + # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 + like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, + "carp in sub-sub-function"); +} + + # foocarp at 024WarnDieCarp.t line 250 +like($warnstr, qr/foocarp.*line $call_line/, "carp output"); + +###################################################################### +# logconfess fix (1.12) +###################################################################### +$app0->buffer(""); + +package Foo1; +sub new { + my($class) = @_; + bless {}, $class; +} + +sub foo1 { + my $log = get_logger(); + $log->logconfess("bah!"); +} + +package main; + +my $foo = Foo1->new(); +eval { $foo->foo1() }; + +like $@, qr/024WarnDieCarp.*Foo1::foo1.*eval/s, "Confess logs correct frame"; + +###################################################################### +# logdie/warn caller level bug +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m +EOT + +$logger = get_logger("Twix::Bar"); + +$logger->logwarn("warn!"); +like $warnstr, qr/024WarnDieCarp/, "logwarn() caller depth bug"; +unlike $warnstr, qr/Logger.pm/, "logwarn() caller depth bug"; + +$Log::Log4perl::Logger::DIE_DEBUG = 1; +$logger->logdie("die!"); +like $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/024WarnDieCarp/, + "logdie() caller depth bug"; +unlike $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/Logger.pm/, + "logdie() caller depth bug"; + +my $app3 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +$app3->buffer(""); + +my $line1 = __LINE__ + 1; +subroutine(); + +my $line2; +sub subroutine { + $line2 = __LINE__ + 1; + $logger->logcluck("cluck!"); +} + +like $app3->buffer(), qr/-$line2: cluck!/, "logcluck()"; +like $app3->buffer(), qr/main::subroutine\(\) called .* line $line1/, + "logcluck()"; + +# Carp test + +$app3->buffer(""); +my $line3 = __LINE__ + 1; +subroutine_carp(); + +my $line4; +sub subroutine_carp { + $line4 = __LINE__ + 1; + $logger->logcarp("carp!"); +} + +like $app3->buffer(), qr/-$line4: carp!/, "logcarp()"; +like $app3->buffer(), qr/main::subroutine_carp\(\) called .* line $line3/, + "logcarp()"; + +# Stringify test +$Log::Log4perl::Logger::DIE_DEBUG = 0; +$Log::Log4perl::STRINGIFY_DIE_MESSAGE = 0; + +eval { + $logger->logcroak( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "croak without stringify"; + +eval { + $logger->logconfess( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "confess without stringify"; + +eval { + $logger->logdie( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "die without stringify"; diff --git a/t/025CustLevels.t b/t/025CustLevels.t new file mode 100644 index 0000000..8bf8036 --- /dev/null +++ b/t/025CustLevels.t @@ -0,0 +1,208 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Erik Selberg, (c) 2002 erik@selberg.com +# clone of 025CustLevels.t but uses nicer method (?) we hope +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; + +#create a custom level "LITEWARN" +use Log::Log4perl; +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +# use strict; + + +ok(1); # If we made it this far, we're ok. + +Log::Log4perl::Logger::create_custom_level("LITEWARN", "WARN"); +#testing for bugfix of 9/19/03 before which custom levels beneath DEBUG didn't work +Log::Log4perl::Logger::create_custom_level("DEBUG2", "DEBUG"); + +# test insane creation of levels + +foreach (1 .. 14) { + ok(Log::Log4perl::Logger::create_custom_level("TEST$_", "INFO"), 0); +} + +# 15th should fail.. this assumes that each level is 10000 apart from +# the other. + +ok(!defined eval { Log::Log4perl::Logger::create_custom_level("TEST15", "INFO") }); + +# now, by re-arranging (as we whine about in create_custom_levels), we +# should be able to get 15. + +my %btree = ( + 8 => "DEBUG", + 4 => 8, + 2 => 4, + 1 => 2, + 3 => 4, + 6 => 8, + 5 => 6, + 7 => 8, + 12 => "DEBUG", + 10 => 12, + 9 => 10, + 11 => 12, + 14 => "DEBUG", + 13 => 14, + 15 => "DEBUG", + ); + +foreach (8, 4, 2, 1, 3, 6, 5, 7, 12, 10, 9, 11, 14, 13, 15) { + my $level = $btree{$_} eq "DEBUG" ? "DEBUG" : "BTREE$btree{$_}"; +# warn("Creating BTREE$_ after $level"); + ok(Log::Log4perl::Logger::create_custom_level("BTREE$_", $level), 0); +# warn("BTREE$_ is ", ${Log::Log4perl::Level::PRIORITY{"BTREE$_"}}); +} + +# foreach (1 .. 15) { +# warn("BTREE$_ is: ", ${Log::Log4perl::Level::PRIORITY{"BTREE$_"}}); +# } + + +my $LOGFILE = "example$$.log"; +unlink $LOGFILE; + +my $config = <<EOT; +log4j.category = LITEWARN, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $LOGFILE +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.debug2test = DEBUG2, FileAppndr +log4j.additivity.debug2test= 0 +EOT + + +Log::Log4perl::init(\$config); + + +# can't create a custom level after init... let's test that. Just look +# for an undef (i.e. failure) from the eval + +ok(!defined eval { Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN"); }); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); +$logger->warn("this is a warning message"); +$logger->litewarn("this is a LITE warning message (2/3 the calories)"); +$logger->info("this info message should not log"); + + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +my $data = <FILE>; +close FILE; +my $result1 = "WARN - this is a warning message\nLITEWARN - this is a LITE warning message (2/3 the calories)\n"; +ok($data, $result1); + +# ********************* +# check the root logger +my $rootlogger = Log::Log4perl->get_logger(""); +$logger->warn("this is a rootlevel warning message"); +$logger->litewarn("this is a rootlevel LITE warning message (2/3 the calories)"); +$logger->info("this rootlevel info message should not log"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result2 = "WARN - this is a rootlevel warning message\nLITEWARN - this is a rootlevel LITE warning message (2/3 the calories)\n"; +ok($data, "$result1$result2"); + +$logger->log($WARN, "a warning message"); +$logger->log($LITEWARN, "a LITE warning message"); +die("lame hack to suppress warning") if ($LITEWARN != $LITEWARN); +$logger->log($DEBUG, "an info message, should not log"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result3 = "WARN - a warning message\nLITEWARN - a LITE warning message\n"; +ok($data, "$result1$result2$result3"); + +# ********************* +# check debug2 level +my $debug2 = Log::Log4perl->get_logger("debug2test"); +$debug2->debug2("this is a debug2 message"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result4 = "DEBUG2 - this is a debug2 message\n"; +ok($data, "$result1$result2$result3$result4"); + +#********************* +#check the is_* methods +ok($logger->is_warn); +ok($logger->is_litewarn); +ok(! $logger->is_info); + + +# warn("Testing inc_level()"); + +#*************************** +#increase/decrease leves +$logger->inc_level(1); #bump up from litewarn to warn +# warn("level is now: ", $logger->level()); +ok($logger->is_warn); +ok(!$logger->is_litewarn); +ok(!$logger->is_info); +$logger->warn("after bumping, warning message"); +$logger->litewarn("after bumping, lite warning message, should not log"); +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result5 = "WARN - after bumping, warning message\n"; +ok($data, "$result1$result2$result3$result4$result5"); + +$logger->dec_level(2); #bump down from warn to litewarn to info + +ok($logger->is_warn); +ok($logger->is_litewarn); +ok($logger->is_info); + +ok(! $logger->is_debug) ; + +$logger->level($FATAL); + +ok($logger->is_fatal() && !($logger->is_error() || $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +$logger->more_logging(); # should inc one level + +ok($logger->is_fatal() && $logger->is_error() && !( $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +$logger->more_logging(100); # should be debug now + +ok($logger->is_fatal() && $logger->is_error() && $logger->is_warn() && + $logger->is_info() && $logger->is_debug()); + +$logger->less_logging(150); # should be OFF now + +ok(!($logger->is_fatal() || $logger->is_error() || $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +BEGIN { plan tests => 51 }; + +unlink $LOGFILE; diff --git a/t/026FileApp.t b/t/026FileApp.t new file mode 100644 index 0000000..b3ae4f4 --- /dev/null +++ b/t/026FileApp.t @@ -0,0 +1,494 @@ +#Testing if the file-appender appends in default mode + +END { + # Must be before enabling the Log4Perl stuff, or file will still + # be open and locked (under Win32) on program close. + + unlink_testfiles(); + } + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; +use File::Path qw(remove_tree); + +our $LOG_DISPATCH_PRESENT; + +BEGIN { + eval { require Log::Dispatch; }; + if(! $@) { + $LOG_DISPATCH_PRESENT = 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfile = File::Spec->catfile($WORK_DIR, "test26.log"); +my $testpath = File::Spec->catfile($WORK_DIR, "test26"); + +BEGIN {plan tests => 26} + +sub unlink_testfiles { + unlink $testfile; + unlink "${testfile}_1"; + unlink "${testfile}_2"; + unlink "${testfile}_3"; + unlink "${testfile}_4"; + unlink "${testfile}_5"; + remove_tree ($testpath, "${testpath}_1"); +} + +unlink_testfiles(); + +#################################################### +# First, preset the log file with some content +#################################################### +open FILE, ">$testfile" or die "Cannot create $testfile"; +print FILE "previous content\n"; +close FILE; + +#################################################### +# Append to a log file without specifying append mode +# explicitely +#################################################### +my $data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +my $log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +my $content = join '', <FILE>; +close FILE; + +is($content, "previous content\nINFO - Shu-wa-chi!\n"); + +#################################################### +# Clobber the log file if overwriting is required +#################################################### +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.mode = write +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\n"); + +#################################################### +# Explicetly say "append" +#################################################### +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.mode = append +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\nINFO - Shu-wa-chi!\n"); + +######################################################### +# Mix Log::Dispatch and Log::Log4perl::Appender appenders +######################################################### +SKIP: { + skip "Skipping Log::Dispatch tests", 2 unless $LOG_DISPATCH_PRESENT; + +$data = <<EOT; +log4perl.category = INFO, FileAppndr1, FileAppndr2 +log4perl.appender.FileAppndr1 = Log::Dispatch::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = append +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout + +log4perl.appender.FileAppndr2 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr2.filename = ${testfile}_2 +log4perl.appender.FileAppndr2.mode = append +log4perl.appender.FileAppndr2.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - Shu-wa-chi!\n"); +} +}; + +######################################################### +# Check if the 0.33 Log::Log4perl::Appender::File bug is +# fixed which caused all messages to end up in the same +# file. +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1, FileAppndr2 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout + +log4perl.appender.FileAppndr2 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr2.filename = ${testfile}_2 +log4perl.appender.FileAppndr2.mode = write +log4perl.appender.FileAppndr2.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - Shu-wa-chi!\n"); +} + +######################################################### +# Check if switching over to a new file will work +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +my $app = Log::Log4perl->appenders()->{FileAppndr1}; +$app->file_switch("${testfile}_2"); +$log->info("File2"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - File$_\n"); +} + +is($app->filename(), "${testfile}_2"); + +######################################################### +# Testing syswrite +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +Log::Log4perl::init(\$data); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +######################################################### +# Testing syswrite with append +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.mode = append +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\nINFO - File1\n"); + +######################################################### +# Testing syswrite and recreate +######################################################### +SKIP: { + skip "File recreation not supported on Win32", 1 if $^O eq "MSWin32"; +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.recreate_check_interval = 0 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +$log->info("File1-1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1-1\n"); +}; + +######################################################### +# Testing syswrite and recreate without check_interval +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +eval { $log->info("File1-1"); }; + +is($@, "", "no error on moved file/syswrite"); + +SKIP: { + skip "Signals not supported on Win32", 2 if $^O eq "MSWin32"; + +######################################################### +# Testing syswrite and recreate_check_signal +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.recreate_check_signal = USR1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +is(kill('USR1', $$), 1, "sending signal"); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); +}; + +######################################################### +# Testing create_at_logtime +######################################################### +unlink "${testfile}_3"; # delete leftovers from previous tests + +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_3 +log4perl.appender.Logfile.create_at_logtime = 1 +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +ok(! -f "${testfile}_3"); + +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_3" or die "Cannot open ${testfile}_3"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +unlink "${testfile}_3"; + +######################################################### +# Testing create_at_logtime with recreate_check_signal +######################################################### +unlink "${testfile}_4"; # delete leftovers from previous tests + +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_4 +log4perl.appender.Logfile.create_at_logtime = 1 +log4perl.appender.Logfile.recreate = 1; +log4perl.appender.Logfile.recreate_check_signal = USR1 +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +ok(! -f "${testfile}_4"); + +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_4" or die "Cannot open ${testfile}_4"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +unlink "${testfile}_4"; + +######################################################### +# Print a header into a newly opened file +######################################################### +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_5 +log4perl.appender.Logfile.header_text = This is a nice header. +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +open FILE, "<${testfile}_5" or die "Cannot open ${testfile}_5"; +$content = join '', <FILE>; +close FILE; + +is($content, "This is a nice header.\n", "header_text"); + +#################################################### +# Create path if it is not already created +#################################################### + + +my $testmkpathfile = File::Spec->catfile($testpath, "test26.log"); + +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testmkpathfile +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.FileAppndr.mkpath = 1 +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testmkpathfile" or die "Cannot create $testmkpathfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\n"); + +#################################################### +# Create path with umask if it is not already created +#################################################### + +SKIP: { + skip "Umask not supported on Win32", 3 if $^O eq "MSWin32"; + + my $oldumask = umask; + + $testmkpathfile = File::Spec->catfile("${testpath}_1", "test26.log"); + + $data = <<EOT; + log4j.category = INFO, FileAppndr + log4j.appender.FileAppndr = Log::Log4perl::Appender::File + log4j.appender.FileAppndr.filename = $testmkpathfile + log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.FileAppndr.umask = 0026 + log4j.appender.FileAppndr.mkpath = 1 + log4j.appender.FileAppndr.mkpath_umask = 0027 +EOT + + Log::Log4perl::init(\$data); + $log = Log::Log4perl::get_logger(""); + $log->info("Shu-wa-chi!"); + + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat("${testpath}_1"); + + is($mode & 07777,0750); #Win32 777 + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($testmkpathfile); + + is($mode & 07777,0640); #Win32 666 + + is(umask,$oldumask); +}; diff --git a/t/027Watch2.t b/t/027Watch2.t new file mode 100644 index 0000000..2fe25b5 --- /dev/null +++ b/t/027Watch2.t @@ -0,0 +1,218 @@ +#testing init_and_watch +#special problem with init_and_watch, +#fixed in Logger::reset by setting logger level to OFF + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl qw(:easy); +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 21; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = "t/tmp"; +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testconf= "$WORK_DIR/test27.conf"; +unlink $testconf if (-e $testconf); + +#goto NEW; +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.dog = DEBUG, goneAppender + +log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + + +Log::Log4perl->init_and_watch($testconf, 1); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +ok( $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +$logger->debug('debug message, should appear'); + +is($app0->buffer(), "DEBUG - debug message, should appear\n"); + + +#--------------------------- +#now go to sleep and reload + +print "sleeping for 3 seconds\n"; +sleep 3; + +$conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +#*****log4j.category.animal.dog = DEBUG, goneAppender + +#*****log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +#*****log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +ok(! $logger->is_debug(), "is_debug - false"); +ok(! $logger->is_info(), "is_info - false"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +#now the logger is ruled by root/s WARN level +$logger->debug('debug message, should NOT appear'); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +is($app1->buffer(), "", "buffer empty"); + +$logger->warn('warning message, should appear'); + +is($app1->buffer(), "WARN - warning message, should appear\n", "warn in"); + +#check the root logger +$logger = Log::Log4perl::get_logger(); + +$logger->warn('warning message, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}/, + "2nd warn in"); + +# ------------------------------------------- +#double-check an unrelated category with a lower level +$logger = Log::Log4perl::get_logger('animal.cat'); +$logger->info('warning message to cat, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}INFO - warning message to cat, should appear/, "message output"); + +NEW: +############################################################################ +# This was a bug in L4p 1.01: After init_and_watch() caused a re-init, +# filename/linenumber were referring to 'eval', not the actual file +# name/line number of the message. + +my $counter = 0; +my $reload_permitted = 1; +conf_file_write(); +Log::Log4perl->init_and_watch($testconf, 1, { + preinit_callback => sub { + $counter++; +#print "Counter incremented to $counter\n"; + return $reload_permitted; + }, +}); + + +my $line_ref = __LINE__ + 1; +DEBUG("first"); + my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> first/, + "init-and-watch caller level first"); + $buf->buffer(""); + +print "Sleeping 1 second\n"; +sleep(1); +conf_file_write(); +$line_ref = __LINE__ + 1; +DEBUG("second"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> second/, + "init-and-watch caller level second"); + $buf->buffer(""); + +$reload_permitted = 0; +print "Sleeping 2 seconds\n"; +sleep(2); +conf_file_write("FATAL"); +$line_ref = __LINE__ + 1; +DEBUG("third"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> third/, + "init-and-watch caller level third"); + $buf->buffer(""); + +$reload_permitted = 1; +print "Sleeping 2 seconds\n"; +sleep(2); +conf_file_write("ERROR"); +$line_ref = __LINE__ + 1; +ERROR("third"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> third/, + "init-and-watch caller level third"); + $buf->buffer(""); + +ok($counter >= 1, "Callback counter check"); + +print "Sleeping 2 seconds\n"; +sleep(2); +ERROR("fourth"); +like $buf->buffer(), qr/main-main:: 027Watch2.t/, + "[rt.cpan.org #60386] caller level check"; + +########################################### +sub conf_file_write { +########################################### + my($level) = @_; + + $level = "DEBUG" unless defined $level; + + open FILE, ">$testconf" or die $!; + print FILE <<EOT; +log4perl.category.main = $level, Testbuffer +log4perl.appender.Testbuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Testbuffer.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Testbuffer.layout.ConversionPattern = %d %C-%M %F{1} %L> %m %n +EOT + close FILE; +#print "Config written\n"; +} + +unlink $testconf; diff --git a/t/027Watch3.t b/t/027Watch3.t new file mode 100644 index 0000000..a07a959 --- /dev/null +++ b/t/027Watch3.t @@ -0,0 +1,152 @@ +#testing init_and_watch +#same as 027Watch2, just with signal handling instead of watch/delay code + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Test::More; +use Config; + +our $SIGNALS_AVAILABLE = 0; + +BEGIN { + no warnings; + # Check if this platform supports signals + if (length $Config{sig_name} and length $Config{sig_num}) { + eval { + $SIG{USR1} = sub { $SIGNALS_AVAILABLE = 1 }; + # From the Config.pm manpage + my(%sig_num); + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + + kill $sig_num{USR1}, $$; + }; + if($@) { + $SIGNALS_AVAILABLE = 0; + } + } + + if ($SIGNALS_AVAILABLE) { + plan tests => 15; + }else{ + plan skip_all => "only on platforms supporting signals"; + } +} + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testconf= File::Spec->catfile($WORK_DIR, "test27.conf"); +unlink $testconf if (-e $testconf); + +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.dog = DEBUG, goneAppender + +log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +Log::Log4perl->init_and_watch($testconf, 'HUP'); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +ok( $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +$logger->debug('debug message, should appear'); + +is($app0->buffer(), "DEBUG - debug message, should appear\n", "debug()"); + + +#--------------------------- +#now reload and then signal + +$conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +#*****log4j.category.animal.dog = DEBUG, goneAppender + +#*****log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +#*****log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +#--------------------------- +# send the signal to the process itself +kill(1, $$) or die "Cannot signal"; + +ok(! $logger->is_debug(), "is_debug - false"); +ok(! $logger->is_info(), "is_info - false"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +#now the logger is ruled by root's WARN level +$logger->debug('debug message, should NOT appear'); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +is($app1->buffer(), "", "buffer empty"); + +$logger->warn('warning message, should appear'); + +is($app1->buffer(), "WARN - warning message, should appear\n", "warn in"); + +#check the root logger +$logger = Log::Log4perl::get_logger(); + +$logger->warn('warning message, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}/, + "2nd warn in"); + +# ------------------------------------------- +#double-check an unrelated category with a lower level +$logger = Log::Log4perl::get_logger('animal.cat'); +$logger->info('warning message to cat, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}INFO - warning message to cat, should appear/, "message output"); + +unlink $testconf; diff --git a/t/027Watch4.t b/t/027Watch4.t new file mode 100755 index 0000000..6f61097 --- /dev/null +++ b/t/027Watch4.t @@ -0,0 +1,44 @@ +#!/usr/local/bin/perl -w + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use warnings; +use Test::More; +use Log::Log4perl::Config::Watch; + +plan tests => 4; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + + # sample file to run tests on +my $file = "$EG_DIR/log4j-manual-1.conf"; + +my $w = Log::Log4perl::Config::Watch->new( + file => $file, + signal => 'USR1', +); + +$w->change_detected(); +$Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED = 0; +$Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED = 0; +$w->change_detected(); + +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED, + 0, "no change checked without signal"); +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED, + 0, "no change detected without signal"); + +$w->force_next_check(); +$w->change_detected(); + +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED, + 1, "change checked after force_next_check()"); +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED, + 0, "no change detected after force_next_check()"); diff --git a/t/028Additivity.t b/t/028Additivity.t new file mode 100644 index 0000000..118d09a --- /dev/null +++ b/t/028Additivity.t @@ -0,0 +1,124 @@ +########################################### +# Test Suite for Appender additivity +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 9 }; + +use Log::Log4perl qw(get_logger :levels); +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Define the root logger and another logger, additivity on +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout +EOT + +my $logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +my $buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +my $buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, "INFO - Percolate this!\n"); +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Define the root logger and another logger, additivity off +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.additivity.Twix.Bar = false +EOT + +$logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, ""); # Not supposed to show up in the root logger +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Define the root logger and another logger, additivity on explicitely +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.additivity.Twix.Bar = true +EOT + +$logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, "INFO - Percolate this!\n"); +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Additivity set via method after init +# https://github.com/mschilli/log4perl/issues/29 +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger = INFO, A1 + log4perl.logger.Twix.Bar = INFO, A2 + + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout +EOT + +$logger = get_logger("Twix::Bar"); +$logger->level( $INFO ); +$logger->additivity( 0 ); +$logger->info("Only for Twix"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, ""); +ok($buf2, "INFO - Only for Twix\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); diff --git a/t/029SysWide.t b/t/029SysWide.t new file mode 100644 index 0000000..353610e --- /dev/null +++ b/t/029SysWide.t @@ -0,0 +1,123 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { plan tests => 6 } + +ok(1); # If we made it this far, we're ok. + +################################################## +# System-wide threshold +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger.a = INFO, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.threshold = ERROR +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +ok($app0->buffer(), "ERROR - Yeah, loga\n"); + +################################################## +# System-wide threshold with appender threshold +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4perl.logger = ERROR, BUF0 +log4perl.logger.a = INFO, BUF1 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF1.Threshold = INFO +log4perl.threshold = ERROR +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +ok($app0->buffer(), "ERROR - Yeah, loga\n"); +ok($app1->buffer(), "ERROR - Yeah, loga\n"); + +############################################################ +# System-wide threshold shouldn't lower appender thresholds +############################################################ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = q( +log4perl.threshold = DEBUG +log4perl.category = INFO, BUF0 +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl::init(\$conf); + +my $logger = get_logger(); +$logger->info("Blah"); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +ok($app0->buffer(), "", "syswide threshold shouldn't lower app thresholds"); + +############################################################ +# System-wide threshold shouldn't lower appender thresholds +############################################################ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = q( +log4perl.threshold = ERROR +log4perl.category = INFO, BUF0 +log4perl.appender.BUF0.Threshold = DEBUG +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl::init(\$conf); + +$logger = get_logger(); +$logger->warn("Blah"); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +ok($app0->buffer(), "", "syswide threshold trumps thresholds"); diff --git a/t/030LDLevel.t b/t/030LDLevel.t new file mode 100644 index 0000000..7594d32 --- /dev/null +++ b/t/030LDLevel.t @@ -0,0 +1,55 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { plan tests => 2 } + +ok(1); # If we made it this far, we're ok. + +# Have TestBuffer log the Log::Dispatch priority +$Log::Log4perl::Appender::TestBuffer::LOG_PRIORITY = 1; +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ALL, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +$loga->debug("debug"); +$loga->info("info"); +$loga->warn("warn"); +$loga->error("error"); +$loga->fatal("fatal"); + +ok($app0->buffer(), + "[0]: DEBUG - debug\n" . + "[1]: INFO - info\n" . + "[3]: WARN - warn\n" . + "[4]: ERROR - error\n" . + "[7]: FATAL - fatal\n" . + "" + ); diff --git a/t/031NDC.t b/t/031NDC.t new file mode 100644 index 0000000..db8dbc3 --- /dev/null +++ b/t/031NDC.t @@ -0,0 +1,105 @@ +########################################### +# Test Suite Log::Log4perl::NDC +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::NDC; +use Log::Log4perl::MDC; + +BEGIN { plan tests => 3 } + +# Have TestBuffer log the Log::Dispatch priority +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ALL, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF0.layout.ConversionPattern = %m <%x> +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +Log::Log4perl::NDC->push("first"); +$loga->debug("debug"); + + # Push more than MAX +Log::Log4perl::NDC->push("second"); +Log::Log4perl::NDC->push("third"); +Log::Log4perl::NDC->push("fourth"); +Log::Log4perl::NDC->push("fifth"); +Log::Log4perl::NDC->push("sixth"); +$loga->info("info"); + + # Delete NDC stack +Log::Log4perl::NDC->remove(); +$loga->warn("warn"); + +Log::Log4perl::NDC->push("seventh"); +$loga->error("error"); + +ok($app0->buffer(), + "debug <first>info <first second third fourth sixth>warn <[undef]>error <seventh>"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl::MDC->put("remote_host", "blah-host"); +Log::Log4perl::MDC->put("ip", "blah-ip"); + +$conf = <<EOT; +log4perl.logger = ALL, BUF1 +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF1.layout.ConversionPattern = %X{remote_host}: %m %X{ip}%n +EOT + +Log::Log4perl::init(\$conf); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $logb = get_logger("b"); + +$logb->debug("testmessage"); + +ok($app1->buffer(), + "blah-host: testmessage blah-ip\n"); + +# Check what happens if %X is used with an undef value +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4perl.logger = ALL, BUF1 +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF1.layout.ConversionPattern = %X{quack}: %m %X{ip}%n +EOT + +Log::Log4perl::init(\$conf); + +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$logb = get_logger("b"); + +$logb->debug("testmessage"); + +ok($app1->buffer(), + "[undef]: testmessage blah-ip\n"); diff --git a/t/032JRollFile.t b/t/032JRollFile.t new file mode 100644 index 0000000..82684c8 --- /dev/null +++ b/t/032JRollFile.t @@ -0,0 +1,73 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +BEGIN { + eval { + require Log::Dispatch::FileRotate; + }; + if ($@ or $Log::Dispatch::FileRotate::VERSION < 1.10) { + plan skip_all => "only with Log::Dispatch::FileRotate 1.10"; + } else { + plan tests => 2; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles); @outfiles = (File::Spec->catfile($WORK_DIR, 'rolltest.log'), + File::Spec->catfile($WORK_DIR, 'rolltest.log.1'), + File::Spec->catfile($WORK_DIR, 'rolltest.log.2'),); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.RollingFileAppender +log4j.appender.myAppender.File=@{[File::Spec->catfile($WORK_DIR, 'rolltest.log')]} +#this will roll the file after one write +log4j.appender.myAppender.MaxFileSize=1024 +log4j.appender.myAppender.MaxBackupIndex=2 +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n + +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +$logger->debug("x" x 1024 . "debugging message 1 "); +$logger->info("x" x 1024 . "info message 1 "); +$logger->warn("x" x 1024 . "warning message 1 "); +$logger->fatal("x" x 1024 . "fatal message 1 "); + +my $rollfile = File::Spec->catfile($WORK_DIR, 'rolltest.log.2'); + +open F, $rollfile or die "Cannot open $rollfile"; +my $result = <F>; +close F; +like($result, qr/^INFO cat1 - x+info message 1/); + +#MaxBackupIndex is 2, so this file shouldn't exist +ok(! -e File::Spec->catfile($WORK_DIR, 'rolltest.log.3')); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} diff --git a/t/033UsrCspec.t b/t/033UsrCspec.t new file mode 100644 index 0000000..36651be --- /dev/null +++ b/t/033UsrCspec.t @@ -0,0 +1,314 @@ +#testing user-defined conversion specifiers (cspec) + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +Log::Log4perl::Appender::TestBuffer->reset(); + + +my $config = <<'EOL'; +log4j.category.plant = DEBUG, appndr1 +log4j.category.animal = DEBUG, appndr2 + +#'U' a global user-defined cspec +log4j.PatternLayout.cspec.U = \ + sub { \ + return "UID $< GID $("; \ + } \ + + +# ******************** +# first appender +log4j.appender.appndr1 = Log::Log4perl::Appender::TestBuffer +#log4j.appender.appndr1 = Log::Log4perl::Appender::Screen +log4j.appender.appndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr1.layout.ConversionPattern = %K xx %G %U + +#'K' cspec local to appndr1 (pid in hex) +log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} + +#'G' cspec unique to appdnr1 +log4j.appender.appndr1.layout.cspec.G = sub {return 'thisistheGcspec'} + + + +# ******************** +# second appender +log4j.appender.appndr2 = Log::Log4perl::Appender::TestBuffer +#log4j.appender.appndr2 = Log::Log4perl::Appender::Screen +log4j.appender.appndr2.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr2.layout.ConversionPattern = %K %U + +#'K' cspec local to appndr2 +log4j.appender.appndr2.layout.cspec.K = \ + sub { \ + my ($self, $message, $category, $priority, $caller_level) = @_; \ + $message =~ /--- (.+) ---/; \ + my $snippet = $1; \ + return ucfirst(lc($priority)).'-'.$snippet.'-'.ucfirst(lc($priority)); \ + } + +#override global 'U' cspec +log4j.appender.appndr2.layout.cspec.U = sub {return 'foobar'} + +EOL + + +Log::Log4perl::init(\$config); + +my $plant = Log::Log4perl::get_logger('plant'); +my $animal = Log::Log4perl::get_logger('animal'); + + +my $hexpid = sprintf "%1x", $$; +my $uid = $<; +my $gid = $(; + + +my $plantbuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr1"); +my $animalbuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr2"); + +$plant->fatal('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->fatal('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Fatal-animal-Fatal foobar"); +$animalbuffer->reset; + +$plant->error('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->error('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Error-animal-Error foobar"); +$animalbuffer->reset; + +$plant->warn('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->warn('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Warn-animal-Warn foobar"); +$animalbuffer->reset; + +$plant->info('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->info('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Info-animal-Info foobar"); +$animalbuffer->reset; + +$plant->debug('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->debug('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Debug-animal-Debug foobar"); +$animalbuffer->reset; + + +#now test the api call we're adding + +Log::Log4perl::Layout::PatternLayout::add_global_cspec('Z', sub {'zzzzzzzz'}); #snooze? + + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +my $logger = Log::Log4perl->get_logger("plant"); +$logger->add_appender($app); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "%m %Z"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "That's the message zzzzzzzz"); + +########################################################### +#testing perl code snippets in Log4perl configuration files +########################################################### + +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = sub { \ + return "Log::Log4perl::Appender::TestBuffer" } +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout + # This should be evaluated at config parse time ("%m %K%n") +log4perl.appender.appndr.layout.ConversionPattern = sub{ "%" . \ + chr(109) . " %K%n"; } + + # This should be evaluated at run time ('K' cspec) +log4perl.appender.appndr.layout.cspec.K = sub { $ENV{TEST_VALUE} } +EOL + +Log::Log4perl::init(\$config); + +$ENV{TEST_VALUE} = "env_value"; + +$logger = Log::Log4perl::get_logger('some'); +$logger->debug("log_message"); + +$ENV{TEST_VALUE} = "env_value2"; +$logger->info("log_message2"); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +#print "Testbuffer: ", $buffer->buffer(), "\n"; + +is($buffer->buffer(), "log_message env_value\nlog_message2 env_value2\n"); + +########################################################### +#testing perl code snippets with ALLOW_CODE_IN_CONFIG_FILE +#disabled +########################################################### + +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout + # This should be evaluated at config parse time ("%m %K%n") +log4perl.appender.appndr.layout.ConversionPattern = sub{ "%m" . \ + chr(109) . " %n"; } +EOL + +Log::Log4perl::Config::allow_code(0); + +eval { + Log::Log4perl::init(\$config); +}; + +print "ERR is $@\n"; + +if($@ and $@ =~ /prohibits/) { + ok(1); +} else { + ok(0); +} + +# Test if cspecs are denied +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %m %n +log4perl.appender.appndr.layout.cspec.K = sub { $ENV{TEST_VALUE} } +EOL + +Log::Log4perl::Config->allow_code(0); + +eval { + Log::Log4perl::init(\$config); +}; + +print "ERR is $@\n"; + +if($@ and $@ =~ /prohibits/) { + ok(1); +} else { + ok(0); +} + +################################################################ +# Test if cspecs are passing the correct caller level +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K %m %n +log4perl.appender.appndr.layout.cspec.K = sub { return (caller($_[4]))[1] } +EOL + +Log::Log4perl::init(\$config); + +my $some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +my $somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +like($somebuffer->buffer(), qr/033UsrCspec.t blah/); + +################################################################ +# cspecs with parameters in curlies +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +our %hash = (foo => "bar", quack => "schmack"); +$hash{hollerin} = "hootin"; # shut up perl warnings + +use Data::Dumper; +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K{foo} %m %K{quack}%n +log4perl.appender.appndr.layout.cspec.K = sub { $main::hash{$_[0]->{curlies} } } +EOL + +Log::Log4perl::init(\$config); + +$some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +$somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +is($somebuffer->buffer(), "bar blah schmack\n"); + +################################################################ +# Get the calling package from a cspec +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K %m%n +log4perl.appender.appndr.layout.cspec.K = \ + sub { scalar caller( $_[4] )} +EOL + +Log::Log4perl::init(\$config); + +$some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +$somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +is($somebuffer->buffer(), "main blah\n"); + +BEGIN { plan tests => 17, } diff --git a/t/034DBI.t b/t/034DBI.t new file mode 100644 index 0000000..3ddea6e --- /dev/null +++ b/t/034DBI.t @@ -0,0 +1,328 @@ +########################################### +# Test using Log::Dispatch::DBI +# Kevin Goess <cpan@goess.org> +########################################### + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +use Test::More; +use Log::Log4perl; +use warnings; +use strict; + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBI; + die if $DBI::VERSION < $minversion->{ "DBI" }; + + require DBD::CSV; + die if $DBD::CSV::VERSION < $minversion->{ "DBD::CSV" }; + + require SQL::Statement; + die if $SQL::Statement::VERSION < $minversion->{ "SQL::Statement" }; + }; + if ($@) { + plan skip_all => + "DBI $minversion->{ DBI } or " . + "DBD::CSV $minversion->{'DBD::CSV'} or " . + "SQL::Statement $minversion->{'SQL::Statement'} " . + "not installed, skipping tests\n"; + }else{ + plan tests => 33; + } +} + +END { + unlink "t/tmp/$table_name"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +require DBI; +my $dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ RaiseError => 1, PrintError => 1 }); + +$dbh->do("DROP TABLE $table_name") if -e "t/tmp/$table_name"; + +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + shortcaller char(5), + thingid char(6), + category char(16), + pkg char(16), + runtime1 char(16), + runtime2 char(16) + ) +EOL + +$dbh->do($stmt); + +#creating a log statement where bind values 1,3,5 and 6 are +#calculated from conversion specifiers and 2,4,7,8 are +#calculated at runtime and fed to the $logger->whatever(...) +#statement + +my $config = <<"EOT"; +#log4j.category = WARN, DBAppndr, console +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.username = bobjones +log4j.appender.DBAppndr.password = 12345 +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) \\ + values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message +log4j.appender.DBAppndr.params.3 = %5.5l +#---------------------------- #4 is thingid +log4j.appender.DBAppndr.params.5 = %c +log4j.appender.DBAppndr.params.6 = %C +#-----------------------------#7,8 are also runtime + +log4j.appender.DBAppndr.bufferSize=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +#a console appender for debugging +log4j.appender.console = Log::Log4perl::Appender::Screen +log4j.appender.console.layout = Log::Log4perl::Layout::SimpleLayout + + +EOT + +Log::Log4perl::init(\$config); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); + + +$logger->fatal('fatal message',1234,'foo',{aaa => 'aaa'}); + +#since we ARE buffering, that message shouldnt be there yet +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE,SHORTCALLER,THINGID,CATEGORY,PKG,RUNTIME1,RUNTIME2 +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected, "buffered"); +} + +$logger->warn('warning message',3456,'foo','bar'); + +#with buffersize == 2, now they should write +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE,SHORTCALLER,THINGID,CATEGORY,PKG,RUNTIME1,RUNTIME2 +FATAL,"fatal message",main:,1234,groceries.beer,main,foo,HASH(0x84cfd64) +WARN,"warning message",main:,3456,groceries.beer,main,foo,bar +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got =~ s/HASH\(.+?\)//; + $expected =~ s/HASH\(.+?\)//; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected, "buffersize=2"); +} + + +# setting is WARN so the debug message should not go through +$logger->debug('debug message',99,'foo','bar'); +$logger->warn('warning message with two params',99, 'foo', 'bar'); +$logger->warn('another warning to kick the buffer',99, 'foo', 'bar'); + +my $sth = $dbh->prepare("select * from $table_name"); +$sth->execute; + +#first two rows are repeats from the last test +my $row = $sth->fetchrow_arrayref; +is($row->[0], 'FATAL'); +is($row->[1], 'fatal message'); +is($row->[3], '1234'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +like($row->[7], qr/HASH/); #verifying param checking for "filter=>sub{...} stuff + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message'); +is($row->[3], '3456'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +#these two rows should have undef for the final two params +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message with two params'); +is($row->[3], '99'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'another warning to kick the buffer'); +is($row->[3], '99'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); +#that should be all +ok(!$sth->fetchrow_arrayref); + +$dbh->disconnect; + +# ************************************** +# checking usePreparedStmt, spurious warning bug reported by Brett Rann +# might as well give it a thorough check +Log::Log4perl->reset; + +unlink "t/tmp/$table_name" + if -e "t/tmp/$table_name"; + +$dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ PrintError => 1 }); + +$stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128) + + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + + +$config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message) \\ + values (?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +EOT + +Log::Log4perl::init(\$config); + +$logger = Log::Log4perl->get_logger("groceries.beer"); + +$logger->fatal('warning message'); + +#since we're not buffering, this message should show up immediately +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE +FATAL,"warning message" +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected); +} + +$logger->fatal('warning message'); + + # https://rt.cpan.org/Public/Bug/Display.html?id=79960 + # undef as NULL +$dbh->do("DROP TABLE $table_name"); +$stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + mdc char(16) + + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + +$config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, mdc, message) \\ + values (?, ?, ?) +log4j.appender.DBAppndr.params.1 = %p +log4j.appender.DBAppndr.params.2 = %X{foo} +#---------------------------- #3 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +EOT + +Log::Log4perl::init(\$config); + +$logger = Log::Log4perl->get_logger(); +$logger->warn('test message'); + +open (F, "t/tmp/$table_name"); +my $got = join '', <F>; +close F; + +my $expected = <<EOT; +loglevel,message,mdc +WARN,"test message", +EOT + +$got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars +$expected =~ s/[^\w ,"()]//g; +is $got, $expected, "dbi insert with NULL values"; diff --git a/t/035JDBCAppender.t b/t/035JDBCAppender.t new file mode 100644 index 0000000..868b3d9 --- /dev/null +++ b/t/035JDBCAppender.t @@ -0,0 +1,144 @@ +########################################### +# Test using Log::Dispatch::DBI +# Kevin Goess <cpan@goess.org> +########################################### + +use strict; +use warnings; + +our $table_name = "log4perl$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use Log::Log4perl; + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBD::CSV; + die if $DBD::CSV::VERSION < $minversion->{ "DBD::CSV" }; + + require Log::Dispatch; + }; + if ($@) { + plan skip_all => + "only with Log::Dispatch and DBD::CSV $minversion->{'DBD::CSV'}"; + }else{ + plan tests => 14; + } +} + +END { + unlink "t/tmp/$table_name"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +require DBI; +my $dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ PrintError => 1 }); + +-e "t/tmp/$table_name" && $dbh->do("DROP TABLE $table_name"); + +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + shortcaller char(5), + thingid char(6), + category char(16), + pkg char(16), + runtime1 char(16), + runtime2 char(16) + + ) +EOL + +$dbh->do($stmt); + +#creating a log statement where bind values 1,3,5 and 6 are +#calculated from conversion specifiers and 2,4,7,8 are +#calculated at runtime and fed to the $logger->whatever(...) +#statement + +my $config = <<"EOT"; +#log4j.category = WARN, DBAppndr, console +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = org.apache.log4j.jdbc.JDBCAppender +log4j.appender.DBAppndr.URL = jdbc:CSV:testdb://localhost:9999;f_dir=t/tmp +log4j.appender.DBAppndr.user = bobjones +log4j.appender.DBAppndr.password = 12345 +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) \\ + values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message +log4j.appender.DBAppndr.params.3 = %5.5l +#---------------------------- #4 is thingid +log4j.appender.DBAppndr.params.5 = %c +log4j.appender.DBAppndr.params.6 = %C +#-----------------------------#7,8 are also runtime + +log4j.appender.DBAppndr.bufferSize=3 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +#a console appender for debugging +log4j.appender.console = Log::Log4perl::Appender::Screen +log4j.appender.console.layout = Log::Log4perl::Layout::SimpleLayout + +EOT + +Log::Log4perl::init(\$config); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); + +#$logger->fatal('fatal message',1234,'foo','bar'); +$logger->fatal('fatal message',1234,'foo', 'bar'); +$logger->warn('warning message',3456,'foo','bar'); +$logger->debug('debug message',99,'foo','bar'); + +my $sth = $dbh->prepare("select * from $table_name"); +$sth->execute; + +my $row = $sth->fetchrow_arrayref; +is($row->[0], 'FATAL'); +is($row->[1], 'fatal message'); +is($row->[3], '1234'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message'); +is($row->[3], '3456'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$dbh->do("DROP TABLE $table_name"); + +1; diff --git a/t/036JSyslog.t b/t/036JSyslog.t new file mode 100644 index 0000000..e3708d3 --- /dev/null +++ b/t/036JSyslog.t @@ -0,0 +1,68 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test; + +BEGIN {plan tests => 1} +ok(1); #always succeed + +#skipping on win32 systems +eval { + require Sys::Syslog; +}; +if ($@){ + print STDERR "Sys::Syslog not installed, skipping...\n"; + exit; +} + + +print <<EOL; + +Since syslog() doesn't return any value that indicates sucess or failure, +I'm just going to send messages to syslog. These messages should +appear in the log file generated by syslog(8): + +INFO - info message 1 +WARN - warning message 1 + +Error messages probably indicate problems with related syslog modules +that exist on some systems. + +EOL + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.SyslogAppender +log4j.appender.myAppender.Facility=local1 +log4j.appender.myAppender.layout=org.apache.log4j.SimpleLayout +CONF + + +#There seems to be problems with Sys::Syslog on some platforms. +#So we'll just run this, maybe it will work and maybe it won't. +#A failure won't keep Log4perl from installing, but it will give +#some indication to the user whether to expect syslog logging +#to work on their system. + +eval { + + Log::Log4perl->init(\$conf); + + my $logger = Log::Log4perl->get_logger('cat1'); + + + $logger->debug("debugging message 1 "); + $logger->info("info message 1 "); + $logger->warn("warning message 1 "); + +}; + + + diff --git a/t/037JWin32Event.t b/t/037JWin32Event.t new file mode 100644 index 0000000..a7f2460 --- /dev/null +++ b/t/037JWin32Event.t @@ -0,0 +1,59 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; + + +#skipping on non-win32 systems +BEGIN { + eval { + require Log::Dispatch::Win32EventLog; + }; + if ($@){ + plan skip_all => "only with Log::Dispatch::Win32EventLog"; + } +}; + +print <<EOL; + +Since EventLog doesn't return any value that indicates sucess or failure, +I'm just going to send messages to the EventLog. You can see these +messages using the event viewer: + +INFO - info message 1 +WARN - warning message 1 + +(Probably prefaced with something like "The description for Event ID ( 0 ) +in Source ( t/037JWinEvent.t ) cannot be found... ") + + +EOL + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.NTEventLogAppender +log4j.appender.myAppender.source=$0 +log4j.appender.myAppender.layout=org.apache.log4j.SimpleLayout +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); + + +BEGIN {plan tests => 1} + +#if we didn't die, we got here +ok(1); diff --git a/t/038XML-DOM1.t b/t/038XML-DOM1.t new file mode 100644 index 0000000..b6f2c80 --- /dev/null +++ b/t/038XML-DOM1.t @@ -0,0 +1,287 @@ + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; +use warnings; +use Data::Dumper; +use File::Spec; +$SIG{__WARN__} = sub { die @_; }; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + + eval { + require XML::DOM; + XML::DOM->VERSION($dvrq); + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 2; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/" + threshold="debug"> + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="A2" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="BUF0" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <param name="Threshold" value="error"/> + </appender> + <appender name="FileAppndr1" class="org.apache.log4j.FileAppender"> + <layout class="Log::Log4perl::Layout::PatternLayout"> + <param name="ConversionPattern" + value="%d %4r [%t] %-5p %c %t - %m%n"/> + </layout> + <param name="File" value="t/tmp/DOMtest"/> + <param name="Append" value="false"/> + </appender> + + <category name="a.b.c.d" additivity="false"> + <level value="warn"/> <!-- note lowercase! --> + <appender-ref ref="A1"/> + + </category> + <category name="a.b"> + <priority value="info"/> + <appender-ref ref="A1"/> + </category> + <category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + <appender-ref ref="A2"/> + </category> + <category name="animal"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + </category> + <category name="xa.b.c.d"> + <priority value="info"/> + <appender-ref ref="A2"/> + </category> + <category name="xa.b"> + <priority value="warn"/> + <appender-ref ref="A2"/> + </category> + + <root> + <priority value="warn"/> + <appender-ref ref="FileAppndr1"/> + </root> + + +</log4j:configuration> + +EOL + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.appender.A2 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A2.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4j.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.BUF0.Threshold = ERROR + +log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender +log4j.appender.FileAppndr1.layout = Log::Log4perl::Layout::PatternLayout +log4j.appender.FileAppndr1.layout.ConversionPattern = %d %4r [%t] %-5p %c %t - %m%n +log4j.appender.FileAppndr1.File = t/tmp/DOMtest +log4j.appender.FileAppndr1.Append = false + +log4j.category.a.b.c.d = WARN, A1 +log4j.category.a.b = INFO, A1 + +log4j.category.xa.b.c.d = INFO, A2 +log4j.category.xa.b = WARN, A2 + +log4j.category.animal = INFO, FileAppndr1 +log4j.category.animal.dog = INFO, FileAppndr1,A2 + +log4j.category = WARN, FileAppndr1 + +log4j.threshold = DEBUG + +log4j.additivity.a.b.c.d = 0 + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} + + +require File::Spec->catfile('t','compare.pl'); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# =======================================================\ +# test variable substitutions +# more brute force + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/" + threshold="${rootthreshold}"> + + <appender name="${A1}" class="${testbfr}"> + <layout class="${simplelayout}"/> + </appender> + <appender name="${A2}" class="${testbfr}"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="BUF0" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <param name="${appthreshold}" value="${appthreshlevel}"/> + </appender> + <appender name="FileAppndr1" class="org.apache.log4j.FileAppender"> + <layout class="Log::Log4perl::Layout::PatternLayout"> + <param name="${convpatt}" + value="${thepatt}"/> + </layout> + <param name="${pfile}" value="${pfileval}"/> + <param name="Append" value="false"/> + </appender> + + <category name="${abcd}" additivity="${abcd_add}"> + <level value="${abcd_level}"/> <!-- note lowercase! --> + <appender-ref ref="A1"/> + + </category> + <category name="a.b"> + <priority value="info"/> + <appender-ref ref="A1"/> + </category> + <category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + <appender-ref ref="A2"/> + </category> + <category name="animal"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + </category> + <category name="xa.b.c.d"> + <priority value="info"/> + <appender-ref ref="A2"/> + </category> + <category name="xa.b"> + <priority value="warn"/> + <appender-ref ref="A2"/> + </category> + + <root> + <priority value="warn"/> + <appender-ref ref="FileAppndr1"/> + </root> + + +</log4j:configuration> + +EOL + + +$ENV{rootthreshold} = 'debug'; +$ENV{A1} = 'A1'; +$ENV{A2} = 'A2'; +$ENV{testbfr} = 'Log::Log4perl::Appender::TestBuffer'; +$ENV{simplelayout} = 'Log::Log4perl::Layout::SimpleLayout'; +$ENV{appthreshold} = 'Threshold'; +$ENV{appthreshlevel} = 'error'; +$ENV{convpatt} = 'ConversionPattern'; +$ENV{thepatt} = '%d %4r [%t] %-5p %c %t - %m%n'; +$ENV{pfile} = 'File'; +$ENV{pfileval} = 't/tmp/DOMtest'; +$ENV{abcd} = 'a.b.c.d'; +$ENV{abcd_add} = 'false'; +$ENV{abcd_level} = 'warn'; +$ENV{a1_appenderref} = 'A1'; + +my $varsubsdata = Log::Log4perl::Config::config_read(\$xmlconfig); + +ok(Compare($varsubsdata, $xmldata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($varsubsdata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($xmldata),"\n"; + } + }; + +#<param name="Threshold" value="error"/> +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="utf-8"?> +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" threshold="debug" oneMessagePerAppender="true"> +<appender name="AppGeneralScreen" class="Log::Log4perl::Appender::Screen"> +<layout class="Log::Log4perl::Layout::SimpleLayout"/> +</appender> +<root> +<priority value="WARN" /> +<appender-ref ref="AppGeneralScreen" /> +</root> +</log4perl:configuration> +EOL + +Log::Log4perl::init( \$xmlconfig ); +my $logger = Log::Log4perl->get_logger(); + +$logger->info("Info"); +$logger->debug("Debug"); diff --git a/t/039XML-DOM2.t b/t/039XML-DOM2.t new file mode 100644 index 0000000..29386ec --- /dev/null +++ b/t/039XML-DOM2.t @@ -0,0 +1,358 @@ + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + eval { + require XML::DOM; + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 4; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" + threshold="debug" oneMessagePerAppender="true"> + +<log4perl:appender name="jabbender" class="Log::Dispatch::Jabber"> + <param-nested name="login"> + <param name="hostname" value="a.jabber.server"/> + <param name="password" value="12345"/> + <param name="port" value="5222"/> + <param name="resource" value="logger"/> + <param name="username" value="bobjones"/> + </param-nested> + <param name="to" value="bob\@a.jabber.server"/> + <param-text name="to">mary\@another.jabber.server</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + +</log4perl:appender> +<log4perl:appender name="DBAppndr2" class="Log::Log4perl::Appender::DBI"> + <param name="warp_message" value="0"/> + <param name="datasource" value="DBI:CSV:f_dir=t/tmp"/> + <param name="bufferSize" value="2"/> + <param name="password" value="sub { \$ENV{PWD} }"/> + <param name="username" value="bobjones"/> + + <param-text name="sql">insert into $table_name (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?)</param-text> + <param-nested name="params"> + <param name="1" value="%p"/> + <param name="3" value="%5.5l"/> + <param name="5" value="%c"/> + <param name="6" value="%C"/> + </param-nested> + + <layout class="Log::Log4perl::Layout::NoopLayout"/> + +</log4perl:appender> +<category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="jabbender"/> +</category> + +<PatternLayout> + <cspec name="G"><![CDATA[sub { return "UID \$< GID \$("; }]]></cspec> +</PatternLayout> + + +</log4perl:configuration> +EOL + + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; + +log4j.category.animal.dog = INFO, jabbender +log4j.threshold = DEBUG + +log4j.oneMessagePerAppender=1 + +log4j.PatternLayout.cspec.G=sub { return "UID \$< GID \$("; } + +log4j.appender.jabbender = Log::Dispatch::Jabber +log4j.appender.jabbender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.jabbender.login.hostname = a.jabber.server +log4j.appender.jabbender.login.port = 5222 +log4j.appender.jabbender.login.username = bobjones +log4j.appender.jabbender.login.password = 12345 +log4j.appender.jabbender.login.resource = logger +log4j.appender.jabbender.to = bob\@a.jabber.server +log4j.appender.jabbender.to = mary\@another.jabber.server + +log4j.appender.DBAppndr2 = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr2.username = bobjones +log4j.appender.DBAppndr2.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr2.password = sub { \$ENV{PWD} } +log4j.appender.DBAppndr2.sql = insert into $table_name (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr2.params.1 = %p +log4j.appender.DBAppndr2.params.3 = %5.5l +log4j.appender.DBAppndr2.params.5 = %c +log4j.appender.DBAppndr2.params.6 = %C + +log4j.appender.DBAppndr2.bufferSize=2 +log4j.appender.DBAppndr2.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr2.layout = Log::Log4perl::Layout::NoopLayout + + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} + + +require 't/compare.pl'; + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + +# ------------------------------------------------ +#ok, let's get more hairy, make-believe + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + +<log4perl:appender name="A1" class="Log::Dispatch::Jabber"> + <param-nested name="A"> + <param-text name="1">fffff</param-text> + <param name="list" value="11111"/> + <param name="list" value="22222"/> + <param-nested name="subnest"> + <param-text name="a">hhhhh</param-text> + <param name="list" value="aaaaa"/> + <param name="list" value="bbbbb"/> + </param-nested> + </param-nested> + <param-text name="to">mary@another.jabber.server</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> +</log4perl:appender> + +</log4perl:configuration> + +EOL + +$propsconfig = <<'EOL'; + +log4j.appender.A1= Log::Dispatch::Jabber +log4j.appender.A1.A.1=fffff +log4j.appender.A1.A.list=11111 +log4j.appender.A1.A.list=22222 +log4j.appender.A1.A.subnest.a=hhhhh +log4j.appender.A1.A.subnest.list=aaaaa +log4j.appender.A1.A.subnest.list=bbbbb +log4j.appender.A1.to=mary@another.jabber.server +log4j.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout +EOL + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# ------------------------------------------------ +#now testing things like cspecs, code refs + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + + +<log4perl:appender name="appndr1" class="Log::Log4perl::Appender::TestBuffer"> + <log4perl:layout class="org.apache.log4j.PatternLayout"> + <param name="ConversionPattern" value = "%K xx %G %U"/> + <cspec name="K"> + sub { return sprintf "%1x", $$} + </cspec> + <cspec name="G"> + sub {return 'thisistheGcspec'} + </cspec> + </log4perl:layout> +</log4perl:appender> + +<category name="plant"> + <priority value="debug"/> + <appender-ref ref="appndr1"/> +</category> + +<PatternLayout> + <cspec name="U"><![CDATA[ + sub { return "UID $< GID $("; } + ]]></cspec> +</PatternLayout> + + + +</log4perl:configuration> + + +EOL + + +$propsconfig = <<'EOL'; +log4j.category.plant = DEBUG, appndr1 + +log4j.PatternLayout.cspec.U = \ + sub { \ + return "UID $< GID $("; \ + } \ + +log4j.appender.appndr1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.appndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr1.layout.ConversionPattern = %K xx %G %U + +log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} + +log4j.appender.appndr1.layout.cspec.G = sub {return 'thisistheGcspec'} +EOL + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + +#now we test variable substitution +#brute force again +my $varsubstconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" + threshold="debug" oneMessagePerAppender="${onemsgperappnder}"> + +<log4perl:appender name="jabbender" class="${jabberclass}"> + <param-nested name="${paramnestedname}"> + <param name="${hostname}" value="${hostnameval}"/> + <param name="${password}" value="${passwordval}"/> + <param name="port" value="5222"/> + <param name="resource" value="logger"/> + <param name="username" value="bobjones"/> + </param-nested> + <param name="to" value="bob@a.jabber.server"/> + <param-text name="to">${topcdata}</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + +</log4perl:appender> +<log4perl:appender name="DBAppndr2" class="Log::Log4perl::Appender::DBI"> + <param name="warp_message" value="0"/> + <param name="datasource" value="DBI:CSV:f_dir=t/tmp"/> + <param name="bufferSize" value="2"/> + <param name="password" value="sub { $ENV{PWD} }"/> + <param name="username" value="bobjones"/> + + <param-text name="sql">insert into ${tablename} (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?)</param-text> + <param-nested name="params"> + <param name="1" value="%p"/> + <param name="3" value="%5.5l"/> + <param name="5" value="%c"/> + <param name="6" value="%C"/> + </param-nested> + + <layout class="Log::Log4perl::Layout::NoopLayout"/> + +</log4perl:appender> +<category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="jabbender"/> +</category> + +<PatternLayout> + <cspec name="${cspecname}"><![CDATA[sub { ${perlcode} }]]></cspec> +</PatternLayout> + + +</log4perl:configuration> +EOL + +$ENV{onemsgperappnder} = 'true'; +$ENV{jabberclass} = 'Log::Dispatch::Jabber'; +$ENV{paramnestedname} = 'login'; +$ENV{hostname} = 'hostname'; +$ENV{hostnameval} = 'a.jabber.server'; +$ENV{password} = 'password'; +$ENV{passwordval} = '12345'; +$ENV{topcdata} = 'mary@another.jabber.server'; +$ENV{tablename} = $table_name; +$ENV{cspecname} = 'G'; +$ENV{perlcode} = 'return "UID $< GID $(";'; + +my $varsubstdata = Log::Log4perl::Config::config_read(\$varsubstconfig); + + + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + diff --git a/t/040Filter.t b/t/040Filter.t new file mode 100644 index 0000000..a4a0cb8 --- /dev/null +++ b/t/040Filter.t @@ -0,0 +1,516 @@ +########################################### +# Test Suite for Log::Log4perl::Filter +# Mike Schilli, 2003 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 36; + +use Log::Log4perl; + +############################################# +# Use a pattern-matching subroutine as filter +############################################# + +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger.Some = INFO, A1 + log4perl.filter.MyFilter = sub { /let this through/ } + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyFilter + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +my $logger = Log::Log4perl->get_logger("Some.Where"); + + # Let this through +$logger->info("Here's the info, let this through!"); + + # Suppress this +$logger->info("Here's the info, suppress this!"); + +like($buffer->buffer(), qr(let this through), "pattern-match let through"); +unlike($buffer->buffer(), qr(suppress), "pattern-match block"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Block in filter based on message level +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger.Some = INFO, A1 + log4perl.filter.MyFilter = sub { \ + my %p = @_; \ + ($p{log4p_level} eq "WARN") ? 1 : 0; \ + } + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyFilter + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Suppress this +$logger->info("This doesn't make it"); + + # Let this through +$logger->warn("This passes the hurdle"); + + +like($buffer->buffer(), qr(passes the hurdle), "level-match let through"); +unlike($buffer->buffer(), qr(make it), "level-match block"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Filter combination with Filter::Boolean +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + + log4perl.filter.Match1 = sub { /let this through/ } + log4perl.filter.Match2 = sub { /and that, too/ } + log4perl.filter.Match3 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match3.StringToMatch = suppress + log4perl.filter.Match3.AcceptOnMatch = true + + log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean + log4perl.filter.MyBoolean.logic = !Match3 && (Match1 || Match2) + + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyBoolean + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Boolean 1"); +$buffer->buffer(""); + + # Block +$logger->info("suppress, let this through"); +is($buffer->buffer(), "", "Boolean 2"); +$buffer->buffer(""); + + # Let through +$logger->info("and that, too"); +like($buffer->buffer(), qr(and that, too), "Boolean 3"); +$buffer->buffer(""); + + # Block +$logger->info("and that, too suppress"); +is($buffer->buffer(), "", "Boolean 4"); +$buffer->buffer(""); + + # Block +$logger->info("let this through - and that, too - suppress"); +is($buffer->buffer(), "", "Boolean 5"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelMatchFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToMatch = INFO + log4perl.filter.Match1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Level"); +$buffer->buffer(""); + + # Block +$logger->warn("suppress, let this through"); +is($buffer->buffer(), "", "Non-Matched Level 1"); +$buffer->buffer(""); + + # Block +$logger->debug("and that, too"); +is($buffer->buffer(), "", "Non-Matched Level 2"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelMatchFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToMatch = INFO + log4perl.filter.Match1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block +$logger->info("let this through"); +is($buffer->buffer(), "", "Non-Matched Level 1 - negative"); +$buffer->buffer(""); + + # Pass +$logger->warn("suppress, let this through"); +like($buffer->buffer(), qr(let this through), "Matched Level - negative"); +$buffer->buffer(""); + + # Pass +$logger->fatal("and that, too"); +like($buffer->buffer(), qr(and that, too), "Matched Level - negative"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# MDCFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::MDC + log4perl.filter.Match1.KeyToMatch = foo + log4perl.filter.Match1.RegexToMatch = ^bar$ + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +Log::Log4perl::MDC->put(foo => 'bar'); +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "MDC - passed"); +$buffer->buffer(""); +Log::Log4perl::MDC->remove; + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "MDC - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# StringMatchFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match1.StringToMatch = block this + log4perl.filter.Match1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "StringMatch - passed"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "StringMatch - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# StringMatchFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match1.StringToMatch = let this through + log4perl.filter.Match1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "StringMatch - passed"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "StringMatch - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Non-existing filter class +############################################# +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::GobbleDeGook + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like($@, qr/Log::Log4perl::Filter::GobbleDeGook/, "Unknown Filter"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Syntax error in subroutine +############################################# +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = sub { */+- }; + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like($@, qr/Can't evaluate/, "Detect flawed filter subroutine"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelRangeFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange + log4perl.filter.Range1.LevelMin = INFO + log4perl.filter.Range1.LevelMax = WARN + log4perl.filter.Range1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Range1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block +$logger->debug("blah"); +is($buffer->buffer(), "", "Outside Range"); +$buffer->buffer(""); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Range"); +$buffer->buffer(""); + + # Let through +$logger->warn("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Range"); +$buffer->buffer(""); + + # Block +$logger->error("blah"); +is($buffer->buffer(), "", "Outside Range"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelRangeFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange + log4perl.filter.Range1.LevelMin = INFO + log4perl.filter.Range1.LevelMax = WARN + log4perl.filter.Range1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Range1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->debug("debug msg"); +like($buffer->buffer(), qr(debug msg), "Outside Range - negative"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "Matched Range - negative"); +$buffer->buffer(""); + + # Block +$logger->warn("block this"); +is($buffer->buffer(), "", "Matched Range - negative"); +$buffer->buffer(""); + + # Let through +$logger->error("error msg"); +like($buffer->buffer(), qr(error msg), "Outside Range - negative"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToWomper = INFO + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like $@, qr/Unknown parameter: LevelToWomper/, "Unknown parameter check"; + +############################################# +# AND-Shortcut with boolean filters +############################################# +my $counter = 0; +no warnings qw( redefine ); +my $old_level_match_ok = *{ Log::Log4perl::Filter::LevelMatch::ok }; +*{ Log::Log4perl::Filter::LevelMatch::ok } = sub { + $counter++; 0 }; + +Log::Log4perl->init(\ <<'EOT'); +log4perl.category.Some.Where = DEBUG, A1 + +log4perl.filter.Debug = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Debug.LevelToMatch = DEBUG +log4perl.filter.Debug.AcceptOnMatch = true + +log4perl.filter.Info = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Info.LevelToMatch = INFO +log4perl.filter.Info.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = Debug && Info + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = MyBoolean +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block it +$logger->debug("some message"); +is($buffer->buffer(), "", "all blocked"); +is( $counter, 1, "shortcut ok" ); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# OR-Shortcut with boolean filters +############################################# +$counter = 0; +*{ Log::Log4perl::Filter::LevelMatch::ok } = sub { + $counter++; 1 }; + +Log::Log4perl->init(\ <<'EOT'); +log4perl.category.Some.Where = DEBUG, A1 + +log4perl.filter.Debug = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Debug.LevelToMatch = DEBUG +log4perl.filter.Debug.AcceptOnMatch = true + +log4perl.filter.Info = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Info.LevelToMatch = INFO +log4perl.filter.Info.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = Debug || Info + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = MyBoolean +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block it +$logger->debug("some message"); +like($buffer->buffer(), qr/some message/, "all blocked"); +is( $counter, 1, "shortcut ok" ); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +*{ Log::Log4perl::Filter::LevelMatch::ok } = $old_level_match_ok; diff --git a/t/041SafeEval.t b/t/041SafeEval.t new file mode 100644 index 0000000..41dc313 --- /dev/null +++ b/t/041SafeEval.t @@ -0,0 +1,191 @@ +######################################################################## +# Test Suite for Log::Log4perl::Config (Safe compartment functionality) +# James FitzGibbon, 2003 (james.fitzgibbon@target.com) +# Mike Schilli, 2003 (log4perl@perlmeister.com) +######################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; +BEGIN { plan tests => 23 }; + +use Log::Log4perl; + +ok(1); # If we made it this far, we're ok. + +my $example_log = "example" . (stat($0))[9] . ".log"; +unlink($example_log); + +Log::Log4perl::Config->vars_shared_with_safe_compartment( + main => [ '$0' ], +); + +# test that unrestricted code works properly +Log::Log4perl::Config::allow_code(1); +my $config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::File + log4perl.appender.Main.filename = sub { "example" . (stat($0))[9] . ".log" } + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +eval { Log::Log4perl->init( \$config ) }; +my $failed = $@ ? 1 : 0; +ok($failed, 0, 'config file with code initializes successfully'); + +# test that disallowing code works properly +Log::Log4perl::Config->allow_code(0); +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is false'); + +# test that providing an explicit mask causes illegal code to fail +Log::Log4perl::Config->allow_code(1); +Log::Log4perl::Config->allowed_code_ops(':default'); +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is true and an explicit mask is set'); + +# test that providing an restrictive convenience mask causes illegal code to fail +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is true and a restrictive convenience mask is set'); + +# test that providing an restrictive convenience mask causes illegal code to fail +Log::Log4perl::Config->allow_code('safe'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'config file with code succeeds if ALLOW_CODE_IN_CONFIG_FILE is true and a safe convenience mask is set'); + +################################################## +# Test allowed_code_ops_convenience_map accessors +################################################### + +# get entire map as hashref +my $map = Log::Log4perl::Config->allowed_code_ops_convenience_map(); +ok(ref $map, 'HASH', 'entire map is returned as a hashref'); +my $numkeys = keys %{ $map }; + +# get entire map as hash +my %map = Log::Log4perl::Config->allowed_code_ops_convenience_map(); +ok(keys %map, $numkeys, 'entire map returned as hash has same number of keys as hashref'); + +# replace entire map +Log::Log4perl::Config->allowed_code_ops_convenience_map( {} ); +ok(keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, 0, + 'can replace entire map with an empty one'); +Log::Log4perl::Config->allowed_code_ops_convenience_map( \%map ); +ok(keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, $numkeys, + 'can replace entire map with an populated one'); + +# Add a new name/mask to the map +Log::Log4perl::Config->allowed_code_ops_convenience_map( foo => [ ':default' ] ); +ok( keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, + $numkeys + 1, 'can add a new name/mask to the map'); + +# get the mask we just added back +my $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( 'foo' ); +ok( $mask->[0], ':default', 'can retrieve a single mask'); + +################################################### +# Test vars_shared_with_safe_compartment accessors +################################################### + +# get entire varlist as hashref +$map = Log::Log4perl::Config->vars_shared_with_safe_compartment(); +ok(ref $map, 'HASH', 'entire map is returned as a hashref'); +$numkeys = keys %{ $map }; + +# get entire map as hash +%map = Log::Log4perl::Config->vars_shared_with_safe_compartment(); +ok(keys %map, $numkeys, 'entire map returned as hash has same number of keys as hashref'); + +# replace entire map +Log::Log4perl::Config->vars_shared_with_safe_compartment( {} ); +ok(keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, 0, + 'can replace entire map with an empty one'); +Log::Log4perl::Config->vars_shared_with_safe_compartment( \%map ); +ok(keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, $numkeys, + 'can replace entire map with an populated one'); + +# Add a new name/mask to the map +$Foo::foo = 1; +@Foo::bar = ( 1, 2, 3 ); +push @Foo::bar, $Foo::foo; # Some nonsense to avoid 'used only once' warning +Log::Log4perl::Config->vars_shared_with_safe_compartment( Foo => [ '$foo', '@bar' ] ); +ok( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, + $numkeys + 1, 'can add a new name/mask to the map'); + +# get the varlist we just added back +my $varlist = Log::Log4perl::Config->vars_shared_with_safe_compartment( 'Foo' ); +ok( $varlist->[0], '$foo', 'can retrieve a single varlist'); +ok( $varlist->[1], '@bar', 'can retrieve a single varlist'); + + +############################################ +# Now the some tests with restricted cspecs +############################################ + +# Global cspec with illegal code +$config = <<'END'; + log4perl.logger = INFO, Main + #'U' a global user-defined cspec + log4j.PatternLayout.cspec.U = sub { unlink 'quackquack'; } + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, + 'global cspec with harmful code rejected on restrictive setting'); + +# Global cspec with legal code +$config = <<'END'; + log4perl.logger = INFO, Main + #'U' a global user-defined cspec + log4j.PatternLayout.cspec.U = sub { 1; } + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +Log::Log4perl::Config->allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'global cspec with legal code allowed on restrictive setting'); + +# Local cspec with illegal code +$config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Main.layout.cspec.K = sub { symlink("a", "b"); } +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'local cspec with harmful code rejected on restrictive setting'); + +# Global cspec with legal code +$config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Main.layout.cspec.K = sub { return sprintf "%1x", $$} +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'local cspec with legal code allowed on restrictive setting'); + +unlink($example_log); diff --git a/t/042SyncApp.t b/t/042SyncApp.t new file mode 100644 index 0000000..18eb416 --- /dev/null +++ b/t/042SyncApp.t @@ -0,0 +1,339 @@ +#!/usr/bin/perl +########################################################################## +# Synchronizing appender output with Log::Log4perl::Appender::Synchronized. +# This test uses fork and a semaphore to get two appenders to get into +# each other/s way. +# Mike Schilli, 2003 (m@perlmeister.com) +########################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(:easy); +Log::Log4perl->easy_init($DEBUG); +use constant INTERNAL_DEBUG => 0; + +our $INTERNAL_DEBUG = 0; + +$| = 1; + +BEGIN { + if(exists $ENV{"L4P_ALL_TESTS"}) { + plan tests => 5; + } else { + plan skip_all => "- only with L4P_ALL_TESTS"; + } +} + +use Log::Log4perl::Util::Semaphore; +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::Synchronized; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $logfile = "$EG_DIR/fork.log"; + +our $lock; +our $locker; +our $locker_key = "abc"; + +unlink $logfile; + +#goto SECOND; + +#print "tie\n"; +$locker = Log::Log4perl::Util::Semaphore->new( + key => $locker_key, +); + +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; + +my $conf = qq( +log4perl.category.Bar.Twix = WARN, Syncer + +log4perl.appender.Logfile = Log::Log4perl::Appender::TestFileCreeper +log4perl.appender.Logfile.autoflush = 1 +log4perl.appender.Logfile.filename = $logfile +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %F{1}%L> %m%n + +log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized +log4perl.appender.Syncer.appender = Logfile +log4perl.appender.Syncer.key = blah +); + +$locker->semlock(); + +Log::Log4perl::init(\$conf); + +my $pid = fork(); + +die "fork failed" unless defined $pid; + +my $logger = get_logger("Bar::Twix"); +if($pid) { + #parent + $locker->semlock(); + #print "Waiting for child\n"; + for(1..10) { + #print "Parent: Writing\n"; + $logger->error("X" x 4097); + } +} else { + #child + $locker->semunlock(); + for(1..10) { + #print "Child: Writing\n"; + $logger->error("Y" x 4097); + } + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +my $clashes_found = 0; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +while(<FILE>) { + if(/XY/ || /YX/) { + $clashes_found = 1; + last; + } +} +close FILE; + +unlink $logfile; +#print $logfile, "\n"; +#exit 0; + +ok(! $clashes_found, "Checking for clashes in logfile"); + +################################################################### +# Test the Socket appender +################################################################### + +use IO::Socket::INET; + +SECOND: + +unlink $logfile; + +#print "tie\n"; +$locker = Log::Log4perl::Util::Semaphore->new( + key => $locker_key, +); + +$conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout +}; + +print "1 Semunlock\n" if $INTERNAL_DEBUG; +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; +$locker->semunlock(); +print "1 Done semunlock\n" if $INTERNAL_DEBUG; + +print "2 Semlock\n" if $INTERNAL_DEBUG; +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; +$locker->semlock(); +print "2 Done semlock\n" if $INTERNAL_DEBUG; + +#print "forking\n"; +$pid = fork(); + +die "fork failed" unless defined $pid; + +if($pid) { + #parent + #print "Waiting for child\n"; + print "Before semlock\n" if $INTERNAL_DEBUG; + $locker->semlock(); + print "Done semlock\n" if $INTERNAL_DEBUG; + + { + my $client = IO::Socket::INET->new( PeerAddr => 'localhost', + PeerPort => 12345, + ); + + #print "Checking connection\n"; + + if(defined $client) { + #print "Client defined, sending test\n"; + eval { $client->send("test\n") }; + if($@) { + #print "Send failed ($!), retrying ...\n"; + sleep(1); + redo; + } + } else { + #print "Server not responding yet ($!) ... retrying\n"; + sleep(1); + redo; + } + $client->close(); + } + + Log::Log4perl::init(\$conf); + $logger = get_logger("Bar::Twix"); + #print "Sending message\n"; + $logger->error("Greetings from the client"); +} else { + #child + + #print STDERR "child starting\n"; + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + ReuseAddr => 1, + Proto => 'tcp'); + + die "Cannot start server: $!" unless defined $sock; + # Ready to receive + #print "Server started\n"; + print "Before semunlock\n" if $INTERNAL_DEBUG; + $locker->semunlock(); + print "After semunlock\n" if $INTERNAL_DEBUG; + + my $nof_messages = 2; + + open FILE, ">$logfile" or die "Cannot open $logfile"; + while(my $client = $sock->accept()) { + #print "Client connected\n"; + while(<$client>) { + print FILE "$_\n"; + last; + } + last unless --$nof_messages; + } + + close FILE; + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +my $data = join '', <FILE>; +close FILE; + +unlink $logfile; + +like($data, qr/Greetings/, "Check logfile of Socket appender"); + +################################################################### +# Test the "silent_recover" options of the Socket appender +################################################################### + +use IO::Socket::INET; + +our $TMP_FILE = "warnings.txt"; +END { unlink $TMP_FILE if defined $TMP_FILE; } + +# Capture STDERR to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return scalar <IN>; } + +$conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout + log4perl.appender.Socket.silent_recovery = 1 +}; + + # issues a warning +Log::Log4perl->init(\$conf); + +like(readwarn(), qr/Connection refused/, + "Check if warning occurs on dead socket"); + +$logger = get_logger("foobar"); + + # silently ignored +$logger->warn("message lost"); + +$locker->semunlock(); +$locker->semlock(); + + # Now start a server +$pid = fork(); + +if($pid) { + #parent + + # wait for child + #print "Waiting for server to start\n"; + $locker->semlock(); + + # Send another message (should be sent) + #print "Sending message\n"; + $logger->warn("message sent"); +} else { + #child + + # Start a server + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + ReuseAddr => 1, + Proto => 'tcp'); + + die "Cannot start server: $!" unless defined $sock; + # Ready to receive + #print "Server started\n"; + $locker->semunlock(); + + my $nof_messages = 1; + + open FILE, ">$logfile" or die "Cannot open $logfile"; + while(my $client = $sock->accept()) { + #print "Client connected\n"; + while(<$client>) { + #print "Got message: $_\n"; + print FILE "$_\n"; + last; + } + last unless --$nof_messages; + } + + close FILE; + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +$data = join '', <FILE>; +close FILE; + +#print "data=$data\n"; + +unlink $logfile; + +unlike($data, qr/message lost/, "Check logfile for lost message"); +like($data, qr/message sent/, "Check logfile for sent message"); diff --git a/t/043VarSubst.t b/t/043VarSubst.t new file mode 100755 index 0000000..90c5da4 --- /dev/null +++ b/t/043VarSubst.t @@ -0,0 +1,141 @@ +#!/usr/bin/perl +########################################################################## +# Check basic variable substitution. +# Mike Schilli, 2003 (m@perlmeister.com) +########################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +BEGIN { plan tests => 8 } +use Log::Log4perl qw(get_logger); + +######################################################## +# Wrong variable name +######################################################## +my $conf = q( +screen = Log::Log4perl::Appender::Screen +log4perl.category = WARN, ScreenApp +log4perl.appender.ScreenApp = ${screen1} +log4perl.appender.ScreenApp.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.ScreenApp.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +eval { Log::Log4perl::init(\$conf) }; + +like($@, qr/Undefined Variable 'screen1'/); + +######################################################## +# Replacing appender class name +######################################################## +$conf = q( +screen = Log::Log4perl::Appender::TestBuffer +log4perl.category = WARN, BufferApp +log4perl.appender.BufferApp = ${screen} +log4perl.appender.BufferApp.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.BufferApp.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +Log::Log4perl::init(\$conf); +my $logger = get_logger(""); +$logger->error("foobar"); +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("BufferApp"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Replacing appender class name +######################################################## +$conf = q( + layout_class = Log::Log4perl::Layout::PatternLayout + layout_pattern = %d %F{1} %L> %m %n + + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Multi-Line variable +######################################################## +$conf = q( + layout_class = \ +Log::Log4perl::\ +Layout::PatternLayout + layout_pattern = %d %F{1} \ +%L> \ +%m \ +%n + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Environment variable substitution +######################################################## +$ENV{layout_class} = "Log::Log4perl::Layout::PatternLayout"; +$ENV{layout_pattern} = "%d %F{1} %L> %m %n"; + +$conf = q( + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); diff --git a/t/044XML-Filter.t b/t/044XML-Filter.t new file mode 100644 index 0000000..05a6afd --- /dev/null +++ b/t/044XML-Filter.t @@ -0,0 +1,256 @@ +#adding filters to XML-DOM configs --kg + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; +use Data::Dumper; +use File::Spec; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + + eval { + require XML::DOM; + XML::DOM->VERSION($dvrq); + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 3; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} +require File::Spec->catfile('t','compare.pl'); + +# ***************************************************** +# first, test a very basic filter setup +# ***************************************************** + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/"> + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </filter> + </appender> + + <root> + <priority value="info"/> + <appender-ref ref="A1"/> + </root> + +</log4j:configuration> + +EOL + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; +log4perl.category = INFO, A1 + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Log::Log4perl::Filter::Boolean +log4perl.appender.A1.Filter.logic = !Match3 && (Match1 || Match2) +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# ***************************************************** +# second, log4perl's boolean filters +# ***************************************************** + +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </filter> + </appender> + + <log4perl:filter name="Match1" value="sub { /let this through/ }" /> + + <log4perl:filter name="Match2">sub { /and that, too/ }</log4perl:filter> + + <log4perl:filter name="Match3" class="Log::Log4perl::Filter::StringMatch"> + <param name="StringToMatch" value="suppress"/> + <param name="AcceptOnMatch" value="true"/> + </log4perl:filter> + + <log4perl:filter name="MyBoolean" class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </log4perl:filter> + + + <root> + <priority value="info"/> + <appender-ref ref="A1"/> + </root> + +</log4perl:configuration> +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = <<EOL; +log4perl.category = INFO, A1 + +log4perl.filter.Match1 = sub { /let this through/ } +log4perl.filter.Match2 = sub { /and that, too/ } +log4perl.filter.Match3 = Log::Log4perl::Filter::StringMatch +log4perl.filter.Match3.StringToMatch = suppress +log4perl.filter.Match3.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = !Match3 && (Match1 || Match2) + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Log::Log4perl::Filter::Boolean +log4perl.appender.A1.Filter.logic = !Match3 && (Match1 || Match2) +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + + + +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + + +# ***************************************************** +# third, level range filter, just for something different +# ***************************************************** + + +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + <log4perl:appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter-ref id="Range1"/> + </log4perl:appender> + + <log4perl:filter name="Range1" class="Log::Log4perl::Filter::LevelRange"> + <param name="LevelMin" value="info"/> + <param name="LevelMax" value="warn"/> + <param name="AcceptOnMatch" value="true"/> + </log4perl:filter> + + <root> + <priority value="debug"/> + <appender-ref ref="A1"/> + </root> +</log4perl:configuration> +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = <<EOL; +log4perl.category = DEBUG, A1 +log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange +log4perl.filter.Range1.LevelMin = INFO +log4perl.filter.Range1.LevelMax = WARN +log4perl.filter.Range1.AcceptOnMatch = true +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Range1 +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + diff --git a/t/045Composite.t b/t/045Composite.t new file mode 100644 index 0000000..adcc06a --- /dev/null +++ b/t/045Composite.t @@ -0,0 +1,372 @@ +########################################### +# Test Suite for Composite Appenders +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { + eval { + require Storable; + }; + if ($@) { + plan skip_all => "only with Storable"; # Limit.pm needs it and + # early Perl versions dont + # have it. + }else{ + plan tests => 20; + } +} + +use Log::Log4perl qw(get_logger :levels); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +ok(1); # If we made it this far, we/re ok. + +################################################## +# Limit Appender +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 +); + +Log::Log4perl->init(\$conf); + +my $logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +$logger->warn("This message will be delayed by one hour."); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/delayed/); + + # Now flush the limiter and check again. The delayed message should now + # be there. +my $limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +like($buffer->buffer(), qr/immediately/); +like($buffer->buffer(), qr/delayed/); + +$buffer->reset(); + # Nothing to flush +$limit->flush(); +is($buffer->buffer(), ""); + +################################################## +# Flush method +################################################## +$conf .= <<EOT; + log4perl.appender.Limiter.appender_method_on_flush = clear +EOT +Log::Log4perl->init(\$conf); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +$logger = get_logger(""); +$logger->warn("This message will be queued but discarded on flush."); +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +is($buffer->buffer(), ""); + +################################################## +# Limit Appender with max_until_discard +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_discarded = 1 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +for(1..10) { + $logger->warn("This message will be discarded"); +} + + # Artificially flush the limit appender +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/discarded/); + +################################################## +# Limit Appender with max_until_discard +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_discarded = 1 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +for(1..10) { + $logger->warn("This message will be discarded"); +} + + # Artificially flush the limit appender +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/discarded/); + +################################################## +# Limit Appender with max_until_flushed +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_flushed = 2 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +$logger->warn("This message won't show right away"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/right away/); + +$logger->warn("This message will show right away"); +like($buffer->buffer(), qr/right away/); + + +################################# +#demonstrating bug in Limiter.pm regarding $_ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +{package My::Test::Appender; +our @ISA = ('Log::Log4perl::Appender::TestBuffer'); +sub new { + my $self = shift; + $_ = ''; #aye, there's the rub! + $self->SUPER::new; +} +} + +$conf = qq( + log4perl.category = WARN, Limiter + + log4perl.appender.Buffer = My::Test::Appender + log4perl.appender.Buffer.layout = SimpleLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 +); + +Log::Log4perl->init(\$conf); +ok(1); + +### API initialization +# +Log::Log4perl->reset(); +my $bufApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::TestBuffer', + name => 'MyBuffer', + ); +$bufApp->layout( + Log::Log4perl::Layout::PatternLayout::Multiline->new( + '%m%n') + ); +# Make the appender known to the system (without assigning it to +# any logger +Log::Log4perl->add_appender( $bufApp ); + +my $limitApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::Limit', + name => 'MyLimit', + appender => 'MyBuffer', + key => 'nem', + ); +$limitApp->post_init(); +$limitApp->composite(1); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("MyBuffer"); +get_logger("")->add_appender($limitApp); +get_logger("")->level($DEBUG); +get_logger("wonk")->debug("waah!"); +is($buffer->buffer(), "waah!\n", "composite api init"); + +### Wrong %M with caching appender +# +Log::Log4perl->reset(); +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # TestBuffer appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d cat=%c meth=%M %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_flushed = 2 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(); + +$logger->warn("Sent from main"); + +package Willy::Wonka; +sub func { + use Log::Log4perl qw(get_logger); + my $logger = get_logger(); + $logger->warn("Sent from func"); +} +package main; + +Willy::Wonka::func(); +$logger->warn("Sent from main"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), + qr/cat=main meth=main::.*cat=Willy.Wonka meth=Willy::Wonka::func/s, + "%M/%c with composite appender"); + +### Different caller stacks with normal vs. composite appenders +Log::Log4perl->reset(); + +$conf = qq( + log4perl.category = WARN, Buffer1, Composite + + # 1st TestBuffer appender + log4perl.appender.Buffer1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer1.layout = PatternLayout + log4perl.appender.Buffer1.layout.ConversionPattern=meth=%M %m %n + + # 2nd TestBuffer appender + log4perl.appender.Buffer2 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer2.layout = PatternLayout + log4perl.appender.Buffer2.layout.ConversionPattern=meth=%M %m %n + + # Composite Appender + log4perl.appender.Composite = Log::Log4perl::Appender::Buffer + log4perl.appender.Composite.appender = Buffer2 + log4perl.appender.Composite.trigger = sub { 1 } +); + +Log::Log4perl->init(\$conf); + +my $buffer1 = Log::Log4perl::Appender::TestBuffer->by_name("Buffer1"); +my $buffer2 = Log::Log4perl::Appender::TestBuffer->by_name("Buffer2"); + +$logger = get_logger(); + +$logger->warn("Sent from main"); + +Willy::Wonka::func(); + +like $buffer1->buffer(), + qr/meth=main:: Sent from main.*meth=Willy::Wonka::func Sent from func/s, + "caller stack from direct appender"; +like $buffer2->buffer(), + qr/meth=main:: Sent from main.*meth=Willy::Wonka::func Sent from func/s, + "caller stack from composite appender"; + +# [RT 72056] Appender Threshold blocks composite appender + +$conf = qq( + log4perl.category = DEBUG, Composite + + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.Threshold=INFO + log4perl.appender.Buffer.layout.ConversionPattern=%M %m %n + + # Composite Appender + log4perl.appender.Composite = Log::Log4perl::Appender::Buffer + log4perl.appender.Composite.appender = Buffer + log4perl.appender.Composite.trigger = sub { 0 } + +); + +Log::Log4perl->init(\$conf); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +$logger = get_logger(); +$logger->debug("this will be blocked by the appender threshold"); + +my $composite = Log::Log4perl->appender_by_name("Composite"); +$composite->flush(); + +is $buffer->buffer(), "", + "appender threshold blocks message in composite appender"; diff --git a/t/046RRDs.t b/t/046RRDs.t new file mode 100644 index 0000000..d1b35d4 --- /dev/null +++ b/t/046RRDs.t @@ -0,0 +1,60 @@ +########################################### +# Test Suite for RRDs appenders +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +use Log::Log4perl qw(get_logger); + +my $DB = "myrrddb.dat"; + +BEGIN { eval 'require RRDs'; + if($@) { + plan skip_all => "(RRDs not installed)"; + exit 0; + } else { + plan tests => 1; + } + }; +END { unlink $DB }; + +use RRDs; + +RRDs::create( + $DB, "--step=1", + "DS:myvalue:GAUGE:2:U:U", + "RRA:MAX:0.5:1:120"); + +Log::Log4perl->init(\qq{ + log4perl.category = INFO, RRDapp + log4perl.appender.RRDapp = Log::Log4perl::Appender::RRDs + log4perl.appender.RRDapp.dbname = $DB + log4perl.appender.RRDapp.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.RRDapp.layout.ConversionPattern = N:%m +}); + +my $logger = get_logger(); + +for(10, 15, 20) { + $logger->info($_); + sleep 1; +} + +my ($start,$step,$names,$data) = + RRDs::fetch($DB, "MAX", + "--start" => time() - 20); +$data = join ' - ', map { "@$_" } grep { defined $_->[0] } @$data; +#print $data; + +like($data, qr/\d\d/); diff --git a/t/048lwp.t b/t/048lwp.t new file mode 100644 index 0000000..5749ff5 --- /dev/null +++ b/t/048lwp.t @@ -0,0 +1,98 @@ +########################################### +# Test Suite for LWP debugging with Log4perl +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { + eval { + require LWP::UserAgent; + die "Skip tests" if $LWP::UserAgent::VERSION < 2.0; + die "Skip tests" if $LWP::UserAgent::VERSION >= 5.822; + }; + + if($@) { + plan skip_all => "Only with 2.0 < LWP::UserAgent < 5.822 "; + } else { + plan tests => 3; + } +} + +use Log::Log4perl qw(:easy); +use Log::Log4perl::Util; + +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::UserAgent", + file => 'lwpout.txt' + }); + +Log::Log4perl->infiltrate_lwp(); + +my $ua = LWP::UserAgent->new(); + +my $tmpfile = Log::Log4perl::Util::tmpfile_name(); +END { unlink $tmpfile }; +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +my $data = join('', <LOG>); +close LOG; + +like($data, qr#\QGET file:$tmpfile\E#); + +END { unlink "lwpout.txt" } + +#################################### +# Check different category +#################################### +Log::Log4perl->reset(); +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::SchmoozeAgent", + file => '>lwpout.txt' + }); + +Log::Log4perl->infiltrate_lwp(); + +$ua = LWP::UserAgent->new(); +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +$data = join('', <LOG>); +close LOG; + +is($data, ''); + +#################################### +# Check layout +#################################### +Log::Log4perl->reset(); +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::UserAgent", + file => '>lwpout.txt', + layout => '%F-%L: %m%n', + }); + +Log::Log4perl->infiltrate_lwp(); + +$ua = LWP::UserAgent->new(); +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +$data = join('', <LOG>); +close LOG; + +like($data, qr#LWP/UserAgent.pm-\d+#); diff --git a/t/049Unhide.t b/t/049Unhide.t new file mode 100644 index 0000000..2d64281 --- /dev/null +++ b/t/049Unhide.t @@ -0,0 +1,50 @@ +########################################### +# Test Suite for ':resurrect' tag +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { + eval { + require Filter::Util::Call; + }; + + if($@) { + plan skip_all => "Filter::Util::Call not available"; + } else { + plan tests => 1; + } +} + +use Log::Log4perl qw(:easy :resurrect); + +Log::Log4perl->easy_init($DEBUG); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m %n +EOT + + # All of these should be activated +###l4p DEBUG "first"; + ###l4p DEBUG "second"; +DEBUG "third"; + +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "first \nsecond \nthird \n", "Hidden statements via ###l4p"); diff --git a/t/050Buffer.t b/t/050Buffer.t new file mode 100644 index 0000000..c4ecd13 --- /dev/null +++ b/t/050Buffer.t @@ -0,0 +1,76 @@ +########################################### +# Test Suite for 'Buffer' appender +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 6; +use Log::Log4perl::Appender::TestBuffer; + +use Log::Log4perl qw(:easy); + +my $conf = q( +log4perl.category = DEBUG, Buffer +log4perl.category.triggertest = DEBUG, Buffer2 + + # Regular Screen Appender +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = PatternLayout +log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, using the appender above as outlet +log4perl.appender.Buffer = Log::Log4perl::Appender::Buffer +log4perl.appender.Buffer.appender = Screen +log4perl.appender.Buffer.trigger_level = ERROR + + # Second Screen Appender +log4perl.appender.Screen2 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen2.layout = PatternLayout +log4perl.appender.Screen2.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, with a subroutine reference as a trigger +log4perl.appender.Buffer2 = Log::Log4perl::Appender::Buffer +log4perl.appender.Buffer2.appender = Screen2 +log4perl.appender.Buffer2.trigger = sub { \ + my($self, $params) = @_; \ + return Log::Log4perl::Level::to_priority($params->{log4p_level}) >= \ + Log::Log4perl::Level::to_priority('ERROR') } + +); + +Log::Log4perl->init(\$conf); + +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); + +DEBUG("This message gets buffered."); +is($buf->buffer(), "", "Buffering DEBUG"); + +INFO("This message gets buffered also."); +is($buf->buffer(), "", "Buffering INFO"); + +ERROR("This message triggers a buffer flush."); +like($buf->buffer(), qr/DEBUG.*?INFO.*?ERROR/s, "Flushing ERROR"); + + +# testing trigger sub + +my $buf2 = Log::Log4perl::Appender::TestBuffer->by_name("Screen2"); + +my $logger = Log::Log4perl->get_logger('triggertest'); +$logger->debug("This message gets buffered."); +is($buf2->buffer(), "", "Buffering DEBUG"); + +$logger->info("This message gets buffered also."); +is($buf2->buffer(), "", "Buffering INFO"); + +$logger->error("This message triggers a buffer flush."); +like($buf2->buffer(), qr/DEBUG.*?INFO.*?ERROR/s, "Flushing ERROR"); diff --git a/t/051Extra.t b/t/051Extra.t new file mode 100644 index 0000000..010f70b --- /dev/null +++ b/t/051Extra.t @@ -0,0 +1,113 @@ +########################################### +# Test Suite for :no_extra_logdie_message +# Mike Schilli, 2005 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Log::Log4perl qw(:easy :no_extra_logdie_message); +use Test::More; + +BEGIN { + if ($] < 5.008) { + plan skip_all => "Only with perl >= 5.008"; + } else { + plan tests => 11; + } +} + +END { + unlink "t/tmp/easy"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +use Log::Log4perl::Appender::TestBuffer; + +is($Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR, 0, "internal variable set"); + +my $conf = qq( +log4perl.category = DEBUG, Screen + + # Regular Screen Appender +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = PatternLayout +log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n +); + +Log::Log4perl->init(\$conf); + +######################################################################### +# Capture STDERR to a temporary file and a filehandle to read from it + +my $TMP_FILE = File::Spec->catfile(qw(t tmp easy)); +$TMP_FILE = "tmp/easy" if ! -d "t"; + +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; binmode IN, ":utf8"; +sub readstderr { return join("", <IN>); } + +END { unlink $TMP_FILE; + close IN; + } +######################################################################### + +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); + +$buf->buffer(""); +my $line_ref = __LINE__ + 1; +LOGCARP("logcarp"); + +like(readstderr(), qr/logcarp at /, "Output to stderr"); +SKIP: { use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 3 unless + defined $Carp::VERSION; + like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); + $buf->buffer(""); + $line_ref = __LINE__ + 1; + LOGCARP("logcarp"); + like(readstderr(), qr/logcarp at /, "Output to stderr"); + like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); +} + +$line_ref += 6; +$buf->clear; +LOGWARN("Doesn't call 'exit'"); +is(readstderr(), "", "No output to stderr"); +like($buf->buffer(), qr/Doesn't call 'exit'/, "Appender output intact"); +######################################################################### +# Turn default behaviour back on +######################################################################### +$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ^= 1; +$buf->buffer(""); + +package Foo; +use Log::Log4perl qw(:easy); +sub foo { + LOGCARP("logcarp"); +} +package main; + +Foo::foo(); + +$line_ref += 17; +like(readstderr(), qr/logcarp.*$line_ref/, "Output to stderr"); +like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); + +$buf->buffer(""); +eval { + LOGDIE("logdie"); +}; +$line_ref += 8; +like($@, qr/logdie.*$line_ref/, "Output to stderr"); +like($buf->buffer(), qr/logdie/, "Appender output intact"); diff --git a/t/052Utf8.t b/t/052Utf8.t new file mode 100644 index 0000000..ea40d39 --- /dev/null +++ b/t/052Utf8.t @@ -0,0 +1,130 @@ +########################################### +# Test Suite for utf8 output +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +use Test::More; +use Log::Log4perl qw(:easy); + +BEGIN { + if($] < 5.008) { + plan skip_all => "utf-8 tests with perl >= 5.8 only"; + } else { + plan tests => 6; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp utf8.out)); +$TMP_FILE = "tmp/utf8.out" if ! -d "t"; + +END { + unlink $TMP_FILE; + rmdir $WORK_DIR; + } + +########### +# utf8 file appender +########### +my $conf = <<EOT; + log4perl.logger = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=$TMP_FILE + log4perl.appender.A1.mode=write + log4perl.appender.A1.utf8=1 + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT +Log::Log4perl->init(\$conf); +DEBUG "quack \x{A4}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +my $data = join '', <FILE>; +close FILE; +like($data, qr/\x{A4}/, "conf: utf8-1"); + +########### +# binmode +########### +$conf = <<EOT; + log4perl.logger = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=$TMP_FILE + log4perl.appender.A1.mode=write + log4perl.appender.A1.binmode=:utf8 + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT +Log::Log4perl->init(\$conf); +DEBUG "quack \x{A5}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +$data = join '', <FILE>; +close FILE; +like($data, qr/\x{A5}/, "binmode: utf8-1"); + +########### +# Easy mode +########### +Log::Log4perl->easy_init({file => ":utf8> $TMP_FILE", + level => $DEBUG}); + +DEBUG "odd character: \x{30B8}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +$data = join '', <FILE>; +close FILE; +like($data, qr/\x{30B8}/, "easy: utf8-1"); + +########### +# Easy mode with utf8 setting +########### + +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +select STDOUT; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; binmode IN, ":utf8"; +sub readstderr { return join("", <IN>); } + +END { unlink $TMP_FILE; + close IN; + } + +Log::Log4perl->easy_init({ + level => $DEBUG, + file => "STDERR", + utf8 => 1, +}); + +use utf8; +DEBUG "Über"; +binmode STDOUT, ":utf8"; # for better error messages of the test suite +like(readstderr(), qr/Über/, 'utf8 matches'); + +########### +# utf8 config file +########### +use Log::Log4perl::Config; +Log::Log4perl::Config->utf8(1); +Log::Log4perl->init("$EG_DIR/log4j-utf8.conf"); +DEBUG "blech"; +my $app = Log::Log4perl::Appender::TestBuffer->by_name("Ä1"); +ok defined $app, "app found"; +my $buf = $app->buffer(); +is $buf, "blech\n", "utf8 named appender"; diff --git a/t/053Resurrect.t b/t/053Resurrect.t new file mode 100644 index 0000000..5c21132 --- /dev/null +++ b/t/053Resurrect.t @@ -0,0 +1,38 @@ +########################################### +# Test Suite for Log::Log4perl::Resurrector +# Mike Schilli, 2007 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use Test::More; +use Log::Log4perl qw(:easy); + +BEGIN { + my $eg = "eg"; + $eg = "../eg" unless -d $eg; + push @INC, $eg; +}; + +use Log::Log4perl::Resurrector; +use L4pResurrectable; + +plan tests => 1; + +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + +L4pResurrectable::foo(); +is($buffer->buffer(), "DEBUG - foo was here\nINFO - bar was here\n", + "resurrected statement"); diff --git a/t/054Subclass.t b/t/054Subclass.t new file mode 100644 index 0000000..0772d99 --- /dev/null +++ b/t/054Subclass.t @@ -0,0 +1,29 @@ +########################################### +# Test Suite for Log::Log4perl::Level +# Mike Schilli, 2008 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +########################################### + # Subclass L4p +package Mylogger; +use strict; +use Log::Log4perl; +our @ISA = qw(Log::Log4perl); + +########################################### +package main; +use strict; + +use Test::More; + +plan tests => 1; + +my $logger = Mylogger->get_logger("Waah"); +is($logger->{category}, "Waah", "subclass category rt #32942"); diff --git a/t/055AppDestroy.t b/t/055AppDestroy.t new file mode 100755 index 0000000..3b73c9e --- /dev/null +++ b/t/055AppDestroy.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl +################################################################### +# Check if a custom appender with a destroy handler gets its +# warning through +################################################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +package SomeAppender; +our @ISA = qw(Log::Log4perl::Appender); +sub new { + bless {}, shift; +} +sub log {} +sub DESTROY { + warn "Horrible Warning!"; +} + +package main; +use warnings; +use strict; +use Test::More; +use Log::Log4perl qw(:easy); + +my $warnings; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +my $conf = q( +log4perl.category = DEBUG, SomeA +log4perl.appender.SomeA = SomeAppender +log4perl.appender.SomeA.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$conf); + +plan tests => 1; + +my $logger = get_logger(); +$logger->debug("foo"); + +Log::Log4perl::Logger->cleanup(); + +END { + like $warnings, qr/Horrible Warning!/, "app destruction warning caught"; +} diff --git a/t/056SyncApp2.t b/t/056SyncApp2.t new file mode 100644 index 0000000..6c0841c --- /dev/null +++ b/t/056SyncApp2.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl +########################################################################## +# The test checks Log::Log4perl::Appender::Synchronized for correct semaphore +# destruction when using parameter "destroy". +# Based on: 042SyncApp.t +# Jens Berthold, 2009 (log4perl@jebecs.de) +########################################################################## +use warnings; +use strict; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl qw(:easy); +Log::Log4perl->easy_init($DEBUG); +use constant INTERNAL_DEBUG => 0; + +our $INTERNAL_DEBUG = 0; + +$| = 1; + +BEGIN { + if(exists $ENV{"L4P_ALL_TESTS"}) { + plan tests => 1; + } else { + plan skip_all => "- only with L4P_ALL_TESTS"; + } +} + +use Log::Log4perl::Util::Semaphore; +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::Synchronized; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $logfile = "$EG_DIR/fork.log"; + +our $lock; + +unlink $logfile; + +my $conf = qq( +log4perl.category.Bar.Twix = WARN, Syncer + +log4perl.appender.Logfile = Log::Log4perl::Appender::TestFileCreeper +log4perl.appender.Logfile.autoflush = 1 +log4perl.appender.Logfile.filename = $logfile +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %F{1}%L> %m%n + +log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized +log4perl.appender.Syncer.appender = Logfile +log4perl.appender.Syncer.key = blah +log4perl.appender.Syncer.destroy = 1 +); + +Log::Log4perl::init(\$conf); + +my $pid = fork(); + +die "fork failed" unless defined $pid; + +my $logger = get_logger("Bar::Twix"); +if($pid) { + # parent + # no logging test here: if child erroneously deletes semaphore, + # any log output at this point would crash the test +} else { + # child + exit 0; +} + +# Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; +unlink $logfile; + +# Destroying appender (+semaphore) fails if child process already destroyed it +Log::Log4perl->appender_by_name('Syncer')->DESTROY(); +ok(!$@, "Destroying appender"); + diff --git a/t/057MsgChomp.t b/t/057MsgChomp.t new file mode 100755 index 0000000..b3c047b --- /dev/null +++ b/t/057MsgChomp.t @@ -0,0 +1,88 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +BEGIN { plan tests => 4 }; + +use Log::Log4perl qw(:easy); + +######################################################### +# double newline +######################################################### +my $conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %d %F{1} %L> %m%n +); + +Log::Log4perl->init( \$conf ); +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; + +unlike($buf->buffer(), qr/blah\n\n/); + +######################################################### +# turn default %m%n chomping feature off +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %d %F{1} %L> %m%n + log4perl.appender.Buffer.layout.message_chomp_before_newline = 0 +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; +like($buf->buffer(), qr/blah\n\n/); + +######################################################### +# %m without chomp +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %m foo %n +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +like($buf->buffer(), qr/blah\n foo/); + +######################################################### +# try %m{chomp} +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %m{chomp} foo %n +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; +like($buf->buffer(), qr/blah foo /); diff --git a/t/058Warnings.t b/t/058Warnings.t new file mode 100644 index 0000000..4dbb464 --- /dev/null +++ b/t/058Warnings.t @@ -0,0 +1,25 @@ + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl qw(:nostrict); + +plan tests => 1; + +my $warnings; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +Log::Log4perl->init( "$EG_DIR/dupe-warning.conf" ); + +is($warnings, undef, "no warnings"); diff --git a/t/059Wrapper.t b/t/059Wrapper.t new file mode 100755 index 0000000..9c34239 --- /dev/null +++ b/t/059Wrapper.t @@ -0,0 +1,94 @@ +#!/usr/local/bin/perl -w + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use Log::Log4perl qw(:easy); + +############################################ +# Tests for Log4perl used by a wrapper class +# Mike Schilli, 2009 (m@perlmeister.com) +########################################### +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 12 } + +########################################### +package L4p::RelayWrapper; +########################################### +no strict qw(refs); +sub get_logger; +Log::Log4perl->wrapper_register(__PACKAGE__); + +*get_logger = sub { + + my @args = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if(defined $args[0] and $args[0] eq __PACKAGE__) { + my $pkg = __PACKAGE__; + $args[0] =~ s/$pkg/Log::Log4perl/g; + } + Log::Log4perl::get_logger( @args ); +}; + +########################################### +package L4p::InheritWrapper; +########################################### +our @ISA = qw(Log::Log4perl); +Log::Log4perl->wrapper_register(__PACKAGE__); + +########################################### +package main; +########################################### + +use Log::Log4perl qw(get_logger); + +my $pkg = "Wobble::Cobble"; +my $pkgcat = "Wobble.Cobble"; + +my $logger; + +$logger = get_logger(); +is $logger->{category}, "main", "imported get_logger()"; + +$logger = get_logger( $pkg ); +is $logger->{category}, $pkgcat, "imported get_logger($pkg)"; + +for my $class (qw(Log::Log4perl + L4p::RelayWrapper + L4p::InheritWrapper)) { + + no strict 'refs'; + + my $func = "$class\::get_logger"; + + if($class !~ /Inherit/) { + # wrap::() + $logger = $func->(); + is $logger->{category}, "main", "$class\::()"; + + $logger = $func->( $pkg ); + is $logger->{category}, $pkgcat, "$class\::($pkg)"; + } + + # wrap->() + $logger = $class->get_logger(); + is $logger->{category}, "main", "$class->()"; + + $logger = $class->get_logger($pkg); + is $logger->{category}, $pkgcat, "$class->($pkg)"; +} + +# use Data::Dumper; +# print Dumper($logger; diff --git a/t/060Initialized.t b/t/060Initialized.t new file mode 100644 index 0000000..5a13e5e --- /dev/null +++ b/t/060Initialized.t @@ -0,0 +1,44 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 3; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +eval { + Log::Log4perl->init('nonexistant_file'); +}; + +ok((not Log::Log4perl->initialized()), 'Failed init doesn\'t flag initialized'); + +Log::Log4perl->reset(); + +eval { + Log::Log4perl->init_once('nonexistant_file'); +}; + +ok((not Log::Log4perl->initialized()), 'Failed init_once doesn\'t flag ' + .'initialized'); + +Log::Log4perl->reset(); + +eval { + Log::Log4perl->init(\ <<EOT); +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c - %m%n +EOT +}; + +ok(Log::Log4perl->initialized(), 'init flags initialized'); + +1; # End of 060Initialized.t diff --git a/t/061Multiline.t b/t/061Multiline.t new file mode 100644 index 0000000..4d92460 --- /dev/null +++ b/t/061Multiline.t @@ -0,0 +1,35 @@ + +# https://rt.cpan.org/Public/Bug/Display.html?id=60197 + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; +use Log::Log4perl::Layout::PatternLayout::Multiline; + +use Test::More tests => 1; + +my $logger = Log::Log4perl->get_logger("blah"); + +my $layout = Log::Log4perl::Layout::PatternLayout::Multiline->new; + +my $logfile = "./file.log"; + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => 'foo', + filename => './file.log', + mode => 'append', + autoflush => 1, + ); + +# Set the appender's layout +$appender->layout($layout); +$logger->add_appender($appender); + +# this message will be split into [], leading to undef being logged, +# which will cause most appenders (e.g. ::File) to warn +$appender->log({ level => 1, message => "\n\n" }, 'foo_category', 'INFO'); + +ok(1, "no warnings should appear here"); + +unlink $logfile; diff --git a/t/062InitHash.t b/t/062InitHash.t new file mode 100644 index 0000000..07996c3 --- /dev/null +++ b/t/062InitHash.t @@ -0,0 +1,27 @@ + +# https://rt.cpan.org/Public/Bug/Display.html?id=68105 + +my $logfile = "test.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; + +use Test::More tests => 1; + +Log::Log4perl->init({ + 'log4perl.rootLogger' => 'ALL, FILE', + 'log4perl.appender.FILE' => + 'Log::Log4perl::Appender::File', + 'log4perl.appender.FILE.filename' => sub { "$logfile" }, + 'log4perl.appender.FILE.layout' => 'SimpleLayout', +}); + +Log::Log4perl->get_logger->debug('yee haw'); + +open FILE, "<$logfile" or die $!; +my $data = join '', <FILE>; +close FILE; + +is( $data, "DEBUG - yee haw\n", "hash-init with subref" ); diff --git a/t/063LoggerRemove.t b/t/063LoggerRemove.t new file mode 100755 index 0000000..508f08a --- /dev/null +++ b/t/063LoggerRemove.t @@ -0,0 +1,56 @@ +# http://stackoverflow.com/questions/5914088 and +# https://github.com/mschilli/log4perl/issues/7 + +use strict; +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +plan tests => 6; + +use Log::Log4perl qw(get_logger :easy); + +# $Log::Log4perl::CHATTY_DESTROY_METHODS = 1; + +my $conf = q( +log4perl.category.main = WARN, LogBuffer +log4perl.category.Bar.Twix = WARN, LogBuffer +log4perl.appender.LogBuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.LogBuffer.layout = \ +Log::Log4perl::Layout::PatternLayout +log4perl.appender.LogBuffer.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +Log::Log4perl::init(\$conf); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("LogBuffer"); + +my $logger = get_logger("Bar::Twix"); + +ok(exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"Bar.Twix"}, + "logger exists"); + +Log::Log4perl->remove_logger( $logger ); +undef $logger; + +ok(!exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"Bar.Twix"}, + "logger gone"); + +# now remove a stealth logger +$logger = get_logger("main"); + +ok(exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"main"}, + "logger exists"); + +WARN "before"; + +Log::Log4perl->remove_logger( $logger ); +undef $logger; + +ok(!exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"main"}, + "logger gone"); + + # this should be a no-op now. +WARN "after"; + +like($buffer->buffer, qr/before/, "log message before logger removal present"); +unlike($buffer->buffer, qr/after/, "log message after logger removal absent"); diff --git a/t/064RealClass.t b/t/064RealClass.t new file mode 100755 index 0000000..8a53782 --- /dev/null +++ b/t/064RealClass.t @@ -0,0 +1,44 @@ +# get_logger($self) in the base class returns a logger for the subclass +# category + +use strict; +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +plan tests => 1; + +package AppBaseClass; +use Log::Log4perl qw(get_logger :easy); +sub meth { + my( $self ) = @_; + get_logger( ref $self )->warn("in base class"); +} + +package AppSubClass; +our @ISA = qw(AppBaseClass); +use Log::Log4perl qw(get_logger :easy); +sub new { + bless {}, shift; +} + +package main; + +use Log::Log4perl qw(get_logger :easy); + +# $Log::Log4perl::CHATTY_DESTROY_METHODS = 1; + +my $conf = q( +log4perl.category.AppSubClass = WARN, LogBuffer +log4perl.appender.LogBuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.LogBuffer.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.LogBuffer.layout.ConversionPattern = %m%n +); + +Log::Log4perl::init(\$conf); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("LogBuffer"); + +my $sub = AppSubClass->new(); +$sub->meth(); + +is $buffer->buffer(), "in base class\n", "subclass logger in base class"; diff --git a/t/065Undef.t b/t/065Undef.t new file mode 100644 index 0000000..31447e5 --- /dev/null +++ b/t/065Undef.t @@ -0,0 +1,28 @@ +use strict; + +use File::Temp qw( tempfile ); + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +my($tmpfh, $tempfile) = tempfile( UNLINK => 1 ); + +use Test::More; +BEGIN { plan tests => 1 }; +use Log::Log4perl qw( :easy ); + +Log::Log4perl->easy_init( { level => $DEBUG, file => $tempfile } ); + +my $warnings = ""; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +DEBUG "foo", undef, "bar"; + +like $warnings, qr/Log message argument #2/, "warning for undef element issued"; diff --git a/t/066SQLite.t b/t/066SQLite.t new file mode 100644 index 0000000..1de4f47 --- /dev/null +++ b/t/066SQLite.t @@ -0,0 +1,96 @@ +########################################### +# Test DBI appender with SQLite +########################################### + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +use Test::More; +use Log::Log4perl; +use warnings; +use strict; + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBI; + die if $DBI::VERSION < $minversion->{ "DBI" }; + + require DBD::SQLite; + }; + if ($@) { + plan skip_all => + "DBI $minversion->{ DBI } " . + "not installed, skipping tests\n"; + }else{ + plan tests => 3; + } +} + +my $testdir = "t/tmp"; +mkdir $testdir; + +my $dbfile = "$testdir/sqlite.dat"; + +END { + unlink $dbfile; + rmdir $testdir; +} + +require DBI; + +unlink $dbfile; +my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","",""); + + # https://rt.cpan.org/Public/Bug/Display.html?id=79960 + # undef as NULL +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + mdc char(16) + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + +my $config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = dbi:SQLite:dbname=$dbfile +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, mdc, message) \\ + values (?, ?, ?) +log4j.appender.DBAppndr.params.1 = %p +log4j.appender.DBAppndr.params.2 = %X{foo} +#---------------------------- #3 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + + #noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout +EOT + +Log::Log4perl::init(\$config); + +my $logger = Log::Log4perl->get_logger(); +$logger->warn('test message'); + +my $ary_ref = $dbh->selectall_arrayref( "SELECT * from $table_name" ); +is $ary_ref->[0]->[0], "WARN", "level logged in db"; +is $ary_ref->[0]->[1], "test message", "msg logged in db"; +is $ary_ref->[0]->[2], undef, "msg logged in db"; diff --git a/t/067Exception.t b/t/067Exception.t new file mode 100644 index 0000000..fba3235 --- /dev/null +++ b/t/067Exception.t @@ -0,0 +1,25 @@ +use strict; + +use File::Temp qw( tempfile ); +use Log::Log4perl qw( get_logger ); +use Test::More; + +plan tests => 1; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +eval { + foo(); +}; + +like $@, qr/main::foo/, "stacktrace on internal error"; + +sub foo { + Log::Log4perl::Logger->cleanup(); + my $logger = get_logger(); +} diff --git a/t/068MultilineIndented.t b/t/068MultilineIndented.t new file mode 100644 index 0000000..275ce98 --- /dev/null +++ b/t/068MultilineIndented.t @@ -0,0 +1,81 @@ +my $logfile = "./file.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; +use Log::Log4perl::Layout::PatternLayout; + +use Test::More tests => 1; + +my $logger = Log::Log4perl->get_logger("blah"); + +# 1 19 +# | | +# %d : yyyy/mm/dd hh:mm:ss +my $layout = Log::Log4perl::Layout::PatternLayout->new("%d > %m{indent}%n"); + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => 'foo', + filename => './file.log', + mode => 'append', + autoflush => 1, + ); + +# Set the appender's layout +$appender->layout($layout); +$logger->add_appender($appender); + +my $msg =<<"EOF_MSG"; +This is +a message with +multiple lines +EOF_MSG + +chomp($msg); + +$appender->log({ level => 1, message => $msg }, 'foo_category', 'INFO'); + +# TEST : +# +# Just one test if format of log file is correct. +# Any error of check_log_file_format() is returned as non empty string and +# appended to $test_name to explain what went wrong. +# +my $err_str = check_log_file_format($logfile); +my $test_name = 'log file has multiline intended format' . ($err_str ? " - reason : $err_str" : ""); +ok ( ! $err_str, $test_name ); + +# returns "" on success +# returns non empty error string on failure +sub check_log_file_format { + my $logfile = shift; + + my $err_str = ""; + my $line_count = 1; + open(my $fh, "<", $logfile) || return "could not open log file '$logfile'"; + + for my $line (<$fh>) { + if ($line_count == 1) { + # 1 19 + # | | + # yyyy/mm/dd hh:mm:ss > %m + unless ( $line =~ m!^\d{4}/\d{2}/\d{2} \d{2}:\d{2}:\d{2} > This is\s*$! ) { + $err_str = "first line wrong, should be: yyyy/mm/dd hh::mm::ss This is" ; + last; + } + } + else { + unless ( $line =~ /^ {22}\S/ ) { + $err_str = "format of line $line_count wrong"; + last; + } + } + $line_count++; + } + + close($fh); + + return $err_str; +} diff --git a/t/069MoreMultiline.t b/t/069MoreMultiline.t new file mode 100644 index 0000000..42d05b6 --- /dev/null +++ b/t/069MoreMultiline.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +my $logfile = "./file.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::Layout::PatternLayout; + +use Test::More tests => 4; + +my $logger = Log::Log4perl->get_logger("blah"); + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => 'testbuffer', +); +$logger->add_appender($appender); + +my $msg = "line1\nline2\nline3\n"; +my $logit = sub { + $appender->log({ level => 1, message => $msg }, 'foo_category', 'INFO'); +}; + +# indent=fix +my $layout = Log::Log4perl::Layout::PatternLayout->new("%m{indent=2}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "line1\n line2\n line3\n ", "indent=2"; +$appender->buffer(""); + +# indent=fix,chomp +$layout = Log::Log4perl::Layout::PatternLayout->new("%m{indent=2,chomp}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "line1\n line2\n line3", "indent=2,chomp"; +$appender->buffer(""); + +# indent=variable +$layout = Log::Log4perl::Layout::PatternLayout->new("123%m{indent}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "123line1\n line2\n line3\n ", "indent"; +$appender->buffer(""); + +# indent=variable,chomp +$layout = Log::Log4perl::Layout::PatternLayout->new("123%m{indent,chomp}"); +$appender->layout($layout); +$logit->(); +#print "[", $appender->buffer(), "]\n"; +is $appender->buffer(), "123line1\n line2\n line3", "indent,chomp"; +$appender->buffer(""); diff --git a/t/070UTCDate.t b/t/070UTCDate.t new file mode 100644 index 0000000..4707299 --- /dev/null +++ b/t/070UTCDate.t @@ -0,0 +1,42 @@ +########################################### +# Tests for Log4perl::DateFormat with gmtime +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 2 } + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::TestBuffer; + +sub init_with_utc { + my ($utc) = @_; + my $conf = <<'CONF'; +log4perl.category.Bar.Twix = WARN, Buffer +log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buffer.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.Buffer.layout.ConversionPattern = %d{HH:mm:ss}%n +CONF + if (defined $utc) { + $conf .= "log4perl.utcDateTimes = $utc\n"; + } + + Log::Log4perl::init(\$conf); +} + +init_with_utc(1); +ok $Log::Log4perl::DateFormat::GMTIME, "init_with_utc"; + +init_with_utc(0); +ok ! $Log::Log4perl::DateFormat::GMTIME, "init_with_utc"; diff --git a/t/compare.pl b/t/compare.pl new file mode 100644 index 0000000..6b58317 --- /dev/null +++ b/t/compare.pl @@ -0,0 +1,86 @@ +#Lifted this code from Data::Compare by Fabien Tassin fta@sofaraway.org . +#Using it in the XML tests + +use Carp; + +sub Compare { + croak "Usage: Data::Compare::Compare(x, y)\n" unless $#_ == 1; + my $x = shift; + my $y = shift; + + my $refx = ref $x; + my $refy = ref $y; + + unless ($refx || $refy) { # both are scalars + return $x eq $y if defined $x && defined $y; # both are defined + !(defined $x || defined $y); + } + elsif ($refx ne $refy) { # not the same type + 0; + } + elsif ($x == $y) { # exactly the same reference + 1; + } + elsif ($refx eq 'SCALAR') { + Compare($$x, $$y); + } + elsif ($refx eq 'ARRAY') { + if ($#$x == $#$y) { # same length + my $i = -1; + for (@$x) { + $i++; + return 0 unless Compare($$x[$i], $$y[$i]); + } + 1; + } + else { + 0; + } + } + elsif ($refx eq 'HASH') { + return 0 unless scalar keys %$x == scalar keys %$y; + for (keys %$x) { + next unless defined $$x{$_} || defined $$y{$_}; + return 0 unless defined $$y{$_} && Compare($$x{$_}, $$y{$_}); + } + 1; + } + elsif ($refx eq 'REF') { + 0; + } + elsif ($refx eq 'CODE') { + 1; #changed for log4perl, let's just accept coderefs + } + elsif ($refx eq 'GLOB') { + 0; + } + else { # a package name (object blessed) + my ($type) = "$x" =~ m/^$refx=(\S+)\(/o; + if ($type eq 'HASH') { + my %x = %$x; + my %y = %$y; + Compare(\%x, \%y); + } + elsif ($type eq 'ARRAY') { + my @x = @$x; + my @y = @$y; + Compare(\@x, \@y); + } + elsif ($type eq 'SCALAR') { + my $x = $$x; + my $y = $$y; + Compare($x, $y); + } + elsif ($type eq 'GLOB') { + 0; + } + elsif ($type eq 'CODE') { + 1; #changed for log4perl, let's just accept coderefs + } + else { + croak "Can't handle $type type."; + } + } +} + +1; diff --git a/t/deeper1.expected b/t/deeper1.expected new file mode 100644 index 0000000..e52bce6 --- /dev/null +++ b/t/deeper1.expected @@ -0,0 +1,14 @@ +INFO plant N/A - info message 1 +WARN plant N/A - warning message 1 +FATAL plant N/A - fatal message 1 +DEBUG animal.dog N/A - debugging message 2 +INFO animal.dog N/A - info message 2 +WARN animal.dog N/A - warning message 2 +FATAL animal.dog N/A - fatal message 2 +INFO animal N/A - info message 3 +WARN animal N/A - warning message 3 +FATAL animal N/A - fatal message 3 +DEBUG animal.dog.leg.toenail N/A - debug message +INFO animal N/A - info message +WARN animal.dog.leg.toenail N/A - warning message +FATAL animal N/A - fatal message diff --git a/t/deeper6.expected b/t/deeper6.expected new file mode 100644 index 0000000..07fbf90 --- /dev/null +++ b/t/deeper6.expected @@ -0,0 +1,13 @@ +INFO a - should print for a, a.b, a.b.c +INFO a.b - should print for a, a.b, a.b.c +INFO a.b.c - should print for a, a.b, a.b.c +WARN a - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c.d - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c.d.e - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c.d - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c.d.e - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e diff --git a/t/deeper7.expected b/t/deeper7.expected new file mode 100644 index 0000000..1234132 --- /dev/null +++ b/t/deeper7.expected @@ -0,0 +1,12 @@ +INFO xa.b.c.d - should print for xa.b.c.d, xa.b.c.d.e +INFO xa.b.c.d.e - should print for xa.b.c.d, xa.b.c.d.e +WARN xa - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c.d - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c.d.e - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c.d - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c.d.e - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e diff --git a/t/lib/Log4perlInternalTest.pm b/t/lib/Log4perlInternalTest.pm new file mode 100755 index 0000000..233cd03 --- /dev/null +++ b/t/lib/Log4perlInternalTest.pm @@ -0,0 +1,62 @@ +package Log::Log4perl::Internal::Test; +use strict; +use warnings; + +# We don't require any of these modules for testing, but if they're +# installed, we require minimal versions. + +our %MINVERSION = qw( + DBI 1.607 + DBD::CSV 0.33 + SQL::Statement 1.20 +); + +1; + +__END__ + +=head1 NAME + +Log::Log4perl::Internal::Test - Internal Test Utilities for Log4perl + +=head1 SYNOPSIS + + use Log::Log4perl::Internal::Test; + +=head1 DESCRIPTION + +Some general-purpose test routines and constants to be used in the Log4perl +test suite. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli <m@perlmeister.com>, +Kevin Goess <cpan@goess.org> + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> +and Kevin Goess E<lt>cpan@goess.orgE<gt>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + diff --git a/t/testdisp.pl b/t/testdisp.pl new file mode 100644 index 0000000..a1911db --- /dev/null +++ b/t/testdisp.pl @@ -0,0 +1,52 @@ +################################################## +# String dispatcher for testing +################################################## + +package Log::Dispatch::String; + +use Log::Dispatch::Output; +use base qw( Log::Dispatch::Output ); +use fields qw( stderr ); + +sub new +{ + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = bless {}, $class; + + $self->_basic_init(%params); + $self->{stderr} = exists $params{stderr} ? $params{stderr} : 1; + $self->{buffer} = ""; + + return $self; +} + +sub log_message +{ + my $self = shift; + my %params = @_; + + $self->{buffer} .= $params{message}; +} + +sub buffer +{ + my($self, $new) = @_; + + if(defined $new) { + $self->{buffer} = $new; + } + + return $self->{buffer}; +} + +sub reset +{ + my($self) = @_; + + $self->{buffer} = ""; +} + +1; |