1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
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
|
