X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Frunlevel.t;h=531b862fd87118727a9ef12961905f43ce12bf7b;hb=1c509eb921569425706e6fe39ea7cb2f11e99d1b;hp=6693a829a882281e5fe592034b308e91da571964;hpb=ca0b63a54384876a335df571abef7f428d67e288;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 6693a82..531b862 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -1,23 +1,17 @@ #!./perl ## -## all of these tests are from Michael Schroeder +## Many of these tests are originally from Michael Schroeder ## -## -## The more esoteric failure modes require Michael's -## stack-of-stacks patch (so we don't test them here, -## and they are commented out before the __END__). -## -## The remaining tests pass with a simpler fix -## intended for 5.004 -## -## Gurusamy Sarathy 97-02-24 +## Adapted and expanded by Gurusamy Sarathy ## chdir 't' if -d 't'; -@INC = "../lib"; +@INC = '../lib'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; +$Is_NetWare = $^O eq 'NetWare'; +$Is_MacOS = $^O eq 'MacOS'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; $|=1; @@ -31,19 +25,23 @@ $tmpfile = "runltmp000"; END { if ($tmpfile) { 1 while unlink $tmpfile; } } for (@prgs){ - my $switch; + my $switch = ""; if (s/^\s*(-\w+)//){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile"; print TEST "$prog\n"; - close TEST; + close TEST or die "Could not close: $!"; my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile` : - $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + $Is_NetWare ? + `perl -I../lib $switch $tmpfile 2>&1` : + $Is_MacOS ? + `$^X -I::lib -MMac::err=unix $switch $tmpfile` : + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN @@ -59,145 +57,13 @@ for (@prgs){ print "ok ", ++$i, "\n"; } -=head2 stay out of here (the real tests are after __END__) - -## -## these tests don't pass yet (need the full stack-of-stacks patch) -## GSAR 97-02-24 -## - -######## -# sort within sort -sub sortfn { - (split(/./, 'x'x10000))[0]; - my (@y) = ( 4, 6, 5); - @y = sort { $a <=> $b } @y; - print "sortfn ".join(', ', @y)."\n"; - return $_[0] <=> $_[1]; -} -@x = ( 3, 2, 1 ); -@x = sort { &sortfn($a, $b) } @x; -print "---- ".join(', ', @x)."\n"; -EXPECT -sortfn 4, 5, 6 ----- 1, 2, 3 -######## -# trapping eval within sort (doesn't work currently because -# die does a SWITCHSTACK()) -@a = (3, 2, 1); -@a = sort { eval('die("no way")') , $a <=> $b} @a; -print join(", ", @a)."\n"; -EXPECT -1, 2, 3 -######## -# this actually works fine, but results in a poor error message -@a = (1, 2, 3); -foo: -{ - @a = sort { last foo; } @a; -} -EXPECT -cannot reach destination block at - line 2. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - next; - return "ZZZ"; -} -sub STORE { -} - -package main; - -tie $bar, TEST; -{ - print "- $bar\n"; -} -print "OK\n"; -EXPECT -cannot reach destination block at - line 8. -######## -package TEST; - -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - goto bbb; - return "ZZZ"; -} - -package main; - -tie $bar, TEST; -print "- $bar\n"; -exit; -bbb: -print "bbb\n"; -EXPECT -bbb -######## -# trapping eval within sort (doesn't work currently because -# die does a SWITCHSTACK()) -sub foo { - $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -EXPECT -0, 1, 2, 3 -######## -package TEST; -sub TIESCALAR { - my $foo; - next; - return bless \$foo; -} -package main; -{ -tie $bar, TEST; -} -EXPECT -cannot reach destination block at - line 4. -######## -# large stack extension causes realloc, and segfault -package TEST; -sub TIESCALAR { - my $foo; - return bless \$foo; -} -sub FETCH { - return "fetch"; -} -sub STORE { -(split(/./, 'x'x10000))[0]; -} -package main; -tie $bar, TEST; -$bar = "x"; - -=cut - -## -## -## The real tests begin here -## -## - __END__ @a = (1, 2, 3); { @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -314,4 +180,230 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. +######## +%seen = (); +sub sortfn { + (split(/./, 'x'x10000))[0]; + my (@y) = ( 4, 6, 5); + @y = sort { $a <=> $b } @y; + my $t = "sortfn ".join(', ', @y)."\n"; + print $t if ($seen{$t}++ == 0); + return $_[0] <=> $_[1]; +} +@x = ( 3, 2, 1 ); +@x = sort { &sortfn($a, $b) } @x; +print "---- ".join(', ', @x)."\n"; +EXPECT +sortfn 4, 5, 6 +---- 1, 2, 3 +######## +@a = (3, 2, 1); +@a = sort { eval('die("no way")') , $a <=> $b} @a; +print join(", ", @a)."\n"; +EXPECT +1, 2, 3 +######## +@a = (1, 2, 3); +foo: +{ + @a = sort { last foo; } @a; +} +EXPECT +Label not found for "last foo" at - line 2. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + next; + return "ZZZ"; +} +sub STORE { +} + +package main; + +tie $bar, TEST; +{ + print "- $bar\n"; +} +print "OK\n"; +EXPECT +Can't "next" outside a loop block at - line 8. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + goto bbb; + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +exit; +bbb: +print "bbb\n"; +EXPECT +Can't find label bbb at - line 8. +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +package TEST; +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + return "fetch"; +} +sub STORE { +(split(/./, 'x'x10000))[0]; +} +package main; +tie $bar, TEST; +$bar = "x"; +######## +package TEST; +sub TIESCALAR { + my $foo; + next; + return bless \$foo; +} +package main; +{ +tie $bar, TEST; +} +EXPECT +Can't "next" outside a loop block at - line 4. +######## +@a = (1, 2, 3); +foo: +{ + @a = sort { exit(0) } @a; +} +END { print "foobar\n" } +EXPECT +foobar +######## +$SIG{__DIE__} = sub { + print "In DIE\n"; + $i = 0; + while (($p,$f,$l,$s) = caller(++$i)) { + print "$p|$f|$l|$s\n"; + } +}; +eval { die }; +&{sub { eval 'die' }}(); +sub foo { eval { die } } foo(); +{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package +EXPECT +In DIE +main|-|8|(eval) +In DIE +main|-|9|(eval) +main|-|9|main::__ANON__ +In DIE +main|-|10|(eval) +main|-|10|main::foo +In DIE +rmb|-|11|(eval) +rmb|-|11|rmb::__ANON__ +######## +package TEST; + +sub TIEARRAY { + return bless [qw(foo fee fie foe)], $_[0]; +} +sub FETCH { + my ($s,$i) = @_; + if ($i) { + goto bbb; + } +bbb: + return $s->[$i]; +} + +package main; +tie my @bar, 'TEST'; +print join('|', @bar[0..3]), "\n"; +EXPECT +foo|fee|fie|foe +######## +package TH; +sub TIEHASH { bless {}, TH } +sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } +tie %h, TH; +eval { $h{A} = 1; print "never\n"; }; +print $@; +eval { $h{B} = 2; }; +print $@; +EXPECT +A 1 +bar +B 2 +bar +######## +sub n { 0 } +sub f { my $x = shift; d(); } +f(n()); +f(); + +sub d { + my $i = 0; my @a; + while (do { { package DB; @a = caller($i++) } } ) { + @a = @DB::args; + for (@a) { print "$_\n"; $_ = '' } + } +} +EXPECT +0 +######## +sub TIEHANDLE { bless {} } +sub PRINT { next } + +tie *STDERR, ''; +{ map ++$_, 1 } + +EXPECT +Can't "next" outside a loop block at - line 2. +######## +sub TIEHANDLE { bless {} } +sub PRINT { print "[TIE] $_[1]" } + +tie *STDERR, ''; +die "DIE\n"; + +EXPECT +[TIE] DIE +######## +sub TIEHANDLE { bless {} } +sub PRINT { + (split(/./, 'x'x10000))[0]; + eval('die("test\n")'); + warn "[TIE] $_[1]"; +} +open OLDERR, '>&STDERR'; +tie *STDERR, ''; + +use warnings FATAL => qw(uninitialized); +print undef; + +EXPECT +[TIE] Use of uninitialized value in print at - line 11.