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 |
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 |
182 | sub sortfn { |
183 | (split(/./, 'x'x10000))[0]; |
184 | my (@y) = ( 4, 6, 5); |
185 | @y = sort { $a <=> $b } @y; |
be7ddd5d |
186 | my $t = "sortfn ".join(', ', @y)."\n"; |
187 | print $t if ($seen{$t}++ == 0); |
e336de0d |
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 |
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 |
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 |
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 |
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 |
321 | In DIE |
322 | rmb|-|11|(eval) |
c99da370 |
323 | rmb|-|11|rmb::__ANON__ |
be4f712a |
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 |
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 |
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 |
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. |