diff options
author | Gurusamy Sarathy <gsar@cpan.org> | 1998-04-03 06:59:37 +0000 |
---|---|---|
committer | Gurusamy Sarathy <gsar@cpan.org> | 1998-04-03 06:59:37 +0000 |
commit | e336de0d01f30cc4061b6d6a00d11df30fc67cd3 (patch) | |
tree | 47af4eae88807f461d216a10701a0502a2373226 /t/op | |
parent | dfb1c8b93631b1cf8c1d0d2295ffff2bf0f098a7 (diff) | |
download | perl-e336de0d01f30cc4061b6d6a00d11df30fc67cd3.tar.gz |
[win32] implement stack-of-stacks so that magic invocations don't
invalidate local stack pointer
p4raw-id: //depot/win32/perl@864
Diffstat (limited to 't/op')
-rwxr-xr-x | t/op/runlevel.t | 262 |
1 files changed, 120 insertions, 142 deletions
diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 6693a829a8..b5e5dbb08c 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -1,17 +1,9 @@ #!./perl ## -## all of these tests are from Michael Schroeder +## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## -## 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 <gsar@umich.edu> 97-02-24 +## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> ## chdir 't' if -d 't'; @@ -59,138 +51,6 @@ 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); { @@ -315,3 +175,121 @@ bar: print "bar reached\n"; EXPECT Can't "goto" outside a block at - line 2. +######## +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 +######## +@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 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 block at - line 4. +######## +@a = (1, 2, 3); +foo: +{ + @a = sort { exit(0) } @a; +} +END { print "foobar\n" } +EXPECT +foobar |