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