1#!/usr/bin/perl 2 3# $Id: 024WarnDieCarp.t,v 1.1 2002/08/29 05:33:28 mschilli Exp $ 4 5# Check the various logFOO for FOO in {die, warn, Carp*} 6 7# note: I <erik@selberg.com> prefer Test::Simple to just Test. 8 9###################################################################### 10# 11# This is a fairly simply smoketest... it basically runs the gamut of 12# the warn / die / croak / cluck / confess / carp family and makes sure 13# that the log output contained the appropriate string and STDERR 14# contains the appropriate string. 15# 16###################################################################### 17 18BEGIN { 19 if($ENV{INTERNAL_DEBUG}) { 20 require Log::Log4perl::InternalDebug; 21 Log::Log4perl::InternalDebug->enable(); 22 } 23} 24 25use warnings; 26use strict; 27 28use Test::More; 29use Log::Log4perl qw(get_logger :easy); 30use Log::Log4perl::Level; 31use File::Spec; use Data::Dumper; 32 33BEGIN { 34 if ($] < 5.006) { 35 plan skip_all => "Only with perl >= 5.006"; 36 } else { 37 plan tests => 73; 38 } 39} 40 41my $warnstr; 42 43# this nullifies warns and dies here... so testing the testscript may suck. 44local $SIG{__WARN__} = sub { $warnstr = join("", @_); }; 45local $SIG{__DIE__} = sub { $warnstr = join("", @_); }; 46 47sub warndietest { 48 my ($method, $in_str, $out_str, $app, $mname) = @_; 49 50 eval { &$method($in_str) }; 51 52 like($warnstr, qr/$out_str/, 53 "$mname($in_str): STDERR contains \"$out_str\""); 54 like($app->buffer(), qr/$out_str/, 55 "$mname($in_str): Buffer contains \"$out_str\""); 56 $app->buffer(""); 57} 58 59# same as above, just look for no output 60sub warndietest_nooutput { 61 my ($method, $in_str, $out_str, $app, $mname) = @_; 62 63 eval { &$method($in_str) }; 64 65 unlike($warnstr, qr/\Q$out_str\E/, 66 "$mname($in_str): STDERR does NOT contain \"$out_str\""); 67 unlike($app->buffer(), qr/$out_str/, 68 "$mname($in_str): Buffer does NOT contain \"$out_str\""); 69} 70 71# warn() still prints to stderr, but nothing gets logged 72sub warndietest_stderronly { 73 my ($method, $in_str, $out_str, $app, $mname) = @_; 74 75 eval { &$method($in_str) }; 76 77 my($pkg, $file, $line) = caller(); 78 79 # it's in stderr 80 like($warnstr, qr/\Q$out_str\E/, 81 "$mname($in_str): STDERR does contain \"$out_str\" ($file:$line)"); 82 # but not logged by log4perl 83 unlike($app->buffer(), qr/$out_str/, 84 "$mname($in_str): Buffer does NOT contain \"$out_str\" ($file:$line)"); 85} 86 87# same as above, just look for no output in buffer, but output in STDERR 88sub dietest_nooutput { 89 my ($method, $in_str, $out_str, $app, $mname) = @_; 90 91 eval { &$method($in_str) }; 92 93 like($warnstr, qr/$out_str/, "$mname($in_str): STDERR contains \"$out_str\""); 94 unlike($app->buffer(), qr/$out_str/, 95 "$mname($in_str): Buffer does NOT contain \"$out_str\""); 96} 97 98 99ok(1, "Initialized OK"); 100 101############################################################ 102# Get a logger and use it without having called init() first 103############################################################ 104my $log = Log::Log4perl::get_logger("abc.def"); 105my $app = Log::Log4perl::Appender->new( 106 "Log::Log4perl::Appender::TestBuffer"); 107$log->add_appender($app); 108 109###################################################################### 110# lets start testing! 111 112$log->level($DEBUG); 113 114my $test = 1; 115 116###################################################################### 117# sanity: make sure the tests spit out FOO to the buffer and STDERR 118 119foreach my $f ("logwarn", "logdie", "logcarp", "logcroak", "logcluck", 120 "logconfess", "error_warn", "error_die") { 121 warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); 122 $test++; 123} 124 125###################################################################### 126# change the log level to ERROR... warns should produce nothing in 127# log4perl now, but logwarn still triggers warn() 128 129$log->level($ERROR); 130 131foreach my $f ("logdie", "logcroak", 132 "logconfess", "error_warn", "error_die") { 133 warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); 134 $test++; 135} 136 137foreach my $f ("logwarn", "logcarp", "logcluck", 138 ) { 139 warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); 140 $test++; 141} 142 143###################################################################### 144# change logging to OFF... FATALs still produce output though. 145 146$log->level($OFF); # $OFF == $FATAL... although I suspect thats a bug in the log4j spec 147 148foreach my $f ("logwarn", "logcarp", "logcluck", "error_warn") { 149 warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); 150 $test++; 151} 152 153foreach my $f ("error_die", "logdie", "logcroak", "logconfess") { 154 dietest_nooutput(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); 155 $test++; 156} 157 158###################################################################### 159# Check if logdie %F%L lists the right file/line 160###################################################################### 161Log::Log4perl->init(\<<'EOT'); 162 log4perl.rootLogger=DEBUG, A1 163 log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer 164 log4perl.appender.A1.layout=org.apache.log4j.PatternLayout 165 log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m 166EOT 167 168my $logger = get_logger("Twix::Bar"); 169 170my $line_number = __LINE__ + 1; 171eval { $logger->logdie("Log and die!"); }; 172 173my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); 174# print "Buffer: ", $app0->buffer(), "\n"; 175 176like($app0->buffer(), qr/024WarnDieCarp.t-$line_number: Log and die!/, 177 "%F-%L adjustment"); 178 179###################################################################### 180# Check if logcarp/cluck/croak are reporting the calling package, 181# not the one the error happened in. 182###################################################################### 183$app0->buffer(""); 184 185package Weirdo; 186our $foo_line; 187our $bar_line; 188 189use Log::Log4perl qw(get_logger); 190sub foo { 191 my $logger = get_logger("Twix::Bar"); 192 $foo_line = __LINE__ + 1; 193 $logger->logcroak("Inferno!"); 194} 195sub bar { 196 my $logger = get_logger("Twix::Bar"); 197 $bar_line = __LINE__ + 1; 198 $logger->logdie("Inferno!"); 199} 200 201package main; 202eval { Weirdo::foo(); }; 203 204like($app0->buffer(), qr/$Weirdo::foo_line/, 205 "Check logcroak/Carp"); 206 207$app0->buffer(""); 208eval { Weirdo::bar(); }; 209 210like($app0->buffer(), qr/$Weirdo::bar_line/, 211 "Check logdie"); 212 213###################################################################### 214# Check if logcarp/cluck/croak are reporting the calling package, 215# when they are more than one hierarchy from the top. 216###################################################################### 217$app0->buffer(""); 218 219package Foo; 220our $foo_line; 221use Log::Log4perl qw(get_logger); 222sub foo { 223 my $logger = get_logger("Twix::Bar"); 224 $foo_line = __LINE__ + 1; 225 $logger->logcarp("Inferno!"); 226} 227 228package Bar; 229sub bar { 230 Foo::foo(); 231} 232 233package main; 234eval { Bar::bar(); }; 235 236SKIP: { 237 use Carp; 238 skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless 239 defined $Carp::VERSION; 240 like($app0->buffer(), qr/$Foo::foo_line/, 241 "Check logcarp"); 242} 243 244###################################################################### 245# Test fix of bug that had logwarn/die/etc print unformatted messages. 246###################################################################### 247$logger = get_logger("Twix::Bar"); 248$log->level($DEBUG); 249 250eval { $logger->logdie(sub { "a" . "-" . "b" }); }; 251like($@, qr/a-b/, "bugfix: logdie with sub{} as argument"); 252 253$logger->logwarn(sub { "a" . "-" . "b" }); 254like($warnstr, qr/a-b/, "bugfix: logwarn with sub{} as argument"); 255 256$logger->logwarn({ filter => \&Dumper, 257 value => "a-b" }); 258like($warnstr, qr/a-b/, "bugfix: logwarn with sub{filter/value} as argument"); 259 260eval { $logger->logcroak({ filter => \&Dumper, 261 value => "a-b" }); }; 262like($warnstr, qr/a-b/, "bugfix: logcroak with sub{} as argument"); 263 264###################################################################### 265# logcroak/cluck/carp/confess level test 266###################################################################### 267our($carp_line, $call_line); 268 269package Foo1; 270use Log::Log4perl qw(:easy); 271sub foo { get_logger("Twix::Bar")->logcarp("foocarp"); $carp_line = __LINE__ } 272 273package Bar1; 274sub bar { Foo1::foo(); $call_line = __LINE__; } 275 276package main; 277 278my $l4p_app = $Log::Log4perl::Logger::APPENDER_BY_NAME{"A1"}; 279my $layout = Log::Log4perl::Layout::PatternLayout->new("%M#%L %m%n"); 280$l4p_app->layout($layout); 281 282$app0->buffer(""); 283Foo1::foo(); $call_line = __LINE__; 284 # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 285like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, 286 "carp in subfunction"); 287 # foocarp at 024WarnDieCarp.t line 250 288like($warnstr, qr/foocarp.*line $call_line/, "carp output"); 289 290$app0->buffer(""); 291Bar1::bar(); 292 293SKIP: { 294 use Carp; 295 skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless 296 defined $Carp::VERSION; 297 298 # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 299 like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, 300 "carp in sub-sub-function"); 301} 302 303 # foocarp at 024WarnDieCarp.t line 250 304like($warnstr, qr/foocarp.*line $call_line/, "carp output"); 305 306###################################################################### 307# logconfess fix (1.12) 308###################################################################### 309$app0->buffer(""); 310 311package Foo1; 312sub new { 313 my($class) = @_; 314 bless {}, $class; 315} 316 317sub foo1 { 318 my $log = get_logger(); 319 $log->logconfess("bah!"); 320} 321 322package main; 323 324my $foo = Foo1->new(); 325eval { $foo->foo1() }; 326 327like $@, qr/024WarnDieCarp.*Foo1::foo1.*eval/s, "Confess logs correct frame"; 328 329###################################################################### 330# logdie/warn caller level bug 331###################################################################### 332Log::Log4perl->init(\<<'EOT'); 333 log4perl.rootLogger=DEBUG, A1 334 log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer 335 log4perl.appender.A1.layout=org.apache.log4j.PatternLayout 336 log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m 337EOT 338 339$logger = get_logger("Twix::Bar"); 340 341$logger->logwarn("warn!"); 342like $warnstr, qr/024WarnDieCarp/, "logwarn() caller depth bug"; 343unlike $warnstr, qr/Logger.pm/, "logwarn() caller depth bug"; 344 345$Log::Log4perl::Logger::DIE_DEBUG = 1; 346$logger->logdie("die!"); 347like $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/024WarnDieCarp/, 348 "logdie() caller depth bug"; 349unlike $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/Logger.pm/, 350 "logdie() caller depth bug"; 351 352my $app3 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); 353$app3->buffer(""); 354 355my $line1 = __LINE__ + 1; 356subroutine(); 357 358my $line2; 359sub subroutine { 360 $line2 = __LINE__ + 1; 361 $logger->logcluck("cluck!"); 362} 363 364like $app3->buffer(), qr/-$line2: cluck!/, "logcluck()"; 365like $app3->buffer(), qr/main::subroutine\(\) called .* line $line1/, 366 "logcluck()"; 367 368# Carp test 369 370$app3->buffer(""); 371my $line3 = __LINE__ + 1; 372subroutine_carp(); 373 374my $line4; 375sub subroutine_carp { 376 $line4 = __LINE__ + 1; 377 $logger->logcarp("carp!"); 378} 379 380like $app3->buffer(), qr/-$line4: carp!/, "logcarp()"; 381like $app3->buffer(), qr/main::subroutine_carp\(\) called .* line $line3/, 382 "logcarp()"; 383 384# Stringify test 385$Log::Log4perl::Logger::DIE_DEBUG = 0; 386$Log::Log4perl::STRINGIFY_DIE_MESSAGE = 0; 387 388eval { 389 $logger->logcroak( { foo => "bar" } ); 390}; 391 392is $@->{ foo }, "bar", "croak without stringify"; 393 394eval { 395 $logger->logconfess( { foo => "bar" } ); 396}; 397 398is $@->{ foo }, "bar", "confess without stringify"; 399 400eval { 401 $logger->logdie( { foo => "bar" } ); 402}; 403 404is $@->{ foo }, "bar", "die without stringify"; 405