#!./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@activestate.com>
##
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;
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
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.
+<
+########
+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
########
-# sort within sort
+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 );
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;
}
print "OK\n";
EXPECT
-cannot reach destination block at - line 8.
+Can't "next" outside a loop block at - line 8.
########
package TEST;
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)');
}
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 {
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 STDERR "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.
projects / p5sagit/p5-mst-13.2.git / blobdiff