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