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