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