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