diff options
Diffstat (limited to 'contrib/perl5/t')
51 files changed, 1313 insertions, 170 deletions
diff --git a/contrib/perl5/t/base/lex.t b/contrib/perl5/t/base/lex.t index 045cb22..8e2452d 100755 --- a/contrib/perl5/t/base/lex.t +++ b/contrib/perl5/t/base/lex.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $ - -print "1..30\n"; +print "1..35\n"; $x = 'x'; @@ -117,3 +115,30 @@ $foo =~ s/^not /substr(<<EOF, 0, 0)/e; Ignored EOF print $foo; + +# see if eval '', s///e, and heredocs mix + +sub T { + my ($where, $num) = @_; + my ($p,$f,$l) = caller; + print "# $p:$f:$l vs /$where/\nnot " unless "$p:$f:$l" =~ /$where/; + print "ok $num\n"; +} + +my $test = 31; + +{ +# line 42 "plink" + local $_ = "not ok "; + eval q{ + s/^not /<<EOT/e and T '^main:\(eval \d+\):2$', $test++; +# fuggedaboudit +EOT + print $_, $test++, "\n"; + T('^main:\(eval \d+\):6$', $test++); +# line 1 "plunk" + T('^main:plunk:1$', $test++); + }; + print "# $@\nnot ok $test\n" if $@; + T '^main:plink:53$', $test++; +} diff --git a/contrib/perl5/t/cmd/for.t b/contrib/perl5/t/cmd/for.t index e45f050..d70af57 100755 --- a/contrib/perl5/t/cmd/for.t +++ b/contrib/perl5/t/cmd/for.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: for.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:09 $ - -print "1..7\n"; +print "1..10\n"; for ($i = 0; $i <= 10; $i++) { $x[$i] = $i; @@ -47,3 +45,13 @@ if ($foo eq '3210abcde') {print "ok 5\n";} else {print "not ok 5 $foo\n";} foreach $foo (("ok 6\n","ok 7\n")) { print $foo; } + +sub foo { + for $i (1..5) { + return $i if $_[0] == $i; + } +} + +print foo(1) == 1 ? "ok" : "not ok", " 8\n"; +print foo(2) == 2 ? "ok" : "not ok", " 9\n"; +print foo(5) == 5 ? "ok" : "not ok", " 10\n"; diff --git a/contrib/perl5/t/cmd/while.t b/contrib/perl5/t/cmd/while.t index c6e464d..392c137 100755 --- a/contrib/perl5/t/cmd/while.t +++ b/contrib/perl5/t/cmd/while.t @@ -2,7 +2,7 @@ # $RCSfile: while.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:15 $ -print "1..10\n"; +print "1..15\n"; open (tmp,'>Cmd_while.tmp') || die "Can't create Cmd_while.tmp."; print tmp "tvi925\n"; @@ -109,3 +109,22 @@ $i = 9; $i++; } print "ok $i\n"; + +# Check curpm is reset when jumping out of a scope +'abc' =~ /b/; +WHILE: +while (1) { + $i++; + print "#$`,$&,$',\nnot " unless $` . $& . $' eq "abc"; + print "ok $i\n"; + { # Localize changes to $` and friends + 'end' =~ /end/; + redo WHILE if $i == 11; + next WHILE if $i == 12; + # 13 do a normal loop + last WHILE if $i == 14; + } +} +$i++; +print "not " unless $` . $& . $' eq "abc"; +print "ok $i\n"; diff --git a/contrib/perl5/t/comp/package.t b/contrib/perl5/t/comp/package.t index d7d19ae..4982256 100755 --- a/contrib/perl5/t/comp/package.t +++ b/contrib/perl5/t/comp/package.t @@ -1,6 +1,6 @@ #!./perl -print "1..7\n"; +print "1..8\n"; $blurfl = 123; $foo = 3; @@ -37,3 +37,17 @@ print $blurfl == 5 ? "ok 4\n" : "not ok 4\n"; eval 'print $blurfl == 5 ? "ok 5\n" : "not ok 5\n";'; eval 'package main; print $blurfl == 123 ? "ok 6\n" : "not ok 6\n";'; print $blurfl == 5 ? "ok 7\n" : "not ok 7\n"; + +package main; + +sub c { caller(0) } + +sub foo { + my $s = shift; + if ($s) { + package PQR; + main::c(); + } +} + +print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n"); diff --git a/contrib/perl5/t/comp/proto.t b/contrib/perl5/t/comp/proto.t index 6a59107..db6a9b5 100755 --- a/contrib/perl5/t/comp/proto.t +++ b/contrib/perl5/t/comp/proto.t @@ -16,7 +16,7 @@ BEGIN { use strict; -print "1..82\n"; +print "1..87\n"; my $i = 1; @@ -413,3 +413,13 @@ sub X::foo4 ($); *X::foo4 = sub ($) {'ok'}; print "not " unless X->foo4 eq 'ok'; print "ok ", $i++, "\n"; + +# test if the (*) prototype allows barewords, constants, scalar expressions, +# globs and globrefs (just as CORE::open() does), all under stricture +sub star (*&) { &{$_[1]} } +my $star = 'FOO'; +star FOO, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star "FOO", sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star $star, sub { print "ok $i\n" if $_[0] eq 'FOO' }; $i++; +star *FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; +star \*FOO, sub { print "ok $i\n" if $_[0] eq \*FOO }; $i++; diff --git a/contrib/perl5/t/comp/require.t b/contrib/perl5/t/comp/require.t index 203b996..5c41f5c 100755 --- a/contrib/perl5/t/comp/require.t +++ b/contrib/perl5/t/comp/require.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = ('.'); + @INC = ('.', '../lib'); } # don't make this lexical @@ -35,7 +35,9 @@ print "ok ",$i++,"\n"; # compile-time failure in require do_require "1)\n"; -print "# $@\nnot " unless $@ =~ /syntax error/i; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. +print "# $@\nnot " unless $@ =~ /(syntax|parse) error/mi; print "ok ",$i++,"\n"; # successful require diff --git a/contrib/perl5/t/io/argv.t b/contrib/perl5/t/io/argv.t index d99865e..c6565dc 100755 --- a/contrib/perl5/t/io/argv.t +++ b/contrib/perl5/t/io/argv.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: argv.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:25 $ +print "1..6\n"; -print "1..5\n"; - -open(try, '>Io.argv.tmp') || (die "Can't open temp file."); +open(try, '>Io.argv.tmp') || (die "Can't open temp file: $!"); print try "a line\n"; close try; @@ -45,4 +43,17 @@ if ($y eq "1a line\n2a line\n3a line\n") else {print "not ok 5\n";} -unlink 'Io.argv.tmp'; +open(try, '>Io.argv.tmp') or die "Can't open temp file: $!"; +close try; +@ARGV = 'Io.argv.tmp'; +$^I = '.bak'; +$/ = undef; +while (<>) { + s/^/ok 6\n/; + print; +} +open(try, '<Io.argv.tmp') or die "Can't open temp file: $!"; +print while <try>; +close try; + +END { unlink 'Io.argv.tmp', 'Io.argv.tmp.bak' } diff --git a/contrib/perl5/t/io/fs.t b/contrib/perl5/t/io/fs.t index 164a667..f09d66c 100755 --- a/contrib/perl5/t/io/fs.t +++ b/contrib/perl5/t/io/fs.t @@ -9,24 +9,23 @@ BEGIN { use Config; -$Is_Dosish = ($^O eq 'dos' or $^O eq 'os2'); +$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or + $^O eq 'os2' or $^O eq 'mint'); -# avoid win32 (for now) -do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32'; - -print "1..26\n"; +print "1..28\n"; $wd = (($^O eq 'MSWin32') ? `cd` : `pwd`); chop($wd); -if ($^O eq 'MSWin32') { `del tmp`; `mkdir tmp`; } +if ($^O eq 'MSWin32') { `del tmp 2>nul`; `mkdir tmp`; } else { `rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`; } chdir './tmp'; `/bin/rm -rf a b c x` if -x '/bin/rm'; umask(022); -if ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} +if ($^O eq 'MSWin32') { print "ok 1 # skipped: bogus umask()\n"; } +elsif ((umask(0)&0777) == 022) {print "ok 1\n";} else {print "not ok 1\n";} open(fh,'>x') || die "Can't create x"; close(fh); open(fh,'>a') || die "Can't create a"; @@ -98,8 +97,9 @@ $foo = (utime 500000000,500000000 + $delta,'b'); if ($foo == 1) {print "ok 16\n";} else {print "not ok 16 $foo\n";} ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, $blksize,$blocks) = stat('b'); -if ($ino) {print "ok 17\n";} else {print "not ok 17\n";} -if ($wd =~ m#/afs/# || $^O eq 'amigaos') +if ($^O eq 'MSWin32') { print "ok 17 # skipped: bogus (stat)[1]\n"; } +elsif ($ino) {print "ok 17\n";} else {print "not ok 17\n";} +if ($wd =~ m#/afs/# || $^O eq 'amigaos' || $^O eq 'dos' || $^O eq 'MSWin32') {print "ok 18 # skipped: granularity of the filetime\n";} elsif ($atime == 500000000 && $mtime == 500000000 + $delta) {print "ok 18\n";} @@ -113,7 +113,6 @@ if ($ino == 0) {print "ok 20\n";} else {print "not ok 20\n";} unlink 'c'; chdir $wd || die "Can't cd back to $wd"; -rmdir 'tmp'; unlink 'c'; if ($^O ne 'MSWin32' and `ls -l perl 2>/dev/null` =~ /^l.*->/) { @@ -156,4 +155,11 @@ else { if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"} close FH; } -unlink "Iofs.tmp"; + +# check if rename() works on directories +rename 'tmp', 'tmp1' or print "not "; +print "ok 27\n"; +-d 'tmp1' or print "not "; +print "ok 28\n"; + +END { rmdir 'tmp1'; unlink "Iofs.tmp"; } diff --git a/contrib/perl5/t/lib/cgi-html.t b/contrib/perl5/t/lib/cgi-html.t index 16aa824..6a7ff1e 100755 --- a/contrib/perl5/t/lib/cgi-html.t +++ b/contrib/perl5/t/lib/cgi-html.t @@ -8,11 +8,11 @@ BEGIN { @INC = '../lib' if -d '../lib'; } -BEGIN {$| = 1; print "1..17\n"; } +BEGIN {$| = 1; print "1..20\n"; } BEGIN {$eol = $^O eq 'VMS' ? "\n" : "\cM\cJ"; $eol = "\r\n" if $^O eq 'os390'; } END {print "not ok 1\n" unless $loaded;} -use CGI (':standard','-no_debug'); +use CGI (':standard','-no_debug','*h3','start_table'); $loaded = 1; print "ok 1\n"; @@ -64,3 +64,6 @@ test(16,($cookie=cookie(-name=>'fred',-value=>['chocolate','chip'],-path=>'/')) 'fred=chocolate&chip; path=/',"cookie()"); test(17,header(-Cookie=>$cookie) =~ m!^Set-Cookie: fred=chocolate&chip\; path=/${eol}Date:.*${eol}Content-Type: text/html${eol}${eol}!s, "header(-cookie)"); +test(18,start_h3 eq '<H3>'); +test(19,end_h3 eq '</H3>'); +test(20,start_table({-border=>undef}) eq '<TABLE BORDER>'); diff --git a/contrib/perl5/t/lib/complex.t b/contrib/perl5/t/lib/complex.t index 2bb14f0..c073f50 100755 --- a/contrib/perl5/t/lib/complex.t +++ b/contrib/perl5/t/lib/complex.t @@ -14,7 +14,7 @@ BEGIN { use Math::Complex; -$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/); +my $VERSION = sprintf("%s", q$Id: complex.t,v 1.9 1998/11/01 00:00:00 dsl Exp $ =~ /(\d+\.d+)/); my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val); @@ -173,20 +173,6 @@ test_loz( 'acoth(-1)', ); -# test the 0**0 - -sub test_ztz { - $test++; - - push(@script, <<'EOT'); -eval 'cplx(0)**cplx(0)'; -print 'not ' unless ($@ =~ /zero raised to the zeroth/); -EOT - push(@script, qq(print "ok $test\\n";\n)); -} - -test_ztz; - # test the bad roots sub test_broot { @@ -387,6 +373,7 @@ __END__ (1,0):(2,3):(1,0) (2,3):(0,0):(1,0) (2,3):(1,0):(2,3) +(0,0):(0,0):(1,0) &Re (3,4):3 @@ -876,4 +863,3 @@ __END__ ( 2,-3):( 0.14694666622553, 0.23182380450040) # eof - diff --git a/contrib/perl5/t/lib/db-recno.t b/contrib/perl5/t/lib/db-recno.t index c89c3ca..da703c9 100755 --- a/contrib/perl5/t/lib/db-recno.t +++ b/contrib/perl5/t/lib/db-recno.t @@ -42,14 +42,16 @@ sub bad_one { print STDERR <<EOM unless $bad_ones++ ; # -# Some older versions of Berkeley DB will fail tests 51, 53 and 55. +# Some older versions of Berkeley DB version 1 will fail tests 51, +# 53 and 55. # # You can safely ignore the errors if you're never going to use the -# broken functionality (recno databases with a modified bval). +# broken functionality (recno databases with a modified bval). # Otherwise you'll have to upgrade your DB library. # -# If you want to upgrade Berkeley DB, the most recent version is 1.85. -# Check out http://www.bostic.com/db for more details. +# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the +# last versions that were released. Berkeley DB version 2 is continually +# being updated -- Check out http://www.sleepycat.com/ for more details. # EOM } diff --git a/contrib/perl5/t/lib/dumper.t b/contrib/perl5/t/lib/dumper.t index 70f8abe..8c8dc40 100755 --- a/contrib/perl5/t/lib/dumper.t +++ b/contrib/perl5/t/lib/dumper.t @@ -9,6 +9,8 @@ BEGIN { } use Data::Dumper; +use Config; +my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; $Data::Dumper::Pad = "#"; my $TMAX; @@ -35,11 +37,11 @@ sub TEST { if (defined &Data::Dumper::Dumpxs) { print "### XS extension loaded, will run XS tests\n"; - $TMAX = 138; $XS = 1; + $TMAX = 162; $XS = 1; } else { print "### XS extensions not loaded, will NOT run XS tests\n"; - $TMAX = 69; $XS = 0; + $TMAX = 81; $XS = 0; } print "1..$TMAX\n"; @@ -234,13 +236,22 @@ EOT ############# 43 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #$VAR1 = { -# "abc\000\efg" => "mno\000" +# "abc\0'\efg" => "mno\0" #}; EOT +} +else { +$WANT = <<'EOT'; +#$VAR1 = { +# "\201\202\203\340\360'\340\205\206\207" => "\224\225\226\340\360" +#}; +EOT +} -$foo = { "abc\000\efg" => "mno\000" }; +$foo = { "abc\000\'\efg" => "mno\000" }; { local $Data::Dumper::Useqq = 1; TEST q(Dumper($foo)); @@ -248,7 +259,7 @@ $foo = { "abc\000\efg" => "mno\000" }; $WANT = <<"EOT"; #\$VAR1 = { -# 'abc\000\efg' => 'mno\000' +# 'abc\0\\'\efg' => 'mno\0' #}; EOT @@ -444,18 +455,34 @@ EOT ############# 85 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT +} +else { + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; EOT +} TEST q( $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], @@ -483,19 +510,34 @@ EOT ############# 97 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #%kennels = ( # First => \'Fido', # Second => \'Wags' #); #@dogs = ( -# $kennels{First}, -# $kennels{Second}, +# ${$kennels{First}}, +# ${$kennels{Second}}, # \%kennels #); #%mutts = %kennels; EOT - +} +else { + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT +} TEST q($d->Reset; $d->Dump); if ($XS) { @@ -504,7 +546,8 @@ EOT ############# 103 ## - $WANT = <<'EOT'; +if (!$Is_ebcdic) { + $WANT = <<'EOT'; #@dogs = ( # 'Fido', # 'Wags', @@ -516,6 +559,21 @@ EOT #%kennels = %{$dogs[2]}; #%mutts = %{$dogs[2]}; EOT +} +else { + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \$dogs[1], +# First => \$dogs[0] +# } +#); +#%kennels = %{$dogs[2]}; +#%mutts = %{$dogs[2]}; +EOT +} TEST q( $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], @@ -539,6 +597,7 @@ EOT ############# 115 ## +if (!$Is_ebcdic) { $WANT = <<'EOT'; #@dogs = ( # 'Fido', @@ -553,6 +612,23 @@ EOT # Second => \'Wags' #); EOT +} +else { + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \'Wags', +# First => \'Fido' +# } +#); +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +EOT +} TEST q( $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); @@ -566,8 +642,8 @@ EOT { -sub a { print "foo\n" } -$c = [ \&a ]; +sub z { print "foo\n" } +$c = [ \&z ]; ############# 121 ## @@ -578,8 +654,8 @@ $c = [ \&a ]; #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;) if $XS; ############# 127 @@ -591,8 +667,8 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'b' => \&a})->Dumpxs;) #]; EOT -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;) if $XS; ############# 133 @@ -604,8 +680,101 @@ TEST q(Data::Dumper->new([\&a,$c],['a','c'])->Seen({'*b' => \&a})->Dumpxs;) #); EOT -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dump;); -TEST q(Data::Dumper->new([\&a,$c],['*a','*c'])->Seen({'*b' => \&a})->Dumpxs;) +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;); +TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;) + if $XS; + +} + +{ + $a = []; + $a->[1] = \$a->[0]; + +############# 139 +## + $WANT = <<'EOT'; +#@a = ( +# undef, +# '' +#); +#$a[1] = \$a[0]; +EOT + +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = \\\\\'foo'; + $b = $$$a; + +############# 145 +## + $WANT = <<'EOT'; +#$a = \\\\\'foo'; +#$b = ${${$a}}; +EOT + +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) if $XS; +} + +{ + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +############# 151 +## + $WANT = <<'EOT'; +#$a = [ +# { +# a => \[ +# { +# c => '' +# }, +# { +# d => \[] +# } +# ] +# }, +# { +# b => undef +# } +#]; +#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; +#${${$a->[0]{a}}->[1]->{d}} = $a; +#$b = ${$a->[0]{a}}; +EOT +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = [[[[\\\\\'foo']]]]; + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +############# 157 +## + $WANT = <<'EOT'; +#$a = [ +# [ +# [ +# [ +# \\\\\'foo' +# ] +# ] +# ] +#]; +#$b = $a->[0][0]; +#$c = ${${$a->[0][0][0][0]}}; +EOT + +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;) + if $XS; } diff --git a/contrib/perl5/t/lib/fatal.t b/contrib/perl5/t/lib/fatal.t new file mode 100755 index 0000000..fb3757f --- /dev/null +++ b/contrib/perl5/t/lib/fatal.t @@ -0,0 +1,27 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + print "1..9\n"; +} + +use strict; +use Fatal qw(open); + +my $i = 1; +eval { open FOO, '<lkjqweriuapofukndajsdlfjnvcvn' }; +print "not " unless $@ =~ /^Can't open/; +print "ok $i\n"; ++$i; + +my $foo = 'FOO'; +for ('$foo', "'$foo'", "*$foo", "\\*$foo") { + eval qq{ open $_, '<$0' }; + print "not " if $@; + print "ok $i\n"; ++$i; + + print "not " unless scalar(<FOO>) =~ m|^#!./perl|; + print "not " if $@; + print "ok $i\n"; ++$i; + close FOO; +} diff --git a/contrib/perl5/t/lib/h2ph.pht b/contrib/perl5/t/lib/h2ph.pht index 80867a6..e5b2932 100644 --- a/contrib/perl5/t/lib/h2ph.pht +++ b/contrib/perl5/t/lib/h2ph.pht @@ -1,3 +1,5 @@ +require '_h2ph_pre.ph'; + unless(defined(&SQUARE)) { sub SQUARE { local($x) = @_; @@ -27,7 +29,7 @@ unless(defined(&_H2PH_H_)) { if(!(defined (defined(&__SOMETHING_MORE_IMPORTANT) ? &__SOMETHING_MORE_IMPORTANT : 0))) { } elsif(!(defined (defined(&__SOMETHING_REALLY_REALLY_IMPORTANT) ? &__SOMETHING_REALLY_REALLY_IMPORTANT : 0))) { - die("Nup, can't go on "); + die("Nup\,\ can\'t\ go\ on\ "); } else { eval 'sub EVERYTHING_IS_OK () {1;}' unless defined(&EVERYTHING_IS_OK); } diff --git a/contrib/perl5/t/lib/io_udp.t b/contrib/perl5/t/lib/io_udp.t index 014e12d..ad2632d 100755 --- a/contrib/perl5/t/lib/io_udp.t +++ b/contrib/perl5/t/lib/io_udp.t @@ -13,7 +13,7 @@ BEGIN { if(-d "lib" && -f "TEST") { if ( ($Config{'extensions'} !~ /\bSocket\b/ || $Config{'extensions'} !~ /\bIO\b/ || - $^O eq 'os2') && + ($^O eq 'os2') || $^O eq 'apollo') && !(($^O eq 'VMS') && $Config{d_socket})) { print "1..0\n"; exit 0; diff --git a/contrib/perl5/t/lib/parsewords.t b/contrib/perl5/t/lib/parsewords.t index 9079179..3c5e75b 100755 --- a/contrib/perl5/t/lib/parsewords.t +++ b/contrib/perl5/t/lib/parsewords.t @@ -7,7 +7,7 @@ BEGIN { use Text::ParseWords; -print "1..17\n"; +print "1..18\n"; @words = shellwords(qq(foo "bar quiz" zoo)); print "not " if $words[0] ne 'foo'; @@ -101,3 +101,8 @@ $string = 'aaaa"bbbbb" cc\ cc \\\\\"dddd\' eee\\\\\"\\\'ffff\' gg'; $result = join('|', parse_line('\s+', 0, $string)); print "not " unless $result eq 'aaaabbbbb|cc cc|\"dddd eee\\\\"\'ffff|gg'; print "ok 17\n"; + +# test whitespace in the delimiters +@words = quotewords(' ', 1, '4 3 2 1 0'); +print "not " unless join(";", @words) eq qq(4;3;2;1;0); +print "ok 18\n"; diff --git a/contrib/perl5/t/lib/posix.t b/contrib/perl5/t/lib/posix.t index 8dafc80..f6d8e92 100755 --- a/contrib/perl5/t/lib/posix.t +++ b/contrib/perl5/t/lib/posix.t @@ -97,5 +97,5 @@ print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime()); $| = 0; # The following line assumes buffered output, which may be not true with EMX: -print '@#!*$@(!@#$' unless $^O eq 'os2'; +print '@#!*$@(!@#$' unless ($^O eq 'os2' || $^O eq 'uwin' || $^O eq 'os390'); _exit(0); diff --git a/contrib/perl5/t/lib/safe2.t b/contrib/perl5/t/lib/safe2.t index c9e3880..6afc117 100755 --- a/contrib/perl5/t/lib/safe2.t +++ b/contrib/perl5/t/lib/safe2.t @@ -8,8 +8,8 @@ BEGIN { print "1..0\n"; exit 0; } - # test 30 rather naughtily expects English error messages - $ENV{'LC_ALL'} = 'C'; + # test 30 rather naughtily expects English error messages + $ENV{'LC_ALL'} = 'C'; } # Tests Todo: @@ -122,11 +122,9 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n"; my $t = 30; $cpt->rdo('/non/existant/file.name'); -print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) || - $! =~ /A file or directory in the path name does not exist/ || - $! =~ /Invalid argument/ || - $! =~ /Device not configured/ ? - "ok $t\n" : "not ok $t # $!\n"); $t++; +# The regexp is getting rather baroque. +print $! =~ /No such file|file specification syntax error|A file or directory in the path name does not exist|Invalid argument|Device not configured|file not found/i ? "ok $t\n" : "not ok $t # $!\n"; $t++; +# test #31 is gone. print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++; #my $rdo_file = "tmp_rdo.tpl"; diff --git a/contrib/perl5/t/lib/searchdict.t b/contrib/perl5/t/lib/searchdict.t index 447c425..c36fdb8 100755 --- a/contrib/perl5/t/lib/searchdict.t +++ b/contrib/perl5/t/lib/searchdict.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..3\n"; +print "1..4\n"; $DICT = <<EOT; Aarhus @@ -44,22 +44,44 @@ open(DICT, "+>dict-$$") or die "Can't create dict-$$: $!"; binmode DICT; # To make length expected one. print DICT $DICT; -my $pos = look *DICT, "abash"; +my $pos = look *DICT, "Ababa"; chomp($word = <DICT>); -print "not " if $pos < 0 || $word ne "abash"; +print "not " if $pos < 0 || $word ne "Ababa"; print "ok 1\n"; -$pos = look *DICT, "foo"; -chomp($word = <DICT>); +if (ord('a') > ord('A') ) { # ASCII + + $pos = look *DICT, "foo"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; -print "not " if $pos != length($DICT); # will search to end of file -print "ok 2\n"; + my $pos = look *DICT, "abash"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "abash"; + print "ok 3\n"; + +} +else { # EBCDIC systems e.g. os390 + + $pos = look *DICT, "FOO"; + chomp($word = <DICT>); + + print "not " if $pos != length($DICT); # will search to end of file + print "ok 2\n"; + + my $pos = look *DICT, "Abba"; + chomp($word = <DICT>); + print "not " if $pos < 0 || $word ne "Abba"; + print "ok 3\n"; +} $pos = look *DICT, "aarhus", 1, 1; chomp($word = <DICT>); print "not " if $pos < 0 || $word ne "Aarhus"; -print "ok 3\n"; +print "ok 4\n"; close DICT or die "cannot close"; unlink "dict-$$"; diff --git a/contrib/perl5/t/lib/textfill.t b/contrib/perl5/t/lib/textfill.t new file mode 100755 index 0000000..19add69 --- /dev/null +++ b/contrib/perl5/t/lib/textfill.t @@ -0,0 +1,96 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +Cyberdog Information + +Cyberdog & Netscape in the news +Important Press Release regarding Cyberdog and Netscape. Check it out! + +Cyberdog Plug-in Support! +Cyberdog support for Netscape Plug-ins is now available to download! Go +to the Cyberdog Beta Download page and download it now! + +Cyberdog Book +Check out Jesse Feiler's way-cool book about Cyberdog. You can find +details out about the book as well as ordering information at Philmont +Software Mill site. + +Java! +Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and install +the Mac OS Runtime for Java and try it out! + +Cyberdog 1.1 Beta 3 +We hope that Cyberdog and OpenDoc 1.1 will be available within the next +two weeks. In the meantime, we have released another version of +Cyberdog, Cyberdog 1.1 Beta 3. This version fixes several bugs that were +reported to us during out public beta period. You can check out our release +notes to see what we fixed! +END + Cyberdog Information + Cyberdog & Netscape in the news Important Press Release regarding + Cyberdog and Netscape. Check it out! + Cyberdog Plug-in Support! Cyberdog support for Netscape Plug-ins is now + available to download! Go to the Cyberdog Beta Download page and download + it now! + Cyberdog Book Check out Jesse Feiler's way-cool book about Cyberdog. + You can find details out about the book as well as ordering information at + Philmont Software Mill site. + Java! Looking to view Java applets in Cyberdog 1.1 Beta 3? Download and + install the Mac OS Runtime for Java and try it out! + Cyberdog 1.1 Beta 3 We hope that Cyberdog and OpenDoc 1.1 will be + available within the next two weeks. In the meantime, we have released + another version of Cyberdog, Cyberdog 1.1 Beta 3. This version fixes + several bugs that were reported to us during out public beta period. You + can check out our release notes to see what we fixed! +END +DONE + + +$| = 1; + +print "1..", @tests/2, "\n"; + +use Text::Wrap; + +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; + +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); + + $in =~ s/^TEST(\d+)?\n//; + + my $back = fill(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + open(F,">#o") and do { print F $back; close(F) }; + open(F,">#e") and do { print F $out; close(F) }; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + fill(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/textwrap.t b/contrib/perl5/t/lib/textwrap.t index 9c8d1b4..c3a455b 100755 --- a/contrib/perl5/t/lib/textwrap.t +++ b/contrib/perl5/t/lib/textwrap.t @@ -1,40 +1,128 @@ -#!./perl +#!./perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } -print "1..5\n"; +@tests = (split(/\nEND\n/s, <<DONE)); +TEST1 +This +is +a +test +END + This + is + a + test +END +TEST2 +This is a test of a very long line. It should be broken up and put onto multiple lines. +This is a test of a very long line. It should be broken up and put onto multiple lines. -use Text::Wrap qw(wrap $columns); +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. + This is a test of a very long line. It should be broken up and put onto + multiple lines. + + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST3 +This is a test of a very long line. It should be broken up and put onto multiple lines. +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. +END +TEST4 +This is a test of a very long line. It should be broken up and put onto multiple lines. -$columns = 30; +END + This is a test of a very long line. It should be broken up and put onto + multiple lines. -$text = <<'EOT'; -Text::Wrap is a very simple paragraph formatter. It formats a -single paragraph at a time by breaking lines at word boundries. -Indentation is controlled for the first line ($initial_tab) and -all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns -should be set to the full width of your output device. -EOT +END +TEST5 +This is a test of a very long line. It should be broken up and put onto multiple This is a test of a very long line. It should be broken up and put +END + This is a test of a very long line. It should be broken up and put onto + multiple This is a test of a very long line. It should be broken up and + put +END +TEST6 +11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END + 11111111 22222222 33333333 44444444 55555555 66666666 77777777 888888888 + 999999999 aaaaaaaaa bbbbbbbbb ccccccccc ddddddddd eeeeeeeee ffffffff + gggggggg hhhhhhhh iiiiiiii jjjjjjjj kkkkkkkk llllllll mmmmmmmmm nnnnnnnnn + ooooooooo ppppppppp qqqqqqqqq rrrrrrrrr sssssssss +END +TEST7 +c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END + c3t1d0s6 c4t1d0s6 c5t1d0s6 c6t1d0s6 c7t1d0s6 c8t1d0s6 c9t1d0s6 c10t1d0s6 + c11t1d0s6 c12t1d0s6 c13t1d0s6 c14t1d0s6 c15t1d0s6 c16t1d0s6 c3t1d0s0 + c4t1d0s0 c5t1d0s0 c6t1d0s0 c7t1d0s0 c8t1d0s0 c9t1d0s0 c10t1d0s0 c11t1d0s0 + c12t1d0s0 c13t1d0s0 c14t1d0s0 c15t1d0s0 c16t1d0s0 +END +TEST8 +A test of a very very long word. +a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +TEST9 +A test of a very very long word. a123456789b123456789c123456789d123456789e123456789f123456789g123456789g1234567 +END + A test of a very very long word. + a123456789b123456789c123456789d123456789e123456789f123456789g123456789g123 + 4567 +END +DONE -$text =~ s/\n/ /g; -$_ = wrap "| ", "|", $text; -#print "$_\n"; +$| = 1; -print "not " unless /^\| Text::Wrap is/; # start is ok -print "ok 1\n"; +print "1..", @tests/2, "\n"; -print "not " if /^.{31,}$/m; # no line longer than 30 chars -print "ok 2\n"; +use Text::Wrap; -print "not " unless /^\|\w/m; # other lines start with -print "ok 3\n"; +$rerun = $ENV{'PERL_DL_NONLAZY'} ? 0 : 1; -print "not " unless /\bsubsquent\b/; # look for a random word -print "ok 4\n"; +$tn = 1; +while (@tests) { + my $in = shift(@tests); + my $out = shift(@tests); -print "not " unless /\bdevice\./; # look for last word -print "ok 5\n"; + $in =~ s/^TEST(\d+)?\n//; + + my $back = wrap(' ', ' ', $in); + + if ($back eq $out) { + print "ok $tn\n"; + } elsif ($rerun) { + my $oi = $in; + foreach ($in, $back, $out) { + s/\t/^I\t/gs; + s/\n/\$\n/gs; + } + print "------------ input ------------\n"; + print $in; + print "\n------------ output -----------\n"; + print $back; + print "\n------------ expected ---------\n"; + print $out; + print "\n-------------------------------\n"; + $Text::Wrap::debug = 1; + wrap(' ', ' ', $oi); + exit(1); + } else { + print "not ok $tn\n"; + } + $tn++; +} diff --git a/contrib/perl5/t/lib/thread.t b/contrib/perl5/t/lib/thread.t index 83407a9..c127d0f 100755 --- a/contrib/perl5/t/lib/thread.t +++ b/contrib/perl5/t/lib/thread.t @@ -24,7 +24,7 @@ sub content } # create a thread passing args and immedaietly wait for it. -my $t = new Thread \&content,("ok 2\n","ok 3\n"); +my $t = new Thread \&content,("ok 2\n","ok 3\n", 1..1000); print $t->join; # check that lock works ... diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 8dea44d..3409556 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..63\n"; +print "1..65\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -206,3 +206,8 @@ t("@bar" eq "foo bar"); # 43 t("@bee" eq "foo bar burbl blah"); # 63 } +# make sure reification behaves +my $t = 63; +sub reify { $_[1] = ++$t; print "@_\n"; } +reify('ok'); +reify('ok'); diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index ffbb1e0..26b477a 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -31,7 +31,7 @@ my %tests = ( 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? - 17 => [ 42, 42, '{ local *F; open F, q[TEST]; close F } die;'], + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'], ); my $max = keys %tests; @@ -46,8 +46,8 @@ foreach my $test (1 .. $max) { ? system qq($perl -e "\$! = $bang; \$? = $query; $code" 2> nul) : system qq($perl -e '\$! = $bang; \$? = $query; $code' 2> /dev/null)); - printf "# 0x%04x 0x%04x 0x%04x\nnot ", $exit, $bang, $query - unless $exit == (($bang || ($query >> 8) || 255) << 8); + printf "# 0x%04x 0x%04x 0x%04x\n", $exit, $bang, $query; + print "not " unless $exit == (($bang || ($query >> 8) || 255) << 8); print "ok $test\n"; } diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t index 9368281..dc163e9 100755 --- a/contrib/perl5/t/op/eval.t +++ b/contrib/perl5/t/op/eval.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: eval.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:48 $ - -print "1..23\n"; +print "1..36\n"; eval 'print "ok 1\n";'; @@ -79,3 +77,97 @@ eval { }; &$x(); } + +my $b = 'wrong'; +my $X = sub { + my $b = "right"; + print eval('"$b"') eq $b ? "ok 24\n" : "not ok 24\n"; +}; +&$X(); + + +# check navigation of multiple eval boundaries to find lexicals + +my $x = 25; +eval <<'EOT'; die if $@; + print "# $x\n"; # clone into eval's pad + sub do_eval1 { + eval $_[0]; die if $@; + } +EOT +do_eval1('print "ok $x\n"'); +$x++; +do_eval1('eval q[print "ok $x\n"]'); +$x++; +do_eval1('sub { eval q[print "ok $x\n"] }->()'); +$x++; + +# calls from within eval'' should clone outer lexicals + +eval <<'EOT'; die if $@; + sub do_eval2 { + eval $_[0]; die if $@; + } +do_eval2('print "ok $x\n"'); +$x++; +do_eval2('eval q[print "ok $x\n"]'); +$x++; +do_eval2('sub { eval q[print "ok $x\n"] }->()'); +$x++; +EOT + +# calls outside eval'' should NOT clone lexicals from called context + +$main::x = 'ok'; +eval <<'EOT'; die if $@; + # $x unbound here + sub do_eval3 { + eval $_[0]; die if $@; + } +EOT +do_eval3('print "$x ' . $x . '\n"'); +$x++; +do_eval3('eval q[print "$x ' . $x . '\n"]'); +$x++; +do_eval3('sub { eval q[print "$x ' . $x . '\n"] }->()'); +$x++; + +# can recursive subroutine-call inside eval'' see its own lexicals? +sub recurse { + my $l = shift; + if ($l < $x) { + ++$l; + eval 'print "# level $l\n"; recurse($l);'; + die if $@; + } + else { + print "ok $l\n"; + } +} +{ + local $SIG{__WARN__} = sub { die "not ok $x\n" if $_[0] =~ /^Deep recurs/ }; + recurse($x-5); +} +$x++; + +# do closures created within eval bind correctly? +eval <<'EOT'; + sub create_closure { + my $self = shift; + return sub { + print $self; + }; + } +EOT +create_closure("ok $x\n")->(); +$x++; + +# does lexical search terminate correctly at subroutine boundary? +$main::r = "ok $x\n"; +sub terminal { eval 'print $r' } +{ + my $r = "not ok $x\n"; + eval 'terminal($r)'; +} +$x++; + diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t index 1b34acd..8096aff 100755 --- a/contrib/perl5/t/op/goto.t +++ b/contrib/perl5/t/op/goto.t @@ -1,10 +1,8 @@ #!./perl -# $RCSfile: goto.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:56 $ - # "This IS structured code. It's just randomly structured." -print "1..9\n"; +print "1..13\n"; while ($?) { $foo = 1; @@ -56,7 +54,7 @@ sub bar { exit; FINALE: -print "ok 9\n"; +print "ok 13\n"; exit; bypass: @@ -86,5 +84,22 @@ $wherever = NOWHERE; eval { goto $wherever }; print $@ =~ /Can't find label NOWHERE/ ? "ok 8\n" : "not ok 8\n"; +# see if a modified @_ propagates +{ + package Foo; + sub DESTROY { my $s = shift; print "ok $s->[0]\n"; } + sub show { print "# @_\nnot ok $_[0][0]\n" if @_ != 5; } + sub start { push @_, 1, "foo", {}; goto &show; } + for (9..11) { start(bless([$_]), 'bar'); } +} + +sub auto { + goto &loadit; +} + +sub AUTOLOAD { print @_ } + +auto("ok 12\n"); + $wherever = FINALE; goto $wherever; diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t new file mode 100755 index 0000000..45d0e25 --- /dev/null +++ b/contrib/perl5/t/op/grep.t @@ -0,0 +1,31 @@ +#!./perl + +# +# grep() and map() tests +# + +print "1..3\n"; + +$test = 1; + +sub ok { + my ($got,$expect) = @_; + print "# expected [$expect], got [$got]\nnot " if $got ne $expect; + print "ok $test\n"; +} + +{ + my @lol = ([qw(a b c)], [], [qw(1 2 3)]); + my @mapped = map {scalar @$_} @lol; + ok "@mapped", "3 0 3"; + $test++; + + my @grepped = grep {scalar @$_} @lol; + ok "@grepped", "$lol[0] $lol[2]"; + $test++; + + @grepped = grep { $_ } @mapped; + ok "@grepped", "3 3"; + $test++; +} + diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t index 2f674d1..b478e01 100755 --- a/contrib/perl5/t/op/local.t +++ b/contrib/perl5/t/op/local.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $ - -print "1..58\n"; +print "1..69\n"; # XXX known to leak scalars $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; @@ -198,3 +196,42 @@ print +($ENV{_X_} eq 'a') ? "" : "not ", "ok 56\n"; print +($ENV{_Y_} eq 'b') ? "" : "not ", "ok 57\n"; print +($ENV{_Z_} eq 'c') ? "" : "not ", "ok 58\n"; +# does implicit localization in foreach skip magic? + +$_ = "ok 59,ok 60,"; +my $iter = 0; +while (/(o.+?),/gc) { + print "$1\n"; + foreach (1..1) { $iter++ } + if ($iter > 2) { print "not ok 60\n"; last; } +} + +{ + package UnderScore; + sub TIESCALAR { bless \my $self, shift } + sub FETCH { die "read \$_ forbidden" } + sub STORE { die "write \$_ forbidden" } + tie $_, __PACKAGE__; + my $t = 61; + my @tests = ( + "Nesting" => sub { print '#'; for (1..3) { print } + print "\n" }, 1, + "Reading" => sub { print }, 0, + "Matching" => sub { $x = /badness/ }, 0, + "Concat" => sub { $_ .= "a" }, 0, + "Chop" => sub { chop }, 0, + "Filetest" => sub { -x }, 0, + "Assignment" => sub { $_ = "Bad" }, 0, + # XXX whether next one should fail is debatable + "Local \$_" => sub { local $_ = 'ok?'; print }, 0, + "for local" => sub { for("#ok?\n"){ print } }, 1, + ); + while ( ($name, $code, $ok) = splice(@tests, 0, 3) ) { + print "# Testing $name\n"; + eval { &$code }; + print(($ok xor $@) ? "ok $t\n" : "not ok $t\n"); + ++$t; + } + untie $_; +} + diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index 7292ffe..c9050ef 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -36,7 +36,9 @@ for (@prgs){ $status = $?; $results = `$CAT $tmpfile`; $results =~ s/\n+$//; - $results =~ s/syntax error/syntax error/i; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; if ( $results ne $expected){ print STDERR "PROG: $switch\n$prog\n"; @@ -418,3 +420,29 @@ EXPECT destroyed destroyed ######## +BEGIN { + $| = 1; + $SIG{__WARN__} = sub { + eval { print $_[0] }; + die "bar\n"; + }; + warn "foo\n"; +} +EXPECT +foo +bar +BEGIN failed--compilation aborted at - line 8. +######## +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +EXPECT +ZZZ +######## +eval ' +use strict; +my $foo = "ZZZ\n"; +END { print $foo } +'; +EXPECT +ZZZ diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index 5ba0a0f..acf16c1 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -15,4 +15,4 @@ print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); print (-d 'blurfl' ? "ok 4\n" : "not ok 4\n"); print (rmdir('blurfl') ? "ok 5\n" : "not ok 5\n"); print (rmdir('blurfl') ? "not ok 6\n" : "ok 6\n"); -print ($! =~ /such|exist/ ? "ok 7\n" : "not ok 7\n"); +print ($! =~ /such|exist|not found/i ? "ok 7\n" : "not ok 7\n"); diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 24b5c43..6623089 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $ - -print "1..8\n"; +print "1..9\n"; print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; @@ -12,3 +10,4 @@ print +(oct('x80000000') == 0x80000000) ? "ok" : "not ok", " 5\n"; print +(hex('80000000') == 0x80000000) ? "ok" : "not ok", " 6\n"; print +(oct('1234') == 668) ? "ok" : "not ok", " 7\n"; print +(hex('1234') == 4660) ? "ok" : "not ok", " 8\n"; +print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 9\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index 9b7bc35..902fc28 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -1,8 +1,12 @@ #!./perl -# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} -print "1..60\n"; +print "1..142\n"; $format = "c2 x5 C C x s d i l a6"; # Need the expression in here to force ary[5] to be numeric. This avoids @@ -31,7 +35,7 @@ print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ? "ok 6\n" : "not ok 6 $x\n"; my $sum = 129; # ASCII -$sum = 103 if ($^O eq 'os390'); # An EBCDIC variant. +$sum = 103 if ($Config{ebcdic} eq 'define'); print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ? "ok 7\n" : "not ok 7 $x\n"; @@ -160,7 +164,12 @@ foreach my $t (@templates) { # 57..60: uuencode/decode -$in = join "", map { chr } 0..255; +# Note that first uuencoding known 'text' data and then checking the +# binary values of the uuencoded version would not be portable between +# character sets. Uuencoding is meant for encoding binary data, not +# text data. + +$in = pack 'C*', 0 .. 255; # just to be anal, we do some random tr/`/ / $uu = <<'EOUU'; @@ -199,7 +208,150 @@ EOUU print "not " unless unpack('u', $uu) eq $in; print "ok ", $test++, "\n"; -# Note that first uuencoding known 'text' data and then checking the -# binary values of the uuencoded version would not be portable between -# character sets. Uuencoding is meant for encoding binary data, not -# text data. +# 61..72: test the ascii template types (A, a, Z) + +print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; +print "ok ", $test++, "\n"; + +print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; +print "ok ", $test++, "\n"; + +print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 "; +print "ok ", $test++, "\n"; + +print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; +print "ok ", $test++, "\n"; + +print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; +print "ok ", $test++, "\n"; + +# 73..78: packing native shorts/ints/longs + +# integrated from mainline and don't want to change numbers all the way +# down. native ints are not supported in _0x so comment out checks +#print "not " unless length(pack("s!", 0)) == $Config{shortsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) == $Config{intsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("l!", 0)) == $Config{longsize}; +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("s!", 0)) <= length(pack("i!", 0)); +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) <= length(pack("l!", 0)); +print "ok ", $test++, "\n"; + +#print "not " unless length(pack("i!", 0)) == length(pack("i", 0)); +print "ok ", $test++, "\n"; + +# 79..138: pack <-> unpack bijectionism + +# 79.. 83 c +foreach my $c (-128, -1, 0, 1, 127) { + print "not " unless unpack("c", pack("c", $c)) == $c; + print "ok ", $test++, "\n"; +} + +# 84.. 88: C +foreach my $C (0, 1, 127, 128, 255) { + print "not " unless unpack("C", pack("C", $C)) == $C; + print "ok ", $test++, "\n"; +} + +# 89.. 93: s +foreach my $s (-32768, -1, 0, 1, 32767) { + print "not " unless unpack("s", pack("s", $s)) == $s; + print "ok ", $test++, "\n"; +} + +# 94.. 98: S +foreach my $S (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("S", pack("S", $S)) == $S; + print "ok ", $test++, "\n"; +} + +# 99..103: i +foreach my $i (-2147483648, -1, 0, 1, 2147483647) { + print "not " unless unpack("i", pack("i", $i)) == $i; + print "ok ", $test++, "\n"; +} + +# 104..108: I +foreach my $I (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("I", pack("I", $I)) == $I; + print "ok ", $test++, "\n"; +} + +# 109..113: l +foreach my $l (-2147483648, -1, 0, 1, 2147483647) { + print "not " unless unpack("l", pack("l", $l)) == $l; + print "ok ", $test++, "\n"; +} + +# 114..118: L +foreach my $L (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("L", pack("L", $L)) == $L; + print "ok ", $test++, "\n"; +} + +# 119..123: n +foreach my $n (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("n", pack("n", $n)) == $n; + print "ok ", $test++, "\n"; +} + +# 124..128: v +foreach my $v (0, 1, 32767, 32768, 65535) { + print "not " unless unpack("v", pack("v", $v)) == $v; + print "ok ", $test++, "\n"; +} + +# 129..133: N +foreach my $N (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("N", pack("N", $N)) == $N; + print "ok ", $test++, "\n"; +} + +# 134..138: V +foreach my $V (0, 1, 2147483647, 2147483648, 4294967295) { + print "not " unless unpack("V", pack("V", $V)) == $V; + print "ok ", $test++, "\n"; +} + +# 139..142: pack nvNV byteorders + +print "not " unless pack("n", 0xdead) eq "\xde\xad"; +print "ok ", $test++, "\n"; + +print "not " unless pack("v", 0xdead) eq "\xad\xde"; +print "ok ", $test++, "\n"; + +print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; +print "ok ", $test++, "\n"; + +print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; +print "ok ", $test++, "\n"; diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index 7d4278f..ed8c778 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,7 +4,7 @@ # the format supported by op/regexp.t. If you want to add a test # that does fit that format, add it to op/re_tests, not here. -print "1..141\n"; +print "1..142\n"; BEGIN { chdir 't' if -d 't'; @@ -595,3 +595,8 @@ print "not " if @_; print "ok $test\n"; $test++; +# see if matching against temporaries (created via pp_helem()) is safe +{ foo => "ok $test\n".$^X }->{foo} =~ /^(.*)\n/g; +print "$1\n"; +$test++; + diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t index 7999b86..01f5f70 100755 --- a/contrib/perl5/t/op/range.t +++ b/contrib/perl5/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..10\n"; +print "1..12\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -46,3 +46,12 @@ foreach ('09'..'08') { print "not " unless join(",", @y) eq join(",", @x); print "ok 10\n"; +# check bounds +@a = 0x7ffffffe..0x7fffffff; +print "not " unless "@a" eq "2147483646 2147483647"; +print "ok 11\n"; + +@a = -0x7fffffff..-0x7ffffffe; +print "not " unless "@a" eq "-2147483647 -2147483646"; +print "ok 12\n"; + diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index a5295f5..3471cc3 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -335,6 +335,9 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce ^(a(?(1)\1)){4}$ aaaaaaaaaa y $1 aaaa ^(a(?(1)\1)){4}$ aaaaaaaaa n - - ^(a(?(1)\1)){4}$ aaaaaaaaaaa n - - +((a{4})+) aaaaaaaaa y $1 aaaaaaaa +(((aa){2})+) aaaaaaaaaa y $1 aaaaaaaa +(((a{2}){2})+) aaaaaaaaaa y $1 aaaaaaaa (?:(f)(o)(o)|(b)(a)(r))* foobar y $1:$2:$3:$4:$5:$6 f:o:o:b:a:r (?<=a)b ab y $& b (?<=a)b cb n - - @@ -483,3 +486,6 @@ b\Z a\nb\n y - - b\z a\nb\n n - - b\Z a\nb y - - b\z a\nb y - - +(^|x)(c) ca y $2 c +a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - +round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t index 54fa590..f935bf1 100755 --- a/contrib/perl5/t/op/repeat.t +++ b/contrib/perl5/t/op/repeat.t @@ -2,7 +2,7 @@ # $RCSfile: repeat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:21 $ -print "1..19\n"; +print "1..20\n"; # compile time @@ -40,3 +40,54 @@ print join(':', () x 4) eq '' ? "ok 16\n" : "not ok 16\n"; print join(':', (9) x 4) eq '9:9:9:9' ? "ok 17\n" : "not ok 17\n"; print join(':', (9,9) x 4) eq '9:9:9:9:9:9:9:9' ? "ok 18\n" : "not ok 18\n"; print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; + +# +# The test #20 is actually testing for Digital C compiler optimizer bug. +# +# Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS) used +# to produce (as of December 1998) broken code for util.c:repeatcpy() +# (a utility function for the 'x' operator) in the case *all* these +# four conditions held: +# +# (1) len == 1 +# (2) "from" had the 8th bit on in its single character +# (3) count > 7 (the 'x' count > 16) +# (4) the highest optimization level was used in compilation +# (which is the default when compiling Perl) +# +# The bug looked like this (. being the eight-bit character and ? being \xff): +# +# 16 ................ +# 17 .........???????. +# 18 .........???????.. +# 19 .........???????... +# 20 .........???????.... +# 21 .........???????..... +# 22 .........???????...... +# 23 .........???????....... +# 24 .........???????.??????? +# 25 .........???????.???????. +# +# The bug could be (obscurely) avoided by changing "from" to +# be an unsigned char pointer. +# +# The bug was triggered in the "if (len == 1)" branch. The fix +# was to introduce a new temporary variable. In diff -u format: +# +# register char *frombase = from; +# +# if (len == 1) { +#- todo = *from; +#+ register char c = *from; +# while (count-- > 0) +#- *to++ = todo; +#+ *to++ = c; +# return; +# } +# +# This obscure bug was not found by the then test suite but instead +# by Mark.Martinec@nsc.ijs.si while trying to install Digest-MD5-2.00. +# +# jhi@iki.fi +# +print "\xdd" x 24 eq "\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd\xdd" ? "ok 20\n" : "not ok 20\n"; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index 307e2a0..bff3c36 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -315,3 +315,23 @@ main|-|9|main::__ANON__ In DIE main|-|10|(eval) main|-|10|main::foo +######## +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 diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index 70341b9..fdb4e34 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -1,8 +1,9 @@ #!./perl -# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $ +print "1..29\n"; -print "1..21\n"; +# XXX known to leak scalars +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } @@ -125,3 +126,34 @@ eval <<'CODE'; my @result = sort 'one', 'two'; CODE print $@ ? "not ok 21\n# $@" : "ok 21\n"; + +{ + my $sortsub = \&backwards; + my $sortglob = *backwards; + my $sortglobr = \*backwards; + my $sortname = 'backwards'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 22\n" : "not ok 22 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); +} + +{ + local $sortsub = \&backwards; + local $sortglob = *backwards; + local $sortglobr = \*backwards; + local $sortname = 'backwards'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); +} + diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t index 826cf38..22e60e3 100755 --- a/contrib/perl5/t/op/sysio.t +++ b/contrib/perl5/t/op/sysio.t @@ -1,12 +1,13 @@ #!./perl -print "1..36\n"; +print "1..39\n"; chdir('op') || die "sysio.t: cannot look for myself: $!"; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; -$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos'); +$reopen = ($^O eq 'VMS' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos' || + $^O eq 'mpeix'); $x = 'abc'; @@ -151,6 +152,21 @@ if ($reopen) { # must close file to update EOF marker for stat print 'not ' unless (-s $outfile == 7); print "ok 28\n"; +# with implicit length argument +print 'not ' unless (syswrite(O, $x) == 3); +print "ok 29\n"; + +# $a still intact +print 'not ' unless ($x eq "abc"); +print "ok 30\n"; + +# $outfile should have grown now +if ($reopen) { # must close file to update EOF marker for stat + close O; open(O, ">>$outfile") || die "sysio.t: cannot write $outfile: $!"; +} +print 'not ' unless (-s $outfile == 10); +print "ok 31\n"; + close(O); open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; @@ -158,30 +174,30 @@ open(I, $outfile) || die "sysio.t: cannot read $outfile: $!"; $b = 'xyz'; # reading too much only return as much as available -print 'not ' unless (sysread(I, $b, 100) == 7); -print "ok 29\n"; +print 'not ' unless (sysread(I, $b, 100) == 10); +print "ok 32\n"; # this we should have -print 'not ' unless ($b eq '#!ererl'); -print "ok 30\n"; +print 'not ' unless ($b eq '#!ererlabc'); +print "ok 33\n"; # test sysseek print 'not ' unless sysseek(I, 2, 0) == 2; -print "ok 31\n"; +print "ok 34\n"; sysread(I, $b, 3); print 'not ' unless $b eq 'ere'; -print "ok 32\n"; +print "ok 35\n"; print 'not ' unless sysseek(I, -2, 1) == 3; -print "ok 33\n"; +print "ok 36\n"; sysread(I, $b, 4); print 'not ' unless $b eq 'rerl'; -print "ok 34\n"; +print "ok 37\n"; print 'not ' unless sysseek(I, 0, 0) eq '0 but true'; -print "ok 35\n"; +print "ok 38\n"; print 'not ' if defined sysseek(I, -1, 1); -print "ok 36\n"; +print "ok 39\n"; close(I); diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index d2cae8e..379093f 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -366,7 +366,10 @@ else { test 72, $@ eq '', $@; # NB: This should be allowed # Try first new style but allow also old style. - test 73, $!{ENOENT} || $! == 2 || ($Is_Dos && $! == 22); # File not found + test 73, $!{ENOENT} || + $! == 2 || # File not found + ($Is_Dos && $! == 22) || + ($^O eq 'mint' && $! == 33); test 74, eval { open FOO, "> $foo" } eq '', 'open for write'; test 75, $@ =~ /^Insecure dependency/, $@; diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 77e74db..472a6a7 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -153,3 +153,16 @@ $C = $B = tied %H ; } untie %H; EXPECT +######## + +# verify no leak when underlying object is selfsame tied variable +my ($a, $b); +sub Self::TIEHASH { bless $_[1], $_[0] } +sub Self::DESTROY { $b = $_[0] + 0; } +{ + my %b5; + $a = \%b5 + 0; + tie %b5, 'Self', \%b5; +} +die unless $a == $b; +EXPECT diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index e3d2472..d7e6a78 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -64,7 +64,7 @@ sub READ { sub WRITE { compare(WRITE => @_); $data = substr($_[1],$_[3] || 0, $_[2]); - 4; + length($data); } sub CLOSE { @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..23\n"; +print "1..29\n"; my $fh = gensym; @@ -132,6 +132,20 @@ $r = syswrite $fh,$buf,4,1; ok($r == 4); ok($data eq "wert"); +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 4); +$data = ""; +$r = syswrite $fh,$buf,4; +ok($r == 4); +ok($data eq "qwer"); + +$buf = "qwerty"; +@expect = (WRITE => $ob, $buf, 6); +$data = ""; +$r = syswrite $fh,$buf; +ok($r == 6); +ok($data eq "qwerty"); + @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t new file mode 100755 index 0000000..3503c3c --- /dev/null +++ b/contrib/perl5/t/op/tr.t @@ -0,0 +1,33 @@ +# tr.t + +print "1..4\n"; + +$_ = "abcdefghijklmnopqrstuvwxyz"; + +tr/a-z/A-Z/; + +print "not " unless $_ eq "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; +print "ok 1\n"; + +tr/A-Z/a-z/; + +print "not " unless $_ eq "abcdefghijklmnopqrstuvwxyz"; +print "ok 2\n"; + +tr/b-y/B-Y/; + +print "not " unless $_ eq "aBCDEFGHIJKLMNOPQRSTUVWXYz"; +print "ok 3\n"; + +# In EBCDIC 'I' is \xc9 and 'J' is \0xd1, 'i' is \x89 and 'j' is \x91. +# Yes, discontinuities. Regardless, the \xca in the below should stay +# untouched (and not became \x8a). + +$_ = "I\xcaJ"; + +tr/I-J/i-j/; + +print "not " unless $_ eq "i\xcaj"; +print "ok 4\n"; + +# diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 8ab2ec4..5b3c7ef 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: undef.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:34 $ - -print "1..21\n"; +print "1..23\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -54,3 +52,10 @@ sub foo { print "ok 19\n"; } print defined &foo ? "ok 20\n" : "not ok 20\n"; undef &foo; print defined(&foo) ? "not ok 21\n" : "ok 21\n"; + +eval { undef $1 }; +print $@ =~ /^Modification of a read/ ? "ok 22\n" : "not ok 22\n"; + +eval { $1 = undef }; +print $@ =~ /^Modification of a read/ ? "ok 23\n" : "not ok 23\n"; + diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 705fa79..9918b2f 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -2,7 +2,7 @@ # $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ -print "1..5\n"; +print "1..6\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -167,3 +167,26 @@ for (0..10) { print $was1 eq $mustbe ? "ok 4\n" : "not ok 4\n"; print $was2 eq $mustbe ? "ok 5\n" : "not ok 5\n"; +$^A = ''; + +# more test + +format OUT3 = +^<<<<<<... +$foo +. + +open(OUT3, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + +$foo = 'fit '; +write(OUT3); +close OUT3; + +$right = +"fit\n"; + +if (`$CAT Op_write.tmp` eq $right) + { print "ok 6\n"; unlink 'Op_write.tmp'; } +else + { print "not ok 6\n"; } + diff --git a/contrib/perl5/t/pragma/constant.t b/contrib/perl5/t/pragma/constant.t index 0b58bae..5b63dfa 100755 --- a/contrib/perl5/t/pragma/constant.t +++ b/contrib/perl5/t/pragma/constant.t @@ -14,7 +14,7 @@ END { print @warnings } ######################### We start with some black magic to print on failure. -BEGIN { $| = 1; print "1..39\n"; } +BEGIN { $| = 1; print "1..46\n"; } END {print "not ok 1\n" unless $loaded;} use constant; $loaded = 1; @@ -139,3 +139,19 @@ test 37, @warnings && test 38, @warnings == 0, "unexpected warning"; test 39, $^W & 1, "Who disabled the warnings?"; + +use constant CSCALAR => \"ok 40\n"; +use constant CHASH => { foo => "ok 41\n" }; +use constant CARRAY => [ undef, "ok 42\n" ]; +use constant CPHASH => [ { foo => 1 }, "ok 43\n" ]; +use constant CCODE => sub { "ok $_[0]\n" }; + +print ${+CSCALAR}; +print CHASH->{foo}; +print CARRAY->[1]; +print CPHASH->{foo}; +eval q{ CPHASH->{bar} }; +test 44, scalar($@ =~ /^No such array/); +print CCODE->(45); +eval q{ CCODE->{foo} }; +test 46, scalar($@ =~ /^Constant is not a HASH/); diff --git a/contrib/perl5/t/pragma/locale.t b/contrib/perl5/t/pragma/locale.t index 00baa66..7e3df8c 100755 --- a/contrib/perl5/t/pragma/locale.t +++ b/contrib/perl5/t/pragma/locale.t @@ -23,6 +23,9 @@ eval { # and mingw32 uses said silly CRT $have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; +# 103 (the last test) may fail but that is okay. +# (It indicates something broken in the environment, not Perl) +# Therefore .. only until 102, not 103. print "1..", ($have_setlocale ? 102 : 98), "\n"; use vars qw($a @@ -404,6 +407,7 @@ print "ok 101\n"; # Test for read-onlys. +print "# testing 102\n"; { no locale; $a = "qwerty"; @@ -419,7 +423,7 @@ print "ok 102\n"; # Thanks to Hallvard Furuseth <h.b.furuseth@usit.uio.no> # for inventing a way to test for ordering consistency # without requiring any particular order. -# ++$jhi;#@iki.fi +# <jhi@iki.fi> print "# testing 103\n"; { diff --git a/contrib/perl5/t/pragma/overload.t b/contrib/perl5/t/pragma/overload.t index afba8a3..0682266 100755 --- a/contrib/perl5/t/pragma/overload.t +++ b/contrib/perl5/t/pragma/overload.t @@ -694,5 +694,17 @@ test($c, "bareword"); # 135 test( scalar ($seven =~ /i/), '1') } +{ + package sorting; + use overload 'cmp' => \∁ + sub new { my ($p, $v) = @_; bless \$v, $p } + sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } +} +{ + my @arr = map sorting->new($_), 0..12; + my @sorted1 = sort @arr; + my @sorted2 = map $$_, @sorted1; + test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; +} # Last test is: -sub last {173} +sub last {174} diff --git a/contrib/perl5/t/pragma/subs.t b/contrib/perl5/t/pragma/subs.t index 680564f..6ebbf78 100755 --- a/contrib/perl5/t/pragma/subs.t +++ b/contrib/perl5/t/pragma/subs.t @@ -55,7 +55,9 @@ for (@prgs){ # allow expected output to be written as if $prog is on STDIN $results =~ s/tmp\d+/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg - $results =~ s/Syntax/syntax/; # non-standard yacc +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; if ( $results =~ s/^SKIPPED\n//) { diff --git a/contrib/perl5/t/pragma/warn-1global b/contrib/perl5/t/pragma/warn-1global index 07b5bc8..a7ca607 100644 --- a/contrib/perl5/t/pragma/warn-1global +++ b/contrib/perl5/t/pragma/warn-1global @@ -12,12 +12,14 @@ EXPECT $a =+ 3 ; EXPECT Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. ######## #! perl -w # warnable code, warnings enabled via #! line $a =+ 3 ; EXPECT Reversed += operator at - line 3. +Name "main::a" used only once: possible typo at - line 3. ######## # warnable code, warnings enabled via compile time $^W @@ -25,6 +27,7 @@ BEGIN { $^W = 1 } $a =+ 3 ; EXPECT Reversed += operator at - line 4. +Name "main::a" used only once: possible typo at - line 4. ######## # compile-time warnable code, warnings enabled via runtime $^W @@ -149,3 +152,8 @@ Use of uninitialized value at - line 5. -e undef EXPECT Use of uninitialized value at - line 2. +######## +BEGIN { $^W = 1 } +for (@{[0]}) { "$_" } # check warning isn't duplicated +EXPECT +Useless use of string in void context at - line 2. diff --git a/contrib/perl5/t/pragma/warning.t b/contrib/perl5/t/pragma/warning.t index fa0301e..35d9d48 100755 --- a/contrib/perl5/t/pragma/warning.t +++ b/contrib/perl5/t/pragma/warning.t @@ -4,11 +4,12 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; $ENV{PERL5LIB} = '../lib'; + require Config; import Config; } $| = 1; -my $Is_VMS = $^O eq 'VMS'; +my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $tmpfile = "tmp0000"; my $i = 0 ; @@ -19,6 +20,8 @@ my @prgs = () ; foreach (sort glob("pragma/warn-*")) { + next if /\.orig$/ ; + next if /(~|\.orig)$/; open F, "<$_" or die "Cannot open $_: $!\n" ; @@ -76,13 +79,29 @@ for (@prgs){ # allow expected output to be written as if $prog is on STDIN $results =~ s/tmp\d+/-/g; $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS; # clip off DCL status msg +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; $expected =~ s/\n+$//; my $prefix = ($results =~ s/^PREFIX\n//) ; + # any special options? (OPTIONS foo bar zap) + my $option_regex = 0; + if ($expected =~ s/^OPTIONS? (.+)\n//) { + foreach my $option (split(' ', $1)) { + if ($option eq 'regex') { # allow regular expressions + $option_regex = 1; + } else { + die "$0: Unknown OPTION '$option'\n"; + } + } + } if ( $results =~ s/^SKIPPED\n//) { print "$results\n" ; } - elsif (($prefix and $results !~ /^\Q$expected/) or - (!$prefix and $results ne $expected)){ + elsif (($prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results !~ /^\Q$expected/))) or + (!$prefix && (( $option_regex && $results !~ /^$expected/) || + (!$option_regex && $results ne $expected)))) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; |
