From 661707e7bd4282aeab5a2f6a8f02ca5731fd813f Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Tue, 8 May 2012 18:20:12 +0000 Subject: Imported from /srv/lorry/lorry-area/error-perl-tarball/Error-0.17018.tar.gz. --- t/08warndie.t | 219 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 219 insertions(+) create mode 100644 t/08warndie.t (limited to 't/08warndie.t') 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 -- cgit v1.2.1