531b862fd87118727a9ef12961905f43ce12bf7b
[perl.git] / t / op / runlevel.t
1 #!./perl
2
3 ##
4 ## Many of these tests are originally from Michael Schroeder
5 ## <Michael.Schroeder@informatik.uni-erlangen.de>
6 ## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
7 ##
8
9 chdir 't' if -d 't';
10 @INC = '../lib';
11 $Is_VMS = $^O eq 'VMS';
12 $Is_MSWin32 = $^O eq 'MSWin32';
13 $Is_NetWare = $^O eq 'NetWare';
14 $Is_MacOS = $^O eq 'MacOS';
15 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
16
17 $|=1;
18
19 undef $/;
20 @prgs = split "\n########\n", <DATA>;
21 print "1..", scalar @prgs, "\n";
22
23 $tmpfile = "runltmp000";
24 1 while -f ++$tmpfile;
25 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
26
27 for (@prgs){
28     my $switch = "";
29     if (s/^\s*(-\w+)//){
30        $switch = $1;
31     }
32     my($prog,$expected) = split(/\nEXPECT\n/, $_);
33     open TEST, ">$tmpfile";
34     print TEST "$prog\n";
35     close TEST or die "Could not close: $!";
36     my $results = $Is_VMS ?
37                       `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
38                   $Is_MSWin32 ?  
39                       `.\\perl -I../lib $switch $tmpfile 2>&1` :
40                   $Is_NetWare ?  
41                       `perl -I../lib $switch $tmpfile 2>&1` :
42                   $Is_MacOS ?
43                       `$^X -I::lib -MMac::err=unix $switch $tmpfile` :
44                   `./perl $switch $tmpfile 2>&1`;
45     my $status = $?;
46     $results =~ s/\n+$//;
47     # allow expected output to be written as if $prog is on STDIN
48     $results =~ s/runltmp\d+/-/g;
49     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
50     $expected =~ s/\n+$//;
51     if ($results ne $expected) {
52        print STDERR "PROG: $switch\n$prog\n";
53        print STDERR "EXPECTED:\n$expected\n";
54        print STDERR "GOT:\n$results\n";
55        print "not ";
56     }
57     print "ok ", ++$i, "\n";
58 }
59
60 __END__
61 @a = (1, 2, 3);
62 {
63   @a = sort { last ; } @a;
64 }
65 EXPECT
66 Can't "last" outside a loop block at - line 3.
67 ########
68 package TEST;
69  
70 sub TIESCALAR {
71   my $foo;
72   return bless \$foo;
73 }
74 sub FETCH {
75   eval 'die("test")';
76   print "still in fetch\n";
77   return ">$@<";
78 }
79 package main;
80  
81 tie $bar, TEST;
82 print "- $bar\n";
83 EXPECT
84 still in fetch
85 - >test at (eval 1) line 1.
86 <
87 ########
88 package TEST;
89  
90 sub TIESCALAR {
91   my $foo;
92   eval('die("foo\n")');
93   print "after eval\n";
94   return bless \$foo;
95 }
96 sub FETCH {
97   return "ZZZ";
98 }
99  
100 package main;
101  
102 tie $bar, TEST;
103 print "- $bar\n";
104 print "OK\n";
105 EXPECT
106 after eval
107 - ZZZ
108 OK
109 ########
110 package TEST;
111  
112 sub TIEHANDLE {
113   my $foo;
114   return bless \$foo;
115 }
116 sub PRINT {
117 print STDERR "PRINT CALLED\n";
118 (split(/./, 'x'x10000))[0];
119 eval('die("test\n")');
120 }
121  
122 package main;
123  
124 open FH, ">&STDOUT";
125 tie *FH, TEST;
126 print FH "OK\n";
127 print STDERR "DONE\n";
128 EXPECT
129 PRINT CALLED
130 DONE
131 ########
132 sub warnhook {
133   print "WARNHOOK\n";
134   eval('die("foooo\n")');
135 }
136 $SIG{'__WARN__'} = 'warnhook';
137 warn("dfsds\n");
138 print "END\n";
139 EXPECT
140 WARNHOOK
141 END
142 ########
143 package TEST;
144  
145 use overload
146      "\"\""   =>  \&str
147 ;
148  
149 sub str {
150   eval('die("test\n")');
151   return "STR";
152 }
153  
154 package main;
155  
156 $bar = bless {}, TEST;
157 print "$bar\n";
158 print "OK\n";
159 EXPECT
160 STR
161 OK
162 ########
163 sub foo {
164   $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
165 }
166 @a = (3, 2, 0, 1);
167 @a = sort foo @a;
168 print join(', ', @a)."\n";
169 EXPECT
170 0, 1, 2, 3
171 ########
172 sub foo {
173   goto bar if $a == 0 || $b == 0;
174   $a <=> $b;
175 }
176 @a = (3, 2, 0, 1);
177 @a = sort foo @a;
178 print join(', ', @a)."\n";
179 exit;
180 bar:
181 print "bar reached\n";
182 EXPECT
183 Can't "goto" out of a pseudo block at - line 2.
184 ########
185 %seen = ();
186 sub sortfn {
187   (split(/./, 'x'x10000))[0];
188   my (@y) = ( 4, 6, 5);
189   @y = sort { $a <=> $b } @y;
190   my $t = "sortfn ".join(', ', @y)."\n";
191   print $t if ($seen{$t}++ == 0);
192   return $_[0] <=> $_[1];
193 }
194 @x = ( 3, 2, 1 );
195 @x = sort { &sortfn($a, $b) } @x;
196 print "---- ".join(', ', @x)."\n";
197 EXPECT
198 sortfn 4, 5, 6
199 ---- 1, 2, 3
200 ########
201 @a = (3, 2, 1);
202 @a = sort { eval('die("no way")') ,  $a <=> $b} @a;
203 print join(", ", @a)."\n";
204 EXPECT
205 1, 2, 3
206 ########
207 @a = (1, 2, 3);
208 foo:
209 {
210   @a = sort { last foo; } @a;
211 }
212 EXPECT
213 Label not found for "last foo" at - line 2.
214 ########
215 package TEST;
216  
217 sub TIESCALAR {
218   my $foo;
219   return bless \$foo;
220 }
221 sub FETCH {
222   next;
223   return "ZZZ";
224 }
225 sub STORE {
226 }
227  
228 package main;
229  
230 tie $bar, TEST;
231 {
232   print "- $bar\n";
233 }
234 print "OK\n";
235 EXPECT
236 Can't "next" outside a loop block at - line 8.
237 ########
238 package TEST;
239  
240 sub TIESCALAR {
241   my $foo;
242   return bless \$foo;
243 }
244 sub FETCH {
245   goto bbb;
246   return "ZZZ";
247 }
248  
249 package main;
250  
251 tie $bar, TEST;
252 print "- $bar\n";
253 exit;
254 bbb:
255 print "bbb\n";
256 EXPECT
257 Can't find label bbb at - line 8.
258 ########
259 sub foo {
260   $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
261 }
262 @a = (3, 2, 0, 1);
263 @a = sort foo @a;
264 print join(', ', @a)."\n";
265 EXPECT
266 0, 1, 2, 3
267 ########
268 package TEST;
269 sub TIESCALAR {
270   my $foo;
271   return bless \$foo;
272 }
273 sub FETCH {
274   return "fetch";
275 }
276 sub STORE {
277 (split(/./, 'x'x10000))[0];
278 }
279 package main;
280 tie $bar, TEST;
281 $bar = "x";
282 ########
283 package TEST;
284 sub TIESCALAR {
285   my $foo;
286   next;
287   return bless \$foo;
288 }
289 package main;
290 {
291 tie $bar, TEST;
292 }
293 EXPECT
294 Can't "next" outside a loop block at - line 4.
295 ########
296 @a = (1, 2, 3);
297 foo:
298 {
299   @a = sort { exit(0) } @a;
300 }
301 END { print "foobar\n" }
302 EXPECT
303 foobar
304 ########
305 $SIG{__DIE__} = sub {
306     print "In DIE\n";
307     $i = 0;
308     while (($p,$f,$l,$s) = caller(++$i)) {
309         print "$p|$f|$l|$s\n";
310     }
311 };
312 eval { die };
313 &{sub { eval 'die' }}();
314 sub foo { eval { die } } foo();
315 {package rmb; sub{ eval{die} } ->() };  # check __ANON__ knows package  
316 EXPECT
317 In DIE
318 main|-|8|(eval)
319 In DIE
320 main|-|9|(eval)
321 main|-|9|main::__ANON__
322 In DIE
323 main|-|10|(eval)
324 main|-|10|main::foo
325 In DIE
326 rmb|-|11|(eval)
327 rmb|-|11|rmb::__ANON__
328 ########
329 package TEST;
330  
331 sub TIEARRAY {
332   return bless [qw(foo fee fie foe)], $_[0];
333 }
334 sub FETCH {
335   my ($s,$i) = @_;
336   if ($i) {
337     goto bbb;
338   }
339 bbb:
340   return $s->[$i];
341 }
342  
343 package main;
344 tie my @bar, 'TEST';
345 print join('|', @bar[0..3]), "\n"; 
346 EXPECT
347 foo|fee|fie|foe
348 ########
349 package TH;
350 sub TIEHASH { bless {}, TH }
351 sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
352 tie %h, TH;
353 eval { $h{A} = 1; print "never\n"; };
354 print $@;
355 eval { $h{B} = 2; };
356 print $@;
357 EXPECT
358 A 1
359 bar
360 B 2
361 bar
362 ########
363 sub n { 0 }
364 sub f { my $x = shift; d(); }
365 f(n());
366 f();
367
368 sub d {
369     my $i = 0; my @a;
370     while (do { { package DB; @a = caller($i++) } } ) {
371         @a = @DB::args;
372         for (@a) { print "$_\n"; $_ = '' }
373     }
374 }
375 EXPECT
376 0
377 ########
378 sub TIEHANDLE { bless {} }
379 sub PRINT { next }
380
381 tie *STDERR, '';
382 { map ++$_, 1 }
383
384 EXPECT
385 Can't "next" outside a loop block at - line 2.
386 ########
387 sub TIEHANDLE { bless {} }
388 sub PRINT { print "[TIE] $_[1]" }
389
390 tie *STDERR, '';
391 die "DIE\n";
392
393 EXPECT
394 [TIE] DIE
395 ########
396 sub TIEHANDLE { bless {} }
397 sub PRINT { 
398     (split(/./, 'x'x10000))[0];
399     eval('die("test\n")');
400     warn "[TIE] $_[1]";
401 }
402 open OLDERR, '>&STDERR';
403 tie *STDERR, '';
404
405 use warnings FATAL => qw(uninitialized);
406 print undef;
407
408 EXPECT
409 [TIE] Use of uninitialized value in print at - line 11.