This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[inseparable changes from match from perl-5.003_97 to perl-5.003_97a]
[perl5.git] / t / op / runlevel.t
CommitLineData
1e422769
PP
1#!./perl
2
3##
4## all of these tests are from Michael Schroeder
5## <Michael.Schroeder@informatik.uni-erlangen.de>
6##
7## The more esoteric failure modes require Michael's
8## stack-of-stacks patch (so we don't test them here,
9## and they are commented out before the __END__).
10##
11## The remaining tests pass with a simpler fix
12## intended for 5.004
13##
14## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
15##
16
17chdir 't' if -d 't';
18@INC = "../lib";
9607fc9c 19$Is_VMS = $^O eq 'VMS';
3fe9a6f1 20$Is_MSWin32 = $^O eq 'MSWin32';
9607fc9c 21$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
1e422769
PP
22
23$|=1;
24
25undef $/;
26@prgs = split "\n########\n", <DATA>;
27print "1..", scalar @prgs, "\n";
28
29$tmpfile = "runltmp000";
301 while -f ++$tmpfile;
9607fc9c 31END { if ($tmpfile) { 1 while unlink $tmpfile; } }
1e422769
PP
32
33for (@prgs){
34 my $switch;
9607fc9c
PP
35 if (s/^\s*(-\w+)//){
36 $switch = $1;
1e422769
PP
37 }
38 my($prog,$expected) = split(/\nEXPECT\n/, $_);
9607fc9c
PP
39 open TEST, ">$tmpfile";
40 print TEST "$prog\n";
1e422769 41 close TEST;
9607fc9c
PP
42 my $results = $Is_VMS ?
43 `MCR $^X "-I[-.lib]" $switch $tmpfile` :
3fe9a6f1
PP
44 $Is_MSWin32 ?
45 `.\\perl -I../lib $switch $tmpfile 2>&1` :
46 `sh -c './perl $switch $tmpfile' 2>&1`;
9607fc9c 47 my $status = $?;
1e422769 48 $results =~ s/\n+$//;
9607fc9c
PP
49 # allow expected output to be written as if $prog is on STDIN
50 $results =~ s/runltmp\d+/-/g;
51 $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
1e422769 52 $expected =~ s/\n+$//;
9607fc9c 53 if ($results ne $expected) {
1e422769
PP
54 print STDERR "PROG: $switch\n$prog\n";
55 print STDERR "EXPECTED:\n$expected\n";
56 print STDERR "GOT:\n$results\n";
57 print "not ";
58 }
59 print "ok ", ++$i, "\n";
60}
61
62=head2 stay out of here (the real tests are after __END__)
63
64##
65## these tests don't pass yet (need the full stack-of-stacks patch)
66## GSAR 97-02-24
67##
68
69########
70# sort within sort
71sub sortfn {
72 (split(/./, 'x'x10000))[0];
73 my (@y) = ( 4, 6, 5);
74 @y = sort { $a <=> $b } @y;
75 print "sortfn ".join(', ', @y)."\n";
76 return $_[0] <=> $_[1];
77}
78@x = ( 3, 2, 1 );
79@x = sort { &sortfn($a, $b) } @x;
80print "---- ".join(', ', @x)."\n";
81EXPECT
82sortfn 4, 5, 6
83---- 1, 2, 3
84########
85# trapping eval within sort (doesn't work currently because
86# die does a SWITCHSTACK())
87@a = (3, 2, 1);
88@a = sort { eval('die("no way")') , $a <=> $b} @a;
89print join(", ", @a)."\n";
90EXPECT
911, 2, 3
92########
93# this actually works fine, but results in a poor error message
94@a = (1, 2, 3);
95foo:
96{
97 @a = sort { last foo; } @a;
98}
99EXPECT
100cannot reach destination block at - line 2.
101########
102package TEST;
103
104sub TIESCALAR {
105 my $foo;
106 return bless \$foo;
107}
108sub FETCH {
109 next;
110 return "ZZZ";
111}
112sub STORE {
113}
114
115package main;
116
117tie $bar, TEST;
118{
119 print "- $bar\n";
120}
121print "OK\n";
122EXPECT
123cannot reach destination block at - line 8.
124########
125package TEST;
126
127sub TIESCALAR {
128 my $foo;
129 return bless \$foo;
130}
131sub FETCH {
132 goto bbb;
133 return "ZZZ";
134}
135
136package main;
137
138tie $bar, TEST;
139print "- $bar\n";
140exit;
141bbb:
142print "bbb\n";
143EXPECT
144bbb
145########
146# trapping eval within sort (doesn't work currently because
147# die does a SWITCHSTACK())
148sub foo {
149 $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
150}
151@a = (3, 2, 0, 1);
152@a = sort foo @a;
153print join(', ', @a)."\n";
154EXPECT
1550, 1, 2, 3
156########
157package TEST;
158sub TIESCALAR {
159 my $foo;
160 next;
161 return bless \$foo;
162}
163package main;
164{
165tie $bar, TEST;
166}
167EXPECT
168cannot reach destination block at - line 4.
169########
170# large stack extension causes realloc, and segfault
171package TEST;
172sub TIESCALAR {
173 my $foo;
174 return bless \$foo;
175}
176sub FETCH {
177 return "fetch";
178}
179sub STORE {
180(split(/./, 'x'x10000))[0];
181}
182package main;
183tie $bar, TEST;
184$bar = "x";
185
186=cut
187
188##
189##
190## The real tests begin here
191##
192##
193
194__END__
195@a = (1, 2, 3);
196{
197 @a = sort { last ; } @a;
198}
199EXPECT
200Can't "last" outside a block at - line 3.
201########
202package TEST;
203
204sub TIESCALAR {
205 my $foo;
206 return bless \$foo;
207}
208sub FETCH {
209 eval 'die("test")';
210 print "still in fetch\n";
211 return ">$@<";
212}
213package main;
214
215tie $bar, TEST;
216print "- $bar\n";
217EXPECT
218still in fetch
219- >test at (eval 1) line 1.
220<
221########
222package TEST;
223
224sub TIESCALAR {
225 my $foo;
226 eval('die("foo\n")');
227 print "after eval\n";
228 return bless \$foo;
229}
230sub FETCH {
231 return "ZZZ";
232}
233
234package main;
235
236tie $bar, TEST;
237print "- $bar\n";
238print "OK\n";
239EXPECT
240after eval
241- ZZZ
242OK
243########
244package TEST;
245
246sub TIEHANDLE {
247 my $foo;
248 return bless \$foo;
249}
250sub PRINT {
251print STDERR "PRINT CALLED\n";
252(split(/./, 'x'x10000))[0];
253eval('die("test\n")');
254}
255
256package main;
257
258open FH, ">&STDOUT";
259tie *FH, TEST;
260print FH "OK\n";
5aabfad6 261print STDERR "DONE\n";
1e422769
PP
262EXPECT
263PRINT CALLED
264DONE
265########
266sub warnhook {
267 print "WARNHOOK\n";
268 eval('die("foooo\n")');
269}
270$SIG{'__WARN__'} = 'warnhook';
271warn("dfsds\n");
272print "END\n";
273EXPECT
274WARNHOOK
275END
276########
277package TEST;
278
279use overload
280 "\"\"" => \&str
281;
282
283sub str {
284 eval('die("test\n")');
285 return "STR";
286}
287
288package main;
289
290$bar = bless {}, TEST;
291print "$bar\n";
292print "OK\n";
293EXPECT
294STR
295OK
296########
297sub foo {
298 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
299}
300@a = (3, 2, 0, 1);
301@a = sort foo @a;
302print join(', ', @a)."\n";
303EXPECT
3040, 1, 2, 3
305########
306sub foo {
307 goto bar if $a == 0;
308 $a <=> $b;
309}
310@a = (3, 2, 0, 1);
311@a = sort foo @a;
312print join(', ', @a)."\n";
313exit;
314bar:
315print "bar reached\n";
316EXPECT
317Can't "goto" outside a block at - line 2.