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