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
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 $Is_MSWin32 = $^O eq 'MSWin32';
21 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
22
23 $|=1;
24
25 undef $/;
26 @prgs = split "\n########\n", <DATA>;
27 print "1..", scalar @prgs, "\n";
28
29 $tmpfile = "runltmp000";
30 1 while -f ++$tmpfile;
31 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
32
33 for (@prgs){
34     my $switch;
35     if (s/^\s*(-\w+)//){
36        $switch = $1;
37     }
38     my($prog,$expected) = split(/\nEXPECT\n/, $_);
39     open TEST, ">$tmpfile";
40     print TEST "$prog\n";
41     close TEST;
42     my $results = $Is_VMS ?
43                   `MCR $^X "-I[-.lib]" $switch $tmpfile` :
44                       $Is_MSWin32 ?  
45                           `.\\perl -I../lib $switch $tmpfile 2>&1` :
46                               `sh -c './perl $switch $tmpfile' 2>&1`;
47     my $status = $?;
48     $results =~ s/\n+$//;
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
52     $expected =~ s/\n+$//;
53     if ($results ne $expected) {
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
71 sub 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;
80 print "---- ".join(', ', @x)."\n";
81 EXPECT
82 sortfn 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;
89 print join(", ", @a)."\n";
90 EXPECT
91 1, 2, 3
92 ########
93 # this actually works fine, but results in a poor error message
94 @a = (1, 2, 3);
95 foo:
96 {
97   @a = sort { last foo; } @a;
98 }
99 EXPECT
100 cannot reach destination block at - line 2.
101 ########
102 package TEST;
103  
104 sub TIESCALAR {
105   my $foo;
106   return bless \$foo;
107 }
108 sub FETCH {
109   next;
110   return "ZZZ";
111 }
112 sub STORE {
113 }
114  
115 package main;
116  
117 tie $bar, TEST;
118 {
119   print "- $bar\n";
120 }
121 print "OK\n";
122 EXPECT
123 cannot reach destination block at - line 8.
124 ########
125 package TEST;
126  
127 sub TIESCALAR {
128   my $foo;
129   return bless \$foo;
130 }
131 sub FETCH {
132   goto bbb;
133   return "ZZZ";
134 }
135  
136 package main;
137  
138 tie $bar, TEST;
139 print "- $bar\n";
140 exit;
141 bbb:
142 print "bbb\n";
143 EXPECT
144 bbb
145 ########
146 # trapping eval within sort (doesn't work currently because
147 # die does a SWITCHSTACK())
148 sub 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;
153 print join(', ', @a)."\n";
154 EXPECT
155 0, 1, 2, 3
156 ########
157 package TEST;
158 sub TIESCALAR {
159   my $foo;
160   next;
161   return bless \$foo;
162 }
163 package main;
164 {
165 tie $bar, TEST;
166 }
167 EXPECT
168 cannot reach destination block at - line 4.
169 ########
170 # large stack extension causes realloc, and segfault
171 package TEST;
172 sub TIESCALAR {
173   my $foo;
174   return bless \$foo;
175 }
176 sub FETCH {
177   return "fetch";
178 }
179 sub STORE {
180 (split(/./, 'x'x10000))[0];
181 }
182 package main;
183 tie $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 }
199 EXPECT
200 Can't "last" outside a block at - line 3.
201 ########
202 package TEST;
203  
204 sub TIESCALAR {
205   my $foo;
206   return bless \$foo;
207 }
208 sub FETCH {
209   eval 'die("test")';
210   print "still in fetch\n";
211   return ">$@<";
212 }
213 package main;
214  
215 tie $bar, TEST;
216 print "- $bar\n";
217 EXPECT
218 still in fetch
219 - >test at (eval 1) line 1.
220 <
221 ########
222 package TEST;
223  
224 sub TIESCALAR {
225   my $foo;
226   eval('die("foo\n")');
227   print "after eval\n";
228   return bless \$foo;
229 }
230 sub FETCH {
231   return "ZZZ";
232 }
233  
234 package main;
235  
236 tie $bar, TEST;
237 print "- $bar\n";
238 print "OK\n";
239 EXPECT
240 after eval
241 - ZZZ
242 OK
243 ########
244 package TEST;
245  
246 sub TIEHANDLE {
247   my $foo;
248   return bless \$foo;
249 }
250 sub PRINT {
251 print STDERR "PRINT CALLED\n";
252 (split(/./, 'x'x10000))[0];
253 eval('die("test\n")');
254 }
255  
256 package main;
257  
258 open FH, ">&STDOUT";
259 tie *FH, TEST;
260 print FH "OK\n";
261 print STDERR "DONE\n";
262 EXPECT
263 PRINT CALLED
264 DONE
265 ########
266 sub warnhook {
267   print "WARNHOOK\n";
268   eval('die("foooo\n")');
269 }
270 $SIG{'__WARN__'} = 'warnhook';
271 warn("dfsds\n");
272 print "END\n";
273 EXPECT
274 WARNHOOK
275 END
276 ########
277 package TEST;
278  
279 use overload
280      "\"\""   =>  \&str
281 ;
282  
283 sub str {
284   eval('die("test\n")');
285   return "STR";
286 }
287  
288 package main;
289  
290 $bar = bless {}, TEST;
291 print "$bar\n";
292 print "OK\n";
293 EXPECT
294 STR
295 OK
296 ########
297 sub foo {
298   $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
299 }
300 @a = (3, 2, 0, 1);
301 @a = sort foo @a;
302 print join(', ', @a)."\n";
303 EXPECT
304 0, 1, 2, 3
305 ########
306 sub foo {
307   goto bar if $a == 0;
308   $a <=> $b;
309 }
310 @a = (3, 2, 0, 1);
311 @a = sort foo @a;
312 print join(', ', @a)."\n";
313 exit;
314 bar:
315 print "bar reached\n";
316 EXPECT
317 Can't "goto" outside a block at - line 2.