1 files changed, 219 insertions, 0 deletions
diff --git a/t/08warndie.t b/t/08warndie.t
new file mode 100644
index 0000000..205c6e1
--- /dev/null
+++ b/t/08warndie.t
@@ -0,0 +1,219 @@
+#!/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