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