Commit | Line | Data |
---|---|---|
1e422769 | 1 | #!./perl |
2 | ||
3 | ## | |
e336de0d | 4 | ## Many of these tests are originally from Michael Schroeder |
1e422769 | 5 | ## <Michael.Schroeder@informatik.uni-erlangen.de> |
6e238990 | 6 | ## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> |
1e422769 | 7 | ## |
8 | ||
9 | chdir 't' if -d 't'; | |
20822f61 | 10 | @INC = '../lib'; |
1c25d394 | 11 | require './test.pl'; |
9607fc9c | 12 | $Is_VMS = $^O eq 'VMS'; |
3fe9a6f1 | 13 | $Is_MSWin32 = $^O eq 'MSWin32'; |
2986a63f | 14 | $Is_NetWare = $^O eq 'NetWare'; |
9607fc9c | 15 | $ENV{PERL5LIB} = "../lib" unless $Is_VMS; |
1e422769 | 16 | |
17 | $|=1; | |
18 | ||
19 | undef $/; | |
20 | @prgs = split "\n########\n", <DATA>; | |
21 | print "1..", scalar @prgs, "\n"; | |
22 | ||
1c25d394 | 23 | $tmpfile = tempfile(); |
1e422769 | 24 | |
25 | for (@prgs){ | |
2c375eb9 | 26 | my $switch = ""; |
9607fc9c | 27 | if (s/^\s*(-\w+)//){ |
28 | $switch = $1; | |
1e422769 | 29 | } |
30 | my($prog,$expected) = split(/\nEXPECT\n/, $_); | |
9607fc9c | 31 | open TEST, ">$tmpfile"; |
32 | print TEST "$prog\n"; | |
d1e4d418 | 33 | close TEST or die "Could not close: $!"; |
9607fc9c | 34 | my $results = $Is_VMS ? |
16ed4686 | 35 | `$^X "-I[-.lib]" $switch $tmpfile 2>&1` : |
be708cc0 JH |
36 | $Is_MSWin32 ? |
37 | `.\\perl -I../lib $switch $tmpfile 2>&1` : | |
38 | $Is_NetWare ? | |
39 | `perl -I../lib $switch $tmpfile 2>&1` : | |
be708cc0 | 40 | `./perl $switch $tmpfile 2>&1`; |
9607fc9c | 41 | my $status = $?; |
1e422769 | 42 | $results =~ s/\n+$//; |
9607fc9c | 43 | # allow expected output to be written as if $prog is on STDIN |
7aa55bb4 | 44 | $results =~ s/$::tempfile_regexp/-/ig; |
9607fc9c | 45 | $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg |
1e422769 | 46 | $expected =~ s/\n+$//; |
9607fc9c | 47 | if ($results ne $expected) { |
1e422769 | 48 | print STDERR "PROG: $switch\n$prog\n"; |
49 | print STDERR "EXPECTED:\n$expected\n"; | |
50 | print STDERR "GOT:\n$results\n"; | |
51 | print "not "; | |
52 | } | |
53 | print "ok ", ++$i, "\n"; | |
54 | } | |
55 | ||
1e422769 | 56 | __END__ |
57 | @a = (1, 2, 3); | |
58 | { | |
59 | @a = sort { last ; } @a; | |
60 | } | |
61 | EXPECT | |
a651a37d | 62 | Can't "last" outside a loop block at - line 3. |
1e422769 | 63 | ######## |
64 | package TEST; | |
65 | ||
66 | sub TIESCALAR { | |
67 | my $foo; | |
68 | return bless \$foo; | |
69 | } | |
70 | sub FETCH { | |
71 | eval 'die("test")'; | |
72 | print "still in fetch\n"; | |
73 | return ">$@<"; | |
74 | } | |
75 | package main; | |
76 | ||
77 | tie $bar, TEST; | |
78 | print "- $bar\n"; | |
79 | EXPECT | |
80 | still in fetch | |
81 | - >test at (eval 1) line 1. | |
82 | < | |
83 | ######## | |
84 | package TEST; | |
85 | ||
86 | sub TIESCALAR { | |
87 | my $foo; | |
88 | eval('die("foo\n")'); | |
89 | print "after eval\n"; | |
90 | return bless \$foo; | |
91 | } | |
92 | sub FETCH { | |
93 | return "ZZZ"; | |
94 | } | |
95 | ||
96 | package main; | |
97 | ||
98 | tie $bar, TEST; | |
99 | print "- $bar\n"; | |
100 | print "OK\n"; | |
101 | EXPECT | |
102 | after eval | |
103 | - ZZZ | |
104 | OK | |
105 | ######## | |
106 | package TEST; | |
107 | ||
108 | sub TIEHANDLE { | |
109 | my $foo; | |
110 | return bless \$foo; | |
111 | } | |
112 | sub PRINT { | |
113 | print STDERR "PRINT CALLED\n"; | |
114 | (split(/./, 'x'x10000))[0]; | |
115 | eval('die("test\n")'); | |
116 | } | |
117 | ||
118 | package main; | |
119 | ||
120 | open FH, ">&STDOUT"; | |
121 | tie *FH, TEST; | |
122 | print FH "OK\n"; | |
5aabfad6 | 123 | print STDERR "DONE\n"; |
1e422769 | 124 | EXPECT |
125 | PRINT CALLED | |
126 | DONE | |
127 | ######## | |
128 | sub warnhook { | |
129 | print "WARNHOOK\n"; | |
130 | eval('die("foooo\n")'); | |
131 | } | |
132 | $SIG{'__WARN__'} = 'warnhook'; | |
133 | warn("dfsds\n"); | |
134 | print "END\n"; | |
135 | EXPECT | |
136 | WARNHOOK | |
137 | END | |
138 | ######## | |
139 | package TEST; | |
140 | ||
141 | use overload | |
142 | "\"\"" => \&str | |
143 | ; | |
144 | ||
145 | sub str { | |
146 | eval('die("test\n")'); | |
147 | return "STR"; | |
148 | } | |
149 | ||
150 | package main; | |
151 | ||
152 | $bar = bless {}, TEST; | |
153 | print "$bar\n"; | |
154 | print "OK\n"; | |
155 | EXPECT | |
156 | STR | |
157 | OK | |
158 | ######## | |
159 | sub foo { | |
160 | $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); | |
161 | } | |
162 | @a = (3, 2, 0, 1); | |
163 | @a = sort foo @a; | |
164 | print join(', ', @a)."\n"; | |
165 | EXPECT | |
166 | 0, 1, 2, 3 | |
167 | ######## | |
168 | sub foo { | |
ca0b63a5 | 169 | goto bar if $a == 0 || $b == 0; |
1e422769 | 170 | $a <=> $b; |
171 | } | |
172 | @a = (3, 2, 0, 1); | |
173 | @a = sort foo @a; | |
174 | print join(', ', @a)."\n"; | |
175 | exit; | |
176 | bar: | |
177 | print "bar reached\n"; | |
178 | EXPECT | |
a651a37d | 179 | Can't "goto" out of a pseudo block at - line 2. |
e336de0d | 180 | ######## |
be7ddd5d | 181 | %seen = (); |
e336de0d GS |
182 | sub sortfn { |
183 | (split(/./, 'x'x10000))[0]; | |
184 | my (@y) = ( 4, 6, 5); | |
185 | @y = sort { $a <=> $b } @y; | |
be7ddd5d JH |
186 | my $t = "sortfn ".join(', ', @y)."\n"; |
187 | print $t if ($seen{$t}++ == 0); | |
e336de0d GS |
188 | return $_[0] <=> $_[1]; |
189 | } | |
190 | @x = ( 3, 2, 1 ); | |
191 | @x = sort { &sortfn($a, $b) } @x; | |
192 | print "---- ".join(', ', @x)."\n"; | |
193 | EXPECT | |
194 | sortfn 4, 5, 6 | |
195 | ---- 1, 2, 3 | |
196 | ######## | |
197 | @a = (3, 2, 1); | |
198 | @a = sort { eval('die("no way")') , $a <=> $b} @a; | |
199 | print join(", ", @a)."\n"; | |
200 | EXPECT | |
201 | 1, 2, 3 | |
202 | ######## | |
203 | @a = (1, 2, 3); | |
204 | foo: | |
205 | { | |
206 | @a = sort { last foo; } @a; | |
207 | } | |
208 | EXPECT | |
209 | Label not found for "last foo" at - line 2. | |
210 | ######## | |
211 | package TEST; | |
212 | ||
213 | sub TIESCALAR { | |
214 | my $foo; | |
215 | return bless \$foo; | |
216 | } | |
217 | sub FETCH { | |
218 | next; | |
219 | return "ZZZ"; | |
220 | } | |
221 | sub STORE { | |
222 | } | |
223 | ||
224 | package main; | |
225 | ||
226 | tie $bar, TEST; | |
227 | { | |
228 | print "- $bar\n"; | |
229 | } | |
230 | print "OK\n"; | |
231 | EXPECT | |
a651a37d | 232 | Can't "next" outside a loop block at - line 8. |
e336de0d GS |
233 | ######## |
234 | package TEST; | |
235 | ||
236 | sub TIESCALAR { | |
237 | my $foo; | |
238 | return bless \$foo; | |
239 | } | |
240 | sub FETCH { | |
241 | goto bbb; | |
242 | return "ZZZ"; | |
243 | } | |
244 | ||
245 | package main; | |
246 | ||
247 | tie $bar, TEST; | |
248 | print "- $bar\n"; | |
249 | exit; | |
250 | bbb: | |
251 | print "bbb\n"; | |
252 | EXPECT | |
253 | Can't find label bbb at - line 8. | |
254 | ######## | |
255 | sub foo { | |
256 | $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); | |
257 | } | |
258 | @a = (3, 2, 0, 1); | |
259 | @a = sort foo @a; | |
260 | print join(', ', @a)."\n"; | |
261 | EXPECT | |
262 | 0, 1, 2, 3 | |
263 | ######## | |
264 | package TEST; | |
265 | sub TIESCALAR { | |
266 | my $foo; | |
267 | return bless \$foo; | |
268 | } | |
269 | sub FETCH { | |
270 | return "fetch"; | |
271 | } | |
272 | sub STORE { | |
273 | (split(/./, 'x'x10000))[0]; | |
274 | } | |
275 | package main; | |
276 | tie $bar, TEST; | |
277 | $bar = "x"; | |
278 | ######## | |
279 | package TEST; | |
280 | sub TIESCALAR { | |
281 | my $foo; | |
282 | next; | |
283 | return bless \$foo; | |
284 | } | |
285 | package main; | |
286 | { | |
287 | tie $bar, TEST; | |
288 | } | |
289 | EXPECT | |
a651a37d | 290 | Can't "next" outside a loop block at - line 4. |
e336de0d GS |
291 | ######## |
292 | @a = (1, 2, 3); | |
293 | foo: | |
294 | { | |
295 | @a = sort { exit(0) } @a; | |
296 | } | |
297 | END { print "foobar\n" } | |
298 | EXPECT | |
299 | foobar | |
2c375eb9 GS |
300 | ######## |
301 | $SIG{__DIE__} = sub { | |
302 | print "In DIE\n"; | |
303 | $i = 0; | |
304 | while (($p,$f,$l,$s) = caller(++$i)) { | |
305 | print "$p|$f|$l|$s\n"; | |
306 | } | |
307 | }; | |
308 | eval { die }; | |
309 | &{sub { eval 'die' }}(); | |
310 | sub foo { eval { die } } foo(); | |
c99da370 | 311 | {package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package |
2c375eb9 GS |
312 | EXPECT |
313 | In DIE | |
314 | main|-|8|(eval) | |
315 | In DIE | |
316 | main|-|9|(eval) | |
317 | main|-|9|main::__ANON__ | |
318 | In DIE | |
319 | main|-|10|(eval) | |
320 | main|-|10|main::foo | |
16920d4e RB |
321 | In DIE |
322 | rmb|-|11|(eval) | |
c99da370 | 323 | rmb|-|11|rmb::__ANON__ |
be4f712a GS |
324 | ######## |
325 | package TEST; | |
326 | ||
327 | sub TIEARRAY { | |
328 | return bless [qw(foo fee fie foe)], $_[0]; | |
329 | } | |
330 | sub FETCH { | |
331 | my ($s,$i) = @_; | |
332 | if ($i) { | |
333 | goto bbb; | |
334 | } | |
335 | bbb: | |
336 | return $s->[$i]; | |
337 | } | |
338 | ||
339 | package main; | |
340 | tie my @bar, 'TEST'; | |
341 | print join('|', @bar[0..3]), "\n"; | |
342 | EXPECT | |
343 | foo|fee|fie|foe | |
0cdb2077 GS |
344 | ######## |
345 | package TH; | |
346 | sub TIEHASH { bless {}, TH } | |
347 | sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } | |
348 | tie %h, TH; | |
349 | eval { $h{A} = 1; print "never\n"; }; | |
350 | print $@; | |
351 | eval { $h{B} = 2; }; | |
352 | print $@; | |
353 | EXPECT | |
354 | A 1 | |
355 | bar | |
356 | B 2 | |
357 | bar | |
ecf8e9dd GS |
358 | ######## |
359 | sub n { 0 } | |
360 | sub f { my $x = shift; d(); } | |
361 | f(n()); | |
362 | f(); | |
363 | ||
364 | sub d { | |
365 | my $i = 0; my @a; | |
366 | while (do { { package DB; @a = caller($i++) } } ) { | |
367 | @a = @DB::args; | |
368 | for (@a) { print "$_\n"; $_ = '' } | |
369 | } | |
370 | } | |
371 | EXPECT | |
372 | 0 | |
7ff03255 SG |
373 | ######## |
374 | sub TIEHANDLE { bless {} } | |
375 | sub PRINT { next } | |
376 | ||
377 | tie *STDERR, ''; | |
378 | { map ++$_, 1 } | |
379 | ||
380 | EXPECT | |
381 | Can't "next" outside a loop block at - line 2. | |
382 | ######## | |
383 | sub TIEHANDLE { bless {} } | |
384 | sub PRINT { print "[TIE] $_[1]" } | |
385 | ||
386 | tie *STDERR, ''; | |
387 | die "DIE\n"; | |
388 | ||
389 | EXPECT | |
390 | [TIE] DIE | |
391 | ######## | |
392 | sub TIEHANDLE { bless {} } | |
393 | sub PRINT { | |
394 | (split(/./, 'x'x10000))[0]; | |
395 | eval('die("test\n")'); | |
396 | warn "[TIE] $_[1]"; | |
397 | } | |
398 | open OLDERR, '>&STDERR'; | |
399 | tie *STDERR, ''; | |
400 | ||
401 | use warnings FATAL => qw(uninitialized); | |
402 | print undef; | |
403 | ||
404 | EXPECT | |
405 | [TIE] Use of uninitialized value in print at - line 11. |