X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fop%2Frunlevel.t;h=531b862fd87118727a9ef12961905f43ce12bf7b;hb=076d9a11d18d650bf0992032a42c6e83fb1c2ea6;hp=ca6aac5e5b48f09299ff2da785637db628460822;hpb=1536cbcdad02306820a683a6623c43d262850c91;p=p5sagit%2Fp5-mst-13.2.git diff --git a/t/op/runlevel.t b/t/op/runlevel.t index ca6aac5..531b862 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -1,22 +1,18 @@ #!./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"; -$ENV{PERL5LIB} = "../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; @@ -26,22 +22,33 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "runltmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { if ($tmpfile) { 1 while unlink $tmpfile; } } for (@prgs){ - my $switch; - if (s/^\s*-\w+//){ - $switch = $&; + my $switch = ""; + if (s/^\s*(-\w+)//){ + $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); - open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; - print TEST $prog, "\n"; - close TEST; - $status = $?; - $results = `cat $tmpfile`; + open TEST, ">$tmpfile"; + print TEST "$prog\n"; + close TEST or die "Could not close: $!"; + my $results = $Is_VMS ? + `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 + $results =~ s/runltmp\d+/-/g; + $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg $expected =~ s/\n+$//; - if ( $results ne $expected){ + if ($results ne $expected) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; @@ -50,20 +57,138 @@ 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 -## - +__END__ +@a = (1, 2, 3); +{ + @a = sort { last ; } @a; +} +EXPECT +Can't "last" outside a loop block at - line 3. +######## +package TEST; + +sub TIESCALAR { + my $foo; + return bless \$foo; +} +sub FETCH { + eval 'die("test")'; + print "still in fetch\n"; + return ">$@<"; +} +package main; + +tie $bar, TEST; +print "- $bar\n"; +EXPECT +still in fetch +- >test at (eval 1) line 1. +< ######## -# sort within sort +package TEST; + +sub TIESCALAR { + my $foo; + eval('die("foo\n")'); + print "after eval\n"; + return bless \$foo; +} +sub FETCH { + return "ZZZ"; +} + +package main; + +tie $bar, TEST; +print "- $bar\n"; +print "OK\n"; +EXPECT +after eval +- ZZZ +OK +######## +package TEST; + +sub TIEHANDLE { + my $foo; + return bless \$foo; +} +sub PRINT { +print STDERR "PRINT CALLED\n"; +(split(/./, 'x'x10000))[0]; +eval('die("test\n")'); +} + +package main; + +open FH, ">&STDOUT"; +tie *FH, TEST; +print FH "OK\n"; +print STDERR "DONE\n"; +EXPECT +PRINT CALLED +DONE +######## +sub warnhook { + print "WARNHOOK\n"; + eval('die("foooo\n")'); +} +$SIG{'__WARN__'} = 'warnhook'; +warn("dfsds\n"); +print "END\n"; +EXPECT +WARNHOOK +END +######## +package TEST; + +use overload + "\"\"" => \&str +; + +sub str { + eval('die("test\n")'); + return "STR"; +} + +package main; + +$bar = bless {}, TEST; +print "$bar\n"; +print "OK\n"; +EXPECT +STR +OK +######## +sub foo { + $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +EXPECT +0, 1, 2, 3 +######## +sub foo { + goto bar if $a == 0 || $b == 0; + $a <=> $b; +} +@a = (3, 2, 0, 1); +@a = sort foo @a; +print join(', ', @a)."\n"; +exit; +bar: +print "bar reached\n"; +EXPECT +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; - print "sortfn ".join(', ', @y)."\n"; + my $t = "sortfn ".join(', ', @y)."\n"; + print $t if ($seen{$t}++ == 0); return $_[0] <=> $_[1]; } @x = ( 3, 2, 1 ); @@ -73,22 +198,19 @@ 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. +Label not found for "last foo" at - line 2. ######## package TEST; @@ -111,7 +233,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -cannot reach destination block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -132,10 +254,8 @@ exit; bbb: print "bbb\n"; EXPECT -bbb +Can't find label bbb at - line 8. ######## -# 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)'); } @@ -148,20 +268,6 @@ EXPECT 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 { @@ -173,136 +279,131 @@ sub STORE { 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. ######## package TEST; - sub TIESCALAR { my $foo; + next; return bless \$foo; } -sub FETCH { - eval 'die("test")'; - print "still in fetch\n"; - return ">$@<"; -} package main; - +{ tie $bar, TEST; -print "- $bar\n"; +} EXPECT -still in fetch -- >test at (eval 1) line 1. -< +Can't "next" outside a loop block at - line 4. ######## -package TEST; - -sub TIESCALAR { - my $foo; - eval('die("foo\n")'); - print "after eval\n"; - return bless \$foo; -} -sub FETCH { - return "ZZZ"; +@a = (1, 2, 3); +foo: +{ + @a = sort { exit(0) } @a; } - -package main; - -tie $bar, TEST; -print "- $bar\n"; -print "OK\n"; +END { print "foobar\n" } EXPECT -after eval -- ZZZ -OK +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 TIEHANDLE { - my $foo; - return bless \$foo; +sub TIEARRAY { + return bless [qw(foo fee fie foe)], $_[0]; } -sub PRINT { -print STDERR "PRINT CALLED\n"; -(split(/./, 'x'x10000))[0]; -eval('die("test\n")'); +sub FETCH { + my ($s,$i) = @_; + if ($i) { + goto bbb; + } +bbb: + return $s->[$i]; } package main; - -open FH, ">&STDOUT"; -tie *FH, TEST; -print FH "OK\n"; -print "DONE\n"; +tie my @bar, 'TEST'; +print join('|', @bar[0..3]), "\n"; EXPECT -PRINT CALLED -DONE +foo|fee|fie|foe ######## -sub warnhook { - print "WARNHOOK\n"; - eval('die("foooo\n")'); -} -$SIG{'__WARN__'} = 'warnhook'; -warn("dfsds\n"); -print "END\n"; +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 -WARNHOOK -END +A 1 +bar +B 2 +bar ######## -package TEST; - -use overload - "\"\"" => \&str -; - -sub str { - eval('die("test\n")'); - return "STR"; +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"; $_ = '' } + } } - -package main; - -$bar = bless {}, TEST; -print "$bar\n"; -print "OK\n"; EXPECT -STR -OK +0 ######## -sub foo { - $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)'); -} -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; +sub TIEHANDLE { bless {} } +sub PRINT { next } + +tie *STDERR, ''; +{ map ++$_, 1 } + EXPECT -0, 1, 2, 3 +Can't "next" outside a loop block at - line 2. ######## -sub foo { - goto bar if $a == 0; - $a <=> $b; +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]"; } -@a = (3, 2, 0, 1); -@a = sort foo @a; -print join(', ', @a)."\n"; -exit; -bar: -print "bar reached\n"; +open OLDERR, '>&STDERR'; +tie *STDERR, ''; + +use warnings FATAL => qw(uninitialized); +print undef; + EXPECT -Can't "goto" outside a block at - line 2. +[TIE] Use of uninitialized value in print at - line 11.