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