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> |
e336de0d |
6 | ## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> |
1e422769 |
7 | ## |
8 | |
9 | chdir 't' if -d 't'; |
10 | @INC = "../lib"; |
9607fc9c |
11 | $Is_VMS = $^O eq 'VMS'; |
3fe9a6f1 |
12 | $Is_MSWin32 = $^O eq 'MSWin32'; |
9607fc9c |
13 | $ENV{PERL5LIB} = "../lib" unless $Is_VMS; |
1e422769 |
14 | |
15 | $|=1; |
16 | |
17 | undef $/; |
18 | @prgs = split "\n########\n", <DATA>; |
19 | print "1..", scalar @prgs, "\n"; |
20 | |
21 | $tmpfile = "runltmp000"; |
22 | 1 while -f ++$tmpfile; |
9607fc9c |
23 | END { if ($tmpfile) { 1 while unlink $tmpfile; } } |
1e422769 |
24 | |
25 | for (@prgs){ |
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"; |
1e422769 |
33 | close TEST; |
9607fc9c |
34 | my $results = $Is_VMS ? |
35 | `MCR $^X "-I[-.lib]" $switch $tmpfile` : |
3fe9a6f1 |
36 | $Is_MSWin32 ? |
37 | `.\\perl -I../lib $switch $tmpfile 2>&1` : |
38 | `sh -c './perl $switch $tmpfile' 2>&1`; |
9607fc9c |
39 | my $status = $?; |
1e422769 |
40 | $results =~ s/\n+$//; |
9607fc9c |
41 | # allow expected output to be written as if $prog is on STDIN |
42 | $results =~ s/runltmp\d+/-/g; |
43 | $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg |
1e422769 |
44 | $expected =~ s/\n+$//; |
9607fc9c |
45 | if ($results ne $expected) { |
1e422769 |
46 | print STDERR "PROG: $switch\n$prog\n"; |
47 | print STDERR "EXPECTED:\n$expected\n"; |
48 | print STDERR "GOT:\n$results\n"; |
49 | print "not "; |
50 | } |
51 | print "ok ", ++$i, "\n"; |
52 | } |
53 | |
1e422769 |
54 | __END__ |
55 | @a = (1, 2, 3); |
56 | { |
57 | @a = sort { last ; } @a; |
58 | } |
59 | EXPECT |
60 | Can't "last" outside a block at - line 3. |
61 | ######## |
62 | package TEST; |
63 | |
64 | sub TIESCALAR { |
65 | my $foo; |
66 | return bless \$foo; |
67 | } |
68 | sub FETCH { |
69 | eval 'die("test")'; |
70 | print "still in fetch\n"; |
71 | return ">$@<"; |
72 | } |
73 | package main; |
74 | |
75 | tie $bar, TEST; |
76 | print "- $bar\n"; |
77 | EXPECT |
78 | still in fetch |
79 | - >test at (eval 1) line 1. |
80 | < |
81 | ######## |
82 | package TEST; |
83 | |
84 | sub TIESCALAR { |
85 | my $foo; |
86 | eval('die("foo\n")'); |
87 | print "after eval\n"; |
88 | return bless \$foo; |
89 | } |
90 | sub FETCH { |
91 | return "ZZZ"; |
92 | } |
93 | |
94 | package main; |
95 | |
96 | tie $bar, TEST; |
97 | print "- $bar\n"; |
98 | print "OK\n"; |
99 | EXPECT |
100 | after eval |
101 | - ZZZ |
102 | OK |
103 | ######## |
104 | package TEST; |
105 | |
106 | sub TIEHANDLE { |
107 | my $foo; |
108 | return bless \$foo; |
109 | } |
110 | sub PRINT { |
111 | print STDERR "PRINT CALLED\n"; |
112 | (split(/./, 'x'x10000))[0]; |
113 | eval('die("test\n")'); |
114 | } |
115 | |
116 | package main; |
117 | |
118 | open FH, ">&STDOUT"; |
119 | tie *FH, TEST; |
120 | print FH "OK\n"; |
5aabfad6 |
121 | print STDERR "DONE\n"; |
1e422769 |
122 | EXPECT |
123 | PRINT CALLED |
124 | DONE |
125 | ######## |
126 | sub warnhook { |
127 | print "WARNHOOK\n"; |
128 | eval('die("foooo\n")'); |
129 | } |
130 | $SIG{'__WARN__'} = 'warnhook'; |
131 | warn("dfsds\n"); |
132 | print "END\n"; |
133 | EXPECT |
134 | WARNHOOK |
135 | END |
136 | ######## |
137 | package TEST; |
138 | |
139 | use overload |
140 | "\"\"" => \&str |
141 | ; |
142 | |
143 | sub str { |
144 | eval('die("test\n")'); |
145 | return "STR"; |
146 | } |
147 | |
148 | package main; |
149 | |
150 | $bar = bless {}, TEST; |
151 | print "$bar\n"; |
152 | print "OK\n"; |
153 | EXPECT |
154 | STR |
155 | OK |
156 | ######## |
157 | sub foo { |
158 | $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); |
159 | } |
160 | @a = (3, 2, 0, 1); |
161 | @a = sort foo @a; |
162 | print join(', ', @a)."\n"; |
163 | EXPECT |
164 | 0, 1, 2, 3 |
165 | ######## |
166 | sub foo { |
ca0b63a5 |
167 | goto bar if $a == 0 || $b == 0; |
1e422769 |
168 | $a <=> $b; |
169 | } |
170 | @a = (3, 2, 0, 1); |
171 | @a = sort foo @a; |
172 | print join(', ', @a)."\n"; |
173 | exit; |
174 | bar: |
175 | print "bar reached\n"; |
176 | EXPECT |
177 | Can't "goto" outside a block at - line 2. |
e336de0d |
178 | ######## |
179 | sub sortfn { |
180 | (split(/./, 'x'x10000))[0]; |
181 | my (@y) = ( 4, 6, 5); |
182 | @y = sort { $a <=> $b } @y; |
183 | print "sortfn ".join(', ', @y)."\n"; |
184 | return $_[0] <=> $_[1]; |
185 | } |
186 | @x = ( 3, 2, 1 ); |
187 | @x = sort { &sortfn($a, $b) } @x; |
188 | print "---- ".join(', ', @x)."\n"; |
189 | EXPECT |
190 | sortfn 4, 5, 6 |
191 | ---- 1, 2, 3 |
192 | ######## |
193 | @a = (3, 2, 1); |
194 | @a = sort { eval('die("no way")') , $a <=> $b} @a; |
195 | print join(", ", @a)."\n"; |
196 | EXPECT |
197 | 1, 2, 3 |
198 | ######## |
199 | @a = (1, 2, 3); |
200 | foo: |
201 | { |
202 | @a = sort { last foo; } @a; |
203 | } |
204 | EXPECT |
205 | Label not found for "last foo" at - line 2. |
206 | ######## |
207 | package TEST; |
208 | |
209 | sub TIESCALAR { |
210 | my $foo; |
211 | return bless \$foo; |
212 | } |
213 | sub FETCH { |
214 | next; |
215 | return "ZZZ"; |
216 | } |
217 | sub STORE { |
218 | } |
219 | |
220 | package main; |
221 | |
222 | tie $bar, TEST; |
223 | { |
224 | print "- $bar\n"; |
225 | } |
226 | print "OK\n"; |
227 | EXPECT |
228 | Can't "next" outside a block at - line 8. |
229 | ######## |
230 | package TEST; |
231 | |
232 | sub TIESCALAR { |
233 | my $foo; |
234 | return bless \$foo; |
235 | } |
236 | sub FETCH { |
237 | goto bbb; |
238 | return "ZZZ"; |
239 | } |
240 | |
241 | package main; |
242 | |
243 | tie $bar, TEST; |
244 | print "- $bar\n"; |
245 | exit; |
246 | bbb: |
247 | print "bbb\n"; |
248 | EXPECT |
249 | Can't find label bbb at - line 8. |
250 | ######## |
251 | sub foo { |
252 | $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); |
253 | } |
254 | @a = (3, 2, 0, 1); |
255 | @a = sort foo @a; |
256 | print join(', ', @a)."\n"; |
257 | EXPECT |
258 | 0, 1, 2, 3 |
259 | ######## |
260 | package TEST; |
261 | sub TIESCALAR { |
262 | my $foo; |
263 | return bless \$foo; |
264 | } |
265 | sub FETCH { |
266 | return "fetch"; |
267 | } |
268 | sub STORE { |
269 | (split(/./, 'x'x10000))[0]; |
270 | } |
271 | package main; |
272 | tie $bar, TEST; |
273 | $bar = "x"; |
274 | ######## |
275 | package TEST; |
276 | sub TIESCALAR { |
277 | my $foo; |
278 | next; |
279 | return bless \$foo; |
280 | } |
281 | package main; |
282 | { |
283 | tie $bar, TEST; |
284 | } |
285 | EXPECT |
286 | Can't "next" outside a block at - line 4. |
287 | ######## |
288 | @a = (1, 2, 3); |
289 | foo: |
290 | { |
291 | @a = sort { exit(0) } @a; |
292 | } |
293 | END { print "foobar\n" } |
294 | EXPECT |
295 | foobar |