Commit | Line | Data |
1e422769 |
1 | #!./perl |
2 | |
3 | ## |
4 | ## all of these tests are from Michael Schroeder |
5 | ## <Michael.Schroeder@informatik.uni-erlangen.de> |
6 | ## |
7 | ## The more esoteric failure modes require Michael's |
8 | ## stack-of-stacks patch (so we don't test them here, |
9 | ## and they are commented out before the __END__). |
10 | ## |
11 | ## The remaining tests pass with a simpler fix |
12 | ## intended for 5.004 |
13 | ## |
14 | ## Gurusamy Sarathy <gsar@umich.edu> 97-02-24 |
15 | ## |
16 | |
17 | chdir 't' if -d 't'; |
18 | @INC = "../lib"; |
9607fc9c |
19 | $Is_VMS = $^O eq 'VMS'; |
3fe9a6f1 |
20 | $Is_MSWin32 = $^O eq 'MSWin32'; |
9607fc9c |
21 | $ENV{PERL5LIB} = "../lib" unless $Is_VMS; |
1e422769 |
22 | |
23 | $|=1; |
24 | |
25 | undef $/; |
26 | @prgs = split "\n########\n", <DATA>; |
27 | print "1..", scalar @prgs, "\n"; |
28 | |
29 | $tmpfile = "runltmp000"; |
30 | 1 while -f ++$tmpfile; |
9607fc9c |
31 | END { if ($tmpfile) { 1 while unlink $tmpfile; } } |
1e422769 |
32 | |
33 | for (@prgs){ |
34 | my $switch; |
9607fc9c |
35 | if (s/^\s*(-\w+)//){ |
36 | $switch = $1; |
1e422769 |
37 | } |
38 | my($prog,$expected) = split(/\nEXPECT\n/, $_); |
9607fc9c |
39 | open TEST, ">$tmpfile"; |
40 | print TEST "$prog\n"; |
1e422769 |
41 | close TEST; |
9607fc9c |
42 | my $results = $Is_VMS ? |
43 | `MCR $^X "-I[-.lib]" $switch $tmpfile` : |
3fe9a6f1 |
44 | $Is_MSWin32 ? |
45 | `.\\perl -I../lib $switch $tmpfile 2>&1` : |
46 | `sh -c './perl $switch $tmpfile' 2>&1`; |
9607fc9c |
47 | my $status = $?; |
1e422769 |
48 | $results =~ s/\n+$//; |
9607fc9c |
49 | # allow expected output to be written as if $prog is on STDIN |
50 | $results =~ s/runltmp\d+/-/g; |
51 | $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg |
1e422769 |
52 | $expected =~ s/\n+$//; |
9607fc9c |
53 | if ($results ne $expected) { |
1e422769 |
54 | print STDERR "PROG: $switch\n$prog\n"; |
55 | print STDERR "EXPECTED:\n$expected\n"; |
56 | print STDERR "GOT:\n$results\n"; |
57 | print "not "; |
58 | } |
59 | print "ok ", ++$i, "\n"; |
60 | } |
61 | |
62 | =head2 stay out of here (the real tests are after __END__) |
63 | |
64 | ## |
65 | ## these tests don't pass yet (need the full stack-of-stacks patch) |
66 | ## GSAR 97-02-24 |
67 | ## |
68 | |
69 | ######## |
70 | # sort within sort |
71 | sub sortfn { |
72 | (split(/./, 'x'x10000))[0]; |
73 | my (@y) = ( 4, 6, 5); |
74 | @y = sort { $a <=> $b } @y; |
75 | print "sortfn ".join(', ', @y)."\n"; |
76 | return $_[0] <=> $_[1]; |
77 | } |
78 | @x = ( 3, 2, 1 ); |
79 | @x = sort { &sortfn($a, $b) } @x; |
80 | print "---- ".join(', ', @x)."\n"; |
81 | EXPECT |
82 | sortfn 4, 5, 6 |
83 | ---- 1, 2, 3 |
84 | ######## |
85 | # trapping eval within sort (doesn't work currently because |
86 | # die does a SWITCHSTACK()) |
87 | @a = (3, 2, 1); |
88 | @a = sort { eval('die("no way")') , $a <=> $b} @a; |
89 | print join(", ", @a)."\n"; |
90 | EXPECT |
91 | 1, 2, 3 |
92 | ######## |
93 | # this actually works fine, but results in a poor error message |
94 | @a = (1, 2, 3); |
95 | foo: |
96 | { |
97 | @a = sort { last foo; } @a; |
98 | } |
99 | EXPECT |
100 | cannot reach destination block at - line 2. |
101 | ######## |
102 | package TEST; |
103 | |
104 | sub TIESCALAR { |
105 | my $foo; |
106 | return bless \$foo; |
107 | } |
108 | sub FETCH { |
109 | next; |
110 | return "ZZZ"; |
111 | } |
112 | sub STORE { |
113 | } |
114 | |
115 | package main; |
116 | |
117 | tie $bar, TEST; |
118 | { |
119 | print "- $bar\n"; |
120 | } |
121 | print "OK\n"; |
122 | EXPECT |
123 | cannot reach destination block at - line 8. |
124 | ######## |
125 | package TEST; |
126 | |
127 | sub TIESCALAR { |
128 | my $foo; |
129 | return bless \$foo; |
130 | } |
131 | sub FETCH { |
132 | goto bbb; |
133 | return "ZZZ"; |
134 | } |
135 | |
136 | package main; |
137 | |
138 | tie $bar, TEST; |
139 | print "- $bar\n"; |
140 | exit; |
141 | bbb: |
142 | print "bbb\n"; |
143 | EXPECT |
144 | bbb |
145 | ######## |
146 | # trapping eval within sort (doesn't work currently because |
147 | # die does a SWITCHSTACK()) |
148 | sub foo { |
149 | $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); |
150 | } |
151 | @a = (3, 2, 0, 1); |
152 | @a = sort foo @a; |
153 | print join(', ', @a)."\n"; |
154 | EXPECT |
155 | 0, 1, 2, 3 |
156 | ######## |
157 | package TEST; |
158 | sub TIESCALAR { |
159 | my $foo; |
160 | next; |
161 | return bless \$foo; |
162 | } |
163 | package main; |
164 | { |
165 | tie $bar, TEST; |
166 | } |
167 | EXPECT |
168 | cannot reach destination block at - line 4. |
169 | ######## |
170 | # large stack extension causes realloc, and segfault |
171 | package TEST; |
172 | sub TIESCALAR { |
173 | my $foo; |
174 | return bless \$foo; |
175 | } |
176 | sub FETCH { |
177 | return "fetch"; |
178 | } |
179 | sub STORE { |
180 | (split(/./, 'x'x10000))[0]; |
181 | } |
182 | package main; |
183 | tie $bar, TEST; |
184 | $bar = "x"; |
185 | |
186 | =cut |
187 | |
188 | ## |
189 | ## |
190 | ## The real tests begin here |
191 | ## |
192 | ## |
193 | |
194 | __END__ |
195 | @a = (1, 2, 3); |
196 | { |
197 | @a = sort { last ; } @a; |
198 | } |
199 | EXPECT |
200 | Can't "last" outside a block at - line 3. |
201 | ######## |
202 | package TEST; |
203 | |
204 | sub TIESCALAR { |
205 | my $foo; |
206 | return bless \$foo; |
207 | } |
208 | sub FETCH { |
209 | eval 'die("test")'; |
210 | print "still in fetch\n"; |
211 | return ">$@<"; |
212 | } |
213 | package main; |
214 | |
215 | tie $bar, TEST; |
216 | print "- $bar\n"; |
217 | EXPECT |
218 | still in fetch |
219 | - >test at (eval 1) line 1. |
220 | < |
221 | ######## |
222 | package TEST; |
223 | |
224 | sub TIESCALAR { |
225 | my $foo; |
226 | eval('die("foo\n")'); |
227 | print "after eval\n"; |
228 | return bless \$foo; |
229 | } |
230 | sub FETCH { |
231 | return "ZZZ"; |
232 | } |
233 | |
234 | package main; |
235 | |
236 | tie $bar, TEST; |
237 | print "- $bar\n"; |
238 | print "OK\n"; |
239 | EXPECT |
240 | after eval |
241 | - ZZZ |
242 | OK |
243 | ######## |
244 | package TEST; |
245 | |
246 | sub TIEHANDLE { |
247 | my $foo; |
248 | return bless \$foo; |
249 | } |
250 | sub PRINT { |
251 | print STDERR "PRINT CALLED\n"; |
252 | (split(/./, 'x'x10000))[0]; |
253 | eval('die("test\n")'); |
254 | } |
255 | |
256 | package main; |
257 | |
258 | open FH, ">&STDOUT"; |
259 | tie *FH, TEST; |
260 | print FH "OK\n"; |
5aabfad6 |
261 | print STDERR "DONE\n"; |
1e422769 |
262 | EXPECT |
263 | PRINT CALLED |
264 | DONE |
265 | ######## |
266 | sub warnhook { |
267 | print "WARNHOOK\n"; |
268 | eval('die("foooo\n")'); |
269 | } |
270 | $SIG{'__WARN__'} = 'warnhook'; |
271 | warn("dfsds\n"); |
272 | print "END\n"; |
273 | EXPECT |
274 | WARNHOOK |
275 | END |
276 | ######## |
277 | package TEST; |
278 | |
279 | use overload |
280 | "\"\"" => \&str |
281 | ; |
282 | |
283 | sub str { |
284 | eval('die("test\n")'); |
285 | return "STR"; |
286 | } |
287 | |
288 | package main; |
289 | |
290 | $bar = bless {}, TEST; |
291 | print "$bar\n"; |
292 | print "OK\n"; |
293 | EXPECT |
294 | STR |
295 | OK |
296 | ######## |
297 | sub foo { |
298 | $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); |
299 | } |
300 | @a = (3, 2, 0, 1); |
301 | @a = sort foo @a; |
302 | print join(', ', @a)."\n"; |
303 | EXPECT |
304 | 0, 1, 2, 3 |
305 | ######## |
306 | sub foo { |
ca0b63a5 |
307 | goto bar if $a == 0 || $b == 0; |
1e422769 |
308 | $a <=> $b; |
309 | } |
310 | @a = (3, 2, 0, 1); |
311 | @a = sort foo @a; |
312 | print join(', ', @a)."\n"; |
313 | exit; |
314 | bar: |
315 | print "bar reached\n"; |
316 | EXPECT |
317 | Can't "goto" outside a block at - line 2. |