Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / runlevel.t
CommitLineData
1e422769 1#!./perl
2
3##
e336de0d 4## Many of these tests are originally from Michael Schroeder
1e422769 5## <Michael.Schroeder@informatik.uni-erlangen.de>
6e238990 6## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
1e422769 7##
8
9chdir 't' if -d 't';
20822f61 10@INC = '../lib';
9607fc9c 11$Is_VMS = $^O eq 'VMS';
3fe9a6f1 12$Is_MSWin32 = $^O eq 'MSWin32';
2986a63f 13$Is_NetWare = $^O eq 'NetWare';
dc459aad 14$Is_MacOS = $^O eq 'MacOS';
9607fc9c 15$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
1e422769 16
17$|=1;
18
19undef $/;
20@prgs = split "\n########\n", <DATA>;
21print "1..", scalar @prgs, "\n";
22
23$tmpfile = "runltmp000";
241 while -f ++$tmpfile;
9607fc9c 25END { if ($tmpfile) { 1 while unlink $tmpfile; } }
1e422769 26
27for (@prgs){
2c375eb9 28 my $switch = "";
9607fc9c 29 if (s/^\s*(-\w+)//){
30 $switch = $1;
1e422769 31 }
32 my($prog,$expected) = split(/\nEXPECT\n/, $_);
9607fc9c 33 open TEST, ">$tmpfile";
34 print TEST "$prog\n";
d1e4d418 35 close TEST or die "Could not close: $!";
9607fc9c 36 my $results = $Is_VMS ?
be708cc0 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`;
9607fc9c 45 my $status = $?;
1e422769 46 $results =~ s/\n+$//;
9607fc9c 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
1e422769 50 $expected =~ s/\n+$//;
9607fc9c 51 if ($results ne $expected) {
1e422769 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
1e422769 60__END__
61@a = (1, 2, 3);
62{
63 @a = sort { last ; } @a;
64}
65EXPECT
a651a37d 66Can't "last" outside a loop block at - line 3.
1e422769 67########
68package TEST;
69
70sub TIESCALAR {
71 my $foo;
72 return bless \$foo;
73}
74sub FETCH {
75 eval 'die("test")';
76 print "still in fetch\n";
77 return ">$@<";
78}
79package main;
80
81tie $bar, TEST;
82print "- $bar\n";
83EXPECT
84still in fetch
85- >test at (eval 1) line 1.
86<
87########
88package TEST;
89
90sub TIESCALAR {
91 my $foo;
92 eval('die("foo\n")');
93 print "after eval\n";
94 return bless \$foo;
95}
96sub FETCH {
97 return "ZZZ";
98}
99
100package main;
101
102tie $bar, TEST;
103print "- $bar\n";
104print "OK\n";
105EXPECT
106after eval
107- ZZZ
108OK
109########
110package TEST;
111
112sub TIEHANDLE {
113 my $foo;
114 return bless \$foo;
115}
116sub PRINT {
117print STDERR "PRINT CALLED\n";
118(split(/./, 'x'x10000))[0];
119eval('die("test\n")');
120}
121
122package main;
123
124open FH, ">&STDOUT";
125tie *FH, TEST;
126print FH "OK\n";
5aabfad6 127print STDERR "DONE\n";
1e422769 128EXPECT
129PRINT CALLED
130DONE
131########
132sub warnhook {
133 print "WARNHOOK\n";
134 eval('die("foooo\n")');
135}
136$SIG{'__WARN__'} = 'warnhook';
137warn("dfsds\n");
138print "END\n";
139EXPECT
140WARNHOOK
141END
142########
143package TEST;
144
145use overload
146 "\"\"" => \&str
147;
148
149sub str {
150 eval('die("test\n")');
151 return "STR";
152}
153
154package main;
155
156$bar = bless {}, TEST;
157print "$bar\n";
158print "OK\n";
159EXPECT
160STR
161OK
162########
163sub foo {
164 $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
165}
166@a = (3, 2, 0, 1);
167@a = sort foo @a;
168print join(', ', @a)."\n";
169EXPECT
1700, 1, 2, 3
171########
172sub foo {
ca0b63a5 173 goto bar if $a == 0 || $b == 0;
1e422769 174 $a <=> $b;
175}
176@a = (3, 2, 0, 1);
177@a = sort foo @a;
178print join(', ', @a)."\n";
179exit;
180bar:
181print "bar reached\n";
182EXPECT
a651a37d 183Can't "goto" out of a pseudo block at - line 2.
e336de0d 184########
be7ddd5d 185%seen = ();
e336de0d 186sub sortfn {
187 (split(/./, 'x'x10000))[0];
188 my (@y) = ( 4, 6, 5);
189 @y = sort { $a <=> $b } @y;
be7ddd5d 190 my $t = "sortfn ".join(', ', @y)."\n";
191 print $t if ($seen{$t}++ == 0);
e336de0d 192 return $_[0] <=> $_[1];
193}
194@x = ( 3, 2, 1 );
195@x = sort { &sortfn($a, $b) } @x;
196print "---- ".join(', ', @x)."\n";
197EXPECT
198sortfn 4, 5, 6
199---- 1, 2, 3
200########
201@a = (3, 2, 1);
202@a = sort { eval('die("no way")') , $a <=> $b} @a;
203print join(", ", @a)."\n";
204EXPECT
2051, 2, 3
206########
207@a = (1, 2, 3);
208foo:
209{
210 @a = sort { last foo; } @a;
211}
212EXPECT
213Label not found for "last foo" at - line 2.
214########
215package TEST;
216
217sub TIESCALAR {
218 my $foo;
219 return bless \$foo;
220}
221sub FETCH {
222 next;
223 return "ZZZ";
224}
225sub STORE {
226}
227
228package main;
229
230tie $bar, TEST;
231{
232 print "- $bar\n";
233}
234print "OK\n";
235EXPECT
a651a37d 236Can't "next" outside a loop block at - line 8.
e336de0d 237########
238package TEST;
239
240sub TIESCALAR {
241 my $foo;
242 return bless \$foo;
243}
244sub FETCH {
245 goto bbb;
246 return "ZZZ";
247}
248
249package main;
250
251tie $bar, TEST;
252print "- $bar\n";
253exit;
254bbb:
255print "bbb\n";
256EXPECT
257Can't find label bbb at - line 8.
258########
259sub 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;
264print join(', ', @a)."\n";
265EXPECT
2660, 1, 2, 3
267########
268package TEST;
269sub TIESCALAR {
270 my $foo;
271 return bless \$foo;
272}
273sub FETCH {
274 return "fetch";
275}
276sub STORE {
277(split(/./, 'x'x10000))[0];
278}
279package main;
280tie $bar, TEST;
281$bar = "x";
282########
283package TEST;
284sub TIESCALAR {
285 my $foo;
286 next;
287 return bless \$foo;
288}
289package main;
290{
291tie $bar, TEST;
292}
293EXPECT
a651a37d 294Can't "next" outside a loop block at - line 4.
e336de0d 295########
296@a = (1, 2, 3);
297foo:
298{
299 @a = sort { exit(0) } @a;
300}
301END { print "foobar\n" }
302EXPECT
303foobar
2c375eb9 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};
312eval { die };
313&{sub { eval 'die' }}();
314sub foo { eval { die } } foo();
c99da370 315{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package
2c375eb9 316EXPECT
317In DIE
318main|-|8|(eval)
319In DIE
320main|-|9|(eval)
321main|-|9|main::__ANON__
322In DIE
323main|-|10|(eval)
324main|-|10|main::foo
16920d4e 325In DIE
326rmb|-|11|(eval)
c99da370 327rmb|-|11|rmb::__ANON__
be4f712a 328########
329package TEST;
330
331sub TIEARRAY {
332 return bless [qw(foo fee fie foe)], $_[0];
333}
334sub FETCH {
335 my ($s,$i) = @_;
336 if ($i) {
337 goto bbb;
338 }
339bbb:
340 return $s->[$i];
341}
342
343package main;
344tie my @bar, 'TEST';
345print join('|', @bar[0..3]), "\n";
346EXPECT
347foo|fee|fie|foe
0cdb2077 348########
349package TH;
350sub TIEHASH { bless {}, TH }
351sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
352tie %h, TH;
353eval { $h{A} = 1; print "never\n"; };
354print $@;
355eval { $h{B} = 2; };
356print $@;
357EXPECT
358A 1
359bar
360B 2
361bar
ecf8e9dd 362########
363sub n { 0 }
364sub f { my $x = shift; d(); }
365f(n());
366f();
367
368sub 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}
375EXPECT
3760