This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix POPSTACK panics that ensued from bad interaction between
[perl5.git] / t / op / runlevel.t
CommitLineData
1e422769
PP
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
PP
7##
8
9chdir 't' if -d 't';
93430cb4 10unshift @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
PP
14
15$|=1;
16
17undef $/;
18@prgs = split "\n########\n", <DATA>;
19print "1..", scalar @prgs, "\n";
20
21$tmpfile = "runltmp000";
221 while -f ++$tmpfile;
9607fc9c 23END { if ($tmpfile) { 1 while unlink $tmpfile; } }
1e422769
PP
24
25for (@prgs){
2c375eb9 26 my $switch = "";
9607fc9c
PP
27 if (s/^\s*(-\w+)//){
28 $switch = $1;
1e422769
PP
29 }
30 my($prog,$expected) = split(/\nEXPECT\n/, $_);
9607fc9c
PP
31 open TEST, ">$tmpfile";
32 print TEST "$prog\n";
1e422769 33 close TEST;
9607fc9c
PP
34 my $results = $Is_VMS ?
35 `MCR $^X "-I[-.lib]" $switch $tmpfile` :
3fe9a6f1
PP
36 $Is_MSWin32 ?
37 `.\\perl -I../lib $switch $tmpfile 2>&1` :
648cac19 38 `./perl $switch $tmpfile 2>&1`;
9607fc9c 39 my $status = $?;
1e422769 40 $results =~ s/\n+$//;
9607fc9c
PP
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
PP
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
PP
54__END__
55@a = (1, 2, 3);
56{
57 @a = sort { last ; } @a;
58}
59EXPECT
60Can't "last" outside a block at - line 3.
61########
62package TEST;
63
64sub TIESCALAR {
65 my $foo;
66 return bless \$foo;
67}
68sub FETCH {
69 eval 'die("test")';
70 print "still in fetch\n";
71 return ">$@<";
72}
73package main;
74
75tie $bar, TEST;
76print "- $bar\n";
77EXPECT
78still in fetch
79- >test at (eval 1) line 1.
80<
81########
82package TEST;
83
84sub TIESCALAR {
85 my $foo;
86 eval('die("foo\n")');
87 print "after eval\n";
88 return bless \$foo;
89}
90sub FETCH {
91 return "ZZZ";
92}
93
94package main;
95
96tie $bar, TEST;
97print "- $bar\n";
98print "OK\n";
99EXPECT
100after eval
101- ZZZ
102OK
103########
104package TEST;
105
106sub TIEHANDLE {
107 my $foo;
108 return bless \$foo;
109}
110sub PRINT {
111print STDERR "PRINT CALLED\n";
112(split(/./, 'x'x10000))[0];
113eval('die("test\n")');
114}
115
116package main;
117
118open FH, ">&STDOUT";
119tie *FH, TEST;
120print FH "OK\n";
5aabfad6 121print STDERR "DONE\n";
1e422769
PP
122EXPECT
123PRINT CALLED
124DONE
125########
126sub warnhook {
127 print "WARNHOOK\n";
128 eval('die("foooo\n")');
129}
130$SIG{'__WARN__'} = 'warnhook';
131warn("dfsds\n");
132print "END\n";
133EXPECT
134WARNHOOK
135END
136########
137package TEST;
138
139use overload
140 "\"\"" => \&str
141;
142
143sub str {
144 eval('die("test\n")');
145 return "STR";
146}
147
148package main;
149
150$bar = bless {}, TEST;
151print "$bar\n";
152print "OK\n";
153EXPECT
154STR
155OK
156########
157sub foo {
158 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
159}
160@a = (3, 2, 0, 1);
161@a = sort foo @a;
162print join(', ', @a)."\n";
163EXPECT
1640, 1, 2, 3
165########
166sub foo {
ca0b63a5 167 goto bar if $a == 0 || $b == 0;
1e422769
PP
168 $a <=> $b;
169}
170@a = (3, 2, 0, 1);
171@a = sort foo @a;
172print join(', ', @a)."\n";
173exit;
174bar:
175print "bar reached\n";
176EXPECT
177Can't "goto" outside a block at - line 2.
e336de0d
GS
178########
179sub 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;
188print "---- ".join(', ', @x)."\n";
189EXPECT
190sortfn 4, 5, 6
d0abe6c5
GS
191sortfn 4, 5, 6
192sortfn 4, 5, 6
e336de0d
GS
193---- 1, 2, 3
194########
195@a = (3, 2, 1);
196@a = sort { eval('die("no way")') , $a <=> $b} @a;
197print join(", ", @a)."\n";
198EXPECT
1991, 2, 3
200########
201@a = (1, 2, 3);
202foo:
203{
204 @a = sort { last foo; } @a;
205}
206EXPECT
207Label not found for "last foo" at - line 2.
208########
209package TEST;
210
211sub TIESCALAR {
212 my $foo;
213 return bless \$foo;
214}
215sub FETCH {
216 next;
217 return "ZZZ";
218}
219sub STORE {
220}
221
222package main;
223
224tie $bar, TEST;
225{
226 print "- $bar\n";
227}
228print "OK\n";
229EXPECT
230Can't "next" outside a block at - line 8.
231########
232package TEST;
233
234sub TIESCALAR {
235 my $foo;
236 return bless \$foo;
237}
238sub FETCH {
239 goto bbb;
240 return "ZZZ";
241}
242
243package main;
244
245tie $bar, TEST;
246print "- $bar\n";
247exit;
248bbb:
249print "bbb\n";
250EXPECT
251Can't find label bbb at - line 8.
252########
253sub foo {
254 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
255}
256@a = (3, 2, 0, 1);
257@a = sort foo @a;
258print join(', ', @a)."\n";
259EXPECT
2600, 1, 2, 3
261########
262package TEST;
263sub TIESCALAR {
264 my $foo;
265 return bless \$foo;
266}
267sub FETCH {
268 return "fetch";
269}
270sub STORE {
271(split(/./, 'x'x10000))[0];
272}
273package main;
274tie $bar, TEST;
275$bar = "x";
276########
277package TEST;
278sub TIESCALAR {
279 my $foo;
280 next;
281 return bless \$foo;
282}
283package main;
284{
285tie $bar, TEST;
286}
287EXPECT
288Can't "next" outside a block at - line 4.
289########
290@a = (1, 2, 3);
291foo:
292{
293 @a = sort { exit(0) } @a;
294}
295END { print "foobar\n" }
296EXPECT
297foobar
2c375eb9
GS
298########
299$SIG{__DIE__} = sub {
300 print "In DIE\n";
301 $i = 0;
302 while (($p,$f,$l,$s) = caller(++$i)) {
303 print "$p|$f|$l|$s\n";
304 }
305};
306eval { die };
307&{sub { eval 'die' }}();
308sub foo { eval { die } } foo();
309EXPECT
310In DIE
311main|-|8|(eval)
312In DIE
313main|-|9|(eval)
314main|-|9|main::__ANON__
315In DIE
316main|-|10|(eval)
317main|-|10|main::foo
be4f712a
GS
318########
319package TEST;
320
321sub TIEARRAY {
322 return bless [qw(foo fee fie foe)], $_[0];
323}
324sub FETCH {
325 my ($s,$i) = @_;
326 if ($i) {
327 goto bbb;
328 }
329bbb:
330 return $s->[$i];
331}
332
333package main;
334tie my @bar, 'TEST';
335print join('|', @bar[0..3]), "\n";
336EXPECT
337foo|fee|fie|foe
0cdb2077
GS
338########
339package TH;
340sub TIEHASH { bless {}, TH }
341sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
342tie %h, TH;
343eval { $h{A} = 1; print "never\n"; };
344print $@;
345eval { $h{B} = 2; };
346print $@;
347EXPECT
348A 1
349bar
350B 2
351bar