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