diff options
Diffstat (limited to 'contrib/perl5/t/op')
78 files changed, 4822 insertions, 467 deletions
diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t new file mode 100755 index 0000000..60f72c3 --- /dev/null +++ b/contrib/perl5/t/op/64bitint.t @@ -0,0 +1,242 @@ +#./perl + +BEGIN { + eval { my $q = pack "q", 0 }; + if ($@) { + print "1..0\n# no 64-bit types\n"; + exit(0); + } + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +# This could use a lot of more tests. + +# so that using > 0xfffffff constants and +# 32+ bit integers don't cause noise +no warnings qw(overflow portable); + +print "1..48\n"; + +my $q = 12345678901; +my $r = 23456789012; +my $f = 0xffffffff; +my $x; +my $y; + +$x = unpack "q", pack "q", $q; +print "not " unless $x == $q && $x > $f; +print "ok 1\n"; + + +$x = sprintf("%lld", 12345678901); +print "not " unless $x eq $q && $x > $f; +print "ok 2\n"; + + +$x = sprintf("%lld", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 3\n"; + +$x = sprintf("%Ld", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 4\n"; + +$x = sprintf("%qd", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 5\n"; + + +$x = sprintf("%llx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 6\n"; + +$x = sprintf("%Lx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 7\n"; + +$x = sprintf("%qx", $q); +print "not " unless hex($x) == 0x2dfdc1c35 && hex($x) > $f; +print "ok 8\n"; + + +$x = sprintf("%llo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 9\n"; + +$x = sprintf("%Lo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 10\n"; + +$x = sprintf("%qo", $q); +print "not " unless oct("0$x") == 0133767016065 && oct($x) > $f; +print "ok 11\n"; + + +$x = sprintf("%llb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 12\n"; + +$x = sprintf("%Lb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 13\n"; + +$x = sprintf("%qb", $q); +print "not " unless oct("0b$x") == 0b1011011111110111000001110000110101 && + oct("0b$x") > $f; +print "ok 14\n"; + + +$x = sprintf("%llu", $q); +print "not " unless $x eq $q && $x > $f; +print "ok 15\n"; + +$x = sprintf("%Lu", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 16\n"; + +$x = sprintf("%qu", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 17\n"; + + +$x = sprintf("%D", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 18\n"; + +$x = sprintf("%U", $q); +print "not " unless $x == $q && $x eq $q && $x > $f; +print "ok 19\n"; + +$x = sprintf("%O", $q); +print "not " unless oct($x) == $q && oct($x) > $f; +print "ok 20\n"; + + +$x = $q + $r; +print "not " unless $x == 35802467913 && $x > $f; +print "ok 21\n"; + +$x = $q - $r; +print "not " unless $x == -11111110111 && -$x > $f; +print "ok 22\n"; + +$x = $q * 1234567; +print "not " unless $x == 15241567763770867 && $x > $f; +print "ok 23\n"; + +$x /= 1234567; +print "not " unless $x == $q && $x > $f; +print "ok 24\n"; + +$x = 98765432109 % 12345678901; +print "not " unless $x == 901; +print "ok 25\n"; + +# The following 12 tests adapted from op/inc. + +$a = 9223372036854775807; +$c = $a++; +print "not " unless $a == 9223372036854775808; +print "ok 26\n"; + +$a = 9223372036854775807; +$c = ++$a; +print "not " unless $a == 9223372036854775808 && $c == $a; +print "ok 27\n"; + +$a = 9223372036854775807; +$c = $a + 1; +print "not " unless $a == 9223372036854775807 && $c == 9223372036854775808; +print "ok 28\n"; + +$a = -9223372036854775808; +$c = $a--; +print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; +print "ok 29\n"; + +$a = -9223372036854775808; +$c = --$a; +print "not " unless $a == -9223372036854775809 && $c == $a; +print "ok 30\n"; + +$a = -9223372036854775808; +$c = $a - 1; +print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; +print "ok 31\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = $a--; +print "not " unless $a == -9223372036854775809 && $c == -9223372036854775808; +print "ok 32\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = --$a; +print "not " unless $a == -9223372036854775809 && $c == $a; +print "ok 33\n"; + +$a = 9223372036854775808; +$a = -$a; +$c = $a - 1; +print "not " unless $a == -9223372036854775808 && $c == -9223372036854775809; +print "ok 34\n"; + +$a = 9223372036854775808; +$b = -$a; +$c = $b--; +print "not " unless $b == -$a-1 && $c == -$a; +print "ok 35\n"; + +$a = 9223372036854775808; +$b = -$a; +$c = --$b; +print "not " unless $b == -$a-1 && $c == $b; +print "ok 36\n"; + +$a = 9223372036854775808; +$b = -$a; +$b = $b - 1; +print "not " unless $b == -(++$a); +print "ok 37\n"; + + +$x = ''; +print "not " unless (vec($x, 1, 64) = $q) == $q; +print "ok 38\n"; + +print "not " unless vec($x, 1, 64) == $q && vec($x, 1, 64) > $f; +print "ok 39\n"; + +print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0; +print "ok 40\n"; + + +print "not " unless ~0 == 0xffffffffffffffff; +print "ok 41\n"; + +print "not " unless (0xffffffff<<32) == 0xffffffff00000000; +print "ok 42\n"; + +print "not " unless ((0xffffffff)<<32)>>32 == 0xffffffff; +print "ok 43\n"; + +print "not " unless 1<<63 == 0x8000000000000000; +print "ok 44\n"; + +print "not " unless (sprintf "%#Vx", 1<<63) eq '0x8000000000000000'; +print "ok 45\n"; + +print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; +print "ok 46\n"; + +print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "ok 47\n"; + +print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "ok 48\n"; + +# eof diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t new file mode 100755 index 0000000..48bf5afe --- /dev/null +++ b/contrib/perl5/t/op/args.t @@ -0,0 +1,54 @@ +#!./perl + +print "1..8\n"; + +# test various operations on @_ + +my $ord = 0; +sub new1 { bless \@_ } +{ + my $x = new1("x"); + my $y = new1("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new2 { splice @_, 0, 0, "a", "b", "c"; return \@_ } +{ + my $x = new2("x"); + my $y = new2("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} + +sub new3 { goto &new1 } +{ + my $x = new3("x"); + my $y = new3("y"); + ++$ord; + print "# got [@$y], expected [y]\nnot " unless "@$y" eq "y"; + print "ok $ord\n"; + ++$ord; + print "# got [@$x], expected [x]\nnot " unless "@$x" eq "x"; + print "ok $ord\n"; +} + +sub new4 { goto &new2 } +{ + my $x = new4("x"); + my $y = new4("y"); + ++$ord; + print "# got [@$x], expected [a b c x]\nnot " unless "@$x" eq "a b c x"; + print "ok $ord\n"; + ++$ord; + print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; + print "ok $ord\n"; +} diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t index 43af807..fe2f0f4 100755 --- a/contrib/perl5/t/op/arith.t +++ b/contrib/perl5/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..4\n"; +print "1..8\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -10,3 +10,14 @@ try 1, 13 % 4 == 1; try 2, -13 % 4 == 3; try 3, 13 % -4 == -3; try 4, -13 % -4 == -1; + +my $limit = 1e6; + +# Division (and modulo) of floating point numbers +# seem to be rather sloppy in Cray. +$limit = 1e8 if $^O eq 'unicos'; + +try 5, abs( 13e21 % 4e21 - 1e21) < $limit; +try 6, abs(-13e21 % 4e21 - 3e21) < $limit; +try 7, abs( 13e21 % -4e21 - -3e21) < $limit; +try 8, abs(-13e21 % -4e21 - -1e21) < $limit; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 3409556..1108f49 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..65\n"; +print "1..66\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -211,3 +211,8 @@ my $t = 63; sub reify { $_[1] = ++$t; print "@_\n"; } reify('ok'); reify('ok'); + +# qw() is no more a runtime split, it's compiletime. +print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; +print "ok 66\n"; + diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t index 57e89c4..b95cec5 100755 --- a/contrib/perl5/t/op/assignwarn.t +++ b/contrib/perl5/t/op/assignwarn.t @@ -8,12 +8,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; +use warnings; -$^W = 1; my $warn = ""; $SIG{q(__WARN__)} = sub { print $warn; $warn .= join("",@_) }; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t new file mode 100755 index 0000000..615e4d3 --- /dev/null +++ b/contrib/perl5/t/op/attrs.t @@ -0,0 +1,176 @@ +#!./perl -w + +# Regression tests for attributes.pm and the C< : attrs> syntax. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +sub NTESTS () ; + +my ($test, $ntests); +BEGIN {$ntests=0} +$test=0; +my $failed = 0; + +print "1..".NTESTS."\n"; + +$SIG{__WARN__} = sub { die @_ }; + +sub mytest { + if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { + if ($@) { + my $x = $@; + $x =~ s/\n.*\z//s; + print "# Got: $x\n" + } + else { + print "# Got unexpected success\n"; + } + if ($_[0]) { + print "# Expected: $_[0]\n"; + } + else { + print "# Expected success\n"; + } + $failed = 1; + print "not "; + } + elsif (@_ == 3 && $_[1] ne $_[2]) { + print "# Got: $_[1]\n"; + print "# Expected: $_[2]\n"; + $failed = 1; + print "not "; + } + print "ok ",++$test,"\n"; +} + +eval 'sub t1 ($) : locked { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +eval 'sub t2 : locked { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +eval 'sub t3 ($) : locked ;'; +mytest; +BEGIN {++$ntests} + +eval 'sub t4 : locked ;'; +mytest; +BEGIN {++$ntests} + +my $anon1; +eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +my $anon2; +eval '$anon2 = sub : locked : method { $_[0]++ }'; +mytest; +BEGIN {++$ntests} + +my $anon3; +eval '$anon3 = sub : method { $_[0]->[1] }'; +mytest; +BEGIN {++$ntests} + +eval 'sub e1 ($) : plugh ;'; +mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; +BEGIN {++$ntests} + +eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; +mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; +BEGIN {++$ntests} + +eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; +mytest qr/Unterminated attribute parameter in attribute list at/; +BEGIN {++$ntests} + +eval 'sub e4 ($) : plugh + xyzzy ;'; +mytest qr/Invalid separator character '[+]' in attribute list at/; +BEGIN {++$ntests} + +eval 'my main $x : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my $x : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my $x ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x) : ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : = 0;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : ;'; +mytest; +BEGIN {++$ntests} + +eval 'my ($x,$y) : plugh;'; +mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; +BEGIN {++$ntests} + +sub A::MODIFY_SCALAR_ATTRIBUTES { return } +eval 'my A $x : plugh;'; +mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; +BEGIN {++$ntests} + +eval 'my A $x : plugh plover;'; +mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; +BEGIN {++$ntests} + +sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } +sub X::foo { 1 } +*Y::bar = \&X::foo; +*Y::bar = \&X::foo; # second time for -w +eval 'package Z; sub Y::bar : locked'; +mytest qr/^X at /; +BEGIN {++$ntests} + +my @attrs = eval 'attributes::get \&Y::bar'; +mytest '', "@attrs", "locked"; +BEGIN {++$ntests} + +@attrs = eval 'attributes::get $anon1'; +mytest '', "@attrs", "locked method"; +BEGIN {++$ntests} + +sub Z::DESTROY { } +sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } +my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; +mytest '', ref($thunk), "Z"; +BEGIN {++$ntests} + +@attrs = eval 'attributes::get $thunk'; +mytest '', "@attrs", "locked method Z"; +BEGIN {++$ntests} + + +# Other tests should be added above this line + +sub NTESTS () { $ntests } + +exit $failed; diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t index 55cc992..cd7c957 100755 --- a/contrib/perl5/t/op/avhv.t +++ b/contrib/perl5/t/op/avhv.t @@ -1,8 +1,8 @@ #!./perl - + BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } require Tie::Array; @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..12\n"; +print "1..28\n"; $sch = { 'abc' => 1, @@ -108,3 +108,71 @@ f($a->{key}); print "not " unless $a->[1] eq 'b'; print "ok 12\n"; +# check if exists() is behaving properly +$avhv = [{foo=>1,bar=>2,pants=>3}]; +print "not " if exists $avhv->{bar}; +print "ok 13\n"; + +$avhv->{pants} = undef; +print "not " unless exists $avhv->{pants}; +print "ok 14\n"; +print "not " if exists $avhv->{bar}; +print "ok 15\n"; + +$avhv->{bar} = 10; +print "not " unless exists $avhv->{bar} and $avhv->{bar} == 10; +print "ok 16\n"; + +$v = delete $avhv->{bar}; +print "not " unless $v == 10; +print "ok 17\n"; + +print "not " if exists $avhv->{bar}; +print "ok 18\n"; + +$avhv->{foo} = 'xxx'; +$avhv->{bar} = 'yyy'; +$avhv->{pants} = 'zzz'; +@x = delete @{$avhv}{'foo','pants'}; +print "# @x\nnot " unless "@x" eq "xxx zzz"; +print "ok 19\n"; + +print "not " unless "$avhv->{bar}" eq "yyy"; +print "ok 20\n"; + +# hash assignment +%$avhv = (); +print "not " unless ref($avhv->[0]) eq 'HASH'; +print "ok 21\n"; + +%hv = %$avhv; +print "not " if grep defined, values %hv; +print "ok 22\n"; +print "not " if grep ref, keys %hv; +print "ok 23\n"; + +%$avhv = (foo => 29, pants => 2, bar => 0); +print "not " unless "@$avhv[1..3]" eq '29 0 2'; +print "ok 24\n"; + +my $extra; +my @extra; +($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; +print "ok 25\n"; + +%$avhv = (); +(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; +print "ok 26\n"; + +@extra = qw(whatever and stuff); +%$avhv = (); +(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; +print "ok 27\n"; + +%$avhv = (); +(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; +print "ok 28\n"; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t index b247341..7bcabdf 100755 --- a/contrib/perl5/t/op/bop.t +++ b/contrib/perl5/t/op/bop.t @@ -6,10 +6,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } -print "1..18\n"; +print "1..30\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -62,3 +62,22 @@ print (($foo | $bar) eq ($Aoz x 75 . $zap) ? "ok 17\n" : "not ok 17\n"); # ^ does not truncate print (($foo ^ $bar) eq ($Axz x 75 . $zap) ? "ok 18\n" : "not ok 18\n"); +# +print "ok \xFF\xFF\n" & "ok 19\n"; +print "ok 20\n" | "ok \0\0\n"; +print "o\000 \0001\000" ^ "\000k\0002\000\n"; + +# +print "ok \x{FF}\x{FF}\n" & "ok 22\n"; +print "ok 23\n" | "ok \x{0}\x{0}\n"; +print "o\x{0} \x{0}4\x{0}" ^ "\x{0}k\x{0}2\x{0}\n"; + +# +print "ok 25\n" if sprintf("%vd", v4095 & v801) eq 801; +print "ok 26\n" if sprintf("%vd", v4095 | v801) eq 4095; +print "ok 27\n" if sprintf("%vd", v4095 ^ v801) eq 3294; + +# +print "ok 28\n" if sprintf("%vd", v4095.801.4095 & v801.4095) eq '801.801'; +print "ok 29\n" if sprintf("%vd", v4095.801.4095 | v801.4095) eq '4095.4095.4095'; +print "ok 30\n" if sprintf("%vd", v801.4095 ^ v4095.801.4095) eq '3294.3294.4095'; diff --git a/contrib/perl5/t/op/chars.t b/contrib/perl5/t/op/chars.t new file mode 100755 index 0000000..efdea02 --- /dev/null +++ b/contrib/perl5/t/op/chars.t @@ -0,0 +1,74 @@ +#!./perl + +print "1..33\n"; + +# because of ebcdic.c these should be the same on asciiish +# and ebcdic machines. +# Peter Prymmer <pvhp@best.com>. + +my $c = "\c@"; +print +((ord($c) == 0) ? "" : "not "),"ok 1\n"; +$c = "\cA"; +print +((ord($c) == 1) ? "" : "not "),"ok 2\n"; +$c = "\cB"; +print +((ord($c) == 2) ? "" : "not "),"ok 3\n"; +$c = "\cC"; +print +((ord($c) == 3) ? "" : "not "),"ok 4\n"; +$c = "\cD"; +print +((ord($c) == 4) ? "" : "not "),"ok 5\n"; +$c = "\cE"; +print +((ord($c) == 5) ? "" : "not "),"ok 6\n"; +$c = "\cF"; +print +((ord($c) == 6) ? "" : "not "),"ok 7\n"; +$c = "\cG"; +print +((ord($c) == 7) ? "" : "not "),"ok 8\n"; +$c = "\cH"; +print +((ord($c) == 8) ? "" : "not "),"ok 9\n"; +$c = "\cI"; +print +((ord($c) == 9) ? "" : "not "),"ok 10\n"; +$c = "\cJ"; +print +((ord($c) == 10) ? "" : "not "),"ok 11\n"; +$c = "\cK"; +print +((ord($c) == 11) ? "" : "not "),"ok 12\n"; +$c = "\cL"; +print +((ord($c) == 12) ? "" : "not "),"ok 13\n"; +$c = "\cM"; +print +((ord($c) == 13) ? "" : "not "),"ok 14\n"; +$c = "\cN"; +print +((ord($c) == 14) ? "" : "not "),"ok 15\n"; +$c = "\cO"; +print +((ord($c) == 15) ? "" : "not "),"ok 16\n"; +$c = "\cP"; +print +((ord($c) == 16) ? "" : "not "),"ok 17\n"; +$c = "\cQ"; +print +((ord($c) == 17) ? "" : "not "),"ok 18\n"; +$c = "\cR"; +print +((ord($c) == 18) ? "" : "not "),"ok 19\n"; +$c = "\cS"; +print +((ord($c) == 19) ? "" : "not "),"ok 20\n"; +$c = "\cT"; +print +((ord($c) == 20) ? "" : "not "),"ok 21\n"; +$c = "\cU"; +print +((ord($c) == 21) ? "" : "not "),"ok 22\n"; +$c = "\cV"; +print +((ord($c) == 22) ? "" : "not "),"ok 23\n"; +$c = "\cW"; +print +((ord($c) == 23) ? "" : "not "),"ok 24\n"; +$c = "\cX"; +print +((ord($c) == 24) ? "" : "not "),"ok 25\n"; +$c = "\cY"; +print +((ord($c) == 25) ? "" : "not "),"ok 26\n"; +$c = "\cZ"; +print +((ord($c) == 26) ? "" : "not "),"ok 27\n"; +$c = "\c["; +print +((ord($c) == 27) ? "" : "not "),"ok 28\n"; +$c = "\c\\"; +print +((ord($c) == 28) ? "" : "not "),"ok 29\n"; +$c = "\c]"; +print +((ord($c) == 29) ? "" : "not "),"ok 30\n"; +$c = "\c^"; +print +((ord($c) == 30) ? "" : "not "),"ok 31\n"; +$c = "\c_"; +print +((ord($c) == 31) ? "" : "not "),"ok 32\n"; +$c = "\c?"; +print +((ord($c) == 127) ? "" : "not "),"ok 33\n"; diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t index 77263ad..6723ca3 100755 --- a/contrib/perl5/t/op/chop.t +++ b/contrib/perl5/t/op/chop.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $ - -print "1..28\n"; +print "1..30\n"; # optimized @@ -85,3 +83,9 @@ $_ = "axx"; $/ = "yy"; print chomp() == 0 ? "ok 27\n" : "not ok 27\n"; print $_ eq "axx" ? "ok 28\n" : "not ok 28\n"; + +# This case once mistakenly behaved like paragraph mode. +$_ = "ab\n"; +$/ = \3; +print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; +print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t index 95d44f5..c691d6f 100755 --- a/contrib/perl5/t/op/closure.t +++ b/contrib/perl5/t/op/closure.t @@ -7,12 +7,12 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; -print "1..169\n"; +print "1..171\n"; my $test = 1; sub test (&) { @@ -157,6 +157,31 @@ test { &{$foo[4]}(4) }; +for my $n (0..4) { + $foo[$n] = sub { + # no intervening reference to $n here + sub { $n == $_[0] } + }; +} + +test { + $foo[0]->()->(0) and + $foo[1]->()->(1) and + $foo[2]->()->(2) and + $foo[3]->()->(3) and + $foo[4]->()->(4) +}; + +{ + my $w; + $w = sub { + my ($i) = @_; + test { $i == 10 }; + sub { $w }; + }; + $w->(10); +} + # Additional tests by Tom Phoenix <rootbeer@teleport.com>. { diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t index 33c74ea..9e714a7 100755 --- a/contrib/perl5/t/op/defins.t +++ b/contrib/perl5/t/op/defins.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $SIG{__WARN__} = sub { $warns++; warn $_[0] }; print "1..14\n"; } diff --git a/contrib/perl5/t/op/delete.t b/contrib/perl5/t/op/delete.t index 6cc4475..10a218b 100755 --- a/contrib/perl5/t/op/delete.t +++ b/contrib/perl5/t/op/delete.t @@ -1,8 +1,8 @@ #!./perl -# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $ +print "1..36\n"; -print "1..16\n"; +# delete() on hash elements $foo{1} = 'a'; $foo{2} = 'b'; @@ -13,7 +13,7 @@ $foo{5} = 'e'; $foo = delete $foo{2}; if ($foo eq 'b') {print "ok 1\n";} else {print "not ok 1 $foo\n";} -if ($foo{2} eq '') {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} +unless (exists $foo{2}) {print "ok 2\n";} else {print "not ok 2 $foo{2}\n";} if ($foo{1} eq 'a') {print "ok 3\n";} else {print "not ok 3\n";} if ($foo{3} eq 'c') {print "ok 4\n";} else {print "not ok 4\n";} if ($foo{4} eq 'd') {print "ok 5\n";} else {print "not ok 5\n";} @@ -24,8 +24,8 @@ if ($foo{5} eq 'e') {print "ok 6\n";} else {print "not ok 6\n";} if (@foo == 2) {print "ok 7\n";} else {print "not ok 7 ", @foo+0, "\n";} if ($foo[0] eq 'd') {print "ok 8\n";} else {print "not ok 8 ", $foo[0], "\n";} if ($foo[1] eq 'e') {print "ok 9\n";} else {print "not ok 9 ", $foo[1], "\n";} -if ($foo{4} eq '') {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} -if ($foo{5} eq '') {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} +unless (exists $foo{4}) {print "ok 10\n";} else {print "not ok 10 $foo{4}\n";} +unless (exists $foo{5}) {print "ok 11\n";} else {print "not ok 11 $foo{5}\n";} if ($foo{1} eq 'a') {print "ok 12\n";} else {print "not ok 12\n";} if ($foo{3} eq 'c') {print "ok 13\n";} else {print "not ok 13\n";} @@ -49,3 +49,75 @@ delete $refhash{"top"}->{"bar"}; @list = keys %{$refhash{"top"}}; print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n"; + +{ + my %a = ('bar', 33); + my($a) = \(values %a); + my $b = \$a{bar}; + my $c = \delete $a{bar}; + + print "not " unless $a == $b && $b == $c; + print "ok 17\n"; +} + +# delete() on array elements + +@foo = (); +$foo[1] = 'a'; +$foo[2] = 'b'; +$foo[3] = 'c'; +$foo[4] = 'd'; +$foo[5] = 'e'; + +$foo = delete $foo[2]; + +if ($foo eq 'b') {print "ok 18\n";} else {print "not ok 18 $foo\n";} +unless (exists $foo[2]) {print "ok 19\n";} else {print "not ok 19 $foo[2]\n";} +if ($foo[1] eq 'a') {print "ok 20\n";} else {print "not ok 20\n";} +if ($foo[3] eq 'c') {print "ok 21\n";} else {print "not ok 21\n";} +if ($foo[4] eq 'd') {print "ok 22\n";} else {print "not ok 22\n";} +if ($foo[5] eq 'e') {print "ok 23\n";} else {print "not ok 23\n";} + +@bar = delete @foo[4,5]; + +if (@bar == 2) {print "ok 24\n";} else {print "not ok 24 ", @bar+0, "\n";} +if ($bar[0] eq 'd') {print "ok 25\n";} else {print "not ok 25 ", $bar[0], "\n";} +if ($bar[1] eq 'e') {print "ok 26\n";} else {print "not ok 26 ", $bar[1], "\n";} +unless (exists $foo[4]) {print "ok 27\n";} else {print "not ok 27 $foo[4]\n";} +unless (exists $foo[5]) {print "ok 28\n";} else {print "not ok 28 $foo[5]\n";} +if ($foo[1] eq 'a') {print "ok 29\n";} else {print "not ok 29\n";} +if ($foo[3] eq 'c') {print "ok 30\n";} else {print "not ok 30\n";} + +$foo = join('',@foo); +if ($foo eq 'ac') {print "ok 31\n";} else {print "not ok 31\n";} + +if (@foo == 4) {print "ok 32\n";} else {print "not ok 32\n";} + +foreach $key (0 .. $#foo) { + delete $foo[$key]; +} + +if (@foo == 0) {print "ok 33\n";} else {print "not ok 33\n";} + +$foo[0] = 'x'; +$foo[1] = 'y'; + +$foo = "@foo"; +print +($foo eq 'x y') ? "ok 34\n" : "not ok 34\n"; + +$refary[0]->[0] = "FOO"; +$refary[0]->[3] = "BAR"; + +delete $refary[0]->[3]; + +print @{$refary[0]} == 1 ? "ok 35\n" : "not ok 35 @list\n"; + +{ + my @a = 33; + my($a) = \(@a); + my $b = \$a[0]; + my $c = \delete $a[bar]; + + print "not " unless $a == $b && $b == $c; + print "ok 36\n"; +} diff --git a/contrib/perl5/t/op/die.t b/contrib/perl5/t/op/die.t index d473ed6..cf4f8b0 100755 --- a/contrib/perl5/t/op/die.t +++ b/contrib/perl5/t/op/die.t @@ -4,7 +4,7 @@ print "1..10\n"; $SIG{__DIE__} = sub { print ref($_[0]) ? ("ok ",$_[0]->[0]++,"\n") : @_ } ; -$err = "ok 1\n"; +$err = "#[\000]\nok 1\n"; eval { die $err; }; diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index 26b477a..cb0478b 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -7,8 +7,14 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -e '../lib'; + unshift @INC, '../lib' if -e '../lib'; } + +if ($^O eq 'mpeix') { + print "1..0 # Skip: broken on MPE/iX\n"; + exit 0; +} + my $perl = -e '../perl' ? '../perl' : -e './perl' ? './perl' : 'perl'; use strict; @@ -31,7 +37,7 @@ my %tests = ( 15 => [ 255, 1], 16 => [ 255, 256], # see if implicit close preserves $? - 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F } die;'], + 17 => [ 0, 512, '{ local *F; open F, q[TEST]; close F; $!=0 } die;'], ); my $max = keys %tests; diff --git a/contrib/perl5/t/op/each.t b/contrib/perl5/t/op/each.t index 9063c2c..879c0d0 100755 --- a/contrib/perl5/t/op/each.t +++ b/contrib/perl5/t/op/each.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $ - -print "1..16\n"; +print "1..19\n"; $h{'abc'} = 'ABC'; $h{'def'} = 'DEF'; @@ -120,3 +118,16 @@ while (($key, $value) = each(h)) { } } if ($i == 5) { print "ok 16\n" } else { print "not ok\n" } + +{ + package Obj; + sub DESTROY { print "ok 18\n"; } + { + my $h = { A => bless [], __PACKAGE__ }; + while (my($k,$v) = each %$h) { + print "ok 17\n" if $k eq 'A' and ref($v) eq 'Obj'; + } + } + print "ok 19\n"; +} + diff --git a/contrib/perl5/t/op/eval.t b/contrib/perl5/t/op/eval.t index dc163e9..1838923 100755 --- a/contrib/perl5/t/op/eval.t +++ b/contrib/perl5/t/op/eval.t @@ -1,6 +1,6 @@ #!./perl -print "1..36\n"; +print "1..40\n"; eval 'print "ok 1\n";'; @@ -171,3 +171,38 @@ sub terminal { eval 'print $r' } } $x++; +# Have we cured panic which occurred with require/eval in die handler ? +$SIG{__DIE__} = sub { eval {1}; die shift }; +eval { die "ok ".$x++,"\n" }; +print $@; + +# does scalar eval"" pop stack correctly? +{ + my $c = eval "(1,2)x10"; + print $c eq '2222222222' ? "ok $x\n" : "# $c\nnot ok $x\n"; + $x++; +} + +# return from eval {} should clear $@ correctly +{ + my $status = eval { + eval { die }; + print "# eval { return } test\n"; + return; # removing this changes behavior + }; + print "not " if $@; + print "ok $x\n"; + $x++; +} + +# ditto for eval "" +{ + my $status = eval q{ + eval q{ die }; + print "# eval q{ return } test\n"; + return; # removing this changes behavior + }; + print "not " if $@; + print "ok $x\n"; + $x++; +} diff --git a/contrib/perl5/t/op/exec.t b/contrib/perl5/t/op/exec.t index 098a455..23e9ec1 100755 --- a/contrib/perl5/t/op/exec.t +++ b/contrib/perl5/t/op/exec.t @@ -1,13 +1,13 @@ #!./perl -# $RCSfile: exec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:49 $ - $| = 1; # flush stdout +$ENV{LC_ALL} = 'C'; # Forge English error messages. +$ENV{LANGUAGE} = 'C'; # Ditto in GNU. + if ($^O eq 'MSWin32') { - print "# exec is unsupported on Win32\n"; # XXX the system tests could be written to use ./perl and so work on Win32 - print "1..0\n"; + print "1..0 # Skip: shh, win32\n"; exit(0); } @@ -25,10 +25,23 @@ print "not ok 3\n" if system "echo", "ok", "3"; # directly called # these should probably be rewritten to match the examples in perlfunc.pod if (system "true") {print "not ok 4\n";} else {print "ok 4\n";} -if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } -print "ok 5\n"; +if ($^O eq 'mpeix') { + print "ok 5 # skipped: status broken on MPE/iX\n"; +} else { + if ((system "/bin/sh -c 'exit 1'") != 256) { print "not "; } + print "ok 5\n"; +} -if ((system "lskdfj") == 255 << 8) {print "ok 6\n";} else {print "not ok 6\n";} +$rc = system "lskdfj"; +if ($rc == 255 << 8 or $rc == -1 and + ( + $! == 2 or + $! =~ /\bno\b.*\bfile/i or + $! == 13 or + $! =~ /permission denied/i + ) + ) + {print "ok 6\n";} else {print "not ok 6\n";} unless (exec "lskdjfalksdjfdjfkls") {print "ok 7\n";} else {print "not ok 7\n";} diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t new file mode 100755 index 0000000..3363dfd --- /dev/null +++ b/contrib/perl5/t/op/exists_sub.t @@ -0,0 +1,46 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..9\n"; + +sub t1; +sub t2 : locked; +sub t3 (); +sub t4 ($); +sub t5 {1;} +{ + package P1; + sub tmc {1;} + package P2; + @ISA = 'P1'; +} + +print "not " unless exists &t1 && not defined &t1; +print "ok 1\n"; +print "not " unless exists &t2 && not defined &t2; +print "ok 2\n"; +print "not " unless exists &t3 && not defined &t3; +print "ok 3\n"; +print "not " unless exists &t4 && not defined &t4; +print "ok 4\n"; +print "not " unless exists &t5 && defined &t5; +print "ok 5\n"; +P2::->tmc; +print "not " unless not exists &P2::tmc && not defined &P2::tmc; +print "ok 6\n"; +my $ref; +$ref->{A}[0] = \&t4; +print "not " unless exists &{$ref->{A}[0]} && not defined &{$ref->{A}[0]}; +print "ok 7\n"; +undef &P1::tmc; +print "not " unless exists &P1::tmc && not defined &P1::tmc; +print "ok 8\n"; +eval 'exists &t5()'; +print "not " unless $@; +print "ok 9\n"; + +exit 0; diff --git a/contrib/perl5/t/op/fh.t b/contrib/perl5/t/op/fh.t new file mode 100755 index 0000000..86e405a --- /dev/null +++ b/contrib/perl5/t/op/fh.t @@ -0,0 +1,26 @@ +#!./perl + +print "1..5\n"; + +my $test = 0; + +# symbolic filehandles should only result in glob entries with FH constructors + +$|=1; +my $a = "SYM000"; +print "not " if defined(fileno($a)) or defined *{$a}; +++$test; print "ok $test\n"; + +select select $a; +print "not " unless defined *{$a}; +++$test; print "ok $test\n"; + +$a++; +print "not " if close $a or defined *{$a}; +++$test; print "ok $test\n"; + +print "not " unless open($a, ">&STDOUT") and defined *{$a}; +++$test; print $a "ok $test\n"; + +print "not " unless close $a; +++$test; print $a "not "; print "ok $test\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t new file mode 100755 index 0000000..e00d5fb --- /dev/null +++ b/contrib/perl5/t/op/filetest.t @@ -0,0 +1,71 @@ +#!./perl + +# There are few filetest operators that are portable enough to test. +# See pod/perlport.pod for details. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; +} + +use Config; +print "1..10\n"; + +print "not " unless -d 'op'; +print "ok 1\n"; + +print "not " unless -f 'TEST'; +print "ok 2\n"; + +print "not " if -f 'op'; +print "ok 3\n"; + +print "not " if -d 'TEST'; +print "ok 4\n"; + +print "not " unless -r 'TEST'; +print "ok 5\n"; + +# make sure TEST is r-x +eval { chmod 0555, 'TEST' }; +$bad_chmod = $@; + +$oldeuid = $>; # root can read and write anything +eval '$> = 1'; # so switch uid (may not be implemented) + +print "# oldeuid = $oldeuid, euid = $>\n"; + +if (!$Config{d_seteuid}) { + print "ok 6 #skipped, no seteuid\n"; +} +elsif ($bad_chmod) { + print "#[$@]\nok 6 #skipped\n"; +} +else { + print "not " if -w 'TEST'; + print "ok 6\n"; +} + +# Scripts are not -x everywhere so cannot test that. + +eval '$> = $oldeuid'; # switch uid back (may not be implemented) + +# this would fail for the euid 1 +# (unless we have unpacked the source code as uid 1...) +print "not " unless -r 'op'; +print "ok 7\n"; + +# this would fail for the euid 1 +# (unless we have unpacked the source code as uid 1...) +if ($Config{d_seteuid}) { + print "not " unless -w 'op'; + print "ok 8\n"; +} else { + print "ok 8 #skipped, no seteuid\n"; +} + +print "not " unless -x 'op'; # Hohum. Are directories -x everywhere? +print "ok 9\n"; + +print "not " unless "@{[grep -r, qw(foo io noo op zoo)]}" eq "io op"; +print "ok 10\n"; diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t index 9790ff0..80c0b72 100755 --- a/contrib/perl5/t/op/fork.t +++ b/contrib/perl5/t/op/fork.t @@ -1,26 +1,376 @@ #!./perl -# $RCSfile: fork.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:53 $ +# tests for both real and emulated fork() BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; require Config; import Config; - unless ($Config{'d_fork'}) { - print "1..0\n"; + unless ($Config{'d_fork'} + or ($^O eq 'MSWin32' and $Config{useithreads} + and $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/)) + { + print "1..0 # Skip: no fork\n"; exit 0; } + $ENV{PERL5LIB} = "../lib"; } -$| = 1; -print "1..2\n"; +if ($^O eq 'mpeix') { + print "1..0 # Skip: fork/status problems on MPE/iX\n"; + exit 0; +} + +$|=1; + +undef $/; +@prgs = split "\n########\n", <DATA>; +print "1..", scalar @prgs, "\n"; + +$tmpfile = "forktmp000"; +1 while -f ++$tmpfile; +END { close TEST; unlink $tmpfile if $tmpfile; } + +$CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); + +for (@prgs){ + my $switch; + if (s/^\s*(-\w.*)//){ + $switch = $1; + } + my($prog,$expected) = split(/\nEXPECT\n/, $_); + $expected =~ s/\n+$//; + # results can be in any order, so sort 'em + my @expected = sort split /\n/, $expected; + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + my $results; + if ($^O eq 'MSWin32') { + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; + } + else { + $results = `./perl $switch $tmpfile 2>&1`; + } + $status = $?; + $results =~ s/\n+$//; + $results =~ s/at\s+forktmp\d+\s+line/at - line/g; + $results =~ s/of\s+forktmp\d+\s+aborted/of - aborted/g; +# bison says 'parse error' instead of 'syntax error', +# various yaccs may or may not capitalize 'syntax'. + $results =~ s/^(syntax|parse) error/syntax error/mig; + $results =~ s/^\n*Process terminated by SIG\w+\n?//mg + if $^O eq 'os2'; + my @results = sort split /\n/, $results; + if ( "@results" ne "@expected" ) { + print STDERR "PROG: $switch\n$prog\n"; + print STDERR "EXPECTED:\n$expected\n"; + print STDERR "GOT:\n$results\n"; + print "not "; + } + print "ok ", ++$i, "\n"; +} +__END__ +$| = 1; if ($cid = fork) { - sleep 2; - if ($result = (kill 9, $cid)) {print "ok 2\n";} else {print "not ok 2 $result\n";} + sleep 1; + if ($result = (kill 9, $cid)) { + print "ok 2\n"; + } + else { + print "not ok 2 $result\n"; + } + sleep 1 if $^O eq 'MSWin32'; # avoid WinNT race bug } else { - $| = 1; print "ok 1\n"; sleep 10; } +EXPECT +ok 1 +ok 2 +######## +$| = 1; +sub forkit { + print "iteration $i start\n"; + my $x = fork; + if (defined $x) { + if ($x) { + print "iteration $i parent\n"; + } + else { + print "iteration $i child\n"; + } + } + else { + print "pid $$ failed to fork\n"; + } +} +while ($i++ < 3) { do { forkit(); }; } +EXPECT +iteration 1 start +iteration 1 parent +iteration 1 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 2 start +iteration 2 parent +iteration 2 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +iteration 3 start +iteration 3 parent +iteration 3 child +######## +$| = 1; +fork() + ? (print("parent\n"),sleep(1)) + : (print("child\n"),exit) ; +EXPECT +parent +child +######## +$| = 1; +fork() + ? (print("parent\n"),exit) + : (print("child\n"),sleep(1)) ; +EXPECT +parent +child +######## +$| = 1; +@a = (1..3); +for (@a) { + if (fork) { + print "parent $_\n"; + $_ = "[$_]"; + } + else { + print "child $_\n"; + $_ = "-$_-"; + } +} +print "@a\n"; +EXPECT +parent 1 +child 1 +parent 2 +child 2 +parent 2 +child 2 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +parent 3 +child 3 +[1] [2] [3] +-1- [2] [3] +[1] -2- [3] +[1] [2] -3- +-1- -2- [3] +-1- [2] -3- +[1] -2- -3- +-1- -2- -3- +######## +use Config; +$| = 1; +$\ = "\n"; +fork() + ? print($Config{osname} eq $^O) + : print($Config{osname} eq $^O) ; +EXPECT +1 +1 +######## +$| = 1; +$\ = "\n"; +fork() + ? do { require Config; print($Config::Config{osname} eq $^O); } + : do { require Config; print($Config::Config{osname} eq $^O); } +EXPECT +1 +1 +######## +$| = 1; +use Cwd; +$\ = "\n"; +my $dir; +if (fork) { + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 parent" : "not ok 1 parent"; + chdir ".."; + rmdir $dir; +} +else { + sleep 2; + $dir = "f$$.tst"; + mkdir $dir, 0755; + chdir $dir; + print cwd() =~ /\Q$dir/i ? "ok 1 child" : "not ok 1 child"; + chdir ".."; + rmdir $dir; +} +EXPECT +ok 1 parent +ok 1 child +######## +$| = 1; +$\ = "\n"; +my $getenv; +if ($^O eq 'MSWin32') { + $getenv = qq[$^X -e "print \$ENV{TST}"]; +} +else { + $getenv = qq[$^X -e 'print \$ENV{TST}']; +} +$ENV{TST} = 'foo'; +if (fork) { + sleep 1; + print "parent before: " . `$getenv`; + $ENV{TST} = 'bar'; + print "parent after: " . `$getenv`; +} +else { + print "child before: " . `$getenv`; + $ENV{TST} = 'baz'; + print "child after: " . `$getenv`; +} +EXPECT +child before: foo +child after: baz +parent before: foo +parent after: bar +######## +$| = 1; +$\ = "\n"; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exit(42); +} +EXPECT +parent got 10752 +######## +$| = 1; +$\ = "\n"; +my $echo = 'echo'; +if ($pid = fork) { + waitpid($pid,0); + print "parent got $?" +} +else { + exec("$echo foo"); +} +EXPECT +foo +parent got 0 +######## +if (fork) { + die "parent died"; +} +else { + die "child died"; +} +EXPECT +parent died at - line 2. +child died at - line 5. +######## +if ($pid = fork) { + eval { die "parent died" }; + print $@; +} +else { + eval { die "child died" }; + print $@; +} +EXPECT +parent died at - line 2. +child died at - line 6. +######## +if (eval q{$pid = fork}) { + eval q{ die "parent died" }; + print $@; +} +else { + eval q{ die "child died" }; + print $@; +} +EXPECT +parent died at (eval 2) line 1. +child died at (eval 2) line 1. +######## +BEGIN { + $| = 1; + fork and exit; + print "inner\n"; +} +# XXX In emulated fork(), the child will not execute anything after +# the BEGIN block, due to difficulties in recreating the parse stacks +# and restarting yyparse() midstream in the child. This can potentially +# be overcome by treating what's after the BEGIN{} as a brand new parse. +#print "outer\n" +EXPECT +inner +######## +sub pipe_to_fork ($$) { + my $parent = shift; + my $child = shift; + pipe($child, $parent) or die; + my $pid = fork(); + die "fork() failed: $!" unless defined $pid; + close($pid ? $child : $parent); + $pid; +} + +if (pipe_to_fork('PARENT','CHILD')) { + # parent + print PARENT "pipe_to_fork\n"; + close PARENT; +} +else { + # child + while (<CHILD>) { print; } + close CHILD; + exit; +} + +sub pipe_from_fork ($$) { + my $parent = shift; + my $child = shift; + pipe($parent, $child) or die; + my $pid = fork(); + die "fork() failed: $!" unless defined $pid; + close($pid ? $child : $parent); + $pid; +} + +if (pipe_from_fork('PARENT','CHILD')) { + # parent + while (<PARENT>) { print; } + close PARENT; +} +else { + # child + print CHILD "pipe_from_fork\n"; + close CHILD; + exit; +} +EXPECT +pipe_from_fork +pipe_to_fork diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t index 253e4a3..4c27445 100755 --- a/contrib/perl5/t/op/glob.t +++ b/contrib/perl5/t/op/glob.t @@ -1,6 +1,9 @@ #!./perl -# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} print "1..6\n"; diff --git a/contrib/perl5/t/op/goto.t b/contrib/perl5/t/op/goto.t index 8096aff..96bb8dd 100755 --- a/contrib/perl5/t/op/goto.t +++ b/contrib/perl5/t/op/goto.t @@ -2,7 +2,7 @@ # "This IS structured code. It's just randomly structured." -print "1..13\n"; +print "1..16\n"; while ($?) { $foo = 1; @@ -30,8 +30,8 @@ print "#2\t:$foo: == 4\n"; if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";} $PERL = ($^O eq 'MSWin32') ? '.\perl' : './perl'; -$x = `$PERL -e "goto foo;" 2>&1`; -if ($x =~ /DCL-W-NOCOMD/) { $x = `\$ mcr sys\$disk:[]perl. -e "goto foo;"`; } +$CMD = qq[$PERL -e "goto foo;" 2>&1 ]; +$x = `$CMD`; if ($x =~ /label/) {print "ok 3\n";} else {print "not ok 3\n";} @@ -55,6 +55,27 @@ exit; FINALE: print "ok 13\n"; + +# does goto LABEL handle block contexts correctly? + +my $cond = 1; +for (1) { + if ($cond == 1) { + $cond = 0; + goto OTHER; + } + elsif ($cond == 0) { + OTHER: + $cond = 2; + print "ok 14\n"; + goto THIRD; + } + else { + THIRD: + print "ok 15\n"; + } +} +print "ok 16\n"; exit; bypass: diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t index a35575e..8d9bca1 100755 --- a/contrib/perl5/t/op/goto_xs.t +++ b/contrib/perl5/t/op/goto_xs.t @@ -10,7 +10,7 @@ # break correctly as well. chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; # turn warnings into fatal errors diff --git a/contrib/perl5/t/op/grent.t b/contrib/perl5/t/op/grent.t new file mode 100755 index 0000000..761d8b9 --- /dev/null +++ b/contrib/perl5/t/op/grent.t @@ -0,0 +1,139 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib" if -d "../lib"; + eval {my @n = getgrgid 0}; + if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { + print "1..0 # Skip: $1\n"; + exit 0; + } + eval { require Config; import Config; }; + my $reason; + if ($Config{'i_grp'} ne 'define') { + $reason = '$Config{i_grp} not defined'; + } + elsif (not -f "/etc/group" ) { # Play safe. + $reason = 'no /etc/group file'; + } + + if (not defined $where) { # Try NIS. + foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { + if (-x $ypcat && + open(GR, "$ypcat group 2>/dev/null |") && + defined(<GR>)) { + $where = "NIS group"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try NetInfo. + foreach my $nidump (qw(/usr/bin/nidump)) { + if (-x $nidump && + open(GR, "$nidump group . 2>/dev/null |") && + defined(<GR>)) { + $where = "NetInfo group"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try local. + my $GR = "/etc/group"; + if (-f $GR && open(GR, $GR) && defined(<GR>)) { + undef $reason; + $where = $GR; + } + } + if ($reason) { + print "1..0 # Skip: $reason\n"; + exit 0; + } +} + +# By now GR filehandle should be open and full of juicy group entries. + +print "1..1\n"; + +# Go through at most this many groups. +# (note that the first entry has been read away by now) +my $max = 25; + +my $n = 0; +my $tst = 1; +my %perfect; +my %seen; + +while (<GR>) { + chomp; + my @s = split /:/; + my ($name_s,$passwd_s,$gid_s,$members_s) = @s; + if (@s) { + push @{ $seen{$name_s} }, $.; + } else { + warn "# Your $where line $. is empty.\n"; + next; + } + if ($n == $max) { + local $/; + my $junk = <GR>; + last; + } + # In principle we could whine if @s != 4 but do we know enough + # of group file formats everywhere? + if (@s == 4) { + $members_s =~ s/\s*,\s*/,/g; + $members_s =~ s/\s+$//; + $members_s =~ s/^\s+//; + @n = getgrgid($gid_s); + # 'nogroup' et al. + next unless @n; + my ($name,$passwd,$gid,$members) = @n; + # Protect against one-to-many and many-to-one mappings. + if ($name_s ne $name) { + @n = getgrnam($name_s); + ($name,$passwd,$gid,$members) = @n; + next if $name_s ne $name; + } + # NOTE: group names *CAN* contain whitespace. + $members =~ s/\s+/,/g; + # what about different orders of members? + $perfect{$name_s}++ + if $name eq $name_s and +# Do not compare passwords: think shadow passwords. +# Not that group passwords are used much but better not assume anything. + $gid eq $gid_s and + $members eq $members_s; + } + $n++; +} + +if (keys %perfect == 0) { + $max++; + print <<EOEX; +# +# The failure of op/grent test is not necessarily serious. +# It may fail due to local group administration conventions. +# If you are for example using both NIS and local groups, +# test failure is possible. Any distributed group scheme +# can cause such failures. +# +# What the grent test is doing is that it compares the $max first +# entries of $where +# with the results of getgrgid() and getgrnam() call. If it finds no +# matches at all, it suspects something is wrong. +# +EOEX + print "not "; + $not = 1; +} else { + $not = 0; +} +print "ok ", $tst++; +print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; +print "\n"; + +close(GR); diff --git a/contrib/perl5/t/op/grep.t b/contrib/perl5/t/op/grep.t index 45d0e25..3a7f8ad 100755 --- a/contrib/perl5/t/op/grep.t +++ b/contrib/perl5/t/op/grep.t @@ -4,7 +4,7 @@ # grep() and map() tests # -print "1..3\n"; +print "1..27\n"; $test = 1; @@ -29,3 +29,71 @@ sub ok { $test++; } +{ + print map({$_} ("ok $test\n")); + $test++; + print map + ({$_} ("ok $test\n")); + $test++; + print((map({a => $_}, ("ok $test\n")))[0]->{a}); + $test++; + print((map + ({a=>$_}, + ("ok $test\n")))[0]->{a}); + $test++; + print map { $_ } ("ok $test\n"); + $test++; + print map + { $_ } ("ok $test\n"); + $test++; + print((map {a => $_}, ("ok $test\n"))[0]->{a}); + $test++; + print((map + {a=>$_}, + ("ok $test\n"))[0]->{a}); + $test++; + my $x = "ok \xFF\xFF\n"; + print map($_&$x,("ok $test\n")); + $test++; + print map + ($_ & $x, ("ok $test\n")); + $test++; + print map { $_ & $x } ("ok $test\n"); + $test++; + print map + { $_&$x } ("ok $test\n"); + $test++; + + print grep({$_} ("ok $test\n")); + $test++; + print grep + ({$_} ("ok $test\n")); + $test++; + print grep({a => $_}->{a}, ("ok $test\n")); + $test++; + print grep + ({a => $_}->{a}, + ("ok $test\n")); + $test++; + print grep { $_ } ("ok $test\n"); + $test++; + print grep + { $_ } ("ok $test\n"); + $test++; + print grep {a => $_}->{a}, ("ok $test\n"); + $test++; + print grep + {a => $_}->{a}, + ("ok $test\n"); + $test++; + print grep($_&"X",("ok $test\n")); + $test++; + print grep + ($_&"X", ("ok $test\n")); + $test++; + print grep { $_ & "X" } ("ok $test\n"); + $test++; + print grep + { $_ & "X" } ("ok $test\n"); + $test++; +} diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t index 47aabe3..4b655c8 100755 --- a/contrib/perl5/t/op/groups.t +++ b/contrib/perl5/t/op/groups.t @@ -1,13 +1,101 @@ #!./perl -if (! -x ($groups = '/usr/ucb/groups') && - ! -x ($groups = '/usr/bin/groups') && - ! -x ($groups = '/bin/groups') -) { - print "1..0\n"; +$ENV{PATH} ="/bin:/usr/bin:/usr/xpg4/bin:/usr/ucb" . + exists $ENV{PATH} ? ":$ENV{PATH}" : ""; +$ENV{LC_ALL} = "C"; # so that external utilities speak English +$ENV{LANGUAGE} = 'C'; # GNU locale extension + +sub quit { + print "1..0 # Skip: no `id` or `groups`\n"; exit 0; } +quit() if $^O eq 'MSWin32' or $^O =~ /lynxos/i; + +# We have to find a command that prints all (effective +# and real) group names (not ids). The known commands are: +# groups +# id -Gn +# id -a +# Beware 1: some systems do just 'id -G' even when 'id -Gn' is used. +# Beware 2: id -Gn or id -a format might be id(name) or name(id). +# Beware 3: the groups= might be anywhere in the id output. +# Beware 4: groups can have spaces ('id -a' being the only defense against this) +# Beware 5: id -a might not contain the groups= part. +# +# That is, we might meet the following: +# +# foo bar zot # accept +# foo 22 42 bar zot # accept +# 1 22 42 2 3 # reject +# groups=(42),foo(1),bar(2),zot me(3) # parse +# groups=22,42,1(foo),2(bar),3(zot me) # parse +# +# and the groups= might be after, before, or between uid=... and gid=... + +GROUPS: { + # prefer 'id' over 'groups' (is this ever wrong anywhere?) + # and 'id -a' over 'id -Gn' (the former is good about spaces in group names) + if (($groups = `id -a 2>/dev/null`) ne '') { + # $groups is of the form: + # uid=39957(gsar) gid=22(users) groups=33536,39181,22(users),0(root),1067(dev) + last GROUPS if $groups =~ /groups=/; + } + if (($groups = `id -Gn 2>/dev/null`) ne '') { + # $groups could be of the form: + # users 33536 39181 root dev + last GROUPS if $groups !~ /^(\d|\s)+$/; + } + if (($groups = `groups 2>/dev/null`) ne '') { + # may not reflect all groups in some places, so do a sanity check + if (-d '/afs') { + print <<EOM; +# These test results *may* be bogus, as you appear to have AFS, +# and I can't find a working 'id' in your PATH (which I have set +# to '$ENV{PATH}'). +# +# If these tests fail, report the particular incantation you use +# on this platform to find *all* the groups that an arbitrary +# luser may belong to, using the 'perlbug' program. +EOM + } + last GROUPS; + } + # Okay, not today. + quit(); +} + +unless (eval { getgrgid(0); 1 }) { + print "1..0 # Skip: getgrgid() not implemented\n"; + exit 0; +} + +# Remember that group names can contain whitespace, '-', et cetera. +# That is: do not \w, do not \S. +if ($groups =~ /groups=(.+)( [ug]id=|$)/) { + my $gr = $1; + my @g0 = split /,/, $gr; + my @g1; + # prefer names over numbers + for (@g0) { + # 42(zot me) + if (/^(\d+)(?:\(([^)]+)\))?/) { + push @g1, ($2 || $1); + } + # zot me(42) + elsif (/^([^(]*)\((\d+)\)/) { + push @g1, ($1 || $2); + } + else { + print "# ignoring group entry [$_]\n"; + } + } + print "# groups=$gr\n"; + print "# g0 = @g0\n"; + print "# g1 = @g1\n"; + $groups = "@g1"; +} + print "1..2\n"; $pwgid = $( + 0; @@ -27,9 +115,13 @@ for (split(' ', $()) { } } -$gr1 = join(' ', sort @gr); +if ($^O eq "uwin") { # Or anybody else who can have spaces in group names. + $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); +} else { + $gr1 = join(' ', sort @gr); +} -$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`$groups`))); +$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',$groups))); if ($gr1 eq $gr2) { print "ok 1\n"; diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t index c253e4b..04905cd 100755 --- a/contrib/perl5/t/op/gv.t +++ b/contrib/perl5/t/op/gv.t @@ -4,7 +4,14 @@ # various typeglob tests # -print "1..23\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +use warnings; + +print "1..30\n"; # type coersion on assignment $foo = 'foo'; @@ -62,7 +69,7 @@ if (defined $baa) { # fact that %X::Y:: is stored in %X:: isn't documented. # (I hope.) -{ package Foo::Bar } +{ package Foo::Bar; no warnings 'once'; $test=1; } print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n"; print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n"; @@ -77,7 +84,7 @@ print +($foo || @foo || %foo) ? "not ok" : "ok", " 14\n"; { my $msg; local $SIG{__WARN__} = sub { $msg = $_[0] }; - local $^W = 1; + use warnings; *foo = 'bar'; print $msg ? "not ok" : "ok", " 15\n"; *foo = undef; @@ -95,4 +102,39 @@ print *{*x{GLOB}} eq "*main::STDOUT" ? "ok 21\n" : "not ok 21\n"; print {*x{IO}} "ok 22\n"; print {*x{FILEHANDLE}} "ok 23\n"; +# test if defined() doesn't create any new symbols + +{ + my $test = 23; + + my $a = "SYM000"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined @{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined %{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined ${$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + print "not " if defined &{$a} or defined *{$a}; + ++$test; print "ok $test\n"; + + *{$a} = sub { print "ok $test\n" }; + print "not " unless defined &{$a} and defined *{$a}; + ++$test; &{$a}; +} + +# does pp_readline() handle glob-ness correctly? + +{ + my $g = *foo; + $g = <DATA>; + print $g; +} +__END__ +ok 30 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t index 6343a2a..9182273 100755 --- a/contrib/perl5/t/op/hashwarn.t +++ b/contrib/perl5/t/op/hashwarn.t @@ -2,19 +2,18 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use strict; +use warnings; use vars qw{ @warnings }; BEGIN { - $^W |= 1; # Insist upon warnings - # ...and save 'em as we go $SIG{'__WARN__'} = sub { push @warnings, @_ }; $| = 1; - print "1..7\n"; + print "1..9\n"; } END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings } @@ -66,6 +65,13 @@ my $ref_msg = '/^Reference found where even-sized list expected/'; %hash = sub { print "ok" }; test_warning 6, shift @warnings, $odd_msg; + my $avhv = [{x=>1,y=>2}]; + %$avhv = (x=>13,'y'); + test_warning 7, shift @warnings, $odd_msg; + + %$avhv = 'x'; + test_warning 8, shift @warnings, $odd_msg; + $_ = { 1..10 }; - test 7, ! @warnings, "Unexpected warning"; + test 9, ! @warnings, "Unexpected warning"; } diff --git a/contrib/perl5/t/op/inc.t b/contrib/perl5/t/op/inc.t index e5a2a92..f59115e 100755 --- a/contrib/perl5/t/op/inc.t +++ b/contrib/perl5/t/op/inc.t @@ -1,9 +1,6 @@ #!./perl - -# $RCSfile$ - -print "1..6\n"; +print "1..12\n"; # Verify that addition/subtraction properly upgrade to doubles. # These tests are only significant on machines with 32 bit longs, @@ -50,3 +47,51 @@ if ($a == -2147483649) {print "ok 6\n"} else {print "not ok 6\n";} + +$a = 2147483648; +$a = -$a; +$c=$a--; +if ($a == -2147483649) + {print "ok 7\n"} +else + {print "not ok 7\n";} + +$a = 2147483648; +$a = -$a; +$c=--$a; +if ($a == -2147483649) + {print "ok 8\n"} +else + {print "not ok 8\n";} + +$a = 2147483648; +$a = -$a; +$a=$a-1; +if ($a == -2147483649) + {print "ok 9\n"} +else + {print "not ok 9\n";} + +$a = 2147483648; +$b = -$a; +$c=$b--; +if ($b == -$a-1) + {print "ok 10\n"} +else + {print "not ok 10\n";} + +$a = 2147483648; +$b = -$a; +$c=--$b; +if ($b == -$a-1) + {print "ok 11\n"} +else + {print "not ok 11\n";} + +$a = 2147483648; +$b = -$a; +$b=$b-1; +if ($b == -(++$a)) + {print "ok 12\n"} +else + {print "not ok 12\n";} diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t index eb060ac..6ac0866 100755 --- a/contrib/perl5/t/op/int.t +++ b/contrib/perl5/t/op/int.t @@ -1,8 +1,11 @@ #!./perl -# $RCSfile: int.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:00 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -print "1..4\n"; +print "1..6\n"; # compile time evaluation @@ -15,3 +18,13 @@ if (int(-1.234) == -1) {print "ok 2\n";} else {print "not ok 2\n";} $x = 1.234; if (int($x) == 1) {print "ok 3\n";} else {print "not ok 3\n";} if (int(-$x) == -1) {print "ok 4\n";} else {print "not ok 4\n";} + +$x = length("abc") % -10; +print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; + +{ + use integer; + $x = length("abc") % -10; + $y = (3/-10)*-10; + print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; +} diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t index eec4611..def5a9e 100755 --- a/contrib/perl5/t/op/join.t +++ b/contrib/perl5/t/op/join.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: join.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:01 $ - -print "1..3\n"; +print "1..6\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} @@ -10,3 +8,15 @@ if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} if (join('',1,2,3) eq '123') {print "ok 2\n";} else {print "not ok 2\n";} if (join(':',split(/ /,"1 2 3")) eq '1:2:3') {print "ok 3\n";} else {print "not ok 3\n";} + +my $f = 'a'; +$f = join ',', 'b', $f, 'e'; +if ($f eq 'b,a,e') {print "ok 4\n";} else {print "# '$f'\nnot ok 4\n";} + +$f = 'a'; +$f = join ',', $f, 'b', 'e'; +if ($f eq 'a,b,e') {print "ok 5\n";} else {print "not ok 5\n";} + +$f = 'a'; +$f = join $f, 'b', 'e', 'k'; +if ($f eq 'baeak') {print "ok 6\n";} else {print "# '$f'\nnot ok 6\n";} diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t new file mode 100755 index 0000000..2fb059d --- /dev/null +++ b/contrib/perl5/t/op/lex_assign.t @@ -0,0 +1,324 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; + +umask 0; +$xref = \ ""; +$runme = ($^O eq 'VMS' ? 'MCR ' : '') . $^X; +@a = (1..5); +%h = (1..6); +$aref = \@a; +$href = \%h; +open OP, qq{$runme -le "print 'aaa Ok ok' for 1..100"|}; +$chopit = 'aaaaaa'; +@chopar = (113 .. 119); +$posstr = '123456'; +$cstr = 'aBcD.eF'; +pos $posstr = 3; +$nn = $n = 2; +sub subb {"in s"} + +@INPUT = <DATA>; +@simple_input = grep /^\s*\w+\s*\$\w+\s*[#\n]/, @INPUT; +print "1..", (10 + @INPUT + @simple_input), "\n"; +$ord = 0; + +sub wrn {"@_"} + +# Check correct optimization of ucfirst etc +$ord++; +my $a = "AB"; +my $b = "\u\L$a"; +print "not " unless $b eq 'Ab'; +print "ok $ord\n"; + +# Check correct destruction of objects: +my $dc = 0; +sub A::DESTROY {$dc += 1} +$a=8; +my $b; +{ my $c = 6; $b = bless \$c, "A"} + +$ord++; +print "not " unless $dc == 0; +print "ok $ord\n"; + +$b = $a+5; + +$ord++; +print "not " unless $dc == 1; +print "ok $ord\n"; + +$ord++; +my $xxx = 'b'; +$xxx = 'c' . ($xxx || 'e'); +print "not " unless $xxx eq 'cb'; +print "ok $ord\n"; + +{ # Check calling STORE + my $sc = 0; + sub B::TIESCALAR {bless [11], 'B'} + sub B::FETCH { -(shift->[0]) } + sub B::STORE { $sc++; my $o = shift; $o->[0] = 17 + shift } + + my $m; + tie $m, 'B'; + $m = 100; + + $ord++; + print "not " unless $sc == 1; + print "ok $ord\n"; + + my $t = 11; + $m = $t + 89; + + $ord++; + print "not " unless $sc == 2; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == -117; + print "ok $ord\n"; + + $m += $t; + + $ord++; + print "not " unless $sc == 3; + print "ok $ord\n"; + + $ord++; + print "# $m\nnot " unless $m == 89; + print "ok $ord\n"; + +} + +# Chains of assignments + +my ($l1, $l2, $l3, $l4); +my $zzzz = 12; +$zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 1 + $zzzz; + +$ord++; +print "# $zzz1 = $l1 = $l2 = $zzz2 = $l3 = $l4 = 13\nnot " + unless $zzz1 == 13 and $zzz2 == 13 and $l1 == 13 + and $l2 == 13 and $l3 == 13 and $l4 == 13; +print "ok $ord\n"; + +for (@INPUT) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + $op = "$op==$op" unless $op =~ /==/; + ($op, $expectop) = $op =~ /(.*)==(.*)/; + + $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) + ? "skip" : "not"; + $integer = ($comment =~ /^i_/) ? "use integer" : '' ; + (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; + + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$a = 'fake'; + $integer; + \$a = $op; + \$b = $expectop; + if (\$a ne \$b) { + print "# \$comment: got `\$a', expected `\$b'\n"; + print "\$skip " if \$a ne \$b or \$skip eq 'skip'; + } + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} + +for (@simple_input) { + $ord++; + ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; + $comment = $op unless defined $comment; + ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; + eval <<EOE; + local \$SIG{__WARN__} = \\&wrn; + my \$$variable = "Ac# Ca\\nxxx"; + \$$variable = $operator \$$variable; + \$toself = \$$variable; + \$direct = $operator "Ac# Ca\\nxxx"; + print "# \\\$$variable = $operator \\\$$variable\\nnot " + unless \$toself eq \$direct; + print "ok \$ord\\n"; +EOE + if ($@) { + if ($@ =~ /is unimplemented/) { + print "# skipping $comment: unimplemented:\nok $ord\n"; + } elsif ($@ =~ /Can't (modify|take log of 0)/) { + print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; + } else { + warn $@; + print "not ok $ord\n"; + } + } +} +__END__ +ref $xref # ref +ref $cstr # ref nonref +`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$undefed` # backtick undef skip(MSWin32) +<*> # glob +<OP> # readline +'faked' # rcatline +(@z = (1 .. 3)) # aassign +chop $chopit # chop +(chop (@x=@chopar)) # schop +chomp $chopit # chomp +(chop (@x=@chopar)) # schomp +pos $posstr # pos +pos $chopit # pos returns undef +$nn++==2 # postinc +$nn++==3 # i_postinc +$nn--==4 # postdec +$nn--==3 # i_postdec +$n ** $n # pow +$n * $n # multiply +$n * $n # i_multiply +$n / $n # divide +$n / $n # i_divide +$n % $n # modulo +$n % $n # i_modulo +$n x $n # repeat +$n + $n # add +$n + $n # i_add +$n - $n # subtract +$n - $n # i_subtract +$n . $n # concat +$n . $a=='2fake' # concat with self +"3$a"=='3fake' # concat with self in stringify +"$n" # stringify +$n << $n # left_shift +$n >> $n # right_shift +$n <=> $n # ncmp +$n <=> $n # i_ncmp +$n cmp $n # scmp +$n & $n # bit_and +$n ^ $n # bit_xor +$n | $n # bit_or +-$n # negate +-$n # i_negate +~$n # complement +atan2 $n,$n # atan2 +sin $n # sin +cos $n # cos +'???' # rand +exp $n # exp +log $n # log +sqrt $n # sqrt +int $n # int +hex $n # hex +oct $n # oct +abs $n # abs +length $posstr # length +substr $posstr, 2, 2 # substr +vec("abc",2,8) # vec +index $posstr, 2 # index +rindex $posstr, 2 # rindex +sprintf "%i%i", $n, $n # sprintf +ord $n # ord +chr $n # chr +crypt $n, $n # crypt +ucfirst ($cstr . "a") # ucfirst padtmp +ucfirst $cstr # ucfirst +lcfirst $cstr # lcfirst +uc $cstr # uc +lc $cstr # lc +quotemeta $cstr # quotemeta +@$aref # rv2av +@$undefed # rv2av undef +each %h==1 # each +values %h # values +keys %h # keys +%$href # rv2hv +pack "C2", $n,$n # pack +split /a/, "abad" # split +join "a"; @a # join +push @a,3==6 # push +unshift @aaa # unshift +reverse @a # reverse +reverse $cstr # reverse - scal +grep $_, 1,0,2,0,3 # grepwhile +map "x$_", 1,0,2,0,3 # mapwhile +subb() # entersub +caller # caller +warn "ignore this\n" # warn +'faked' # die +open BLAH, "<non-existent" # open +fileno STDERR # fileno +umask 0 # umask +select STDOUT # sselect +select "","","",0 # select +getc OP # getc +'???' # read +'???' # sysread +'???' # syswrite +'???' # send +'???' # recv +'???' # tell +'???' # fcntl +'???' # ioctl +'???' # flock +'???' # accept +'???' # shutdown +'???' # ftsize +'???' # ftmtime +'???' # ftatime +'???' # ftctime +chdir 'non-existent' # chdir +'???' # chown +'???' # chroot +unlink 'non-existent' # unlink +chmod 'non-existent' # chmod +utime 'non-existent' # utime +rename 'non-existent', 'non-existent1' # rename +link 'non-existent', 'non-existent1' # link +'???' # symlink +readlink 'non-existent', 'non-existent1' # readlink +'???' # mkdir +'???' # rmdir +'???' # telldir +'???' # fork +'???' # wait +'???' # waitpid +system "$runme -e 0" # system skip(VMS) +'???' # exec +'???' # kill +getppid # getppid +getpgrp # getpgrp +'???' # setpgrp +getpriority $$, $$ # getpriority +'???' # setpriority +time # time +localtime $^T # localtime +gmtime $^T # gmtime +sleep 1 # sleep +'???' # alarm +'???' # shmget +'???' # shmctl +'???' # shmread +'???' # shmwrite +'???' # msgget +'???' # msgctl +'???' # msgsnd +'???' # msgrcv +'???' # semget +'???' # semctl +'???' # semop +'???' # getlogin +'???' # syscall diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t new file mode 100755 index 0000000..e704f6f --- /dev/null +++ b/contrib/perl5/t/op/lfs.t @@ -0,0 +1,226 @@ +# NOTE: this file tests how large files (>2GB) work with perlio (stdio/sfio). +# sysopen(), sysseek(), syswrite(), sysread() are tested in t/lib/syslfs.t. +# If you modify/add tests here, remember to update also t/lib/syslfs.t. + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; + # Don't bother if there are no quad offsets. + require Config; import Config; + if ($Config{lseeksize} < 8) { + print "1..0\n# no 64-bit file offsets\n"; + exit(0); + } +} + +sub zap { + close(BIG); + unlink("big"); + unlink("big1"); + unlink("big2"); +} + +sub bye { + zap(); + exit(0); +} + +sub explain { + print <<EOM; +# +# If the lfs (large file support: large meaning larger than two gigabytes) +# tests are skipped or fail, it may mean either that your process +# (or process group) is not allowed to write large files (resource +# limits) or that the file system you are running the tests on doesn't +# let your user/group have large files (quota) or the filesystem simply +# doesn't support large files. You may even need to reconfigure your kernel. +# (This is all very operating system and site-dependent.) +# +# Perl may still be able to support large files, once you have +# such a process, enough quota, and such a (file) system. +# +EOM +} + +print "# checking whether we have sparse files...\n"; + +# Known have-nots. +if ($^O eq 'win32' || $^O eq 'vms') { + print "1..0\n# no sparse files (because this is $^O) \n"; + bye(); +} + +# Known haves that have problems running this test +# (for example because they do not support sparse files, like UNICOS) +if ($^O eq 'unicos') { + print "1..0\n# large files known to work but unable to test them here ($^O)\n"; + bye(); +} + +# Then try to heuristically deduce whether we have sparse files. + +# Let's not depend on Fcntl or any other extension. + +my ($SEEK_SET, $SEEK_CUR, $SEEK_END) = (0, 1, 2); + +# We'll start off by creating a one megabyte file which has +# only three "true" bytes. If we have sparseness, we should +# consume less blocks than one megabyte (assuming nobody has +# one megabyte blocks...) + +open(BIG, ">big1") or + do { warn "open big1 failed: $!\n"; bye }; +binmode(BIG) or + do { warn "binmode big1 failed: $!\n"; bye }; +seek(BIG, 1_000_000, $SEEK_SET) or + do { warn "seek big1 failed: $!\n"; bye }; +print BIG "big" or + do { warn "print big1 failed: $!\n"; bye }; +close(BIG) or + do { warn "close big1 failed: $!\n"; bye }; + +my @s1 = stat("big1"); + +print "# s1 = @s1\n"; + +open(BIG, ">big2") or + do { warn "open big2 failed: $!\n"; bye }; +binmode(BIG) or + do { warn "binmode big2 failed: $!\n"; bye }; +seek(BIG, 2_000_000, $SEEK_SET) or + do { warn "seek big2 failed; $!\n"; bye }; +print BIG "big" or + do { warn "print big2 failed; $!\n"; bye }; +close(BIG) or + do { warn "close big2 failed; $!\n"; bye }; + +my @s2 = stat("big2"); + +print "# s2 = @s2\n"; + +zap(); + +unless ($s1[7] == 1_000_003 && $s2[7] == 2_000_003 && + $s1[11] == $s2[11] && $s1[12] == $s2[12]) { + print "1..0\n#no sparse files?\n"; + bye; +} + +print "# we seem to have sparse files...\n"; + +# By now we better be sure that we do have sparse files: +# if we are not, the following will hog 5 gigabytes of disk. Ooops. + +$ENV{LC_ALL} = "C"; + +open(BIG, ">big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; +unless (seek(BIG, 5_000_000_000, $SEEK_SET)) { + print "1..0\n# seeking past 2GB failed: $!\n"; + explain(); + bye(); +} + +# Either the print or (more likely, thanks to buffering) the close will +# fail if there are are filesize limitations (process or fs). +my $print = print BIG "big"; +print "# print failed: $!\n" unless $print; +my $close = close BIG; +print "# close failed: $!\n" unless $close; +unless ($print && $close) { + if ($! =~/too large/i) { + print "1..0\n# writing past 2GB failed: process limits?\n"; + } elsif ($! =~ /quota/i) { + print "1..0\n# filesystem quota limits?\n"; + } + explain(); + bye(); +} + +@s = stat("big"); + +print "# @s\n"; + +unless ($s[7] == 5_000_000_003) { + print "1..0\n# not configured to use large files?\n"; + explain(); + bye(); +} + +sub fail () { + print "not "; + $fail++; +} + +print "1..17\n"; + +my $fail = 0; + +fail unless $s[7] == 5_000_000_003; # exercizes pp_stat +print "ok 1\n"; + +fail unless -s "big" == 5_000_000_003; # exercizes pp_ftsize +print "ok 2\n"; + +fail unless -e "big"; +print "ok 3\n"; + +fail unless -f "big"; +print "ok 4\n"; + +open(BIG, "big") or do { warn "open failed: $!\n"; bye }; +binmode BIG; + +fail unless seek(BIG, 4_500_000_000, $SEEK_SET); +print "ok 5\n"; + +fail unless tell(BIG) == 4_500_000_000; +print "ok 6\n"; + +fail unless seek(BIG, 1, $SEEK_CUR); +print "ok 7\n"; + +fail unless tell(BIG) == 4_500_000_001; +print "ok 8\n"; + +fail unless seek(BIG, -1, $SEEK_CUR); +print "ok 9\n"; + +fail unless tell(BIG) == 4_500_000_000; +print "ok 10\n"; + +fail unless seek(BIG, -3, $SEEK_END); +print "ok 11\n"; + +fail unless tell(BIG) == 5_000_000_000; +print "ok 12\n"; + +my $big; + +fail unless read(BIG, $big, 3) == 3; +print "ok 13\n"; + +fail unless $big eq "big"; +print "ok 14\n"; + +# 705_032_704 = (I32)5_000_000_000 +fail unless seek(BIG, 705_032_704, $SEEK_SET); +print "ok 15\n"; + +my $zero; + +fail unless read(BIG, $zero, 3) == 3; +print "ok 16\n"; + +fail unless $zero eq "\0\0\0"; +print "ok 17\n"; + +explain if $fail; + +bye(); # does the necessary cleanup + +END { + unlink "big"; # be paranoid about leaving 5 gig files lying around +} + +# eof diff --git a/contrib/perl5/t/op/list.t b/contrib/perl5/t/op/list.t index a4230b6..4d7a2d5 100755 --- a/contrib/perl5/t/op/list.t +++ b/contrib/perl5/t/op/list.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: list.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:02 $ - -print "1..27\n"; +print "1..28\n"; @foo = (1, 2, 3, 4); if ($foo[0] == 1 && $foo[3] == 4) {print "ok 1\n";} else {print "not ok 1\n";} @@ -81,3 +79,11 @@ for ($x = 0; $x < 3; $x++) { print $a,$b,$c; } +# slices +{ + my @a = (0, undef, undef, 3); + my @b = @a[1,2]; + my @c = (0, undef, undef, 3)[1, 2]; + print "not " unless @b == @c and @c == 2; + print "ok 28\n"; +} diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t new file mode 100755 index 0000000..f15201f --- /dev/null +++ b/contrib/perl5/t/op/lop.t @@ -0,0 +1,44 @@ +#!./perl + +# +# test the logical operators '&&', '||', '!', 'and', 'or', 'not' +# + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..7\n"; + +my $test = 0; +for my $i (undef, 0 .. 2, "", "0 but true") { + my $true = 1; + my $false = 0; + for my $j (undef, 0 .. 2, "", "0 but true") { + $true &&= !( + ((!$i || !$j) != !($i && $j)) + or (!($i || $j) != (!$i && !$j)) + or (!!($i || $j) != !(!$i && !$j)) + or (!(!$i || !$j) != !!($i && $j)) + ); + $false ||= ( + ((!$i || !$j) == !!($i && $j)) + and (!!($i || $j) == (!$i && !$j)) + and ((!$i || $j) == ($i && !$j)) + and (($i || !$j) != (!$i && $j)) + ); + } + if (not $true) { + print "not "; + } elsif ($false) { + print "not "; + } + print "ok ", ++$test, "\n"; +} + +# $test == 6 +my $i = 0; +(($i ||= 1) &&= 3) += 4; +print "not " unless $i == 7; +print "ok ", ++$test, "\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t index 7f08e06..7739276 100755 --- a/contrib/perl5/t/op/magic.t +++ b/contrib/perl5/t/op/magic.t @@ -1,13 +1,14 @@ #!./perl BEGIN { - $^W = 1; $| = 1; chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } +use warnings; + sub ok { my ($n, $result, $info) = @_; if ($result) { @@ -22,6 +23,8 @@ sub ok { $Is_MSWin32 = $^O eq 'MSWin32'; $Is_VMS = $^O eq 'VMS'; $Is_Dos = $^O eq 'dos'; +$Is_os2 = $^O eq 'os2'; +$Is_Cygwin = $^O eq 'cygwin'; $PERL = ($Is_MSWin32 ? '.\perl' : './perl'); print "1..35\n"; @@ -111,6 +114,14 @@ ok 18, $$ > 0, $$; if ($^O eq 'qnx') { chomp($wd = `/usr/bin/fullpath -t`); } + elsif($Is_Cygwin) { + # Cygwin turns the symlink into the real file + chomp($wd = `pwd`); + $wd =~ s#/t$##; + } + elsif($Is_os2) { + $wd = Cwd::sys_cwd(); + } else { $wd = '.'; } @@ -120,8 +131,9 @@ ok 18, $$ > 0, $$; $script = "$wd/show-shebang"; if ($Is_MSWin32) { chomp($wd = `cd`); - $perl = "$wd\\perl.exe"; - $script = "$wd\\show-shebang.bat"; + $wd =~ s|\\|/|g; + $perl = "$wd/perl.exe"; + $script = "$wd/show-shebang.bat"; $headmaybe = <<EOH ; \@rem =' \@echo off @@ -135,13 +147,16 @@ __END__ :endofperl EOT } - if ($^O eq 'os390') { # no shebang + elsif ($Is_os2) { + $script = "./show-shebang"; + } + if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang $headmaybe = <<EOH ; eval 'exec ./perl -S \$0 \${1+"\$\@"}' if 0; EOH } - $s1 = $s2 = "\$^X is $perl, \$0 is $script\n"; + $s1 = "\$^X is $perl, \$0 is $script\n"; ok 19, open(SCRIPT, ">$script"), $!; ok 20, print(SCRIPT $headmaybe . <<EOB . <<'EOF' . $tailmaybe), $!; #!$wd/perl @@ -151,13 +166,15 @@ EOF ok 21, close(SCRIPT), $!; ok 22, chmod(0755, $script), $!; $_ = `$script`; - s/.exe//i if $Is_Dos; + s/\.exe//i if $Is_Dos or $Is_Cygwin or $Is_os2; s{\bminiperl\b}{perl}; # so that test doesn't fail with miniperl s{is perl}{is $perl}; # for systems where $^X is only a basename - ok 23, ($Is_MSWin32 ? uc($_) eq uc($s2) : $_ eq $s2), ":$_:!=:$s2:"; + s{\\}{/}g; + ok 23, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1:"; $_ = `$perl $script`; - s/.exe//i if $Is_Dos; - ok 24, ($Is_MSWin32 ? uc($_) eq uc($s1) : $_ eq $s1), ":$_:!=:$s1: after `$perl $script`"; + s/\.exe//i if $Is_Dos or $Is_os2; + s{\\}{/}g; + ok 24, (($Is_MSWin32 || $Is_os2) ? uc($_) eq uc($s1) : $_ eq $s1), " :$_:!=:$s1: after `$perl $script`"; ok 25, unlink($script), $!; } @@ -185,7 +202,7 @@ else { } { - local $SIG{'__WARN__'} = sub { print "not " }; + local $SIG{'__WARN__'} = sub { print "# @_\nnot " }; $! = undef; print "ok 31\n"; } @@ -202,8 +219,8 @@ if ($Is_MSWin32) { ok 35, (scalar(keys(%ENV)) == 0); } else { - ok "32 # skipped",1; - ok "33 # skipped",1; - ok "34 # skipped",1; - ok "35 # skipped",1; + ok "32 # skipped: no caseless %ENV support",1; + ok "33 # skipped: no caseless %ENV support",1; + ok "34 # skipped: no caseless %ENV support",1; + ok "35 # skipped: no caseless %ENV support",1; } diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t index f1b1888..1c6f3c5 100755 --- a/contrib/perl5/t/op/method.t +++ b/contrib/perl5/t/op/method.t @@ -4,7 +4,7 @@ # test method calls and autoloading. # -print "1..26\n"; +print "1..49\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -19,6 +19,35 @@ sub test { print "ok ", ++$cnt, "\n" } +# First, some basic checks of method-calling syntax: +$obj = bless [], "Pack"; +sub Pack::method { shift; join(",", "method", @_) } +$mname = "method"; + +test(Pack->method("a","b","c"), "method,a,b,c"); +test(Pack->$mname("a","b","c"), "method,a,b,c"); +test(method Pack ("a","b","c"), "method,a,b,c"); +test((method Pack "a","b","c"), "method,a,b,c"); + +test(Pack->method(), "method"); +test(Pack->$mname(), "method"); +test(method Pack (), "method"); +test(Pack->method, "method"); +test(Pack->$mname, "method"); +test(method Pack, "method"); + +test($obj->method("a","b","c"), "method,a,b,c"); +test($obj->$mname("a","b","c"), "method,a,b,c"); +test((method $obj ("a","b","c")), "method,a,b,c"); +test((method $obj "a","b","c"), "method,a,b,c"); + +test($obj->method(), "method"); +test($obj->$mname(), "method"); +test((method $obj ()), "method"); +test($obj->method, "method"); +test($obj->$mname, "method"); +test(method $obj, "method"); + test( A->d, "C::d"); # Update hash table; *B::d = \&D::d; # Import now. @@ -126,3 +155,15 @@ test(A->eee(), "new B: In A::eee, 4"); # Which sticks # this test added due to bug discovery test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); + +# test that failed subroutine calls don't affect method calls +{ + package A1; + sub foo { "foo" } + package A2; + @ISA = 'A1'; + package main; + test(A2->foo(), "foo"); + test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); + test(A2->foo(), "foo"); +} diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index c9050ef..ac1a44f 100755 --- a/contrib/perl5/t/op/misc.t +++ b/contrib/perl5/t/op/misc.t @@ -4,7 +4,7 @@ # separate executable and can't simply use eval. chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -25,22 +25,25 @@ for (@prgs){ $switch = $1; } my($prog,$expected) = split(/\nEXPECT\n/, $_); + open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + print TEST $prog, "\n"; + close TEST or die "Cannot close $tmpfile: $!"; + if ($^O eq 'MSWin32') { - open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1"; + $results = `.\\perl -I../lib $switch $tmpfile 2>&1`; } else { - open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1"; + $results = `./perl $switch $tmpfile 2>&1`; } - print TEST $prog, "\n"; - close TEST; $status = $?; - $results = `$CAT $tmpfile`; $results =~ s/\n+$//; + $results =~ s/at\s+misctmp\d+\s+line/at - line/g; + $results =~ s/of\s+misctmp\d+\s+aborted/of - aborted/g; # 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){ + if ( $results ne $expected ) { print STDERR "PROG: $switch\n$prog\n"; print STDERR "EXPECTED:\n$expected\n"; print STDERR "GOT:\n$results\n"; @@ -56,11 +59,12 @@ $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## +use integer; $cusp = ~0 ^ (~0 >> 1); $, = " "; print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; EXPECT -7 0 0 1 ! +-1 0 0 1 ! ######## $foo=undef; $foo->go; EXPECT @@ -77,7 +81,7 @@ $x=0x0eabcd; print $x->ref; EXPECT Can't call method "ref" without a package or object reference at - line 1. ######## -chop ($str .= <STDIN>); +chop ($str .= <DATA>); ######## close ($banana); ######## @@ -89,7 +93,7 @@ eval {sub bar {print "In bar";}} ######## system './perl -ne "print if eof" /dev/null' ######## -chop($file = <>); +chop($file = <DATA>); ######## package N; sub new {my ($obj,$n)=@_; bless \$n} @@ -101,7 +105,7 @@ EXPECT ######## %@x=0; EXPECT -Can't modify hash deref in repeat at - line 1, near "0;" +Can't modify hash dereference in repeat (x) at - line 1, near "0;" Execution of - aborted due to compilation errors. ######## $_="foo"; @@ -346,20 +350,22 @@ Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern ######## /(?{"{"}})/ # Check it outside of eval too EXPECT -Unmatched right bracket at (re_eval 1) line 1, at end of line +Unmatched right curly bracket at (re_eval 1) line 1, at end of line syntax error at (re_eval 1) line 1, near ""{"}" Compilation failed in regexp at - line 1. ######## -BEGIN { @ARGV = qw(a b c) } +BEGIN { @ARGV = qw(a b c d e) } BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" } END { print "end <",shift,">\nargv <@ARGV>\n" } INIT { print "init <",shift,">\n" } +CHECK { print "check <",shift,">\n" } EXPECT -argv <a b c> +argv <a b c d e> begin <a> -init <b> -end <c> -argv <> +check <b> +init <c> +end <d> +argv <e> ######## -l # fdopen from a system descriptor to a system descriptor used to close @@ -433,6 +439,54 @@ foo bar BEGIN failed--compilation aborted at - line 8. ######## +package X; +@ISA='Y'; +sub new { + my $class = shift; + my $self = { }; + bless $self, $class; + my $init = shift; + $self->foo($init); + print "new", $init; + return $self; +} +sub DESTROY { + my $self = shift; + print "DESTROY", $self->foo; +} +package Y; +sub attribute { + my $self = shift; + my $var = shift; + if (@_ == 0) { + return $self->{$var}; + } elsif (@_ == 1) { + $self->{$var} = shift; + } +} +sub AUTOLOAD { + $AUTOLOAD =~ /::([^:]+)$/; + my $method = $1; + splice @_, 1, 0, $method; + goto &attribute; +} +package main; +my $x = X->new(1); +for (2..3) { + my $y = X->new($_); + print $y->foo; +} +print $x->foo; +EXPECT +new1new22DESTROY2new33DESTROY31DESTROY1 +######## +re(); +sub re { + my $re = join '', eval 'qr/(??{ $obj->method })/'; + $re; +} +EXPECT +######## use strict; my $foo = "ZZZ\n"; END { print $foo } @@ -446,3 +500,48 @@ END { print $foo } '; EXPECT ZZZ +######## +-w +if (@ARGV) { print "" } +else { + if ($x == 0) { print "" } else { print $x } +} +EXPECT +Use of uninitialized value in numeric eq (==) at - line 4. +######## +$x = sub {}; +foo(); +sub foo { eval { return }; } +print "ok\n"; +EXPECT +ok +######## +my @l = qw(hello.* world); +my $x; + +foreach $x (@l) { + print "before - $x\n"; + $x = "\Q$x\E"; + print "quotemeta - $x\n"; + $x = "\u$x"; + print "ucfirst - $x\n"; + $x = "\l$x"; + print "lcfirst - $x\n"; + $x = "\U$x\E"; + print "uc - $x\n"; + $x = "\L$x\E"; + print "lc - $x\n"; +} +EXPECT +before - hello.* +quotemeta - hello\.\* +ucfirst - Hello\.\* +lcfirst - hello\.\* +uc - HELLO\.\* +lc - hello\.\* +before - world +quotemeta - world +ucfirst - World +lcfirst - world +uc - WORLD +lc - world diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index acf16c1..cf8e55d 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -1,18 +1,25 @@ #!./perl -# $RCSfile: mkdir.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:06 $ +print "1..9\n"; -print "1..7\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} -$^O eq 'MSWin32' ? `del /s /q blurfl 2>&1` : `rm -rf blurfl`; +use File::Path; +rmtree('blurfl'); # tests 3 and 7 rather naughtily expect English error messages $ENV{'LC_ALL'} = 'C'; +$ENV{LANGUAGE} = 'C'; # GNU locale extension print (mkdir('blurfl',0777) ? "ok 1\n" : "not ok 1\n"); print (mkdir('blurfl',0777) ? "not ok 2\n" : "ok 2\n"); -print ($! =~ /exist|denied/ ? "ok 3\n" : "# $!\nnot ok 3\n"); +print ($! =~ /cannot move|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|not found/i ? "ok 7\n" : "not ok 7\n"); +print ($! =~ /cannot find|such|exist|not found/i ? "ok 7\n" : "# $!\nnot ok 7\n"); +print (mkdir('blurfl') ? "ok 8\n" : "not ok 8\n"); +print (rmdir('blurfl') ? "ok 9\n" : "not ok 9\n"); diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t new file mode 100755 index 0000000..fd36e2e --- /dev/null +++ b/contrib/perl5/t/op/nothr5005.t @@ -0,0 +1,35 @@ +#!./perl + +# NOTE: Please don't add tests to this file unless they *need* to be run in +# separate executable and can't simply use eval. + +BEGIN + { + chdir 't' if -d 't'; + unshift @INC, "../lib"; + require Config; + import Config; + if ($Config{'use5005threads'}) + { + print "1..0 # Skip: this perl is threaded\n"; + exit 0; + } + } + + +$|=1; + +print "1..9\n"; +$t = 1; +sub foo { local(@_) = ('p', 'q', 'r'); } +sub bar { unshift @_, 'D'; @_ } +sub baz { push @_, 'E'; return @_ } +for (1..3) + { + print "not " unless join('',foo('a', 'b', 'c')) eq 'pqr'; + print "ok ",$t++,"\n"; + print "not" unless join('',bar('d')) eq 'Dd'; + print "ok ",$t++,"\n"; + print "not" unless join('',baz('e')) eq 'eE'; + print "ok ",$t++,"\n"; + } diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t new file mode 100755 index 0000000..8eb9b6e --- /dev/null +++ b/contrib/perl5/t/op/numconvert.t @@ -0,0 +1,186 @@ +#!./perl + +# +# test the conversion operators +# +# Notations: +# +# "N p i N vs N N": Apply op-N, then op-p, then op-i, then reporter-N +# Compare with application of op-N, then reporter-N +# Right below are descriptions of different ops and reporters. + +# We do not use these subroutines any more, sub overhead makes a "switch" +# solution better: + +# obviously, 0, 1 and 2, 3 are destructive. (XXXX 64-bit? 4 destructive too) + +# *0 = sub {--$_[0]}; # - +# *1 = sub {++$_[0]}; # + + +# # Converters +# *2 = sub { $_[0] = $max_uv & $_[0]}; # U +# *3 = sub { use integer; $_[0] += $zero}; # I +# *4 = sub { $_[0] += $zero}; # N +# *5 = sub { $_[0] = "$_[0]" }; # P + +# # Side effects +# *6 = sub { $max_uv & $_[0]}; # u +# *7 = sub { use integer; $_[0] + $zero}; # i +# *8 = sub { $_[0] + $zero}; # n +# *9 = sub { $_[0] . "" }; # p + +# # Reporters +# sub a2 { sprintf "%u", $_[0] } # U +# sub a3 { sprintf "%d", $_[0] } # I +# sub a4 { sprintf "%g", $_[0] } # N +# sub a5 { "$_[0]" } # P + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict 'vars'; + +my $max_chain = $ENV{PERL_TEST_NUMCONVERTS} || 2; + +# Bulk out if unsigned type is hopelessly wrong: +my $max_uv1 = ~0; +my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here +my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here + +print "# max_uv1 = $max_uv1, max_uv2 = $max_uv2, big_iv = $big_iv\n"; +if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) { + print "1..0\n# Unsigned arithmetic is not sane\n"; + exit 0; +} + +my $st_t = 4*4; # We try 4 initializers and 4 reporters + +my $num = 0; +$num += 10**$_ - 4**$_ for 1.. $max_chain; +$num *= $st_t; +print "1..$num\n"; # In fact 15 times more subsubtests... + +my $max_uv = ~0; +my $max_iv = int($max_uv/2); +my $zero = 0; + +my $l_uv = length $max_uv; +my $l_iv = length $max_iv; + +# Hope: the first digits are good +my $larger_than_uv = substr 97 x 100, 0, $l_uv; +my $smaller_than_iv = substr 12 x 100, 0, $l_iv; +my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1); + +my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1, + $max_uv, $max_uv + 1); +unshift @list, (reverse map -$_, @list), 0; # 15 elts +@list = map "$_", @list; # Normalize + +# print "@list\n"; + + +my @opnames = split //, "-+UINPuinp"; + +# @list = map { 2->($_), 3->($_), 4->($_), 5->($_), } @list; # Prepare input + +#print "@list\n"; +#print "'@ops'\n"; + +my $test = 1; +my $nok; +for my $num_chain (1..$max_chain) { + my @ops = map [split //], grep /[4-9]/, + map { sprintf "%0${num_chain}d", $_ } 0 .. 10**$num_chain - 1; + + #@ops = ([]) unless $num_chain; + #@ops = ([6, 4]); + + # print "'@ops'\n"; + for my $op (@ops) { + for my $first (2..5) { + for my $last (2..5) { + $nok = 0; + my @otherops = grep $_ <= 3, @$op; + my @curops = ($op,\@otherops); + + for my $num (@list) { + my $inpt; + my @ans; + + for my $short (0, 1) { + # undef $inpt; # Forget all we had - some bugs were masked + + $inpt = $num; # Try to not contaminate $num... + $inpt = "$inpt"; + if ($first == 2) { + $inpt = $max_uv & $inpt; # U 2 + } elsif ($first == 3) { + use integer; $inpt += $zero; # I 3 + } elsif ($first == 4) { + $inpt += $zero; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + + # Saves 20% of time - not with this logic: + #my $tmp = $inpt; + #my $tmp1 = $num; + #next if $num_chain > 1 + # and "$tmp" ne "$tmp1"; # Already the coercion gives problems... + + for my $curop (@{$curops[$short]}) { + if ($curop < 5) { + if ($curop < 3) { + if ($curop == 0) { + --$inpt; # - 0 + } elsif ($curop == 1) { + ++$inpt; # + 1 + } else { + $inpt = $max_uv & $inpt; # U 2 + } + } elsif ($curop == 3) { + use integer; $inpt += $zero; + } else { + $inpt += $zero; # N 4 + } + } elsif ($curop < 8) { + if ($curop == 5) { + $inpt = "$inpt"; # P 5 + } elsif ($curop == 6) { + $max_uv & $inpt; # u 6 + } else { + use integer; $inpt + $zero; + } + } elsif ($curop == 8) { + $inpt + $zero; # n 8 + } else { + $inpt . ""; # p 9 + } + } + + if ($last == 2) { + $inpt = sprintf "%u", $inpt; # U 2 + } elsif ($last == 3) { + $inpt = sprintf "%d", $inpt; # I 3 + } elsif ($last == 4) { + $inpt = sprintf "%g", $inpt; # N 4 + } else { + $inpt = "$inpt"; # P 5 + } + push @ans, $inpt; + } + $nok++, + print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n" + if $ans[0] ne $ans[1]; + } + print "not " if $nok; + print "ok $test\n"; + #print $txt if $nok; + $test++; + } + } + } +} diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 6623089..27ac5aa 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,13 +1,53 @@ #!./perl -print "1..9\n"; - -print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n"; -print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n"; -print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 3\n"; -print +(oct('20000000000') == 020000000000) ? "ok" : "not ok", " 4\n"; -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"; +print "1..36\n"; + +print +(oct('0b10101') == 0b10101) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10101') == 025) ? "ok" : "not ok", " 2\n"; +print +(oct('0b10101') == 21) ? "ok" : "not ok", " 3\n"; +print +(oct('0b10101') == 0x15) ? "ok" : "not ok", " 4\n"; + +print +(oct('b10101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b10101') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b10101') == 0x15) ? "ok" : "not ok", " 8\n"; + +print +(oct('01234') == 0b1010011100) ? "ok" : "not ok", " 9\n"; +print +(oct('01234') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('01234') == 668) ? "ok" : "not ok", " 11\n"; +print +(oct('01234') == 0x29c) ? "ok" : "not ok", " 12\n"; + +print +(oct('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x1234') == 011064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x1234') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 16\n"; + +print +(oct('x1234') == 0b1001000110100) ? "ok" : "not ok", " 17\n"; +print +(oct('x1234') == 011064) ? "ok" : "not ok", " 18\n"; +print +(oct('x1234') == 4660) ? "ok" : "not ok", " 19\n"; +print +(oct('x1234') == 0x1234) ? "ok" : "not ok", " 20\n"; + +print +(hex('01234') == 0b1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('01234') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('01234') == 4660) ? "ok" : "not ok", " 23\n"; +print +(hex('01234') == 0x1234) ? "ok" : "not ok", " 24\n"; + +print +(hex('0x1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; +print +(hex('0x1234') == 011064) ? "ok" : "not ok", " 26\n"; +print +(hex('0x1234') == 4660) ? "ok" : "not ok", " 27\n"; +print +(hex('0x1234') == 0x1234) ? "ok" : "not ok", " 28\n"; + +print +(hex('x1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; +print +(hex('x1234') == 011064) ? "ok" : "not ok", " 30\n"; +print +(hex('x1234') == 4660) ? "ok" : "not ok", " 31\n"; +print +(hex('x1234') == 0x1234) ? "ok" : "not ok", " 32\n"; + +print +(oct('0b11111111111111111111111111111111') == 4294967295) ? + "ok" : "not ok", " 33\n"; +print +(oct('037777777777') == 4294967295) ? + "ok" : "not ok", " 34\n"; +print +(oct('0xffffffff') == 4294967295) ? + "ok" : "not ok", " 35\n"; + +print +(hex('0xffffffff') == 4294967295) ? + "ok" : "not ok", " 36\n"; diff --git a/contrib/perl5/t/op/ord.t b/contrib/perl5/t/op/ord.t index ba943f4..22ff3af 100755 --- a/contrib/perl5/t/op/ord.t +++ b/contrib/perl5/t/op/ord.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: ord.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:09 $ - -print "1..3\n"; +print "1..5\n"; # compile time evaluation @@ -10,9 +8,16 @@ print "1..3\n"; # 193 EBCDIC if (ord('A') == 65 || ord('A') == 193) {print "ok 1\n";} else {print "not ok 1\n";} +print "not " unless ord(chr(500)) == 500; +print "ok 2\n"; + # run time evaluation $x = 'ABC'; -if (ord($x) == 65 || ord($x) == 193) {print "ok 2\n";} else {print "not ok 2\n";} +if (ord($x) == 65 || ord($x) == 193) {print "ok 3\n";} else {print "not ok 3\n";} + +if (chr 65 eq 'A' || chr 193 eq 'A') {print "ok 4\n";} else {print "not ok 4\n";} -if (chr 65 == 'A' || chr 193 == 'A') {print "ok 3\n";} else {print "not ok 3\n";} +$x = 500; +print "not " unless ord(chr($x)) == $x; +print "ok 5\n"; diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index 902fc28..b336cb5 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -6,7 +6,7 @@ BEGIN { require Config; import Config; } -print "1..142\n"; +print "1..156\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 @@ -19,7 +19,10 @@ print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); $out1=join(':',@ary); $out2=join(':',@ary2); -print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n"); +# Using long double NVs may introduce greater accuracy than wanted. +$out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; +$out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; +print ($out1 eq $out2? "ok 2\n" : "not ok 2\n"); print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); @@ -95,7 +98,7 @@ print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); # temps sub foo { my $a = "a"; return $a . $a++ . $a++ } { - local $^W = 1; + use warnings; my $last = $test; local $SIG{__WARN__} = sub { print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ @@ -208,7 +211,7 @@ EOUU print "not " unless unpack('u', $uu) eq $in; print "ok ", $test++, "\n"; -# 61..72: test the ascii template types (A, a, Z) +# 61..73: test the ascii template types (A, a, Z) print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; print "ok ", $test++, "\n"; @@ -234,115 +237,116 @@ 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 "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 \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 pack('Z3', "foo") eq "fo\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 +# 74..79: 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 "not " unless length(pack("s!", 0)) == $Config{shortsize}; print "ok ", $test++, "\n"; -#print "not " unless length(pack("i!", 0)) == $Config{intsize}; +print "not " unless length(pack("i!", 0)) == $Config{intsize}; print "ok ", $test++, "\n"; -#print "not " unless length(pack("l!", 0)) == $Config{longsize}; +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 "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 "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 "not " unless length(pack("i!", 0)) == length(pack("i", 0)); print "ok ", $test++, "\n"; -# 79..138: pack <-> unpack bijectionism +# 80..139: pack <-> unpack bijectionism -# 79.. 83 c +# 80.. 84 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 +# 85.. 89: 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 +# 90.. 94: 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 +# 95.. 99: 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 +# 100..104: 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 +# 105..109: 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 +# 110..114: 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 +# 115..119: 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 +# 120..124: 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 +# 125..129: 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 +# 130..134: 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 +# 135..139: 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 +# 140..143: pack nvNV byteorders print "not " unless pack("n", 0xdead) eq "\xde\xad"; print "ok ", $test++, "\n"; @@ -355,3 +359,49 @@ print "ok ", $test++, "\n"; print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; print "ok ", $test++, "\n"; + +# 144..152: / + +my $z; +eval { ($x) = unpack '/a*','hello' }; +print 'not ' unless $@; print "ok $test\n"; $test++; +eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; +print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; + +eval { ($x) = pack '/a*','hello' }; +print 'not ' unless $@; print "ok $test\n"; $test++; +$z = pack 'n/a* w/A*','string','etc'; +print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' }; +print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; +$test++; + +eval { ($x) = unpack 'a/a*/a*', '3012ab345678901234567' }; +print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "not ok $test\n"; +$test++; + +eval { ($x) = unpack 'a/a*/b*', '212ab' }; +my $expected_x = '100001100100'; +if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; } +print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n"; +$test++; + +# 153..156: / with # + +eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; + a3/A # Count in ASCII + C/a* # Count in a C char + C/Z # Count in a C char but skip after \0 +EOU +print $@ eq '' && $z eq 'ok' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $x eq 'yes' ? "ok $test\n" : "not ok $test\n"; $test++; +print $@ eq '' && $y eq 'z' ? "ok $test\n" : "not ok $test\n"; $test++; + +$z = pack <<EOP,'string','etc'; + n/a* # Count as network short + w/A* # Count a BER integer +EOP +print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index ed8c778..188a3a3 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,11 +4,11 @@ # 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..142\n"; +print "1..211\n"; BEGIN { chdir 't' if -d 't'; - @INC = "../lib" if -d "../lib"; + unshift @INC, "../lib" if -d "../lib"; } eval 'use Config'; # Defaults assumed if this fails @@ -282,14 +282,7 @@ eval qq("${context}y" =~ /(?<=$context)y/); print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; print "ok 71\n"; -# This one will fail when POSIX character classes do get implemented -{ - my $w; - local $^W = 1; - local $SIG{__WARN__} = sub{$w = shift}; - eval q('a' =~ /[[:alpha:]]/); - print "not " if $w !~ /^\QCharacter class syntax [: :] is reserved/; -} +# removed test print "ok 72\n"; # Long Monsters @@ -363,6 +356,7 @@ sub matchit { /xg; } +@ans = (); push @ans, $res while $res = matchit; print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; @@ -375,6 +369,30 @@ print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; print "ok $test\n"; $test++; +print "not " unless "abc" =~ /^(??{"a"})b/; +print "ok $test\n"; +$test++; + +my $matched; +$matched = qr/\((?:(?>[^()]+)|(??{$matched}))*\)/; + +@ans = @ans1 = (); +push(@ans, $res), push(@ans1, $&) while $res = m/$matched/g; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne "1 1 1"; +print "ok $test\n"; +$test++; + +print "# ans1='@ans1'\n# expect='$expect'\nnot " if "@ans1" ne $expect; +print "ok $test\n"; +$test++; + +@ans = m/$matched/g; + +print "# ans='@ans'\n# expect='$expect'\nnot " if "@ans" ne $expect; +print "ok $test\n"; +$test++; + @ans = ('a/b' =~ m%(.*/)?(.*)%); # Stack may be bad print "not " if "@ans" ne 'a/ b'; print "ok $test\n"; @@ -555,8 +573,8 @@ sub must_warn_pat { sub must_warn { my ($warn_pat, $code) = @_; - local $^W; local %SIG; - eval 'BEGIN { $^W = 1; $SIG{__WARN__} = $warn_pat };' . $code; + local %SIG; + eval 'BEGIN { use warnings; $SIG{__WARN__} = $warn_pat };' . $code; print "ok $test\n"; $test++; } @@ -595,8 +613,385 @@ print "not " if @_; print "ok $test\n"; $test++; +/a(?=.$)/; +print "not " if $#+ != 0 or $#- != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 2 or $-[0] != 1; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[1] or defined $-[1] or defined $+[2] or defined $-[2]; +print "ok $test\n"; +$test++; + +/a(a)(a)/; +print "not " if $#+ != 2 or $#- != 2; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 3 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[2] != 3 or $-[2] != 2; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[3] or defined $-[3] or defined $+[4] or defined $-[4]; +print "ok $test\n"; +$test++; + +/.(a)(b)?(a)/; +print "not " if $#+ != 3 or $#- != 3; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 3 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[3] != 3 or $-[3] != 2; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[2] or defined $-[2] or defined $+[4] or defined $-[4]; +print "ok $test\n"; +$test++; + +/.(a)/; +print "not " if $#+ != 1 or $#- != 1; +print "ok $test\n"; +$test++; + +print "not " if $+[0] != 2 or $-[0] != 0; +print "ok $test\n"; +$test++; + +print "not " if $+[1] != 2 or $-[1] != 1; +print "ok $test\n"; +$test++; + +print "not " + if defined $+[2] or defined $-[2] or defined $+[3] or defined $-[3]; +print "ok $test\n"; +$test++; + +/.(a)(ba*)?/; +print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; +print "ok $test\n"; +$test++; + +$_ = 'aaa'; +pos = 1; +@a = /\Ga/g; +print "not " unless "@a" eq "a a"; +print "ok $test\n"; +$test++; + +$str = 'abcde'; +pos $str = 2; + +print "not " if $str =~ /^\G/; +print "ok $test\n"; +$test++; + +print "not " if $str =~ /^.\G/; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /^..\G/; +print "ok $test\n"; +$test++; + +print "not " if $str =~ /^...\G/; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /.\G./ and $& eq 'bc'; +print "ok $test\n"; +$test++; + +print "not " unless $str =~ /\G../ and $& eq 'cd'; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless $str =~ /b(?{$foo = $_; $bar = pos})c/ + and $foo eq 'abcde' and $bar eq 2; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +pos $str = undef; +print "#'$str','$foo','$bar'\nnot " + unless $str =~ /b(?{$foo = $_; $bar = pos})c/g + and $foo eq 'abcde' and $bar eq 2 and pos $str eq 3; +print "ok $test\n"; +$test++; + +$_ = $str; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless /b(?{$foo = $_; $bar = pos})c/ + and $foo eq 'abcde' and $bar eq 2; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +print "#'$str','$foo','$bar'\nnot " + unless /b(?{$foo = $_; $bar = pos})c/g + and $foo eq 'abcde' and $bar eq 2 and pos eq 3; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +pos = undef; +1 while /b(?{$foo = $_; $bar = pos})c/g; +print "#'$str','$foo','$bar'\nnot " + unless $foo eq 'abcde' and $bar eq 2 and not defined pos; +print "ok $test\n"; +$test++; + +undef $foo; undef $bar; +$_ = 'abcde|abcde'; +print "#'$str','$foo','$bar','$_'\nnot " + unless s/b(?{$foo = $_; $bar = pos})c/x/g and $foo eq 'abcde|abcde' + and $bar eq 8 and $_ eq 'axde|axde'; +print "ok $test\n"; +$test++; + +@res = (); +# List context: +$_ = 'abcde|abcde'; +@dummy = /([ace]).(?{push @res, $1,$2})([ce])(?{push @res, $1,$2})/g; +@res = map {defined $_ ? "'$_'" : 'undef'} @res; +$res = "@res"; +print "#'@res' '$_'\nnot " + unless "@res" eq "'a' undef 'a' 'c' 'e' undef 'a' undef 'a' 'c'"; +print "ok $test\n"; +$test++; + +@res = (); +@dummy = /([ace]).(?{push @res, $`,$&,$'})([ce])(?{push @res, $`,$&,$'})/g; +@res = map {defined $_ ? "'$_'" : 'undef'} @res; +$res = "@res"; +print "#'@res' '$_'\nnot " + unless "@res" eq + "'' 'ab' 'cde|abcde' " . + "'' 'abc' 'de|abcde' " . + "'abcd' 'e|' 'abcde' " . + "'abcde|' 'ab' 'cde' " . + "'abcde|' 'abc' 'de'" ; +print "ok $test\n"; +$test++; + +#Some more \G anchor checks +$foo='aabbccddeeffgg'; + +pos($foo)=1; + +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'ab'); +print "ok $test\n"; +$test++; + +pos($foo) += 1; +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'cc'); +print "ok $test\n"; +$test++; + +pos($foo) += 1; +$foo=~/.\G(..)/g; +print "not " unless($1 eq 'de'); +print "ok $test\n"; +$test++; + +print "not " unless $foo =~ /\Gef/g; +print "ok $test\n"; +$test++; + +undef pos $foo; + +$foo=~/\G(..)/g; +print "not " unless($1 eq 'aa'); +print "ok $test\n"; +$test++; + +$foo=~/\G(..)/g; +print "not " unless($1 eq 'bb'); +print "ok $test\n"; +$test++; + +pos($foo)=5; +$foo=~/\G(..)/g; +print "not " unless($1 eq 'cd'); +print "ok $test\n"; +$test++; + +$_='123x123'; +@res = /(\d*|x)/g; +print "not " unless('123||x|123|' eq join '|', @res); +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++; +# See if $i work inside (?{}) in the presense of saved substrings and +# changing $_ +@a = qw(foo bar); +@b = (); +s/(\w)(?{push @b, $1})/,$1,/g for @a; + +print "# \@b='@b', expect 'f o o b a r'\nnot " unless("@b" eq "f o o b a r"); +print "ok $test\n"; +$test++; + +print "not " unless("@a" eq ",f,,o,,o, ,b,,a,,r,"); +print "ok $test\n"; +$test++; + +$brackets = qr{ + { (?> [^{}]+ | (??{ $brackets }) )* } + }x; + +"{{}" =~ $brackets; +print "ok $test\n"; # Did we survive? +$test++; + +"something { long { and } hairy" =~ $brackets; +print "ok $test\n"; # Did we survive? +$test++; + +"something { long { and } hairy" =~ m/((??{ $brackets }))/; +print "not " unless $1 eq "{ and }"; +print "ok $test\n"; +$test++; + +$_ = "a-a\nxbb"; +pos=1; +m/^-.*bb/mg and print "not "; +print "ok $test\n"; +$test++; + +$text = "aaXbXcc"; +pos($text)=0; +$text =~ /\GXb*X/g and print 'not '; +print "ok $test\n"; +$test++; + +$text = "xA\n" x 500; +$text =~ /^\s*A/m and print 'not '; +print "ok $test\n"; +$test++; + +$text = "abc dbf"; +@res = ($text =~ /.*?(b).*?\b/g); +"@res" eq 'b b' or print 'not '; +print "ok $test\n"; +$test++; + +@a = map chr,0..255; + +@b = grep(/\S/,@a); +@c = grep(/[^\s]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\S/,@a); +@c = grep(/[\S]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\s/,@a); +@c = grep(/[^\S]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\s/,@a); +@c = grep(/[\s]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\D/,@a); +@c = grep(/[^\d]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\D/,@a); +@c = grep(/[\D]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\d/,@a); +@c = grep(/[^\D]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\d/,@a); +@c = grep(/[\d]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\W/,@a); +@c = grep(/[^\w]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\W/,@a); +@c = grep(/[\W]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\w/,@a); +@c = grep(/[^\W]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +@b = grep(/\w/,@a); +@c = grep(/[\w]/,@a); +print "not " if "@b" ne "@c"; +print "ok $test\n"; +$test++; + +# see if backtracking optimization works correctly +"\n\n" =~ /\n $ \n/x or print "not "; +print "ok $test\n"; +$test++; + +"\n\n" =~ /\n* $ \n/x or print "not "; +print "ok $test\n"; +$test++; + +"\n\n" =~ /\n+ $ \n/x or print "not "; +print "ok $test\n"; +$test++; diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t new file mode 100755 index 0000000..ca14a99 --- /dev/null +++ b/contrib/perl5/t/op/pwent.t @@ -0,0 +1,137 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib" if -d "../lib"; + eval {my @n = getpwuid 0}; + if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { + print "1..0 # Skip: $1\n"; + exit 0; + } + eval { require Config; import Config; }; + my $reason; + if ($Config{'i_pwd'} ne 'define') { + $reason = '$Config{i_pwd} undefined'; + } + elsif (not -f "/etc/passwd" ) { # Play safe. + $reason = 'no /etc/passwd file'; + } + + if (not defined $where) { # Try NIS. + foreach my $ypcat (qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat)) { + if (-x $ypcat && + open(PW, "$ypcat passwd 2>/dev/null |") && + defined(<PW>)) { + $where = "NIS passwd"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try NetInfo. + foreach my $nidump (qw(/usr/bin/nidump)) { + if (-x $nidump && + open(PW, "$nidump passwd . 2>/dev/null |") && + defined(<PW>)) { + $where = "NetInfo passwd"; + undef $reason; + last; + } + } + } + + if (not defined $where) { # Try local. + my $PW = "/etc/passwd"; + if (-f $PW && open(PW, $PW) && defined(<PW>)) { + $where = $PW; + undef $reason; + } + } + + if ($reason) { # Give up. + print "1..0 # Skip: $reason\n"; + exit 0; + } +} + +# By now PW filehandle should be open and full of juicy password entries. + +print "1..1\n"; + +# Go through at most this many users. +# (note that the first entry has been read away by now) +my $max = 25; + +my $n = 0; +my $tst = 1; +my %perfect; +my %seen; + +while (<PW>) { + chomp; + my @s = split /:/; + my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + next if /^\+/; # ignore NIS includes + if (@s) { + push @{ $seen{$name_s} }, $.; + } else { + warn "# Your $where line $. is empty.\n"; + next; + } + if ($n == $max) { + local $/; + my $junk = <PW>; + last; + } + # In principle we could whine if @s != 7 but do we know enough + # of passwd file formats everywhere? + if (@s == 7) { + @n = getpwuid($uid_s); + # 'nobody' et al. + next unless @n; + my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; + # Protect against one-to-many and many-to-one mappings. + if ($name_s ne $name) { + @n = getpwnam($name_s); + ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n; + next if $name_s ne $name; + } + $perfect{$name_s}++ + if $name eq $name_s and + $uid eq $uid_s and +# Do not compare passwords: think shadow passwords. + $gid eq $gid_s and + $gcos eq $gcos_s and + $home eq $home_s and + $shell eq $shell_s; + } + $n++; +} + +if (keys %perfect == 0) { + $max++; + print <<EOEX; +# +# The failure of op/pwent test is not necessarily serious. +# It may fail due to local password administration conventions. +# If you are for example using both NIS and local passwords, +# test failure is possible. Any distributed password scheme +# can cause such failures. +# +# What the pwent test is doing is that it compares the $max first +# entries of $where +# with the results of getpwuid() and getpwnam() call. If it finds no +# matches at all, it suspects something is wrong. +# +EOEX + print "not "; + $not = 1; +} else { + $not = 0; +} +print "ok ", $tst++; +print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not; +print "\n"; + +close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t index 913e07c..60e5b7b 100755 --- a/contrib/perl5/t/op/quotemeta.t +++ b/contrib/perl5/t/op/quotemeta.t @@ -1,8 +1,14 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + print "1..15\n"; -if ($^O eq 'os390') { # An EBCDIC variant. +if ($Config{ebcdic} eq 'define') { $_=join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t index c779f9d..97019bb 100755 --- a/contrib/perl5/t/op/rand.t +++ b/contrib/perl5/t/op/rand.t @@ -17,7 +17,7 @@ BEGIN { chdir "t" if -d "t"; - @INC = "../lib" if -d "../lib"; + unshift @INC, "../lib" if -d "../lib"; } use strict; @@ -52,6 +52,17 @@ sub bits ($) { $max = $min = rand(1); for (1..$reps) { my $n = rand(1); + if ($n < 0.0 or $n >= 1.0) { + print <<EOM; +# WHOA THERE! \$Config{drand01} is set to '$Config{drand01}', +# but that apparently produces values < 0.0 or >= 1.0. +# Make sure \$Config{drand01} is a valid expression in the +# C-language, and produces values in the range [0.0,1.0). +# +# I give up. +EOM + exit; + } $sum += $n; $bits += bits($n * 256); # Don't be greedy; 8 is enough # It's too many if randbits is less than 8! @@ -74,8 +85,8 @@ sub bits ($) { # reason that the diagnostic message might get the # wrong value is that Config.pm is incorrect.) # - if ($max <= 0 or $max >= (1 << $randbits)) { # Just in case... - print "not ok 1\n"; + if ($max <= 0 or $max >= (2 ** $randbits)) {# Just in case... + print "# max=[$max] min=[$min]\nnot ok 1\n"; print "# This perl was compiled with randbits=$randbits\n"; print "# which is _way_ off. Or maybe your system rand is broken,\n"; print "# or your C compiler can't multiply, or maybe Martians\n"; @@ -91,7 +102,7 @@ sub bits ($) { $off = int($off) + ($off > 0); # Next more positive int if ($off) { $shouldbe = $Config{randbits} + $off; - print "not ok 1\n"; + print "# max=[$max] min=[$min]\nnot ok 1\n"; print "# This perl was compiled with randbits=$randbits on $^O.\n"; print "# Consider using randbits=$shouldbe instead.\n"; # And skip the remaining tests; they would be pointless now. diff --git a/contrib/perl5/t/op/range.t b/contrib/perl5/t/op/range.t index 01f5f70..e8aecf5 100755 --- a/contrib/perl5/t/op/range.t +++ b/contrib/perl5/t/op/range.t @@ -1,6 +1,6 @@ #!./perl -print "1..12\n"; +print "1..15\n"; print join(':',1..5) eq '1:2:3:4:5' ? "ok 1\n" : "not ok 1\n"; @@ -55,3 +55,21 @@ print "ok 11\n"; print "not " unless "@a" eq "-2147483647 -2147483646"; print "ok 12\n"; +# check magic +{ + my $bad = 0; + local $SIG{'__WARN__'} = sub { $bad = 1 }; + my $x = 'a-e'; + $x =~ s/(\w)-(\w)/join ':', $1 .. $2/e; + $bad = 1 unless $x eq 'a:b:c:d:e'; + print $bad ? "not ok 13\n" : "ok 13\n"; +} + +# Should use magical autoinc only when both are strings +print "not " unless 0 == (() = "0"..-1); +print "ok 14\n"; + +for my $x ("0"..-1) { + print "not "; +} +print "ok 15\n"; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index 3471cc3..d506e6e 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -45,7 +45,7 @@ a[b-d]e ace y $& ace a[b-d] aac y $& ac a[-b] a- y $& a- a[b-] a- y $& a- -a[b-a] - c - /a[b-a]/: invalid [] range in regexp +a[b-a] - c - /a[b-a]/: invalid [] range "b-a" in regexp a[]b - c - /a[]b/: unmatched [] in regexp a[ - c - /a[/: unmatched [] in regexp a] a] y $& a] @@ -218,7 +218,7 @@ a[-]?c ac y $& ac 'a[b-d]'i AAC y $& AC 'a[-b]'i A- y $& A- 'a[b-]'i A- y $& A- -'a[b-a]'i - c - /a[b-a]/: invalid [] range in regexp +'a[b-a]'i - c - /a[b-a]/: invalid [] range "b-a" in regexp 'a[]b'i - c - /a[]b/: unmatched [] in regexp 'a['i - c - /a[/: unmatched [] in regexp 'a]'i A] y $& A] @@ -402,7 +402,7 @@ a(?{{})b - c - /a(?{{})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{}})b - c - /a(?{}})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{"{"})b - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced a(?{"\{"})b cabd y $& ab -a(?{"{"}})b - c - Unmatched right bracket +a(?{"{"}})b - c - Unmatched right curly bracket a(?{$bl="\{"}).b caxbd y $bl { x(~~)*(?:(?:F)?)? x~~ y - - ^a(?#xxx){3}c aaac y $& aaac @@ -474,18 +474,279 @@ $(?<=^(a)) a y $1 a ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ [a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp -[a[:xyz:] - c - /[a[:xyz:]/: unmatched [] in regexp -([a[:xyz:]b]+) pbaq y $1 ba +[a[:xyz:] - c - Character class [:xyz:] unknown +[a[:]b[:c] abc y $& abc +([a[:xyz:]b]+) pbaq c - Character class [:xyz:] unknown +[a[:]b[:c] abc y $& abc +([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd +([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy +([[:ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- ${nulnul} +([[:cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul} +([[:digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 +([[:graph:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd +([[:print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- +([[:space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 +([[:word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__ +([[:upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB +([[:xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01 +([[:^alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 01 +([[:^alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 __-- ${nulnul}${ffff} +([[:^ascii:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${ffff} +([[:^cntrl:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:^digit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd +([[:^lower:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 AB +([[:^print:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ${nulnul}${ffff} +([[:^punct:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy +([[:^space:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy__-- +([[:^word:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 -- ${nulnul}${ffff} +([[:^upper:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 cd01 +([[:^xdigit:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 Xy__-- ${nulnul}${ffff} +[[:foo:]] - c - Character class [:foo:] unknown +[[:^foo:]] - c - Character class [:^foo:] unknown ((?>a+)b) aaab y $1 aaab (?>(a+))b aaab y $1 aaa ((?>[^()]+)|\([^()]*\))+ ((abc(ade)ufh()()x y $& abc(ade)ufh()()x (?<=x+)y - c - /(?<=x+)y/: variable length lookbehind not implemented a{37,17} - c - /a{37,17}/: Can't do {n,m} with n > m +\Z a\nb\n y $-[0] 3 +\z a\nb\n y $-[0] 4 +$ a\nb\n y $-[0] 3 +\Z b\na\n y $-[0] 3 +\z b\na\n y $-[0] 4 +$ b\na\n y $-[0] 3 +\Z b\na y $-[0] 3 +\z b\na y $-[0] 3 +$ b\na y $-[0] 3 +'\Z'm a\nb\n y $-[0] 3 +'\z'm a\nb\n y $-[0] 4 +'$'m a\nb\n y $-[0] 1 +'\Z'm b\na\n y $-[0] 3 +'\z'm b\na\n y $-[0] 4 +'$'m b\na\n y $-[0] 1 +'\Z'm b\na y $-[0] 3 +'\z'm b\na y $-[0] 3 +'$'m b\na y $-[0] 1 a\Z a\nb\n n - - -b\Z a\nb\n y - - -b\z a\nb\n n - - -b\Z a\nb y - - -b\z a\nb y - - +a\z a\nb\n n - - +a$ a\nb\n n - - +a\Z b\na\n y $-[0] 2 +a\z b\na\n n - - +a$ b\na\n y $-[0] 2 +a\Z b\na y $-[0] 2 +a\z b\na y $-[0] 2 +a$ b\na y $-[0] 2 +'a\Z'm a\nb\n bn - - +'a\z'm a\nb\n n - - +'a$'m a\nb\n y $-[0] 0 +'a\Z'm b\na\n y $-[0] 2 +'a\z'm b\na\n n - - +'a$'m b\na\n y $-[0] 2 +'a\Z'm b\na y $-[0] 2 +'a\z'm b\na y $-[0] 2 +'a$'m b\na y $-[0] 2 +aa\Z aa\nb\n n - - +aa\z aa\nb\n n - - +aa$ aa\nb\n n - - +aa\Z b\naa\n y $-[0] 2 +aa\z b\naa\n n - - +aa$ b\naa\n y $-[0] 2 +aa\Z b\naa y $-[0] 2 +aa\z b\naa y $-[0] 2 +aa$ b\naa y $-[0] 2 +'aa\Z'm aa\nb\n bn - - +'aa\z'm aa\nb\n n - - +'aa$'m aa\nb\n y $-[0] 0 +'aa\Z'm b\naa\n y $-[0] 2 +'aa\z'm b\naa\n n - - +'aa$'m b\naa\n y $-[0] 2 +'aa\Z'm b\naa y $-[0] 2 +'aa\z'm b\naa y $-[0] 2 +'aa$'m b\naa y $-[0] 2 +aa\Z ac\nb\n n - - +aa\z ac\nb\n n - - +aa$ ac\nb\n n - - +aa\Z b\nac\n n - - +aa\z b\nac\n n - - +aa$ b\nac\n n - - +aa\Z b\nac n - - +aa\z b\nac n - - +aa$ b\nac n - - +'aa\Z'm ac\nb\n n - - +'aa\z'm ac\nb\n n - - +'aa$'m ac\nb\n n - - +'aa\Z'm b\nac\n n - - +'aa\z'm b\nac\n n - - +'aa$'m b\nac\n n - - +'aa\Z'm b\nac n - - +'aa\z'm b\nac n - - +'aa$'m b\nac n - - +aa\Z ca\nb\n n - - +aa\z ca\nb\n n - - +aa$ ca\nb\n n - - +aa\Z b\nca\n n - - +aa\z b\nca\n n - - +aa$ b\nca\n n - - +aa\Z b\nca n - - +aa\z b\nca n - - +aa$ b\nca n - - +'aa\Z'm ca\nb\n n - - +'aa\z'm ca\nb\n n - - +'aa$'m ca\nb\n n - - +'aa\Z'm b\nca\n n - - +'aa\z'm b\nca\n n - - +'aa$'m b\nca\n n - - +'aa\Z'm b\nca n - - +'aa\z'm b\nca n - - +'aa$'m b\nca n - - +ab\Z ab\nb\n n - - +ab\z ab\nb\n n - - +ab$ ab\nb\n n - - +ab\Z b\nab\n y $-[0] 2 +ab\z b\nab\n n - - +ab$ b\nab\n y $-[0] 2 +ab\Z b\nab y $-[0] 2 +ab\z b\nab y $-[0] 2 +ab$ b\nab y $-[0] 2 +'ab\Z'm ab\nb\n bn - - +'ab\z'm ab\nb\n n - - +'ab$'m ab\nb\n y $-[0] 0 +'ab\Z'm b\nab\n y $-[0] 2 +'ab\z'm b\nab\n n - - +'ab$'m b\nab\n y $-[0] 2 +'ab\Z'm b\nab y $-[0] 2 +'ab\z'm b\nab y $-[0] 2 +'ab$'m b\nab y $-[0] 2 +ab\Z ac\nb\n n - - +ab\z ac\nb\n n - - +ab$ ac\nb\n n - - +ab\Z b\nac\n n - - +ab\z b\nac\n n - - +ab$ b\nac\n n - - +ab\Z b\nac n - - +ab\z b\nac n - - +ab$ b\nac n - - +'ab\Z'm ac\nb\n n - - +'ab\z'm ac\nb\n n - - +'ab$'m ac\nb\n n - - +'ab\Z'm b\nac\n n - - +'ab\z'm b\nac\n n - - +'ab$'m b\nac\n n - - +'ab\Z'm b\nac n - - +'ab\z'm b\nac n - - +'ab$'m b\nac n - - +ab\Z ca\nb\n n - - +ab\z ca\nb\n n - - +ab$ ca\nb\n n - - +ab\Z b\nca\n n - - +ab\z b\nca\n n - - +ab$ b\nca\n n - - +ab\Z b\nca n - - +ab\z b\nca n - - +ab$ b\nca n - - +'ab\Z'm ca\nb\n n - - +'ab\z'm ca\nb\n n - - +'ab$'m ca\nb\n n - - +'ab\Z'm b\nca\n n - - +'ab\z'm b\nca\n n - - +'ab$'m b\nca\n n - - +'ab\Z'm b\nca n - - +'ab\z'm b\nca n - - +'ab$'m b\nca n - - +abb\Z abb\nb\n n - - +abb\z abb\nb\n n - - +abb$ abb\nb\n n - - +abb\Z b\nabb\n y $-[0] 2 +abb\z b\nabb\n n - - +abb$ b\nabb\n y $-[0] 2 +abb\Z b\nabb y $-[0] 2 +abb\z b\nabb y $-[0] 2 +abb$ b\nabb y $-[0] 2 +'abb\Z'm abb\nb\n bn - - +'abb\z'm abb\nb\n n - - +'abb$'m abb\nb\n y $-[0] 0 +'abb\Z'm b\nabb\n y $-[0] 2 +'abb\z'm b\nabb\n n - - +'abb$'m b\nabb\n y $-[0] 2 +'abb\Z'm b\nabb y $-[0] 2 +'abb\z'm b\nabb y $-[0] 2 +'abb$'m b\nabb y $-[0] 2 +abb\Z ac\nb\n n - - +abb\z ac\nb\n n - - +abb$ ac\nb\n n - - +abb\Z b\nac\n n - - +abb\z b\nac\n n - - +abb$ b\nac\n n - - +abb\Z b\nac n - - +abb\z b\nac n - - +abb$ b\nac n - - +'abb\Z'm ac\nb\n n - - +'abb\z'm ac\nb\n n - - +'abb$'m ac\nb\n n - - +'abb\Z'm b\nac\n n - - +'abb\z'm b\nac\n n - - +'abb$'m b\nac\n n - - +'abb\Z'm b\nac n - - +'abb\z'm b\nac n - - +'abb$'m b\nac n - - +abb\Z ca\nb\n n - - +abb\z ca\nb\n n - - +abb$ ca\nb\n n - - +abb\Z b\nca\n n - - +abb\z b\nca\n n - - +abb$ b\nca\n n - - +abb\Z b\nca n - - +abb\z b\nca n - - +abb$ b\nca n - - +'abb\Z'm ca\nb\n n - - +'abb\z'm ca\nb\n n - - +'abb$'m ca\nb\n n - - +'abb\Z'm b\nca\n n - - +'abb\z'm b\nca\n n - - +'abb$'m b\nca\n n - - +'abb\Z'm b\nca n - - +'abb\z'm b\nca n - - +'abb$'m b\nca n - - (^|x)(c) ca y $2 c a*abc?xyz+pqr{3}ab{2,}xy{4,5}pq{0,6}AB{0,}zz x n - - +a(?{$a=2;$b=3;($b)=$a})b yabz y $b 2 round\(((?>[^()]+))\) _I(round(xs * sz),1) y $1 xs * sz +'((?x:.) )' x y $1- x - +'((?-x:.) )'x x y $1- x- +foo.bart foo.bart y - - +'^d[x][x][x]'m abcd\ndxxx y - - +.X(.+)+X bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+XX bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.XX(.+)+X bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+X bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+XX bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.XX(.+)+X bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.XX(.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.X(.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.X(.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.XX(.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X](.+)+[X] bbbbXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X](.+)+[X][X] bbbbXcXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X][X](.+)+[X] bbbbXXcXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa y - - +.[X](.+)+[X] bbbbXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X](.+)+[X][X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +.[X][X](.+)+[X] bbbbXXXaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa n - - +tt+$ xxxtt y - - +([a-\d]+) za-9z y $1 a-9 +([\d-z]+) a0-za y $1 0-z +([\d-\s]+) a0- z y $1 0- +([a-[:digit:]]+) za-9z y $1 a-9 +([[:digit:]-z]+) =0-z= y $1 0-z +([[:digit:]-[:alpha:]]+) =0-z= y $1 0-z +\GX.*X aaaXbX n - - +(\d+\.\d+) 3.1415926 y $1 3.1415926 +(\ba.{0,10}br) have a web browser y $1 a web br +'\.c(pp|xx|c)?$'i Changes n - - +'\.c(pp|xx|c)?$'i IO.c y - - +'(\.c(pp|xx|c)?$)'i IO.c y $1 .c +^([a-z]:) C:/ n - - +'^\S\s+aa$'m \nx aa y - - +(^|a)b ab y - - diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t index ca19ebc..d101c2f 100755 --- a/contrib/perl5/t/op/readdir.t +++ b/contrib/perl5/t/op/readdir.t @@ -1,10 +1,21 @@ #!./perl +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + eval 'opendir(NOSUCH, "no/such/directory");'; if ($@) { print "1..0\n"; exit; } print "1..3\n"; +for $i (1..2000) { + local *OP; + opendir(OP, "op") or die "can't opendir: $!"; + # should auto-closedir() here +} + if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); diff --git a/contrib/perl5/t/op/recurse.t b/contrib/perl5/t/op/recurse.t index 6594940..dc823ed 100755 --- a/contrib/perl5/t/op/recurse.t +++ b/contrib/perl5/t/op/recurse.t @@ -4,7 +4,7 @@ # test recursive functions. # -print "1..23\n"; +print "1..25\n"; sub gcd ($$) { return gcd($_[0] - $_[1], $_[1]) if ($_[0] > $_[1]); @@ -84,3 +84,33 @@ for $x (0..3) { print 'not ' unless (($t = takeuchi($x, $y, $z)) == $z + 1); print "ok ", $i++, "\n"; print "# takeuchi($x, $y, $z) = $t\n"; + +{ + sub get_first1 { + get_list1(@_)->[0]; + } + + sub get_list1 { + return [24] unless $_[0]; + my $u = get_first1(0); + [$u]; + } + my $x = get_first1(1); + print "ok $x\n"; +} + +{ + sub get_first2 { + return get_list2(@_)->[0]; + } + + sub get_list2 { + return [25] unless $_[0]; + my $u = get_first2(0); + return [$u]; + } + my $x = get_first2(1); + print "ok $x\n"; +} + +$i = 26; diff --git a/contrib/perl5/t/op/ref.t b/contrib/perl5/t/op/ref.t index 1d70f9f..a2baab8 100755 --- a/contrib/perl5/t/op/ref.t +++ b/contrib/perl5/t/op/ref.t @@ -1,6 +1,6 @@ #!./perl -print "1..55\n"; +print "1..56\n"; # Test glob operations. @@ -241,11 +241,11 @@ print $$_,"\n"; package A; sub new { bless {}, shift } DESTROY { print "# destroying 'A'\nok 51\n" } - package B; + package _B; sub new { bless {}, shift } - DESTROY { print "# destroying 'B'\nok 50\n"; bless shift, 'A' } + DESTROY { print "# destroying '_B'\nok 50\n"; bless shift, 'A' } package main; - my $b = B->new; + my $b = _B->new; } # test if $_[0] is properly protected in DESTROY() @@ -271,14 +271,22 @@ print $$_,"\n"; print "# good, didn't recurse\n"; } +# test if refgen behaves with autoviv magic + +{ + my @a; + $a[1] = "ok 53\n"; + print ${\$_} for @a; +} + # test global destruction package FINALE; { - $ref3 = bless ["ok 55\n"]; # package destruction - my $ref2 = bless ["ok 54\n"]; # lexical destruction - local $ref1 = bless ["ok 53\n"]; # dynamic destruction + $ref3 = bless ["ok 56\n"]; # package destruction + my $ref2 = bless ["ok 55\n"]; # lexical destruction + local $ref1 = bless ["ok 54\n"]; # dynamic destruction 1; # flush any temp values on stack } diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t index 11b3ee3..4ffe136 100755 --- a/contrib/perl5/t/op/regexp.t +++ b/contrib/perl5/t/op/regexp.t @@ -16,6 +16,8 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # y expect a match # n expect no match # c expect an error +# B test exposes a known bug in Perl, should be skipped +# b test exposes a known bug in Perl, should be skipped if noamp # # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>. # @@ -31,7 +33,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } $iters = shift || 1; # Poor man performance suite, 10000 is OK. @@ -45,6 +47,8 @@ seek(TESTS,0,0); $. = 0; $bang = sprintf "\\%03o", ord "!"; # \41 would not be portable. +$ffff = chr(0xff) x 2; +$nulnul = "\0" x 2; $| = 1; print "1..$numtests\n# $iters iterations\n"; @@ -57,12 +61,18 @@ while (<TESTS>) { infty_subst(\$pat); infty_subst(\$expect); $pat = "'$pat'" unless $pat =~ /^[:']/; - $pat =~ s/\\n/\n/g; $pat =~ s/(\$\{\w+\})/$1/eeg; + $pat =~ s/\\n/\n/g; + $subject =~ s/(\$\{\w+\})/$1/eeg; $subject =~ s/\\n/\n/g; + $expect =~ s/(\$\{\w+\})/$1/eeg; $expect =~ s/\\n/\n/g; $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; - for $study ("", "study \$subject") { + $skip = ($skip_amp ? ($result =~ s/B//i) : ($result =~ s/B//)); + # Certain tests don't work with utf8 (the re_test should be in UTF8) + $skip = 1 if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word):\]/; + $result =~ s/B//i unless $skip; + for $study ('', 'study \$subject') { $c = $iters; eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";"; chomp( $err = $@ ); @@ -70,6 +80,9 @@ while (<TESTS>) { if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST } last; # no need to study a syntax error } + elsif ( $skip ) { + print "ok $. # skipped\n"; next TEST; + } elsif ($@) { print "not ok $. $input => error `$err'\n"; next TEST; } diff --git a/contrib/perl5/t/op/repeat.t b/contrib/perl5/t/op/repeat.t index f935bf1..c030ba9 100755 --- a/contrib/perl5/t/op/repeat.t +++ b/contrib/perl5/t/op/repeat.t @@ -42,10 +42,15 @@ 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. +# The test #20 is actually testing for Digital C compiler optimizer bug, +# present in Dec C versions 5.* and 6.0 (used in Digital UNIX and VMS), +# found in December 1998. The bug was reported to Digital^WCompaq as +# DECC 2745 (21-Dec-1998) +# GEM_BUGS 7619 (23-Dec-1998) +# As of April 1999 the bug has been fixed in Tru64 UNIX 5.0 and is planned +# to be fixed also in 4.0G. # -# 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() +# The bug was as follows: broken code was produced for util.c:repeatcpy() # (a utility function for the 'x' operator) in the case *all* these # four conditions held: # @@ -68,9 +73,6 @@ print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; # 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: # @@ -85,6 +87,9 @@ print join('', (split(//,"123")) x 2) eq '123123' ? "ok 19\n" : "not ok 19\n"; # return; # } # +# The bug could also be (obscurely) avoided by changing "from" to +# be an unsigned char pointer. +# # 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. # diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index bff3c36..e988ad9 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -3,11 +3,11 @@ ## ## Many of these tests are originally from Michael Schroeder ## <Michael.Schroeder@informatik.uni-erlangen.de> -## Adapted and expanded by Gurusamy Sarathy <gsar@umich.edu> +## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com> ## chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; @@ -32,10 +32,10 @@ for (@prgs){ print TEST "$prog\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile` : + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `sh -c './perl $switch $tmpfile' 2>&1`; + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN @@ -57,7 +57,7 @@ __END__ @a = sort { last ; } @a; } EXPECT -Can't "last" outside a block at - line 3. +Can't "last" outside a loop block at - line 3. ######## package TEST; @@ -174,7 +174,7 @@ exit; bar: print "bar reached\n"; EXPECT -Can't "goto" outside a block at - line 2. +Can't "goto" out of a pseudo block at - line 2. ######## sub sortfn { (split(/./, 'x'x10000))[0]; @@ -227,7 +227,7 @@ tie $bar, TEST; } print "OK\n"; EXPECT -Can't "next" outside a block at - line 8. +Can't "next" outside a loop block at - line 8. ######## package TEST; @@ -285,7 +285,7 @@ package main; tie $bar, TEST; } EXPECT -Can't "next" outside a block at - line 4. +Can't "next" outside a loop block at - line 4. ######## @a = (1, 2, 3); foo: @@ -335,3 +335,17 @@ tie my @bar, 'TEST'; print join('|', @bar[0..3]), "\n"; EXPECT foo|fee|fie|foe +######## +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 +A 1 +bar +B 2 +bar diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index fdb4e34..ba0a4c2 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -1,11 +1,29 @@ #!./perl -print "1..29\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +use warnings; +print "1..49\n"; # XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +{ + no warnings 'uninitialized'; + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} + +# these shouldn't hang +{ + no warnings; + sort { for ($_ = 0;; $_++) {} } @a; + sort { while(1) {} } @a; + sort { while(1) { last; } } @a; + sort { while(0) { last; } } @a; +} -sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 } +sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 } my $upperfirst = 'A' lt 'a'; @@ -31,129 +49,224 @@ $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; print "# 1: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 1\n" : "not ok 1\n"); -$x = join('', sort( backwards @harry)); +$x = join('', sort( Backwards @harry)); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; print "# 2: x = '$x', expected = '$expected'\n"; print ($x eq $expected ? "ok 2\n" : "not ok 2\n"); +$x = join('', sort( Backwards_stacked @harry)); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 3: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ? "ok 3\n" : "not ok 3\n"); + $x = join('', sort @george, 'to', @harry); $expected = $upperfirst ? 'AbelAxedCaincatchaseddoggonepunishedtoxyz' : 'catchaseddoggonepunishedtoxyzAbelAxedCain' ; -print "# 3: x = '$x', expected = '$expected'\n"; -print ($x eq $expected ?"ok 3\n":"not ok 3\n"); +print "# 4: x = '$x', expected = '$expected'\n"; +print ($x eq $expected ?"ok 4\n":"not ok 4\n"); @a = (); @b = reverse @a; -print ("@b" eq "" ? "ok 4\n" : "not ok 4 (@b)\n"); +print ("@b" eq "" ? "ok 5\n" : "not ok 5 (@b)\n"); @a = (1); @b = reverse @a; -print ("@b" eq "1" ? "ok 5\n" : "not ok 5 (@b)\n"); +print ("@b" eq "1" ? "ok 6\n" : "not ok 6 (@b)\n"); @a = (1,2); @b = reverse @a; -print ("@b" eq "2 1" ? "ok 6\n" : "not ok 6 (@b)\n"); +print ("@b" eq "2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); @a = (1,2,3); @b = reverse @a; -print ("@b" eq "3 2 1" ? "ok 7\n" : "not ok 7 (@b)\n"); +print ("@b" eq "3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); @a = (1,2,3,4); @b = reverse @a; -print ("@b" eq "4 3 2 1" ? "ok 8\n" : "not ok 8 (@b)\n"); +print ("@b" eq "4 3 2 1" ? "ok 9\n" : "not ok 9 (@b)\n"); @a = (10,2,3,4); @b = sort {$a <=> $b;} @a; -print ("@b" eq "2 3 4 10" ? "ok 9\n" : "not ok 9 (@b)\n"); +print ("@b" eq "2 3 4 10" ? "ok 10\n" : "not ok 10 (@b)\n"); -$sub = 'backwards'; +$sub = 'Backwards'; $x = join('', sort $sub @harry); $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; -print "# 10: x = $x, expected = '$expected'\n"; -print ($x eq $expected ? "ok 10\n" : "not ok 10\n"); +print "# 11: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 11\n" : "not ok 11\n"); + +$sub = 'Backwards_stacked'; +$x = join('', sort $sub @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print "# 12: x = $x, expected = '$expected'\n"; +print ($x eq $expected ? "ok 12\n" : "not ok 12\n"); # literals, combinations @b = sort (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 11\n" : "not ok 11\n"); +print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); print "# x = '@b'\n"; @b = sort grep { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 12\n" : "not ok 12\n"); +print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); print "# x = '@b'\n"; @b = sort map { $_ } (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 13\n" : "not ok 13\n"); +print ("@b" eq '1 2 3 4' ? "ok 15\n" : "not ok 15\n"); print "# x = '@b'\n"; @b = sort reverse (4,1,3,2); -print ("@b" eq '1 2 3 4' ? "ok 14\n" : "not ok 14\n"); +print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n"); print "# x = '@b'\n"; -$^W = 0; # redefining sort sub inside the sort sub should fail sub twoface { *twoface = sub { $a <=> $b }; &twoface } eval { @b = sort twoface 4,1,3,2 }; -print ($@ =~ /redefine active sort/ ? "ok 15\n" : "not ok 15\n"); +print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n"); # redefining sort subs outside the sort should not fail -eval { *twoface = sub { &backwards } }; -print $@ ? "not ok 16\n" : "ok 16\n"; +eval { no warnings 'redefine'; *twoface = sub { &Backwards } }; +print $@ ? "not ok 18\n" : "ok 18\n"; eval { @b = sort twoface 4,1,3,2 }; -print ("@b" eq '4 3 2 1' ? "ok 17\n" : "not ok 17 |@b|\n"); +print ("@b" eq '4 3 2 1' ? "ok 19\n" : "not ok 19 |@b|\n"); -*twoface = sub { *twoface = *backwards; $a <=> $b }; +{ + no warnings 'redefine'; + *twoface = sub { *twoface = *Backwards; $a <=> $b }; +} eval { @b = sort twoface 4,1 }; -print ($@ =~ /redefine active sort/ ? "ok 18\n" : "not ok 18\n"); +print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n"); -*twoface = sub { +{ + no warnings 'redefine'; + *twoface = sub { eval 'sub twoface { $a <=> $b }'; - die($@ =~ /redefine active sort/ ? "ok 19\n" : "not ok 19\n"); + die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n"); $a <=> $b; }; +} eval { @b = sort twoface 4,1 }; -print $@ ? "$@" : "not ok 19\n"; +print $@ ? "$@" : "not ok 21\n"; eval <<'CODE'; - my @result = sort main'backwards 'one', 'two'; + my @result = sort main'Backwards 'one', 'two'; CODE -print $@ ? "not ok 20\n# $@" : "ok 20\n"; +print $@ ? "not ok 22\n# $@" : "ok 22\n"; eval <<'CODE'; # "sort 'one', 'two'" should not try to parse "'one" as a sort sub my @result = sort 'one', 'two'; CODE -print $@ ? "not ok 21\n# $@" : "ok 21\n"; +print $@ ? "not ok 23\n# $@" : "ok 23\n"; { - my $sortsub = \&backwards; - my $sortglob = *backwards; - my $sortglobr = \*backwards; - my $sortname = 'backwards'; + 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"); + print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 23\n" : "not ok 23 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 24\n" : "not ok 24 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 25\n" : "not ok 25 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); } { - local $sortsub = \&backwards; - local $sortglob = *backwards; - local $sortglobr = \*backwards; - local $sortname = 'backwards'; + my $sortsub = \&Backwards_stacked; + my $sortglob = *Backwards_stacked; + my $sortglobr = \*Backwards_stacked; + my $sortname = 'Backwards_stacked'; @b = sort $sortsub 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 26\n" : "not ok 26 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); @b = sort $sortglob 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 27\n" : "not ok 27 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); @b = sort $sortname 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 28\n" : "not ok 28 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 30\n" : "not ok 30 |@b|\n"); @b = sort $sortglobr 4,1,3,2; - print ("@b" eq '4 3 2 1' ? "ok 29\n" : "not ok 29 |@b|\n"); + print ("@b" eq '4 3 2 1' ? "ok 31\n" : "not ok 31 |@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 32\n" : "not ok 32 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 33\n" : "not ok 33 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 34\n" : "not ok 34 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 35\n" : "not ok 35 |@b|\n"); +} + +{ + local $sortsub = \&Backwards_stacked; + local $sortglob = *Backwards_stacked; + local $sortglobr = \*Backwards_stacked; + local $sortname = 'Backwards_stacked'; + @b = sort $sortsub 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 36\n" : "not ok 36 |@b|\n"); + @b = sort $sortglob 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 37\n" : "not ok 37 |@b|\n"); + @b = sort $sortname 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 38\n" : "not ok 38 |@b|\n"); + @b = sort $sortglobr 4,1,3,2; + print ("@b" eq '4 3 2 1' ? "ok 39\n" : "not ok 39 |@b|\n"); +} + +## exercise sort builtins... ($a <=> $b already tested) +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { + my $dummy; # force blockness + return $b <=> $a +} @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 40\n" : "not ok 40\n"); +print "# x = '@b'\n"; +$x = join('', sort { $a cmp $b } @harry); +$expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; +print ($x eq $expected ? "ok 41\n" : "not ok 41\n"); +print "# x = '$x'; expected = '$expected'\n"; +$x = join('', sort { $b cmp $a } @harry); +$expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; +print ($x eq $expected ? "ok 42\n" : "not ok 42\n"); +print "# x = '$x'; expected = '$expected'\n"; +{ + use integer; + @b = sort { $a <=> $b } @a; + print ("@b" eq '5 19 90 255 1996' ? "ok 43\n" : "not ok 43\n"); + print "# x = '@b'\n"; + @b = sort { $b <=> $a } @a; + print ("@b" eq '1996 255 90 19 5' ? "ok 44\n" : "not ok 44\n"); + print "# x = '@b'\n"; + $x = join('', sort { $a cmp $b } @harry); + $expected = $upperfirst ? 'AbelCaincatdogx' : 'catdogxAbelCain'; + print ($x eq $expected ? "ok 45\n" : "not ok 45\n"); + print "# x = '$x'; expected = '$expected'\n"; + $x = join('', sort { $b cmp $a } @harry); + $expected = $upperfirst ? 'xdogcatCainAbel' : 'CainAbelxdogcat'; + print ($x eq $expected ? "ok 46\n" : "not ok 46\n"); + print "# x = '$x'; expected = '$expected'\n"; } +# test that an optimized-away comparison block doesn't take any other +# arguments away with it +$x = join('', sort { $a <=> $b } 3, 1, 2); +print $x eq "123" ? "ok 47\n" : "not ok 47\n"; + +# test sorting in non-main package +package Foo; +@a = ( 5, 19, 1996, 255, 90 ); +@b = sort { $b <=> $a } @a; +print ("@b" eq '1996 255 90 19 5' ? "ok 48\n" : "not ok 48\n"); +print "# x = '@b'\n"; + +@b = sort main::Backwards_stacked @a; +print ("@b" eq '90 5 255 1996 19' ? "ok 49\n" : "not ok 49\n"); +print "# x = '@b'\n"; diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t index 7f0acce..8b9f4ad 100755 --- a/contrib/perl5/t/op/split.t +++ b/contrib/perl5/t/op/split.t @@ -48,11 +48,9 @@ print $_ eq '1:2:3:4:5:6:::' ? "ok 10\n" : "not ok 10 $_\n"; # Does assignment to a list imply split to one more field than that? if ($^O eq 'MSWin32') { $foo = `.\\perl -D1024 -e "(\$a,\$b) = split;" 2>&1` } +elsif ($^O eq 'VMS') { $foo = `./perl "-D1024" -e "(\$a,\$b) = split;" 2>&1` } else { $foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1` } -if ($foo =~ /DCL-W-NOCOMD/) { - $foo = `\$ mcr sys\$disk:[]perl. "-D1024" -e "(\$a,\$b) = split;"`; -} -print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n"; +print $foo =~ /DEBUGGING/ || $foo =~ /SV = (VOID|IV\(3\))/ ? "ok 11\n" : "not ok 11\n"; # Can we say how many fields to split to when assigning to a list? ($a,$b) = split(' ','1 2 3 4 5 6', 2); diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t index b9b4751..4d54d2c 100755 --- a/contrib/perl5/t/op/sprintf.t +++ b/contrib/perl5/t/op/sprintf.t @@ -2,9 +2,14 @@ # $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} +use warnings; + print "1..4\n"; -$^W = 1; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { $w++; @@ -14,8 +19,8 @@ $SIG{__WARN__} = sub { }; $w = 0; -$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f","hi",123,0,456,0,ord('A'),3.0999); -if ($x eq ' hi 123 %foo 456 0A3.1' && $w == 0) { +$x = sprintf("%3s %-4s%%foo %.0d%5d %#x%c%3.1f %b %x %X %#b %#x %#X","hi",123,0,456,0,ord('A'),3.0999,11,171,171,11,171,171); +if ($x eq ' hi 123 %foo 456 0A3.1 1011 ab AB 0b1011 0xab 0XAB' && $w == 0) { print "ok 1\n"; } else { print "not ok 1 '$x'\n"; diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t index 2207b40..af4920c 100755 --- a/contrib/perl5/t/op/stat.t +++ b/contrib/perl5/t/op/stat.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } use Config; @@ -14,28 +14,45 @@ print "1..58\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_Dos = $^O eq 'dos'; $Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32; +$Is_Cygwin = $^O eq 'cygwin'; chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`)); -$DEV = `ls -l /dev` unless $Is_Dosish; +$DEV = `ls -l /dev` unless $Is_Dosish or $Is_Cygwin; unlink "Op.stat.tmp"; -open(FOO, ">Op.stat.tmp"); - -# hack to make Apollo update link count: -$junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); - -($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, - $blksize,$blocks) = stat(FOO); -if ($nlink == 1) {print "ok 1\n";} else {print "not ok 1\n";} -if ($Is_MSWin32 || ($mtime && $mtime == $ctime)) {print "ok 2\n";} -else {print "# |$mtime| vs |$ctime|\nnot ok 2\n";} - -print FOO "Now is the time for all good men to come to.\n"; -close(FOO); - -sleep 2; +if (open(FOO, ">Op.stat.tmp")) { + # hack to make Apollo update link count: + $junk = `ls Op.stat.tmp` unless ($Is_MSWin32 || $Is_Dos); + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime, + $blksize,$blocks) = stat(FOO); + if ($nlink == 1) { + print "ok 1\n"; + } + else { + print "# res=$res, nlink=$nlink.\nnot ok 1\n"; + } + if ($Is_MSWin32 or $Is_Cygwin || ($mtime && $mtime == $ctime)) { + print "ok 2\n"; + } + else { + print "# |$mtime| vs |$ctime|\nnot ok 2\n"; + } + + my $funky_FAT_timestamps = $Is_Cygwin; + + sleep 3 if $funky_FAT_timestamps; + + print FOO "Now is the time for all good men to come to.\n"; + close(FOO); + + sleep 2 unless $funky_FAT_timestamps; + +} else { + print "# open failed: $!\nnot ok 1\nnot ok 2\n"; +} -if ($Is_Dosish) { unlink "Op.stat.tmp2" } +if ($Is_Dosish) { unlink "Op.stat.tmp2"} else { `rm -f Op.stat.tmp2;ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`; } @@ -50,7 +67,8 @@ elsif ($nlink == 2) else {print "# \$nlink is |$nlink|\nnot ok 3\n";} if ( $Is_Dosish - || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime) # Solaris tmpfs bug + # Solaris tmpfs bug + || ($cwd =~ m#^/tmp# and $mtime && $mtime==$ctime && $^O eq 'solaris') || $cwd =~ m#/afs/# || $^O eq 'amigaos') { print "ok 4 # skipped: different semantic of mtime/ctime\n"; @@ -65,7 +83,7 @@ else { } print "#4 :$mtime: should != :$ctime:\n"; -unlink "Op.stat.tmp"; +unlink "Op.stat.tmp" or print "# unlink failed: $!\n"; if ($Is_MSWin32) { open F, '>Op.stat.tmp' and close F } else { `touch Op.stat.tmp` } @@ -76,7 +94,7 @@ $Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; if (! -z 'Op.stat.tmp') {print "ok 7\n";} else {print "not ok 7\n";} if (-s 'Op.stat.tmp') {print "ok 8\n";} else {print "not ok 8\n";} -unlink 'Op.stat.tmp'; +unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; $olduid = $>; # can't test -r if uid == 0 $Is_MSWin32 ? `cmd /c echo hi > Op.stat.tmp` : `echo hi >Op.stat.tmp`; chmod 0,'Op.stat.tmp'; @@ -93,6 +111,9 @@ foreach ((12,13,14,15,16,17)) { print "ok $_\n"; #deleted tests } +# in ms windows, Op.stat.tmp inherits owner uid from directory +# not sure about os/2, but chown is harmless anyway +eval { chown $>,'Op.stat.tmp'; 1 } or print "# $@" ; chmod 0700,'Op.stat.tmp'; if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";} if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";} @@ -149,7 +170,7 @@ else {print "not ok 33\n";} if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";} -if ($^O eq 'amigaos' or $Is_Dosish) { +if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { print "ok 35 # skipped: no -u\n"; goto tty_test; } @@ -184,14 +205,23 @@ unless($ENV{PERL_SKIP_TTY_TEST}) { print "ok 37\n"; } else { - unless (open(tty,"/dev/tty")) { - print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n"; + my $TTY = "/dev/tty"; + + $TTY = "/dev/ttyp0" if $^O eq 'rhapsody'; + + if (defined $TTY) { + unless (open(TTY, $TTY)) { + print STDERR "Can't open $TTY--run t/TEST outside of make.\n"; + } + if (-t TTY) {print "ok 36\n";} else {print "not ok 36\n";} + if (-c TTY) {print "ok 37\n";} else {print "not ok 37\n";} + close(TTY); + } else { # if some platform completely undefines $TTY + print "ok 36 # skipped\n"; + print "ok 37 # skipped\n"; } - if (-t tty) {print "ok 36\n";} else {print "not ok 36\n";} - if (-c tty) {print "ok 37\n";} else {print "not ok 37\n";} - close(tty); } - if (! -t tty) {print "ok 38\n";} else {print "not ok 38\n";} + if (! -t TTY) {print "ok 38\n";} else {print "not ok 38\n";} if (-t) {print "ok 39\n";} else {print "not ok 39\n";} } else { @@ -249,4 +279,4 @@ $_ = 'Op.stat.tmp'; if (-f) {print "ok 57\n";} else {print "not ok 57\n";} if (-f()) {print "ok 58\n";} else {print "not ok 58\n";} -unlink 'Op.stat.tmp'; +unlink 'Op.stat.tmp' or print "# unlink failed: $!\n"; diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t index afa06ab..9757f4c 100755 --- a/contrib/perl5/t/op/subst.t +++ b/contrib/perl5/t/op/subst.t @@ -1,6 +1,12 @@ #!./perl -print "1..71\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + +print "1..84\n"; $x = 'foo'; $_ = "x"; @@ -181,7 +187,8 @@ tr/a-z/A-Z/; print $_ eq 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789' ? "ok 52\n" : "not ok 52\n"; # same as tr/A-Z/a-z/; -if ($^O eq 'os390') { # An EBCDIC variant. +if ($Config{ebcdic} eq 'define') { # EBCDIC. + no utf8; y[\301-\351][\201-\251]; } else { # Ye Olde ASCII. Or something like it. y[\101-\132][\141-\172]; @@ -305,6 +312,70 @@ s{ \d+ \b [,.;]? (?{ 'digits' }) print ($_ eq $foo ? "ok 70\n" : "not ok 70\n#'$_'\n#'$foo'\n"); $_ = 'x' x 20; -s/\d*|x/<$&>/g; +s/(\d*|x)/<$1>/g; $foo = '<>' . ('<x><>' x 20) ; print ($_ eq $foo ? "ok 71\n" : "not ok 71\n#'$_'\n#'$foo'\n"); + +$t = 'aaaaaaaaa'; + +$_ = $t; +pos = 6; +s/\Ga/xx/g; +print "not " unless $_ eq 'aaaaaaxxxxxx'; +print "ok 72\n"; + +$_ = $t; +pos = 6; +s/\Ga/x/g; +print "not " unless $_ eq 'aaaaaaxxx'; +print "ok 73\n"; + +$_ = $t; +pos = 6; +s/\Ga/xx/; +print "not " unless $_ eq 'aaaaaaxxaa'; +print "ok 74\n"; + +$_ = $t; +pos = 6; +s/\Ga/x/; +print "not " unless $_ eq 'aaaaaaxaa'; +print "ok 75\n"; + +$_ = $t; +s/\Ga/xx/g; +print "not " unless $_ eq 'xxxxxxxxxxxxxxxxxx'; +print "ok 76\n"; + +$_ = $t; +s/\Ga/x/g; +print "not " unless $_ eq 'xxxxxxxxx'; +print "ok 77\n"; + +$_ = $t; +s/\Ga/xx/; +print "not " unless $_ eq 'xxaaaaaaaa'; +print "ok 78\n"; + +$_ = $t; +s/\Ga/x/; +print "not " unless $_ eq 'xaaaaaaaa'; +print "ok 79\n"; + +$_ = 'aaaa'; +s/\ba/./g; +print "#'$_'\nnot " unless $_ eq '.aaa'; +print "ok 80\n"; + +eval q% s/a/"b"}/e %; +print ($@ =~ /Bad evalled substitution/ ? "ok 81\n" : "not ok 81\n"); +eval q% ($_ = "x") =~ s/(.)/"$1 "/e %; +print +($_ eq "x " and !length $@) ? "ok 82\n" : "not ok 82\n# \$_ eq $_, $@\n"; +$x = $x = 'interp'; +eval q% ($_ = "x") =~ s/x(($x)*)/"$1"/e %; +print +($_ eq '' and !length $@) ? "ok 83\n" : "not ok 83\n# \$_ eq $_, $@\n"; + +$_ = "C:/"; +s/^([a-z]:)/\u$1/ and print "not "; +print "ok 84\n"; + diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t new file mode 100755 index 0000000..e2e7c0e5 --- /dev/null +++ b/contrib/perl5/t/op/subst_amp.t @@ -0,0 +1,104 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; + require Config; import Config; +} + +print "1..13\n"; + +$_ = 'x' x 20; +s/\d*|x/<$&>/g; +$foo = '<>' . ('<x><>' x 20) ; +print ($_ eq $foo ? "ok 1\n" : "not ok 1\n#'$_'\n#'$foo'\n"); + +$t = 'aaa'; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/xx/g; +print "not " unless "$_ @res" eq 'axxxx aaa a aaa aa'; +print "ok 2\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/x/g; +print "not " unless "$_ @res" eq 'axx aaa a aaa aa'; +print "ok 3\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/xx/; +print "not " unless "$_ @res" eq 'axxa aaa a'; +print "ok 4\n"; + +$_ = $t; +@res = (); +pos = 1; +s/\Ga(?{push @res, $_, $`})/x/; +print "not " unless "$_ @res" eq 'axa aaa a'; +print "ok 5\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/xx/g; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; +print "ok 6\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x/g; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; +print "ok 7\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/xx/; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; +print "ok 8\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x/; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; +print "ok 9\n"; + +sub x2 {'xx'} +sub x1 {'x'} + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x2/ge; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxxx aaa a aaa aa'; +print "ok 10\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x1/ge; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axx aaa a aaa aa'; +print "ok 11\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x2/e; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axxa aaa a'; +print "ok 12\n"; + +$a = $t; +@res = (); +pos ($a) = 1; +$a =~ s/\Ga(?{push @res, $_, $`})/x1/e; +print "#'$a' '@res'\nnot " unless "$a @res" eq 'axa aaa a'; +print "ok 13\n"; + diff --git a/contrib/perl5/t/op/subst_wamp.t b/contrib/perl5/t/op/subst_wamp.t new file mode 100755 index 0000000..b716b30 --- /dev/null +++ b/contrib/perl5/t/op/subst_wamp.t @@ -0,0 +1,11 @@ +#!./perl + +$dummy = defined $&; # Now we have it... +for $file ('op/subst.t', 't/op/subst.t') { + if (-r $file) { + do $file; + exit; + } +} +die "Cannot find op/subst.t or t/op/subst.t\n"; + diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t index 87efcb4..5764e67 100755 --- a/contrib/perl5/t/op/substr.t +++ b/contrib/perl5/t/op/substr.t @@ -1,12 +1,14 @@ -#!./perl -print "1..106\n"; +print "1..125\n"; #P = start of string Q = start of substr R = end of substr S = end of string -$a = 'abcdefxyz'; -BEGIN { $^W = 1 }; +BEGIN { + unshift @INC, '../lib' if -d '../lib' ; +} +use warnings ; +$a = 'abcdefxyz'; $SIG{__WARN__} = sub { if ($_[0] =~ /^substr outside of string/) { $w++; @@ -19,139 +21,198 @@ $SIG{__WARN__} = sub { } }; -sub fail { !defined(shift) && $w-- }; +sub ok { print (($_[1] ? "" : "not ") . "ok $_[0]\n") } + +$FATAL_MSG = '^substr outside of string' ; -print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n"); # P=Q R S -print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n"); # P Q R S -print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n"); # P Q S R -print (fail(substr($a,999,999)) ? "ok 4\n" : "not ok 4\n"); # P R Q S -print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n"); # P=Q R S -print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n"); # P Q R S +ok 1, substr($a,0,3) eq 'abc'; # P=Q R S +ok 2, substr($a,3,3) eq 'def'; # P Q R S +ok 3, substr($a,6,999) eq 'xyz'; # P Q S R +$b = substr($a,999,999) ; # warn # P R Q S +ok 4, $w-- == 1 ; +eval{substr($a,999,999) = "" ; };# P R Q S +ok 5, $@ =~ /$FATAL_MSG/; +ok 6, substr($a,0,-6) eq 'abc'; # P=Q R S +ok 7, substr($a,-3,1) eq 'x'; # P Q R S $[ = 1; -print (substr($a,1,3) eq 'abc' ? "ok 7\n" : "not ok 7\n"); # P=Q R S -print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n"); # P Q R S -print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n"); # P Q S R -print (fail(substr($a,999,999)) ? "ok 10\n" : "not ok 10\n");# P R Q S -print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");# P=Q R S -print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n"); # P Q R S +ok 8, substr($a,1,3) eq 'abc' ; # P=Q R S +ok 9, substr($a,4,3) eq 'def' ; # P Q R S +ok 10, substr($a,7,999) eq 'xyz';# P Q S R +$b = substr($a,999,999) ; # warn # P R Q S +ok 11, $w-- == 1 ; +eval{substr($a,999,999) = "" ; } ; # P R Q S +ok 12, $@ =~ /$FATAL_MSG/; +ok 13, substr($a,1,-6) eq 'abc' ;# P=Q R S +ok 14, substr($a,-3,1) eq 'x' ; # P Q R S $[ = 0; substr($a,3,3) = 'XYZ'; -print $a eq 'abcXYZxyz' ? "ok 13\n" : "not ok 13\n"; +ok 15, $a eq 'abcXYZxyz' ; substr($a,0,2) = ''; -print $a eq 'cXYZxyz' ? "ok 14\n" : "not ok 14\n"; +ok 16, $a eq 'cXYZxyz' ; substr($a,0,0) = 'ab'; -print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n"; +ok 17, $a eq 'abcXYZxyz' ; substr($a,0,0) = '12345678'; -print $a eq '12345678abcXYZxyz' ? "ok 16\n" : "not ok 16\n"; +ok 18, $a eq '12345678abcXYZxyz' ; substr($a,-3,3) = 'def'; -print $a eq '12345678abcXYZdef' ? "ok 17\n" : "not ok 17\n"; +ok 19, $a eq '12345678abcXYZdef'; substr($a,-3,3) = '<'; -print $a eq '12345678abcXYZ<' ? "ok 18\n" : "not ok 18\n"; +ok 20, $a eq '12345678abcXYZ<' ; substr($a,-1,1) = '12345678'; -print $a eq '12345678abcXYZ12345678' ? "ok 19\n" : "not ok 19\n"; +ok 21, $a eq '12345678abcXYZ12345678' ; $a = 'abcdefxyz'; -print (substr($a,6) eq 'xyz' ? "ok 20\n" : "not ok 20\n"); # P Q R=S -print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n"); # P Q R=S -print (fail(substr($a,999)) ? "ok 22\n" : "not ok 22\n"); # P R=S Q -print (substr($a,0) eq 'abcdefxyz' ? "ok 23\n" : "not ok 23\n");# P=Q R=S -print (substr($a,9) eq '' ? "ok 24\n" : "not ok 24\n"); # P Q=R=S -print (substr($a,-11) eq 'abcdefxyz' ? "ok 25\n" : "not ok 25\n");# Q P R=S -print (substr($a,-9) eq 'abcdefxyz' ? "ok 26\n" : "not ok 26\n"); # P=Q R=S +ok 22, substr($a,6) eq 'xyz' ; # P Q R=S +ok 23, substr($a,-3) eq 'xyz' ; # P Q R=S +$b = substr($a,999,999) ; # warning # P R=S Q +ok 24, $w-- == 1 ; +eval{substr($a,999,999) = "" ; } ; # P R=S Q +ok 25, $@ =~ /$FATAL_MSG/; +ok 26, substr($a,0) eq 'abcdefxyz' ; # P=Q R=S +ok 27, substr($a,9) eq '' ; # P Q=R=S +ok 28, substr($a,-11) eq 'abcdefxyz'; # Q P R=S +ok 29, substr($a,-9) eq 'abcdefxyz'; # P=Q R=S $a = '54321'; -print (fail(substr($a,-7, 1)) ? "ok 27\n" : "not ok 27\n"); # Q R P S -print (fail(substr($a,-7,-6)) ? "ok 28\n" : "not ok 28\n"); # Q R P S -print (substr($a,-5,-7) eq '' ? "ok 29\n" : "not ok 29\n"); # R P=Q S -print (substr($a, 2,-7) eq '' ? "ok 30\n" : "not ok 30\n"); # R P Q S -print (substr($a,-3,-7) eq '' ? "ok 31\n" : "not ok 31\n"); # R P Q S -print (substr($a, 2,-5) eq '' ? "ok 32\n" : "not ok 32\n"); # P=R Q S -print (substr($a,-3,-5) eq '' ? "ok 33\n" : "not ok 33\n"); # P=R Q S -print (substr($a, 2,-4) eq '' ? "ok 34\n" : "not ok 34\n"); # P R Q S -print (substr($a,-3,-4) eq '' ? "ok 35\n" : "not ok 35\n"); # P R Q S -print (substr($a, 5,-6) eq '' ? "ok 36\n" : "not ok 36\n"); # R P Q=S -print (substr($a, 5,-5) eq '' ? "ok 37\n" : "not ok 37\n"); # P=R Q S -print (substr($a, 5,-3) eq '' ? "ok 38\n" : "not ok 38\n"); # P R Q=S -print (fail(substr($a, 7,-7)) ? "ok 39\n" : "not ok 39\n"); # R P S Q -print (fail(substr($a, 7,-5)) ? "ok 40\n" : "not ok 40\n"); # P=R S Q -print (fail(substr($a, 7,-3)) ? "ok 41\n" : "not ok 41\n"); # P R S Q -print (fail(substr($a, 7, 0)) ? "ok 42\n" : "not ok 42\n"); # P S Q=R - -print (substr($a,-7,2) eq '' ? "ok 43\n" : "not ok 43\n"); # Q P=R S -print (substr($a,-7,4) eq '54' ? "ok 44\n" : "not ok 44\n"); # Q P R S -print (substr($a,-7,7) eq '54321' ? "ok 45\n" : "not ok 45\n");# Q P R=S -print (substr($a,-7,9) eq '54321' ? "ok 46\n" : "not ok 46\n");# Q P S R -print (substr($a,-5,0) eq '' ? "ok 47\n" : "not ok 47\n"); # P=Q=R S -print (substr($a,-5,3) eq '543' ? "ok 48\n" : "not ok 48\n");# P=Q R S -print (substr($a,-5,5) eq '54321' ? "ok 49\n" : "not ok 49\n");# P=Q R=S -print (substr($a,-5,7) eq '54321' ? "ok 50\n" : "not ok 50\n");# P=Q S R -print (substr($a,-3,0) eq '' ? "ok 51\n" : "not ok 51\n"); # P Q=R S -print (substr($a,-3,3) eq '321' ? "ok 52\n" : "not ok 52\n");# P Q R=S -print (substr($a,-2,3) eq '21' ? "ok 53\n" : "not ok 53\n"); # P Q S R -print (substr($a,0,-5) eq '' ? "ok 54\n" : "not ok 54\n"); # P=Q=R S -print (substr($a,2,-3) eq '' ? "ok 55\n" : "not ok 55\n"); # P Q=R S -print (substr($a,0,0) eq '' ? "ok 56\n" : "not ok 56\n"); # P=Q=R S -print (substr($a,0,5) eq '54321' ? "ok 57\n" : "not ok 57\n");# P=Q R=S -print (substr($a,0,7) eq '54321' ? "ok 58\n" : "not ok 58\n");# P=Q S R -print (substr($a,2,0) eq '' ? "ok 59\n" : "not ok 59\n"); # P Q=R S -print (substr($a,2,3) eq '321' ? "ok 60\n" : "not ok 60\n"); # P Q R=S -print (substr($a,5,0) eq '' ? "ok 61\n" : "not ok 61\n"); # P Q=R=S -print (substr($a,5,2) eq '' ? "ok 62\n" : "not ok 62\n"); # P Q=S R -print (substr($a,-7,-5) eq '' ? "ok 63\n" : "not ok 63\n"); # Q P=R S -print (substr($a,-7,-2) eq '543' ? "ok 64\n" : "not ok 64\n");# Q P R S -print (substr($a,-5,-5) eq '' ? "ok 65\n" : "not ok 65\n"); # P=Q=R S -print (substr($a,-5,-2) eq '543' ? "ok 66\n" : "not ok 66\n");# P=Q R S -print (substr($a,-3,-3) eq '' ? "ok 67\n" : "not ok 67\n"); # P Q=R S -print (substr($a,-3,-1) eq '32' ? "ok 68\n" : "not ok 68\n");# P Q R S +$b = substr($a,-7, 1) ; # warn # Q R P S +ok 30, $w-- == 1 ; +eval{substr($a,-7, 1) = "" ; }; # Q R P S +ok 31, $@ =~ /$FATAL_MSG/; +$b = substr($a,-7,-6) ; # warn # Q R P S +ok 32, $w-- == 1 ; +eval{substr($a,-7,-6) = "" ; }; # Q R P S +ok 33, $@ =~ /$FATAL_MSG/; +ok 34, substr($a,-5,-7) eq ''; # R P=Q S +ok 35, substr($a, 2,-7) eq ''; # R P Q S +ok 36, substr($a,-3,-7) eq ''; # R P Q S +ok 37, substr($a, 2,-5) eq ''; # P=R Q S +ok 38, substr($a,-3,-5) eq ''; # P=R Q S +ok 39, substr($a, 2,-4) eq ''; # P R Q S +ok 40, substr($a,-3,-4) eq ''; # P R Q S +ok 41, substr($a, 5,-6) eq ''; # R P Q=S +ok 42, substr($a, 5,-5) eq ''; # P=R Q S +ok 43, substr($a, 5,-3) eq ''; # P R Q=S +$b = substr($a, 7,-7) ; # warn # R P S Q +ok 44, $w-- == 1 ; +eval{substr($a, 7,-7) = "" ; }; # R P S Q +ok 45, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7,-5) ; # warn # P=R S Q +ok 46, $w-- == 1 ; +eval{substr($a, 7,-5) = "" ; }; # P=R S Q +ok 47, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7,-3) ; # warn # P Q S Q +ok 48, $w-- == 1 ; +eval{substr($a, 7,-3) = "" ; }; # P Q S Q +ok 49, $@ =~ /$FATAL_MSG/; +$b = substr($a, 7, 0) ; # warn # P S Q=R +ok 50, $w-- == 1 ; +eval{substr($a, 7, 0) = "" ; }; # P S Q=R +ok 51, $@ =~ /$FATAL_MSG/; + +ok 52, substr($a,-7,2) eq ''; # Q P=R S +ok 53, substr($a,-7,4) eq '54'; # Q P R S +ok 54, substr($a,-7,7) eq '54321';# Q P R=S +ok 55, substr($a,-7,9) eq '54321';# Q P S R +ok 56, substr($a,-5,0) eq ''; # P=Q=R S +ok 57, substr($a,-5,3) eq '543';# P=Q R S +ok 58, substr($a,-5,5) eq '54321';# P=Q R=S +ok 59, substr($a,-5,7) eq '54321';# P=Q S R +ok 60, substr($a,-3,0) eq ''; # P Q=R S +ok 61, substr($a,-3,3) eq '321';# P Q R=S +ok 62, substr($a,-2,3) eq '21'; # P Q S R +ok 63, substr($a,0,-5) eq ''; # P=Q=R S +ok 64, substr($a,2,-3) eq ''; # P Q=R S +ok 65, substr($a,0,0) eq ''; # P=Q=R S +ok 66, substr($a,0,5) eq '54321';# P=Q R=S +ok 67, substr($a,0,7) eq '54321';# P=Q S R +ok 68, substr($a,2,0) eq ''; # P Q=R S +ok 69, substr($a,2,3) eq '321'; # P Q R=S +ok 70, substr($a,5,0) eq ''; # P Q=R=S +ok 71, substr($a,5,2) eq ''; # P Q=S R +ok 72, substr($a,-7,-5) eq ''; # Q P=R S +ok 73, substr($a,-7,-2) eq '543';# Q P R S +ok 74, substr($a,-5,-5) eq ''; # P=Q=R S +ok 75, substr($a,-5,-2) eq '543';# P=Q R S +ok 76, substr($a,-3,-3) eq ''; # P Q=R S +ok 77, substr($a,-3,-1) eq '32';# P Q R S $a = ''; -print (substr($a,-2,2) eq '' ? "ok 69\n" : "not ok 69\n"); # Q P=R=S -print (substr($a,0,0) eq '' ? "ok 70\n" : "not ok 70\n"); # P=Q=R=S -print (substr($a,0,1) eq '' ? "ok 71\n" : "not ok 71\n"); # P=Q=S R -print (substr($a,-2,3) eq '' ? "ok 72\n" : "not ok 72\n"); # Q P=S R -print (substr($a,-2) eq '' ? "ok 73\n" : "not ok 73\n"); # Q P=R=S -print (substr($a,0) eq '' ? "ok 74\n" : "not ok 74\n"); # P=Q=R=S +ok 78, substr($a,-2,2) eq ''; # Q P=R=S +ok 79, substr($a,0,0) eq ''; # P=Q=R=S +ok 80, substr($a,0,1) eq ''; # P=Q=S R +ok 81, substr($a,-2,3) eq ''; # Q P=S R +ok 82, substr($a,-2) eq ''; # Q P=R=S +ok 83, substr($a,0) eq ''; # P=Q=R=S + + +ok 84, substr($a,0,-1) eq ''; # R P=Q=S +$b = substr($a,-2, 0) ; # warn # Q=R P=S +ok 85, $w-- == 1 ; +eval{substr($a,-2, 0) = "" ; }; # Q=R P=S +ok 86, $@ =~ /$FATAL_MSG/; +$b = substr($a,-2, 1) ; # warn # Q R P=S +ok 87, $w-- == 1 ; +eval{substr($a,-2, 1) = "" ; }; # Q R P=S +ok 88, $@ =~ /$FATAL_MSG/; -print (substr($a,0,-1) eq '' ? "ok 75\n" : "not ok 75\n"); # R P=Q=S -print (fail(substr($a,-2,0)) ? "ok 76\n" : "not ok 76\n"); # Q=R P=S -print (fail(substr($a,-2,1)) ? "ok 77\n" : "not ok 77\n"); # Q R P=S -print (fail(substr($a,-2,-1)) ? "ok 78\n" : "not ok 78\n"); # Q R P=S -print (fail(substr($a,-2,-2)) ? "ok 79\n" : "not ok 79\n"); # Q=R P=S -print (fail(substr($a,1,-2)) ? "ok 80\n" : "not ok 81\n"); # R P=S Q -print (fail(substr($a,1,1)) ? "ok 81\n" : "not ok 81\n"); # P=S Q R -print (fail(substr($a,1,0)) ? "ok 82\n" : "not ok 82\n"); # P=S Q=R -print (fail(substr($a,1)) ? "ok 83\n" : "not ok 83\n"); # P=R=S Q +$b = substr($a,-2,-1) ; # warn # Q R P=S +ok 89, $w-- == 1 ; +eval{substr($a,-2,-1) = "" ; }; # Q R P=S +ok 90, $@ =~ /$FATAL_MSG/; +$b = substr($a,-2,-2) ; # warn # Q=R P=S +ok 91, $w-- == 1 ; +eval{substr($a,-2,-2) = "" ; }; # Q=R P=S +ok 92, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1,-2) ; # warn # R P=S Q +ok 93, $w-- == 1 ; +eval{substr($a, 1,-2) = "" ; }; # R P=S Q +ok 94, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1, 1) ; # warn # P=S Q R +ok 95, $w-- == 1 ; +eval{substr($a, 1, 1) = "" ; }; # P=S Q R +ok 96, $@ =~ /$FATAL_MSG/; + +$b = substr($a, 1, 0) ;# warn # P=S Q=R +ok 97, $w-- == 1 ; +eval{substr($a, 1, 0) = "" ; }; # P=S Q=R +ok 98, $@ =~ /$FATAL_MSG/; + +$b = substr($a,1) ; # warning # P=R=S Q +ok 99, $w-- == 1 ; +eval{substr($a,1) = "" ; }; # P=R=S Q +ok 100, $@ =~ /$FATAL_MSG/; my $a = 'zxcvbnm'; substr($a,2,0) = ''; -print $a eq 'zxcvbnm' ? "ok 84\n" : "not ok 84\n"; +ok 101, $a eq 'zxcvbnm'; substr($a,7,0) = ''; -print $a eq 'zxcvbnm' ? "ok 85\n" : "not ok 85\n"; +ok 102, $a eq 'zxcvbnm'; substr($a,5,0) = ''; -print $a eq 'zxcvbnm' ? "ok 86\n" : "not ok 86\n"; +ok 103, $a eq 'zxcvbnm'; substr($a,0,2) = 'pq'; -print $a eq 'pqcvbnm' ? "ok 87\n" : "not ok 87\n"; +ok 104, $a eq 'pqcvbnm'; substr($a,2,0) = 'r'; -print $a eq 'pqrcvbnm' ? "ok 88\n" : "not ok 88\n"; +ok 105, $a eq 'pqrcvbnm'; substr($a,8,0) = 'asd'; -print $a eq 'pqrcvbnmasd' ? "ok 89\n" : "not ok 89\n"; +ok 106, $a eq 'pqrcvbnmasd'; substr($a,0,2) = 'iop'; -print $a eq 'ioprcvbnmasd' ? "ok 90\n" : "not ok 90\n"; +ok 107, $a eq 'ioprcvbnmasd'; substr($a,0,5) = 'fgh'; -print $a eq 'fghvbnmasd' ? "ok 91\n" : "not ok 91\n"; +ok 108, $a eq 'fghvbnmasd'; substr($a,3,5) = 'jkl'; -print $a eq 'fghjklsd' ? "ok 92\n" : "not ok 92\n"; +ok 109, $a eq 'fghjklsd'; substr($a,3,2) = '1234'; -print $a eq 'fgh1234lsd' ? "ok 93\n" : "not ok 93\n"; +ok 110, $a eq 'fgh1234lsd'; # with lexicals (and in re-entered scopes) @@ -160,52 +221,50 @@ for (0,1) { unless ($_) { $txt = "Foo"; substr($txt, -1) = "X"; - print $txt eq "FoX" ? "ok 94\n" : "not ok 94\n"; + ok 111, $txt eq "FoX"; } else { - local $^W = 0; # because of (spurious?) "uninitialised value" substr($txt, 0, 1) = "X"; - print $txt eq "X" ? "ok 95\n" : "not ok 95\n"; + ok 112, $txt eq "X"; } } +$w = 0 ; # coercion of references { my $s = []; substr($s, 0, 1) = 'Foo'; - print substr($s,0,7) eq "FooRRAY" && !($w-=2) ? "ok 96\n" : "not ok 96\n"; + ok 113, substr($s,0,7) eq "FooRRAY" && !($w-=2); } # check no spurious warnings -print $w ? "not ok 97\n" : "ok 97\n"; +ok 114, $w == 0; # check new 4 arg replacement syntax $a = "abcxyz"; $w = 0; -print "not " unless substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; -print "ok 98\n"; -print "not " unless substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; -print "ok 99\n"; -print "not " unless substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; -print "ok 100\n"; - -print "not " unless substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" +ok 115, substr($a, 0, 3, "") eq "abc" && $a eq "xyz"; +ok 116, substr($a, 0, 0, "abc") eq "" && $a eq "abcxyz"; +ok 117, substr($a, 3, -1, "") eq "xy" && $a eq "abcz"; + +ok 118, substr($a, 3, undef, "xy") eq "" && $a eq "abcxyz" && $w == 3; -print "ok 101\n"; + $w = 0; -print "not " unless substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; -print "ok 102\n"; -print "not " unless fail(substr($a, -99, 0, "")); -print "ok 103\n"; -print "not " unless fail(substr($a, 99, 3, "")); -print "ok 104\n"; +ok 119, substr($a, 3, 9999999, "") eq "xyz" && $a eq "abc"; +eval{substr($a, -99, 0, "") }; +ok 120, $@ =~ /$FATAL_MSG/; +eval{substr($a, 99, 3, "") }; +ok 121, $@ =~ /$FATAL_MSG/; substr($a, 0, length($a), "foo"); -print "not " unless $a eq "foo" && !$w; -print "ok 105\n"; +ok 122, $a eq "foo" && !$w; # using 4 arg substr as lvalue is a compile time error eval 'substr($a,0,0,"") = "abc"'; -print "not " unless $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; -print "ok 106\n"; +ok 123, $@ && $@ =~ /Can't modify substr/ && $a eq "foo"; + +$a = "abcdefgh"; +ok 124, sub { shift }->(substr($a, 0, 4, "xxxx")) eq 'abcd'; +ok 125, $a eq 'xxxxefgh'; diff --git a/contrib/perl5/t/op/sysio.t b/contrib/perl5/t/op/sysio.t index 22e60e3..e43f850 100755 --- a/contrib/perl5/t/op/sysio.t +++ b/contrib/perl5/t/op/sysio.t @@ -2,7 +2,7 @@ print "1..39\n"; -chdir('op') || die "sysio.t: cannot look for myself: $!"; +chdir('op') || chdir('t/op') || die "sysio.t: cannot look for myself: $!"; open(I, 'sysio.t') || die "sysio.t: cannot find myself: $!"; diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index 379093f..6548b46 100755 --- a/contrib/perl5/t/op/taint.t +++ b/contrib/perl5/t/op/taint.t @@ -9,7 +9,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } use strict; @@ -19,6 +19,17 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +BEGIN { + if ($^O eq 'VMS' && !defined($Config{d_setenv})) { + $ENV{PATH} = $ENV{PATH}; + $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy'; + } + if ($Config{d_shm} || $Config{d_msg}) { + require IPC::SysV; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } +} + my $Is_VMS = $^O eq 'VMS'; my $Is_MSWin32 = $^O eq 'MSWin32'; my $Is_Dos = $^O eq 'dos'; @@ -33,9 +44,9 @@ if ($Is_VMS) { } eval <<EndOfCleanup; END { - \$ENV{PATH} = ''; + \$ENV{PATH} = '' if $Config{d_setenv}; warn "# Note: logical name 'PATH' may have been deleted\n"; - @ENV{keys %old} = values %old; + \@ENV{keys %old} = values %old; } EndOfCleanup } @@ -87,7 +98,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..149\n"; +print "1..151\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -130,7 +141,7 @@ print "1..149\n"; } else { $tmp = (grep { defined and -d and (stat _)[2] & 2 } - qw(/tmp /var/tmp /usr/tmp /sys$scratch), + qw(sys$scratch /tmp /var/tmp /usr/tmp), @ENV{qw(TMP TEMP)})[0] or print "# can't find world-writeable directory to test PATH\n"; } @@ -247,7 +258,8 @@ print "1..149\n"; # Globs should be forbidden, except under VMS, # which doesn't spawn an external program. -if ($Is_VMS) { +if (1 # built-in glob + or $Is_VMS) { for (35..36) { print "ok $_\n"; } } else { @@ -383,10 +395,10 @@ else { for (76..79) { print "ok $_ # Skipped: open('|') is not available\n" } } else { - test 76, eval { open FOO, "| $foo" } eq '', 'popen to'; + test 76, eval { open FOO, "| x$foo" } eq '', 'popen to'; test 77, $@ =~ /^Insecure dependency/, $@; - test 78, eval { open FOO, "$foo |" } eq '', 'popen from'; + test 78, eval { open FOO, "x$foo |" } eq '', 'popen from'; test 79, $@ =~ /^Insecure dependency/, $@; } @@ -539,14 +551,14 @@ else { my @getpwent = getpwent(); die "getpwent: $!\n" unless (@getpwent); test 142,( not tainted $getpwent[0] - and not tainted $getpwent[1] + and tainted $getpwent[1] and not tainted $getpwent[2] and not tainted $getpwent[3] and not tainted $getpwent[4] and not tainted $getpwent[5] - and tainted $getpwent[6] # gecos + and tainted $getpwent[6] # ge?cos and not tainted $getpwent[7] - and not tainted $getpwent[8]); + and tainted $getpwent[8]); # shell endpwent(); } else { for (142) { print "ok $_ # Skipped: getpwent() is not available\n" } @@ -597,3 +609,74 @@ else { $why =~ s/e/'-'.$$/ge; test 149, tainted $why; } + +# test shmread +{ + if ($Config{d_shm}) { + no strict 'subs'; + my $sent = "foobar"; + my $rcvd; + my $size = 2000; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU) || + warn "# shmget failed: $!\n"; + if (defined $id) { + if (shmwrite($id, $sent, 0, 60)) { + if (shmread($id, $rcvd, 0, 60)) { + substr($rcvd, index($rcvd, "\0")) = ''; + } else { + warn "# shmread failed: $!\n"; + } + } else { + warn "# shmwrite failed: $!\n"; + } + shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + } else { + warn "# shmget failed: $!\n"; + } + + if ($rcvd eq $sent) { + test 150, tainted $rcvd; + } else { + print "ok 150 # Skipped: SysV shared memory operation failed\n"; + } + } else { + print "ok 150 # Skipped: SysV shared memory is not available\n"; + } +} + +# test msgrcv +{ + if ($Config{d_msg}) { + no strict 'subs'; + my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); + + my $sent = "message"; + my $type_sent = 1234; + my $rcvd; + my $type_rcvd; + + if (defined $id) { + if (msgsnd($id, pack("l! a*", $type_sent, $sent), 0)) { + if (msgrcv($id, $rcvd, 60, 0, 0)) { + ($type_rcvd, $rcvd) = unpack("l! a*", $rcvd); + } else { + warn "# msgrcv failed\n"; + } + } else { + warn "# msgsnd failed\n"; + } + msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + } else { + warn "# msgget failed\n"; + } + + if ($rcvd eq $sent && $type_sent == $type_rcvd) { + test 151, tainted $rcvd; + } else { + print "ok 151 # Skipped: SysV message queue operation failed\n"; + } + } else { + print "ok 151 # Skipped: SysV message queues are not available\n"; + } +} + diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 472a6a7..9543420 100755 --- a/contrib/perl5/t/op/tie.t +++ b/contrib/perl5/t/op/tie.t @@ -6,7 +6,7 @@ # Currently it only tests the untie warning chdir 't' if -d 't'; -@INC = "../lib"; +unshift @INC, "../lib"; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -77,8 +77,7 @@ EXPECT ######## # strict behaviour, without any extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -86,8 +85,7 @@ EXPECT ######## # strict behaviour, with 1 extra references generating an error -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; @@ -96,8 +94,7 @@ untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references via tied generating an error -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -107,8 +104,7 @@ untie attempted while 1 inner references still exist ######## # strict behaviour, with 1 extra references which are destroyed -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; @@ -117,8 +113,7 @@ EXPECT ######## # strict behaviour, with extra 1 references via tied which are destroyed -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; @@ -128,8 +123,7 @@ EXPECT ######## # strict error behaviour, with 2 extra references -#use warning 'untie'; -local $^W = 1 ; +use warnings 'untie'; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; @@ -139,14 +133,12 @@ untie attempted while 2 inner references still exist ######## # strict behaviour, check scope of strictness. -#no warning 'untie'; -local $^W = 0 ; +no warnings 'untie'; use Tie::Hash ; $A = tie %H, Tie::StdHash; $C = $B = tied %H ; { - #use warning 'untie'; - local $^W = 1 ; + use warnings 'untie'; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; @@ -166,3 +158,15 @@ sub Self::DESTROY { $b = $_[0] + 0; } } die unless $a == $b; EXPECT +######## +# Interaction of tie and vec + +my ($a, $b); +use Tie::Scalar; +tie $a,Tie::StdScalar or die; +vec($b,1,1)=1; +$a = $b; +vec($a,1,1)=0; +vec($b,1,1)=0; +die unless $a eq $b; +EXPECT diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t index 8e78b2f..25fda3f 100755 --- a/contrib/perl5/t/op/tiearray.t +++ b/contrib/perl5/t/op/tiearray.t @@ -3,7 +3,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my %seen; diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index d7e6a78..6ae3faa 100755 --- a/contrib/perl5/t/op/tiehandle.t +++ b/contrib/perl5/t/op/tiehandle.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib'; + unshift @INC, '../lib'; } my @expect; diff --git a/contrib/perl5/t/op/time.t b/contrib/perl5/t/op/time.t index 1bec442..caf2c14 100755 --- a/contrib/perl5/t/op/time.t +++ b/contrib/perl5/t/op/time.t @@ -2,7 +2,7 @@ # $RCSfile: time.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:32 $ -if ($does_gmtime = gmtime(time)) { print "1..5\n" } +if ($does_gmtime = gmtime(time)) { print "1..6\n" } else { print "1..3\n" } ($beguser,$begsys) = times; @@ -45,3 +45,9 @@ if (index(" :0:1:-1:364:365:-364:-365:",':' . ($localyday - $yday) . ':') > 0) {print "ok 5\n";} else {print "not ok 5\n";} + +# This could be stricter. +if (gmtime() =~ /^(Sun|Mon|Tue|Wed|Thu|Fri|Sat) (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec) ([ \d]\d) (\d\d):(\d\d):(\d\d) (\d\d\d\d)$/) + {print "ok 6\n";} +else + {print "not ok 6\n";} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t index 3503c3c..4e6667c 100755 --- a/contrib/perl5/t/op/tr.t +++ b/contrib/perl5/t/op/tr.t @@ -1,5 +1,10 @@ # tr.t +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib"; +} + print "1..4\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -22,12 +27,13 @@ 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). +{ + no utf8; + $_ = "I\xcaJ"; -$_ = "I\xcaJ"; - -tr/I-J/i-j/; - -print "not " unless $_ eq "i\xcaj"; -print "ok 4\n"; + 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 5b3c7ef..8944ee3 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -1,6 +1,11 @@ #!./perl -print "1..23\n"; +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib'; +} + +print "1..27\n"; print defined($a) ? "not ok 1\n" : "ok 1\n"; @@ -59,3 +64,18 @@ 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"; +{ + require Tie::Hash; + tie my %foo, 'Tie::StdHash'; + print defined %foo ? "ok 24\n" : "not ok 24\n"; + %foo = ( a => 1 ); + print defined %foo ? "ok 25\n" : "not ok 25\n"; +} + +{ + require Tie::Array; + tie my @foo, 'Tie::StdArray'; + print defined @foo ? "ok 26\n" : "not ok 26\n"; + @foo = ( a => 1 ); + print defined @foo ? "ok 27\n" : "not ok 27\n"; +} diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t index bde78fd..a6bd03d 100755 --- a/contrib/perl5/t/op/universal.t +++ b/contrib/perl5/t/op/universal.t @@ -5,10 +5,10 @@ BEGIN { chdir 't' if -d 't'; - @INC = '../lib' if -d '../lib'; + unshift @INC, '../lib' if -d '../lib'; } -print "1..72\n"; +print "1..73\n"; $a = {}; bless $a, "Bob"; @@ -70,7 +70,7 @@ test ! $a->can("export_tags"); # a method in Exporter test (eval { $a->VERSION }) == 2.718; test ! (eval { $a->VERSION(2.719) }) && - $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /; + $@ =~ /^Alice version 2.71(?:9|8999\d+) required--this is only version 2.718 at /; test (eval { $a->VERSION(2.718) }) && ! $@; @@ -102,3 +102,5 @@ test $a->can("sleep"); test ! UNIVERSAL::can($b, "can"); test ! $a->can("export_tags"); # a method in Exporter + +test ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t index 7117144..bf60fc4 100755 --- a/contrib/perl5/t/op/vec.t +++ b/contrib/perl5/t/op/vec.t @@ -8,7 +8,7 @@ print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; vec($foo,0,1) = 1; print length($foo) == 1 ? "ok 3\n" : "not ok 3\n"; -print ord($foo) == 1 ? "ok 4\n" : "not ok 4\n"; +print unpack('C',$foo) == 1 ? "ok 4\n" : "not ok 4\n"; print vec($foo,0,1) == 1 ? "ok 5\n" : "not ok 5\n"; print vec($foo,20,1) == 0 ? "ok 6\n" : "not ok 6\n"; @@ -18,7 +18,7 @@ print length($foo) == 3 ? "ok 8\n" : "not ok 8\n"; print vec($foo,1,8) == 0 ? "ok 9\n" : "not ok 9\n"; vec($foo,1,8) = 0xf1; print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n"; -print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); +print ((unpack('C',substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n"); print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n"; print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n"; vec($Vec, 0, 32) = 0xbaddacab; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t new file mode 100755 index 0000000..b08849f --- /dev/null +++ b/contrib/perl5/t/op/ver.t @@ -0,0 +1,96 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, "../lib"; +} + +print "1..22\n"; + +my $test = 1; + +use v5.5.640; +require v5.5.640; +print "ok $test\n"; ++$test; + +# printing characters should work +print v111; +print v107.32; +print "$test\n"; ++$test; + +# hash keys too +$h{v111.107} = "ok"; +print "$h{ok} $test\n"; ++$test; + +# poetry optimization should also +sub v77 { "ok" } +$x = v77; +print "$x $test\n"; ++$test; + +# but not when dots are involved +$x = v77.78.79; +print "not " unless $x eq "MNO"; +print "ok $test\n"; ++$test; + +print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; +print "ok $test\n"; ++$test; + +# +# now do the same without the "v" +use 5.5.640; +require 5.5.640; +print "ok $test\n"; ++$test; + +# hash keys too +$h{111.107.32} = "ok"; +print "$h{ok } $test\n"; ++$test; + +$x = 77.78.79; +print "not " unless $x eq "MNO"; +print "ok $test\n"; ++$test; + +print "not " unless 1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}"; +print "ok $test\n"; ++$test; + +# test sprintf("%vd"...) etc +print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%vX", 1.22.333.4444) eq '1.16.14D.115C'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +print "ok $test\n"; ++$test; + +print "not " unless sprintf("%*vb", "##", v1.22.333.4444) + eq '1##10110##101001101##1000101011100'; +print "ok $test\n"; ++$test; + +{ + use bytes; + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + print "ok $test\n"; ++$test; + + print "not " unless + sprintf("%vd", 1.22.333.4444) eq '1.22.197.141.225.133.156'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + print "ok $test\n"; ++$test; + + print "not " unless sprintf("%*vb", "##", v1.22.333.4444) + eq '1##10110##11000101##10001101##11100001##10000101##10011100'; + print "ok $test\n"; ++$test; +} diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 9918b2f..87d5042 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $ - -print "1..6\n"; +print "1..8\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -190,3 +188,16 @@ if (`$CAT Op_write.tmp` eq $right) else { print "not ok 6\n"; } +# test lexicals and globals +{ + my $this = "ok"; + our $that = 7; + format LEX = +@<<@| +$this,$that +. + open(LEX, ">&STDOUT") or die; + write LEX; + $that = 8; + write LEX; +} |
