#!/usr/bin/perl -w
use strict;
use warnings;
use Test::More tests => 21;
use Error qw/ :warndie /;
# Turn on full stack trace capture
$Error::Debug = 1;
# This file's name - for string matching. We need to quotemeta it, because on
# Win32, the filename is t\08warndie.t, and we don't want that accidentally
# matching an (invalid) \08 octal digit
my $file = qr/\Q$0\E/;
# Most of these tests are fatal, and print data on STDERR. We therefore use
# this testing function to run a CODEref in a child process and captures its
# STDERR and note whether the CODE block exited
my ( $s, $felloffcode );
my $linekid = __LINE__ + 15; # the $code->() is 15 lines below this one
sub run_kid(&)
{
my ( $code ) = @_;
# Win32's fork() emulation can't correctly handle the open("-|") case yet
# So we'll implement this manually - inspired by 'perldoc perlfork'
pipe my $childh, my $child or die "Cannot pipe() - $!";
defined( my $kid = fork() ) or die "Cannot fork() - $!";
if ( !$kid ) {
close $childh;
close STDERR;
open(STDERR, ">&=" . fileno($child)) or die;
$code->();
print STDERR "FELL OUT OF CODEREF\n";
exit(1);
}
close $child;
$s = "";
while( defined ( $_ = <$childh> ) ) {
$s .= $_;
}
close( $childh );
waitpid( $kid, 0 );
$felloffcode = 0;
$s =~ tr/\r//d; # Remove Win32 \r linefeeds to make RE tests easier
if( $s =~ s/FELL OUT OF CODEREF\n$// ) {
$felloffcode = 1;
}
}
ok(1, "Loaded");
run_kid {
print STDERR "Print to STDERR\n";
};
is( $s, "Print to STDERR\n", "Test framework STDERR" );
is( $felloffcode, 1, "Test framework felloffcode" );
my $line;
$line = __LINE__;
run_kid {
warn "A warning\n";
};
my ( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^A warning at $file line $linea\.?:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "warn \\n-terminated STDERR" );
is( $felloffcode, 1, "warn \\n-terminated felloffcode" );
$line = __LINE__;
run_kid {
warn "A warning";
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^A warning at $file line $linea\.?:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "warn unterminated STDERR" );
is( $felloffcode, 1, "warn unterminated felloffcode" );
$line = __LINE__;
run_kid {
die "An error\n";
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^
Unhandled perl error caught at toplevel:
An error
Thrown from: $file:$linea
Full stack trace:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "die \\n-terminated STDERR" );
is( $felloffcode, 0, "die \\n-terminated felloffcode" );
$line = __LINE__;
run_kid {
die "An error";
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^
Unhandled perl error caught at toplevel:
An error
Thrown from: $file:$linea
Full stack trace:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "die unterminated STDERR" );
is( $felloffcode, 0, "die unterminated felloffcode" );
$line = __LINE__;
run_kid {
throw Error( -text => "An exception" );
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^
Unhandled exception of type Error caught at toplevel:
An exception
Thrown from: $file:$linea
Full stack trace:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "Error STDOUT" );
is( $felloffcode, 0, "Error felloffcode" );
# Now custom warn and die functions to ensure the :warndie handler respects them
$SIG{__WARN__} = sub { warn "My custom warning here: $_[0]" };
$SIG{__DIE__} = sub { die "My custom death here: $_[0]" };
# First test them
$line = __LINE__;
run_kid {
warn "A warning";
};
$linea = $line + 2;
like( $s, qr/^My custom warning here: A warning at $file line $linea\.?
$/, "Custom warn test STDERR" );
is( $felloffcode, 1, "Custom warn test felloffcode" );
$line = __LINE__;
run_kid {
die "An error";
};
$linea = $line + 2;
like( $s, qr/^My custom death here: An error at $file line $linea\.?
/, "Custom die test STDERR" );
is( $felloffcode, 0, "Custom die test felloffcode" );
# Re-install the :warndie handlers
import Error qw( :warndie );
$line = __LINE__;
run_kid {
warn "A warning\n";
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^My custom warning here: A warning at $file line $linea\.?:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "Custom warn STDERR" );
is( $felloffcode, 1, "Custom warn felloffcode" );
$line = __LINE__;
run_kid {
die "An error";
};
( $linea, $lineb ) = ( $line + 2, $line + 3 );
like( $s, qr/^My custom death here:
Unhandled perl error caught at toplevel:
An error
Thrown from: $file:$linea
Full stack trace:
\tmain::__ANON__\(\) called at $file line $linekid
\tmain::run_kid\('?CODE\(0x[0-9a-f]+\)'?\) called at $file line $lineb
$/, "Custom die STDERR" );
is( $felloffcode, 0, "Custom die felloffcode" );
# Done