1N/A#!./perl
1N/A
1N/A##
1N/A## Many of these tests are originally from Michael Schroeder
1N/A## <Michael.Schroeder@informatik.uni-erlangen.de>
1N/A## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
1N/A##
1N/A
1N/Achdir 't' if -d 't';
1N/A@INC = '../lib';
1N/A$Is_VMS = $^O eq 'VMS';
1N/A$Is_MSWin32 = $^O eq 'MSWin32';
1N/A$Is_NetWare = $^O eq 'NetWare';
1N/A$Is_MacOS = $^O eq 'MacOS';
1N/A$ENV{PERL5LIB} = "../lib" unless $Is_VMS;
1N/A
1N/A$|=1;
1N/A
1N/Aundef $/;
1N/A@prgs = split "\n########\n", <DATA>;
1N/Aprint "1..", scalar @prgs, "\n";
1N/A
1N/A$tmpfile = "runltmp000";
1N/A1 while -f ++$tmpfile;
1N/AEND { if ($tmpfile) { 1 while unlink $tmpfile; } }
1N/A
1N/Afor (@prgs){
1N/A my $switch = "";
1N/A if (s/^\s*(-\w+)//){
1N/A $switch = $1;
1N/A }
1N/A my($prog,$expected) = split(/\nEXPECT\n/, $_);
1N/A open TEST, ">$tmpfile";
1N/A print TEST "$prog\n";
1N/A close TEST or die "Could not close: $!";
1N/A my $results = $Is_VMS ?
1N/A `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` :
1N/A $Is_MSWin32 ?
1N/A `.\\perl -I../lib $switch $tmpfile 2>&1` :
1N/A $Is_NetWare ?
1N/A `perl -I../lib $switch $tmpfile 2>&1` :
1N/A $Is_MacOS ?
1N/A `$^X -I::lib -MMac::err=unix $switch $tmpfile` :
1N/A `./perl $switch $tmpfile 2>&1`;
1N/A my $status = $?;
1N/A $results =~ s/\n+$//;
1N/A # allow expected output to be written as if $prog is on STDIN
1N/A $results =~ s/runltmp\d+/-/g;
1N/A $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg
1N/A $expected =~ s/\n+$//;
1N/A if ($results ne $expected) {
1N/A print STDERR "PROG: $switch\n$prog\n";
1N/A print STDERR "EXPECTED:\n$expected\n";
1N/A print STDERR "GOT:\n$results\n";
1N/A print "not ";
1N/A }
1N/A print "ok ", ++$i, "\n";
1N/A}
1N/A
1N/A__END__
1N/A@a = (1, 2, 3);
1N/A{
1N/A @a = sort { last ; } @a;
1N/A}
1N/AEXPECT
1N/ACan't "last" outside a loop block at - line 3.
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A return bless \$foo;
1N/A}
1N/Asub FETCH {
1N/A eval 'die("test")';
1N/A print "still in fetch\n";
1N/A return ">$@<";
1N/A}
1N/Apackage main;
1N/A
1N/Atie $bar, TEST;
1N/Aprint "- $bar\n";
1N/AEXPECT
1N/Astill in fetch
1N/A- >test at (eval 1) line 1.
1N/A<
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A eval('die("foo\n")');
1N/A print "after eval\n";
1N/A return bless \$foo;
1N/A}
1N/Asub FETCH {
1N/A return "ZZZ";
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Atie $bar, TEST;
1N/Aprint "- $bar\n";
1N/Aprint "OK\n";
1N/AEXPECT
1N/Aafter eval
1N/A- ZZZ
1N/AOK
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIEHANDLE {
1N/A my $foo;
1N/A return bless \$foo;
1N/A}
1N/Asub PRINT {
1N/Aprint STDERR "PRINT CALLED\n";
1N/A(split(/./, 'x'x10000))[0];
1N/Aeval('die("test\n")');
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Aopen FH, ">&STDOUT";
1N/Atie *FH, TEST;
1N/Aprint FH "OK\n";
1N/Aprint STDERR "DONE\n";
1N/AEXPECT
1N/APRINT CALLED
1N/ADONE
1N/A########
1N/Asub warnhook {
1N/A print "WARNHOOK\n";
1N/A eval('die("foooo\n")');
1N/A}
1N/A$SIG{'__WARN__'} = 'warnhook';
1N/Awarn("dfsds\n");
1N/Aprint "END\n";
1N/AEXPECT
1N/AWARNHOOK
1N/AEND
1N/A########
1N/Apackage TEST;
1N/A
1N/Ause overload
1N/A "\"\"" => \&str
1N/A;
1N/A
1N/Asub str {
1N/A eval('die("test\n")');
1N/A return "STR";
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/A$bar = bless {}, TEST;
1N/Aprint "$bar\n";
1N/Aprint "OK\n";
1N/AEXPECT
1N/ASTR
1N/AOK
1N/A########
1N/Asub foo {
1N/A $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
1N/A}
1N/A@a = (3, 2, 0, 1);
1N/A@a = sort foo @a;
1N/Aprint join(', ', @a)."\n";
1N/AEXPECT
1N/A0, 1, 2, 3
1N/A########
1N/Asub foo {
1N/A goto bar if $a == 0 || $b == 0;
1N/A $a <=> $b;
1N/A}
1N/A@a = (3, 2, 0, 1);
1N/A@a = sort foo @a;
1N/Aprint join(', ', @a)."\n";
1N/Aexit;
1N/Abar:
1N/Aprint "bar reached\n";
1N/AEXPECT
1N/ACan't "goto" out of a pseudo block at - line 2.
1N/A########
1N/A%seen = ();
1N/Asub sortfn {
1N/A (split(/./, 'x'x10000))[0];
1N/A my (@y) = ( 4, 6, 5);
1N/A @y = sort { $a <=> $b } @y;
1N/A my $t = "sortfn ".join(', ', @y)."\n";
1N/A print $t if ($seen{$t}++ == 0);
1N/A return $_[0] <=> $_[1];
1N/A}
1N/A@x = ( 3, 2, 1 );
1N/A@x = sort { &sortfn($a, $b) } @x;
1N/Aprint "---- ".join(', ', @x)."\n";
1N/AEXPECT
1N/Asortfn 4, 5, 6
1N/A---- 1, 2, 3
1N/A########
1N/A@a = (3, 2, 1);
1N/A@a = sort { eval('die("no way")') , $a <=> $b} @a;
1N/Aprint join(", ", @a)."\n";
1N/AEXPECT
1N/A1, 2, 3
1N/A########
1N/A@a = (1, 2, 3);
1N/Afoo:
1N/A{
1N/A @a = sort { last foo; } @a;
1N/A}
1N/AEXPECT
1N/ALabel not found for "last foo" at - line 2.
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A return bless \$foo;
1N/A}
1N/Asub FETCH {
1N/A next;
1N/A return "ZZZ";
1N/A}
1N/Asub STORE {
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Atie $bar, TEST;
1N/A{
1N/A print "- $bar\n";
1N/A}
1N/Aprint "OK\n";
1N/AEXPECT
1N/ACan't "next" outside a loop block at - line 8.
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A return bless \$foo;
1N/A}
1N/Asub FETCH {
1N/A goto bbb;
1N/A return "ZZZ";
1N/A}
1N/A
1N/Apackage main;
1N/A
1N/Atie $bar, TEST;
1N/Aprint "- $bar\n";
1N/Aexit;
1N/Abbb:
1N/Aprint "bbb\n";
1N/AEXPECT
1N/ACan't find label bbb at - line 8.
1N/A########
1N/Asub foo {
1N/A $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
1N/A}
1N/A@a = (3, 2, 0, 1);
1N/A@a = sort foo @a;
1N/Aprint join(', ', @a)."\n";
1N/AEXPECT
1N/A0, 1, 2, 3
1N/A########
1N/Apackage TEST;
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A return bless \$foo;
1N/A}
1N/Asub FETCH {
1N/A return "fetch";
1N/A}
1N/Asub STORE {
1N/A(split(/./, 'x'x10000))[0];
1N/A}
1N/Apackage main;
1N/Atie $bar, TEST;
1N/A$bar = "x";
1N/A########
1N/Apackage TEST;
1N/Asub TIESCALAR {
1N/A my $foo;
1N/A next;
1N/A return bless \$foo;
1N/A}
1N/Apackage main;
1N/A{
1N/Atie $bar, TEST;
1N/A}
1N/AEXPECT
1N/ACan't "next" outside a loop block at - line 4.
1N/A########
1N/A@a = (1, 2, 3);
1N/Afoo:
1N/A{
1N/A @a = sort { exit(0) } @a;
1N/A}
1N/AEND { print "foobar\n" }
1N/AEXPECT
1N/Afoobar
1N/A########
1N/A$SIG{__DIE__} = sub {
1N/A print "In DIE\n";
1N/A $i = 0;
1N/A while (($p,$f,$l,$s) = caller(++$i)) {
1N/A print "$p|$f|$l|$s\n";
1N/A }
1N/A};
1N/Aeval { die };
1N/A&{sub { eval 'die' }}();
1N/Asub foo { eval { die } } foo();
1N/A{package rmb; sub{ eval{die} } ->() }; # check __ANON__ knows package
1N/AEXPECT
1N/AIn DIE
1N/Amain|-|8|(eval)
1N/AIn DIE
1N/Amain|-|9|(eval)
1N/Amain|-|9|main::__ANON__
1N/AIn DIE
1N/Amain|-|10|(eval)
1N/Amain|-|10|main::foo
1N/AIn DIE
1N/Armb|-|11|(eval)
1N/Armb|-|11|rmb::__ANON__
1N/A########
1N/Apackage TEST;
1N/A
1N/Asub TIEARRAY {
1N/A return bless [qw(foo fee fie foe)], $_[0];
1N/A}
1N/Asub FETCH {
1N/A my ($s,$i) = @_;
1N/A if ($i) {
1N/A goto bbb;
1N/A }
1N/Abbb:
1N/A return $s->[$i];
1N/A}
1N/A
1N/Apackage main;
1N/Atie my @bar, 'TEST';
1N/Aprint join('|', @bar[0..3]), "\n";
1N/AEXPECT
1N/Afoo|fee|fie|foe
1N/A########
1N/Apackage TH;
1N/Asub TIEHASH { bless {}, TH }
1N/Asub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
1N/Atie %h, TH;
1N/Aeval { $h{A} = 1; print "never\n"; };
1N/Aprint $@;
1N/Aeval { $h{B} = 2; };
1N/Aprint $@;
1N/AEXPECT
1N/AA 1
1N/Abar
1N/AB 2
1N/Abar
1N/A########
1N/Asub n { 0 }
1N/Asub f { my $x = shift; d(); }
1N/Af(n());
1N/Af();
1N/A
1N/Asub d {
1N/A my $i = 0; my @a;
1N/A while (do { { package DB; @a = caller($i++) } } ) {
1N/A @a = @DB::args;
1N/A for (@a) { print "$_\n"; $_ = '' }
1N/A }
1N/A}
1N/AEXPECT
1N/A0
1N/A########
1N/Asub TIEHANDLE { bless {} }
1N/Asub PRINT { next }
1N/A
1N/Atie *STDERR, '';
1N/A{ map ++$_, 1 }
1N/A
1N/AEXPECT
1N/ACan't "next" outside a loop block at - line 2.
1N/A########
1N/Asub TIEHANDLE { bless {} }
1N/Asub PRINT { print "[TIE] $_[1]" }
1N/A
1N/Atie *STDERR, '';
1N/Adie "DIE\n";
1N/A
1N/AEXPECT
1N/A[TIE] DIE
1N/A########
1N/Asub TIEHANDLE { bless {} }
1N/Asub PRINT {
1N/A (split(/./, 'x'x10000))[0];
1N/A eval('die("test\n")');
1N/A warn "[TIE] $_[1]";
1N/A}
1N/Aopen OLDERR, '>&STDERR';
1N/Atie *STDERR, '';
1N/A
1N/Ause warnings FATAL => qw(uninitialized);
1N/Aprint undef;
1N/A
1N/AEXPECT
1N/A[TIE] Use of uninitialized value in print at - line 11.