path: root/t/024WarnDieCarp.t

#!/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";