diff options
Diffstat (limited to 'contrib/perl5/t/op')
65 files changed, 2427 insertions, 377 deletions
diff --git a/contrib/perl5/t/op/64bitint.t b/contrib/perl5/t/op/64bitint.t index 60f72c3..88fbc55 100755 --- a/contrib/perl5/t/op/64bitint.t +++ b/contrib/perl5/t/op/64bitint.t @@ -3,20 +3,20 @@ BEGIN { eval { my $q = pack "q", 0 }; if ($@) { - print "1..0\n# no 64-bit types\n"; + print "1..0\n# Skip: no 64-bit types\n"; exit(0); } chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -# This could use a lot of more tests. +# This could use many more tests. # so that using > 0xfffffff constants and # 32+ bit integers don't cause noise no warnings qw(overflow portable); -print "1..48\n"; +print "1..55\n"; my $q = 12345678901; my $r = 23456789012; @@ -123,85 +123,106 @@ $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"; +if ($^O ne 'unicos') { + $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"; + +} else { + # Unicos has imprecise doubles (14 decimal digits or so), + # especially if operating near the UV/IV limits the low-order bits + # become mangled even by simple arithmetic operations. + for (23..37) { + print "ok $_ # skipped: too imprecise numbers\n"; + } +} $x = ''; @@ -233,10 +254,44 @@ print "ok 45\n"; print "not " unless (0x8000000000000000 | 1) == 0x8000000000000001; print "ok 46\n"; -print "not " unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; +print "not " + unless (0xf000000000000000 & 0x8000000000000000) == 0x8000000000000000; print "ok 47\n"; -print "not " unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; +print "not " + unless (0xf000000000000000 ^ 0xfffffffffffffff0) == 0x0ffffffffffffff0; print "ok 48\n"; + +print "not " + unless (sprintf "%b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 49\n"; + +print "not " + unless (sprintf "%64b", ~0) eq + '1111111111111111111111111111111111111111111111111111111111111111'; +print "ok 50\n"; + +print "not " unless (sprintf "%d", ~0>>1) eq '9223372036854775807'; +print "ok 51\n"; + +print "not " unless (sprintf "%u", ~0) eq '18446744073709551615'; +print "ok 52\n"; + +# If the 53..55 fail you have problems in the parser's string->int conversion, +# see toke.c:scan_num(). + +$q = -9223372036854775808; +print "# $q ne\n# -9223372036854775808\nnot " unless "$q" eq "-9223372036854775808"; +print "ok 53\n"; + +$q = 9223372036854775807; +print "# $q ne\n# 9223372036854775807\nnot " unless "$q" eq "9223372036854775807"; +print "ok 54\n"; + +$q = 18446744073709551615; +print "# $q ne\n# 18446744073709551615\nnot " unless "$q" eq "18446744073709551615"; +print "ok 55\n"; + # eof diff --git a/contrib/perl5/t/op/append.t b/contrib/perl5/t/op/append.t index d115146..5aa4bf9 100755 --- a/contrib/perl5/t/op/append.t +++ b/contrib/perl5/t/op/append.t @@ -2,7 +2,7 @@ # $RCSfile: append.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:36 $ -print "1..3\n"; +print "1..13\n"; $a = 'ab' . 'c'; # compile time $b = 'def'; @@ -19,3 +19,41 @@ $_ = $a; $_ .= $b; print "#3\t:$_: eq :abcdef:\n"; if ($_ eq 'abcdef') {print "ok 3\n";} else {print "not ok 3\n";} + +# test that when right argument of concat is UTF8, and is the same +# variable as the target, and the left argument is not UTF8, it no +# longer frees the wrong string. +{ + sub r2 { + my $string = ''; + $string .= pack("U0a*", 'mnopqrstuvwx'); + $string = "abcdefghijkl$string"; + } + + r2() and print "ok $_\n" for qw/ 4 5 /; +} + +# test that nul bytes get copied +{ +# Character 'b' occurs at codepoint 130 decimal or \202 octal +# under an EBCDIC coded character set. +# my($a, $ab) = ("a", "a\000b"); + my($a, $ab) = ("\141", "\141\000\142"); + my($u, $ub) = map pack("U0a*", $_), $a, $ab; + my $t1 = $a; $t1 .= $ab; + print $t1 =~ /\142/ ? "ok 6\n" : "not ok 6\t# $t1\n"; + my $t2 = $a; $t2 .= $ub; + print $t2 =~ /\142/ ? "ok 7\n" : "not ok 7\t# $t2\n"; + my $t3 = $u; $t3 .= $ab; + print $t3 =~ /\142/ ? "ok 8\n" : "not ok 8\t# $t3\n"; + my $t4 = $u; $t4 .= $ub; + print $t4 =~ /\142/ ? "ok 9\n" : "not ok 9\t# $t4\n"; + my $t5 = $a; $t5 = $ab . $t5; + print $t5 =~ /\142/ ? "ok 10\n" : "not ok 10\t# $t5\n"; + my $t6 = $a; $t6 = $ub . $t6; + print $t6 =~ /\142/ ? "ok 11\n" : "not ok 11\t# $t6\n"; + my $t7 = $u; $t7 = $ab . $t7; + print $t7 =~ /\142/ ? "ok 12\n" : "not ok 12\t# $t7\n"; + my $t8 = $u; $t8 = $ub . $t8; + print $t8 =~ /\142/ ? "ok 13\n" : "not ok 13\t# $t8\n"; +} diff --git a/contrib/perl5/t/op/args.t b/contrib/perl5/t/op/args.t index 48bf5afe..ce2c398 100755 --- a/contrib/perl5/t/op/args.t +++ b/contrib/perl5/t/op/args.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; # test various operations on @_ @@ -52,3 +52,24 @@ sub new4 { goto &new2 } print "# got [@$y], expected [a b c y]\nnot " unless "@$y" eq "a b c y"; print "ok $ord\n"; } + +# see if POPSUB gets to see the right pad across a dounwind() with +# a reified @_ + +sub methimpl { + my $refarg = \@_; + die( "got: @_\n" ); +} + +sub method { + &methimpl; +} + +sub try { + eval { method('foo', 'bar'); }; + print "# $@" if $@; +} + +for (1..5) { try() } +++$ord; +print "ok $ord\n"; diff --git a/contrib/perl5/t/op/arith.t b/contrib/perl5/t/op/arith.t index fe2f0f4..5b04f93 100755 --- a/contrib/perl5/t/op/arith.t +++ b/contrib/perl5/t/op/arith.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..12\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -21,3 +21,10 @@ 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; + +# UVs should behave properly + +try 9, 4063328477 % 65535 == 27407; +try 10, 4063328477 % 4063328476 == 1; +try 11, 4063328477 % 2031664238 == 1; +try 12, 2031664238 % 4063328477 == 2031664238; diff --git a/contrib/perl5/t/op/array.t b/contrib/perl5/t/op/array.t index 1108f49..7cc84e3 100755 --- a/contrib/perl5/t/op/array.t +++ b/contrib/perl5/t/op/array.t @@ -1,6 +1,6 @@ #!./perl -print "1..66\n"; +print "1..70\n"; # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -139,8 +139,8 @@ t("@foo" eq "bar burbl blah"); # 39 @foo = ('XXX',@foo, 'YYY'); t("@foo" eq "XXX bar burbl blah YYY"); # 40 -@foo = @foo = qw(foo bar burbl blah); -t("@foo" eq "foo bar burbl blah"); # 41 +@foo = @foo = qw(foo b\a\r bu\\rbl blah); +t("@foo" eq 'foo b\a\r bu\\rbl blah'); # 41 @bar = @foo = qw(foo bar); # 42 t("@foo" eq "foo bar"); @@ -216,3 +216,16 @@ reify('ok'); print "not " unless qw(foo bar snorfle)[2] eq 'snorfle'; print "ok 66\n"; +@ary = (12,23,34,45,56); + +print "not " unless shift(@ary) == 12; +print "ok 67\n"; + +print "not " unless pop(@ary) == 56; +print "ok 68\n"; + +print "not " unless push(@ary,56) == 4; +print "ok 69\n"; + +print "not " unless unshift(@ary,12) == 5; +print "ok 70\n"; diff --git a/contrib/perl5/t/op/assignwarn.t b/contrib/perl5/t/op/assignwarn.t index b95cec5..aff433c 100755 --- a/contrib/perl5/t/op/assignwarn.t +++ b/contrib/perl5/t/op/assignwarn.t @@ -8,7 +8,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; @@ -21,7 +21,7 @@ sub ok { print $_[1] ? "ok " : "not ok ", $_[0], "\n"; } sub uninitialized { $warn =~ s/Use of uninitialized value[^\n]+\n//s; } -print "1..23\n"; +print "1..32\n"; { my $x; $x ++; ok 1, ! uninitialized; } { my $x; $x --; ok 2, ! uninitialized; } @@ -55,7 +55,19 @@ print "1..23\n"; { my $x; $x |= "x"; ok 21, ! uninitialized; } { my $x; $x ^= "x"; ok 22, ! uninitialized; } -ok 23, $warn eq ''; +{ use integer; my $x; $x += 1; ok 23, ! uninitialized; } +{ use integer; my $x; $x -= 1; ok 24, ! uninitialized; } + +{ use integer; my $x; $x *= 1; ok 25, uninitialized; } +{ use integer; my $x; $x /= 1; ok 26, uninitialized; } +{ use integer; my $x; $x %= 1; ok 27, uninitialized; } + +{ use integer; my $x; $x ++; ok 28, ! uninitialized; } +{ use integer; my $x; $x --; ok 29, ! uninitialized; } +{ use integer; my $x; ++ $x; ok 30, ! uninitialized; } +{ use integer; my $x; -- $x; ok 31, ! uninitialized; } + +ok 32, $warn eq ''; # If we got any errors that we were not expecting, then print them print map "#$_\n", split /\n/, $warn if length $warn; diff --git a/contrib/perl5/t/op/attrs.t b/contrib/perl5/t/op/attrs.t index 615e4d3..2702004 100755 --- a/contrib/perl5/t/op/attrs.t +++ b/contrib/perl5/t/op/attrs.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } sub NTESTS () ; diff --git a/contrib/perl5/t/op/avhv.t b/contrib/perl5/t/op/avhv.t index cd7c957..5b91fd2 100755 --- a/contrib/perl5/t/op/avhv.t +++ b/contrib/perl5/t/op/avhv.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } require Tie::Array; diff --git a/contrib/perl5/t/op/bop.t b/contrib/perl5/t/op/bop.t index 7bcabdf..0354f00 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'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..30\n"; +print "1..44\n"; # numerics print ((0xdead & 0xbeef) == 0x9ead ? "ok 1\n" : "not ok 1\n"); @@ -39,7 +39,7 @@ print (((1 << ($bits - 1)) == $cusp && do { use integer; 1 << ($bits - 1) } == -$cusp) ? "ok 11\n" : "not ok 11\n"); print ((($cusp >> 1) == ($cusp / 2) && - do { use integer; $cusp >> 1 } == -($cusp / 2)) + do { use integer; abs($cusp >> 1) } == ($cusp / 2)) ? "ok 12\n" : "not ok 12\n"); $Aaz = chr(ord("A") & ord("z")); @@ -81,3 +81,91 @@ 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'; +# +print "ok 31\n" if sprintf("%vd", v120.300 & v200.400) eq '72.256'; +print "ok 32\n" if sprintf("%vd", v120.300 | v200.400) eq '248.444'; +print "ok 33\n" if sprintf("%vd", v120.300 ^ v200.400) eq '176.188'; +# +my $a = v120.300; +my $b = v200.400; +$a ^= $b; +print "ok 34\n" if sprintf("%vd", $a) eq '176.188'; +my $a = v120.300; +my $b = v200.400; +$a |= $b; +print "ok 35\n" if sprintf("%vd", $a) eq '248.444'; + +# +# UTF8 ~ behaviour +# + +my @not36; + +for (0x100...0xFFF) { + $a = ~(chr $_); + push @not36, sprintf("%#03X", $_) + if $a ne chr(~$_) or length($a) != 1 or ~$a ne chr($_); +} +if (@not36) { + print "# test 36 failed\n"; + print "not "; +} +print "ok 36\n"; + +my @not37; + +for my $i (0xEEE...0xF00) { + for my $j (0x0..0x120) { + $a = ~(chr ($i) . chr $j); + push @not37, sprintf("%#03X %#03X", $i, $j) + if $a ne chr(~$i).chr(~$j) or + length($a) != 2 or + ~$a ne chr($i).chr($j); + } +} +if (@not37) { + print "# test 37 failed\n"; + print "not "; +} +print "ok 37\n"; + +print "not " unless ~chr(~0) eq "\0"; +print "ok 38\n"; + +my @not39; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not39, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)|chr($j)) ne (~chr($i)&~chr($j)); + } +} +if (@not39) { + print "# test 39 failed\n"; + print "not "; +} +print "ok 39\n"; + +my @not40; + +for my $i (0x100..0x120) { + for my $j (0x100...0x120) { + push @not40, sprintf("%#03X %#03X", $i, $j) + if ~(chr($i)&chr($j)) ne (~chr($i)|~chr($j)); + } +} +if (@not40) { + print "# test 40 failed\n"; + print "not "; +} +print "ok 40\n"; + +# More variations on 19 and 22. +print "ok \xFF\x{FF}\n" & "ok 41\n"; +print "ok \x{FF}\xFF\n" & "ok 42\n"; + +# Tests to see if you really can do casts negative floats to unsigned properly +$neg1 = -1.0; +print ((~ $neg1 == 0) ? "ok 43\n" : "not ok 43\n"); +$neg7 = -7.0; +print ((~ $neg7 == 6) ? "ok 44\n" : "not ok 44\n"); diff --git a/contrib/perl5/t/op/chop.t b/contrib/perl5/t/op/chop.t index 6723ca3..1b55f11 100755 --- a/contrib/perl5/t/op/chop.t +++ b/contrib/perl5/t/op/chop.t @@ -1,6 +1,6 @@ #!./perl -print "1..30\n"; +print "1..37\n"; # optimized @@ -89,3 +89,30 @@ $_ = "ab\n"; $/ = \3; print chomp() == 0 ? "ok 29\n" : "not ok 29\n"; print $_ eq "ab\n" ? "ok 30\n" : "not ok 30\n"; + +# Go Unicode. + +$_ = "abc\x{1234}"; +chop; +print $_ eq "abc" ? "ok 31\n" : "not ok 31\n"; + +$_ = "abc\x{1234}d"; +chop; +print $_ eq "abc\x{1234}" ? "ok 32\n" : "not ok 32\n"; + +$_ = "\x{1234}\x{2345}"; +chop; +print $_ eq "\x{1234}" ? "ok 33\n" : "not ok 33\n"; + +my @stuff = qw(this that); +print chop(@stuff[0,1]) eq 't' ? "ok 34\n" : "not ok 34\n"; + +# bug id 20010305.012 +@stuff = qw(ab cd ef); +print chop(@stuff = @stuff) eq 'f' ? "ok 35\n" : "not ok 35\n"; + +@stuff = qw(ab cd ef); +print chop(@stuff[0, 2]) eq 'f' ? "ok 36\n" : "not ok 36\n"; + +my %stuff = (1..4); +print chop(@stuff{1, 3}) eq '4' ? "ok 37\n" : "not ok 37\n"; diff --git a/contrib/perl5/t/op/closure.t b/contrib/perl5/t/op/closure.t index c691d6f..5f3245f 100755 --- a/contrib/perl5/t/op/closure.t +++ b/contrib/perl5/t/op/closure.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/defins.t b/contrib/perl5/t/op/defins.t index 9e714a7..33c74ea 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'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { $warns++; warn $_[0] }; print "1..14\n"; } diff --git a/contrib/perl5/t/op/die_exit.t b/contrib/perl5/t/op/die_exit.t index cb0478b..a389946 100755 --- a/contrib/perl5/t/op/die_exit.t +++ b/contrib/perl5/t/op/die_exit.t @@ -7,7 +7,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -e '../lib'; + @INC = '../lib'; } if ($^O eq 'mpeix') { diff --git a/contrib/perl5/t/op/exists_sub.t b/contrib/perl5/t/op/exists_sub.t index 3363dfd..d4aa292 100755 --- a/contrib/perl5/t/op/exists_sub.t +++ b/contrib/perl5/t/op/exists_sub.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..9\n"; diff --git a/contrib/perl5/t/op/filetest.t b/contrib/perl5/t/op/filetest.t index e00d5fb..f757c79 100755 --- a/contrib/perl5/t/op/filetest.t +++ b/contrib/perl5/t/op/filetest.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use Config; diff --git a/contrib/perl5/t/op/flip.t b/contrib/perl5/t/op/flip.t index 20167f3..99b22ef 100755 --- a/contrib/perl5/t/op/flip.t +++ b/contrib/perl5/t/op/flip.t @@ -2,7 +2,7 @@ # $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $ -print "1..9\n"; +print "1..10\n"; @a = (1,2,3,4,5,6,7,8,9,10,11,12); @@ -17,7 +17,7 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";} @a = ('a','b','c','d','e','f','g'); -open(of,'../Configure'); +open(of,'harness') or die "Can't open harness: $!"; while (<of>) { (3 .. 5) && ($foo .= $_); } @@ -27,3 +27,10 @@ if ($x eq 3) {print "ok 8\n";} else {print "not ok 8 $x:$foo:\n";} $x = 3.14; if (($x...$x) eq "1") {print "ok 9\n";} else {print "not ok 9\n";} + +{ + # coredump reported in bug 20001018.008 + readline(UNKNOWN); + $. = 1; + print "ok 10\n" unless 1 .. 10; +} diff --git a/contrib/perl5/t/op/fork.t b/contrib/perl5/t/op/fork.t index 80c0b72..88b6b4b 100755 --- a/contrib/perl5/t/op/fork.t +++ b/contrib/perl5/t/op/fork.t @@ -4,7 +4,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; require Config; import Config; unless ($Config{'d_fork'} or ($^O eq 'MSWin32' and $Config{useithreads} @@ -184,6 +184,28 @@ child 3 [1] -2- -3- -1- -2- -3- ######## +$| = 1; +foreach my $c (1,2,3) { + if (fork) { + print "parent $c\n"; + } + else { + print "child $c\n"; + exit; + } +} +while (wait() != -1) { print "waited\n" } +EXPECT +child 1 +child 2 +child 3 +parent 1 +parent 2 +parent 3 +waited +waited +waited +######## use Config; $| = 1; $\ = "\n"; @@ -374,3 +396,28 @@ else { EXPECT pipe_from_fork pipe_to_fork +######## +$|=1; +if ($pid = fork()) { + print "forked first kid\n"; + print "waitpid() returned ok\n" if waitpid($pid,0) == $pid; +} +else { + print "first child\n"; + exit(0); +} +if ($pid = fork()) { + print "forked second kid\n"; + print "wait() returned ok\n" if wait() == $pid; +} +else { + print "second child\n"; + exit(0); +} +EXPECT +forked first kid +first child +waitpid() returned ok +forked second kid +second child +wait() returned ok diff --git a/contrib/perl5/t/op/glob.t b/contrib/perl5/t/op/glob.t index 4c27445..fc0ba77 100755 --- a/contrib/perl5/t/op/glob.t +++ b/contrib/perl5/t/op/glob.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..6\n"; diff --git a/contrib/perl5/t/op/goto_xs.t b/contrib/perl5/t/op/goto_xs.t index 8d9bca1..cf2cafd 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'; -unshift @INC, "../lib"; +@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 index 761d8b9..211dc91 100755 --- a/contrib/perl5/t/op/grent.t +++ b/contrib/perl5/t/op/grent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getgrgid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -54,9 +54,9 @@ BEGIN { } } -# By now GR filehandle should be open and full of juicy group entries. +# By now the GR filehandle should be open and full of juicy group entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many groups. # (note that the first entry has been read away by now) @@ -67,9 +67,11 @@ my $tst = 1; my %perfect; my %seen; +setgrent(); while (<GR>) { chomp; - my @s = split /:/; + # LIMIT -1 so that groups with no users don't fall off + my @s = split /:/, $_, -1; my ($name_s,$passwd_s,$gid_s,$members_s) = @s; if (@s) { push @{ $seen{$name_s} }, $.; @@ -111,6 +113,8 @@ while (<GR>) { $n++; } +endgrent(); + if (keys %perfect == 0) { $max++; print <<EOEX; @@ -136,4 +140,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/grent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @gr1; + +setgrent(); +for (1..$max) { + my $gr = scalar getgrent(); + last unless defined $gr; + push @gr1, $gr; +} +endgrent(); + +my @gr2; + +setgrent(); +for (1..$max) { + my ($gr) = (getgrent()); + last unless defined $gr; + push @gr2, $gr; +} +endgrent(); + +print "not " unless "@gr1" eq "@gr2"; +print "ok ", $tst++, "\n"; + close(GR); diff --git a/contrib/perl5/t/op/groups.t b/contrib/perl5/t/op/groups.t index 4b655c8..082d2d1 100755 --- a/contrib/perl5/t/op/groups.t +++ b/contrib/perl5/t/op/groups.t @@ -115,7 +115,8 @@ for (split(' ', $()) { } } -if ($^O eq "uwin") { # Or anybody else who can have spaces in group names. +if ($^O =~ /^(?:uwin|solaris)$/) { + # Or anybody else who can have spaces in group names. $gr1 = join(' ', grep(!$did{$_}++, sort split(' ', join(' ', @gr)))); } else { $gr1 = join(' ', sort @gr); diff --git a/contrib/perl5/t/op/gv.t b/contrib/perl5/t/op/gv.t index 04905cd..8311244 100755 --- a/contrib/perl5/t/op/gv.t +++ b/contrib/perl5/t/op/gv.t @@ -6,12 +6,12 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..30\n"; +print "1..40\n"; # type coersion on assignment $foo = 'foo'; @@ -128,6 +128,42 @@ print {*x{FILEHANDLE}} "ok 23\n"; ++$test; &{$a}; } +# although it *should* if you're talking about magicals + +{ + my $test = 29; + + my $a = "]"; + print "not " unless defined ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + + $a = "1"; + "o" =~ /(o)/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "2"; + print "not " if ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; + $a = "1x"; + print "not " if defined ${$a}; + ++$test; print "ok $test\n"; + print "not " if defined *{$a}; + ++$test; print "ok $test\n"; + $a = "11"; + "o" =~ /(((((((((((o)))))))))))/; + print "not " unless ${$a}; + ++$test; print "ok $test\n"; + print "not " unless defined *{$a}; + ++$test; print "ok $test\n"; +} + + # does pp_readline() handle glob-ness correctly? { @@ -137,4 +173,4 @@ print {*x{FILEHANDLE}} "ok 23\n"; } __END__ -ok 30 +ok 40 diff --git a/contrib/perl5/t/op/hashwarn.t b/contrib/perl5/t/op/hashwarn.t index 9182273..8466a71 100755 --- a/contrib/perl5/t/op/hashwarn.t +++ b/contrib/perl5/t/op/hashwarn.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/int.t b/contrib/perl5/t/op/int.t index 6ac0866..7d675a4 100755 --- a/contrib/perl5/t/op/int.t +++ b/contrib/perl5/t/op/int.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -print "1..6\n"; +print "1..7\n"; # compile time evaluation @@ -28,3 +28,9 @@ print $x == -7 ? "ok 5\n" : "# expected -7, got $x\nnot ok 5\n"; $y = (3/-10)*-10; print $x+$y == 3 && abs($x) < 10 ? "ok 6\n" : "not ok 6\n"; } + +# check bad strings still get converted + +@x = ( 6, 8, 10); +print "not " if $x["1foo"] != 8; +print "ok 7\n"; diff --git a/contrib/perl5/t/op/join.t b/contrib/perl5/t/op/join.t index def5a9e..0f849fd 100755 --- a/contrib/perl5/t/op/join.t +++ b/contrib/perl5/t/op/join.t @@ -1,6 +1,6 @@ #!./perl -print "1..6\n"; +print "1..14\n"; @x = (1, 2, 3); if (join(':',@x) eq '1:2:3') {print "ok 1\n";} else {print "not ok 1\n";} @@ -20,3 +20,48 @@ 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";} + +# 7,8 check for multiple read of tied objects +{ package X; + sub TIESCALAR { my $x = 7; bless \$x }; + sub FETCH { my $y = shift; $$y += 5 }; + tie my $t, 'X'; + my $r = join ':', $t, 99, $t, 99; + print "# expected '12:99:17:99' got '$r'\nnot " if $r ne '12:99:17:99'; + print "ok 7\n"; + $r = join '', $t, 99, $t, 99; + print "# expected '22992799' got '$r'\nnot " if $r ne '22992799'; + print "ok 8\n"; +}; + +# 9,10 and for multiple read of undef +{ my $s = 5; + local ($^W, $SIG{__WARN__}) = ( 1, sub { $s+=4 } ); + my $r = join ':', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a::9:b::13:c' got '$r'\nnot " if $r ne 'a::9:b::13:c'; + print "ok 9\n"; + my $r = join '', 'a', undef, $s, 'b', undef, $s, 'c'; + print "# expected 'a17b21c' got '$r'\nnot " if $r ne 'a17b21c'; + print "ok 10\n"; +}; + +{ my $s = join("", chr(0x1234), chr(0xff)); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 11\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), ""); + print "not " unless length($s) == 2 && $s eq "\x{1234}\x{ff}"; + print "ok 12\n"; +} + +{ my $s = join(chr(0x1234), chr(0xff), chr(0x2345)); + print "not " unless length($s) == 3 && $s eq "\x{ff}\x{1234}\x{2345}"; + print "ok 13\n"; +} + +{ my $s = join(chr(0xff), chr(0x1234), chr(0xfe)); + print "not " unless length($s) == 3 && $s eq "\x{1234}\x{ff}\x{fe}"; + print "ok 14\n"; +} + diff --git a/contrib/perl5/t/op/lex_assign.t b/contrib/perl5/t/op/lex_assign.t index 2fb059d..d761f73 100755 --- a/contrib/perl5/t/op/lex_assign.t +++ b/contrib/perl5/t/op/lex_assign.t @@ -2,9 +2,8 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; umask 0; $xref = \ ""; @@ -112,11 +111,12 @@ for (@INPUT) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; $op = "$op==$op" unless $op =~ /==/; ($op, $expectop) = $op =~ /(.*)==(.*)/; $skip = ($op =~ /^'\?\?\?'/ or $comment =~ /skip\(.*\Q$^O\E.*\)/i) - ? "skip" : "not"; + ? "skip" : "# '$_'\nnot"; $integer = ($comment =~ /^i_/) ? "use integer" : '' ; (print "#skipping $comment:\nok $ord\n"), next if $skip eq 'skip'; @@ -137,7 +137,7 @@ EOE print "# skipping $comment: unimplemented:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } @@ -146,6 +146,7 @@ for (@simple_input) { $ord++; ($op, undef, $comment) = /^([^\#]+)(\#\s+(.*))?/; $comment = $op unless defined $comment; + chomp; ($operator, $variable) = /^\s*(\w+)\s*\$(\w+)/ or warn "misprocessed '$_'\n"; eval <<EOE; local \$SIG{__WARN__} = \\&wrn; @@ -164,14 +165,14 @@ EOE print "# skipping $comment: syntax not good for selfassign:\nok $ord\n"; } else { warn $@; - print "not ok $ord\n"; + print "# '$_'\nnot ok $ord\n"; } } } __END__ ref $xref # ref ref $cstr # ref nonref -`$runme -e "print qq[1\n]"` # backtick skip(MSWin32) +`$runme -e "print qq[1\\n]"` # backtick skip(MSWin32) `$undefed` # backtick undef skip(MSWin32) <*> # glob <OP> # readline @@ -242,7 +243,7 @@ lc $cstr # lc quotemeta $cstr # quotemeta @$aref # rv2av @$undefed # rv2av undef -each %h==1 # each +(each %h) % 2 == 1 # each values %h # values keys %h # keys %$href # rv2hv @@ -307,7 +308,7 @@ getpriority $$, $$ # getpriority time # time localtime $^T # localtime gmtime $^T # gmtime -sleep 1 # sleep +'???' # sleep: can randomly fail '???' # alarm '???' # shmget '???' # shmctl diff --git a/contrib/perl5/t/op/lfs.t b/contrib/perl5/t/op/lfs.t index e704f6f..0a1c399 100755 --- a/contrib/perl5/t/op/lfs.t +++ b/contrib/perl5/t/op/lfs.t @@ -4,15 +4,20 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @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"; + print "1..0 # Skip: no 64-bit file offsets\n"; exit(0); } } +use strict; + +our @s; +our $fail; + sub zap { close(BIG); unlink("big"); @@ -25,35 +30,42 @@ sub bye { exit(0); } +my $explained; + sub explain { - print <<EOM; + unless ($explained++) { + 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.) +# 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 (the network filesystem?) +# 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. +# It is just that the test failed now. # EOM + } + print "1..0 # Skip: @_\n" if @_; } 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"; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "1..0 # Skip: no sparse files in $^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"; + print "1..0 # Skip: no sparse files in $^0, unable to test large files\n"; bye(); } @@ -102,7 +114,7 @@ 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"; + print "1..0 # Skip: no sparse files?\n"; bye; } @@ -110,14 +122,22 @@ 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. +# This may fail by producing some signal; run in a subprocess first for safety $ENV{LC_ALL} = "C"; +my $r = system '../perl', '-e', <<'EOF'; +open(BIG, ">big"); +seek(BIG, 5_000_000_000, 0); +print BIG "big"; +exit 0; +EOF + 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(); +if ($r or not seek(BIG, 5_000_000_000, $SEEK_SET)) { + my $err = $r ? 'signal '.($r & 0x7f) : $!; + explain("seeking past 2GB failed: $err"); bye(); } @@ -129,11 +149,12 @@ 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"; + explain("writing past 2GB failed: process limits?"); } elsif ($! =~ /quota/i) { - print "1..0\n# filesystem quota limits?\n"; + explain("filesystem quota limits?"); + } else { + explain("error: $!"); } - explain(); bye(); } @@ -142,8 +163,7 @@ unless ($print && $close) { print "# @s\n"; unless ($s[7] == 5_000_000_003) { - print "1..0\n# not configured to use large files?\n"; - explain(); + explain("kernel/fs not configured to use large files?"); bye(); } @@ -152,9 +172,30 @@ sub fail () { $fail++; } +sub offset ($$) { + my ($offset_will_be, $offset_want) = @_; + my $offset_is = eval $offset_will_be; + unless ($offset_is == $offset_want) { + print "# bad offset $offset_is, want $offset_want\n"; + my ($offset_func) = ($offset_will_be =~ /^(\w+)/); + if (unpack("L", pack("L", $offset_want)) == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + print "# $offset_want cast into 32 bits equals $offset_is.\n"; + } elsif ($offset_want - unpack("L", pack("L", $offset_want)) - 1 + == $offset_is) { + print "# 32-bit wraparound suspected in $offset_func() since\n"; + printf "# %s - unpack('L', pack('L', %s)) - 1 equals %s.\n", + $offset_want, + $offset_want, + $offset_is; + } + fail; + } +} + print "1..17\n"; -my $fail = 0; +$fail = 0; fail unless $s[7] == 5_000_000_003; # exercizes pp_stat print "ok 1\n"; @@ -174,25 +215,28 @@ binmode BIG; fail unless seek(BIG, 4_500_000_000, $SEEK_SET); print "ok 5\n"; -fail unless tell(BIG) == 4_500_000_000; +offset('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; +# If you get 205_032_705 from here it means that +# your tell() is returning 32-bit values since (I32)4_500_000_001 +# is exactly 205_032_705. +offset('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; +offset('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; +offset('tell(BIG)', 5_000_000_000); print "ok 12\n"; my $big; @@ -204,6 +248,8 @@ fail unless $big eq "big"; print "ok 14\n"; # 705_032_704 = (I32)5_000_000_000 +# See that we don't have "big" in the 705_... spot: +# that would mean that we have a wraparound. fail unless seek(BIG, 705_032_704, $SEEK_SET); print "ok 15\n"; @@ -215,7 +261,7 @@ print "ok 16\n"; fail unless $zero eq "\0\0\0"; print "ok 17\n"; -explain if $fail; +explain() if $fail; bye(); # does the necessary cleanup diff --git a/contrib/perl5/t/op/local.t b/contrib/perl5/t/op/local.t index b478e01..cf606b7 100755 --- a/contrib/perl5/t/op/local.t +++ b/contrib/perl5/t/op/local.t @@ -2,9 +2,6 @@ print "1..69\n"; -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - sub foo { local($a, $b) = @_; local($c, $d); diff --git a/contrib/perl5/t/op/lop.t b/contrib/perl5/t/op/lop.t index f15201f..d57271a 100755 --- a/contrib/perl5/t/op/lop.t +++ b/contrib/perl5/t/op/lop.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..7\n"; diff --git a/contrib/perl5/t/op/magic.t b/contrib/perl5/t/op/magic.t index 7739276..c2a8211 100755 --- a/contrib/perl5/t/op/magic.t +++ b/contrib/perl5/t/op/magic.t @@ -3,7 +3,7 @@ BEGIN { $| = 1; chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; $SIG{__WARN__} = sub { die "Dying on warning: ", @_ }; } @@ -189,16 +189,18 @@ if ($Is_VMS || $Is_Dos) { } else { $PATH = $ENV{PATH}; + $PDL = $ENV{PERL_DESTRUCT_LEVEL} || 0; $ENV{foo} = "bar"; %ENV = (); $ENV{PATH} = $PATH; + $ENV{PERL_DESTRUCT_LEVEL} = $PDL || 0; ok 29, ($Is_MSWin32 ? (`cmd /x /c set foo 2>NUL` eq "") : (`echo \$foo` eq "\n") ); - $ENV{NoNeSuCh} = "foo"; + $ENV{__NoNeSuCh} = "foo"; $0 = "bar"; - ok 30, ($Is_MSWin32 ? (`cmd /x /c set NoNeSuCh` eq "NoNeSuCh=foo\n") - : (`echo \$NoNeSuCh` eq "foo\n") ); + ok 30, ($Is_MSWin32 ? (`cmd /x /c set __NoNeSuCh` eq "__NoNeSuCh=foo\n") + : (`echo \$__NoNeSuCh` eq "foo\n") ); } { diff --git a/contrib/perl5/t/op/method.t b/contrib/perl5/t/op/method.t index 1c6f3c5..be4df75 100755 --- a/contrib/perl5/t/op/method.t +++ b/contrib/perl5/t/op/method.t @@ -4,7 +4,12 @@ # test method calls and autoloading. # -print "1..49\n"; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +print "1..53\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -167,3 +172,16 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1); test(A2->foo(), "foo"); } + +{ + test(do { use Config; eval 'Config->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); + test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +} + +test(do { eval 'E->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "E"; $e->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); + diff --git a/contrib/perl5/t/op/misc.t b/contrib/perl5/t/op/misc.t index ac1a44f..35437a4 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'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -15,7 +15,7 @@ print "1..", scalar @prgs, "\n"; $tmpfile = "misctmp000"; 1 while -f ++$tmpfile; -END { unlink $tmpfile if $tmpfile; } +END { while($tmpfile && unlink $tmpfile){} } $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat'); @@ -26,6 +26,9 @@ for (@prgs){ } my($prog,$expected) = split(/\nEXPECT\n/, $_); open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!"; + $prog =~ s#/dev/null#NL:# if $^O eq 'VMS'; + $prog =~ s#if \(-e _ and -f _ and -r _\)#if (-e _ and -f _)# if $^O eq 'VMS'; # VMS file locking + print TEST $prog, "\n"; close TEST or die "Cannot close $tmpfile: $!"; @@ -59,12 +62,12 @@ $a = ":="; split /($a)/o, "a:=b:=c"; print "@_" EXPECT a := b := c ######## -use integer; $cusp = ~0 ^ (~0 >> 1); +use integer; $, = " "; -print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n"; +print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n"; EXPECT --1 0 0 1 ! +7 0 0 8 ! ######## $foo=undef; $foo->go; EXPECT @@ -346,7 +349,7 @@ print "you die joe!\n" unless "@x" eq 'x y z'; /(?{"{"})/ # Check it outside of eval too EXPECT Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern -/(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1. +Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/(?{ << HERE "{"})/ at - line 1. ######## /(?{"{"}})/ # Check it outside of eval too EXPECT @@ -371,8 +374,8 @@ argv <e> # fdopen from a system descriptor to a system descriptor used to close # the former. open STDERR, '>&=STDOUT' or die $!; -select STDOUT; $| = 1; print fileno STDOUT; -select STDERR; $| = 1; print fileno STDERR; +select STDOUT; $| = 1; print fileno STDOUT or die $!; +select STDERR; $| = 1; print fileno STDERR or die $!; EXPECT 1 2 @@ -545,3 +548,56 @@ ucfirst - World lcfirst - world uc - WORLD lc - world +######## +sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next } +my $x = "foo"; +{ f } continue { print $x, "\n" } +EXPECT +foo +######## +sub C () { 1 } +sub M { $_[0] = 2; } +eval "C"; +M(C); +EXPECT +Modification of a read-only value attempted at - line 2. +######## +print qw(ab a\b a\\b); +EXPECT +aba\ba\b +######## +# This test is here instead of pragma/locale.t because +# the bug depends on in the internal state of the locale +# settings and pragma/locale messes up that state pretty badly. +# We need a "fresh run". +BEGIN { + eval { require POSIX }; + if ($@) { + exit(0); # running minitest? + } +} +use Config; +my $have_setlocale = $Config{d_setlocale} eq 'define'; +$have_setlocale = 0 if $@; +# Visual C's CRT goes silly on strings of the form "en_US.ISO8859-1" +# and mingw32 uses said silly CRT +$have_setlocale = 0 if $^O eq 'MSWin32' && $Config{cc} =~ /^(cl|gcc)/i; +exit(0) unless $have_setlocale; +my @locales; +if (-x "/usr/bin/locale" && open(LOCALES, "/usr/bin/locale -a|")) { + while(<LOCALES>) { + chomp; + push(@locales, $_); + } + close(LOCALES); +} +exit(0) unless @locales; +for (@locales) { + use POSIX qw(locale_h); + use locale; + setlocale(LC_NUMERIC, $_) or next; + my $s = sprintf "%g %g", 3.1, 3.1; + next if $s eq '3.1 3.1' || $s =~ /^(3.+1) \1$/; + print "$_ $s\n"; +} +EXPECT diff --git a/contrib/perl5/t/op/mkdir.t b/contrib/perl5/t/op/mkdir.t index cf8e55d..c5a090c 100755 --- a/contrib/perl5/t/op/mkdir.t +++ b/contrib/perl5/t/op/mkdir.t @@ -4,7 +4,7 @@ print "1..9\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use File::Path; diff --git a/contrib/perl5/t/op/my.t b/contrib/perl5/t/op/my.t index 1777e88..601e1d6 100755 --- a/contrib/perl5/t/op/my.t +++ b/contrib/perl5/t/op/my.t @@ -2,7 +2,7 @@ # $RCSfile: my.t,v $ -print "1..30\n"; +print "1..31\n"; sub foo { my($a, $b) = @_; @@ -92,3 +92,10 @@ print +(@x ? "not " : ""), "ok 29\n"; { @x = my %y } print +(@x ? "not " : ""), "ok 30\n"; +# Found in HTML::FormatPS +my %fonts = qw(nok 31); +for my $full (keys %fonts) { + $full =~ s/^n//; + # Supposed to be copy-on-write via force_normal after a THINKFIRST check. + print "$full $fonts{nok}\n"; +} diff --git a/contrib/perl5/t/op/nothr5005.t b/contrib/perl5/t/op/nothr5005.t index fd36e2e..411a0b4 100755 --- a/contrib/perl5/t/op/nothr5005.t +++ b/contrib/perl5/t/op/nothr5005.t @@ -6,7 +6,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; require Config; import Config; if ($Config{'use5005threads'}) diff --git a/contrib/perl5/t/op/numconvert.t b/contrib/perl5/t/op/numconvert.t index 8eb9b6e..f3c9867 100755 --- a/contrib/perl5/t/op/numconvert.t +++ b/contrib/perl5/t/op/numconvert.t @@ -51,7 +51,13 @@ 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"; + print "1..0 # skipped: unsigned perl arithmetic is not sane"; + eval { require Config; import Config }; + use vars qw(%Config); + if ($Config{d_quad} eq 'define') { + print " (common in 64-bit platforms)"; + } + print "\n"; exit 0; } diff --git a/contrib/perl5/t/op/oct.t b/contrib/perl5/t/op/oct.t index 27ac5aa..fe155d3 100755 --- a/contrib/perl5/t/op/oct.t +++ b/contrib/perl5/t/op/oct.t @@ -1,53 +1,88 @@ #!./perl -print "1..36\n"; +print "1..50\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('0b1_0101') == 0b101_01) ? "ok" : "not ok", " 1\n"; +print +(oct('0b10_101') == 0_2_5) ? "ok" : "not ok", " 2\n"; +print +(oct('0b101_01') == 2_1) ? "ok" : "not ok", " 3\n"; +print +(oct('0b1010_1') == 0x1_5) ? "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('b1_0101') == 0b10101) ? "ok" : "not ok", " 5\n"; +print +(oct('b10_101') == 025) ? "ok" : "not ok", " 6\n"; +print +(oct('b101_01') == 21) ? "ok" : "not ok", " 7\n"; +print +(oct('b1010_1') == 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('01_234') == 0b10_1001_1100) ? "ok" : "not ok", " 9\n"; +print +(oct('012_34') == 01234) ? "ok" : "not ok", " 10\n"; +print +(oct('0123_4') == 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('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n"; +print +(oct('0x12_34') == 01_1064) ? "ok" : "not ok", " 14\n"; +print +(oct('0x123_4') == 4660) ? "ok" : "not ok", " 15\n"; +print +(oct('0x1234') == 0x12_34) ? "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 +(oct('x1_234') == 0b100100011010_0) ? "ok" : "not ok", " 17\n"; +print +(oct('x12_34') == 0_11064) ? "ok" : "not ok", " 18\n"; +print +(oct('x123_4') == 4660) ? "ok" : "not ok", " 19\n"; +print +(oct('x1234') == 0x_1234) ? "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('01_234') == 0b_1001000110100) ? "ok" : "not ok", " 21\n"; +print +(hex('012_34') == 011064) ? "ok" : "not ok", " 22\n"; +print +(hex('0123_4') == 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('0x_1234') == 0b1001000110100) ? "ok" : "not ok", " 25\n"; +print +(hex('0x1_234') == 011064) ? "ok" : "not ok", " 26\n"; +print +(hex('0x12_34') == 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 +(hex('x_1234') == 0b1001000110100) ? "ok" : "not ok", " 29\n"; +print +(hex('x12_34') == 011064) ? "ok" : "not ok", " 30\n"; +print +(hex('x123_4') == 4660) ? "ok" : "not ok", " 31\n"; +print +(hex('x1234_') == 0x1234) ? "ok" : "not ok", " 32\n"; -print +(oct('0b11111111111111111111111111111111') == 4294967295) ? +print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ? "ok" : "not ok", " 33\n"; -print +(oct('037777777777') == 4294967295) ? +print +(oct('037_777_777_777') == 4294967295) ? "ok" : "not ok", " 34\n"; -print +(oct('0xffffffff') == 4294967295) ? +print +(oct('0xffff_ffff') == 4294967295) ? "ok" : "not ok", " 35\n"; -print +(hex('0xffffffff') == 4294967295) ? +print +(hex('0xff_ff_ff_ff') == 4294967295) ? "ok" : "not ok", " 36\n"; + +$_ = "\0_7_7"; +print length eq 5 ? "ok" : "not ok", " 37\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 39\n"; +if (ord("\t") != 9) { + # question mark is 111 in 1047, 037, && POSIX-BC + print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; +} +else { + print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; +} + +$_ = "\x_7_7"; +print length eq 5 ? "ok" : "not ok", " 41\n"; +print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; +chop, chop, chop, chop; +print $_ eq "\0" ? "ok" : "not ok", " 43\n"; +if (ord("\t") != 9) { + # / is 97 in 1047, 037, && POSIX-BC + print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; +} +else { + print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; +} + +print +(oct('0b'.( '0'x10).'1_0101') == 0b101_01) ? "ok" : "not ok", " 45\n"; +print +(oct('0b'.( '0'x100).'1_0101') == 0b101_01) ? "ok" : "not ok", " 46\n"; +print +(oct('0b'.('0'x1000).'1_0101') == 0b101_01) ? "ok" : "not ok", " 47\n"; + +print +(hex(( '0'x10).'01234') == 0x1234) ? "ok" : "not ok", " 48\n"; +print +(hex(( '0'x100).'01234') == 0x1234) ? "ok" : "not ok", " 49\n"; +print +(hex(('0'x1000).'01234') == 0x1234) ? "ok" : "not ok", " 50\n"; + diff --git a/contrib/perl5/t/op/pack.t b/contrib/perl5/t/op/pack.t index b336cb5..67bd547 100755 --- a/contrib/perl5/t/op/pack.t +++ b/contrib/perl5/t/op/pack.t @@ -2,11 +2,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..156\n"; +print "1..159\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 @@ -372,8 +372,9 @@ 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++; +$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; +print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\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"; @@ -405,3 +406,13 @@ $z = pack <<EOP,'string','etc'; w/A* # Count a BER integer EOP print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++; + +print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless "1.20.300.4000" eq + sprintf "%vd", pack(" U*",1,20,300,4000); +print "ok $test\n"; $test++; +print 'not ' unless v1.20.300.4000 ne + sprintf "%vd", pack("C0U*",1,20,300,4000); +print "ok $test\n"; $test++; + diff --git a/contrib/perl5/t/op/pat.t b/contrib/perl5/t/op/pat.t index 188a3a3..ffbc945 100755 --- a/contrib/perl5/t/op/pat.t +++ b/contrib/perl5/t/op/pat.t @@ -4,17 +4,14 @@ # 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..211\n"; +print "1..231\n"; BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } eval 'use Config'; # Defaults assumed if this fails -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - $x = "abc\ndef\n"; if ($x =~ /^abc/) {print "ok 1\n";} else {print "not ok 1\n";} @@ -266,12 +263,12 @@ print "ok 68\n"; undef $@; eval "'aaa' =~ /a{1,$reg_infty}/"; -print "not " if $@ !~ m%^\Q/a{1,$reg_infty}/: Quantifier in {,} bigger than%; +print "not " if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 69\n"; eval "'aaa' =~ /a{1,$reg_infty_p}/"; print "not " - if $@ !~ m%^\Q/a{1,$reg_infty_p}/: Quantifier in {,} bigger than%; + if $@ !~ m%^\QQuantifier in {,} bigger than%; print "ok 70\n"; undef $@; @@ -279,7 +276,7 @@ undef $@; $context = 'x' x 256; eval qq("${context}y" =~ /(?<=$context)y/); -print "not " if $@ !~ m%^\Q/(?<=\Ex+/: lookbehind longer than 255 not%; +print "not " if $@ !~ m%^\QLookbehind longer than 255 not%; print "ok 71\n"; # removed test @@ -496,7 +493,7 @@ $test++; $_ = 'xabcx'; foreach $ans ('', 'c') { /(?<=(?=a)..)((?=c)|.)/g; - print "not " unless $1 eq $ans; + print "# \$1 ='$1'\n# \$ans='$ans'\nnot " unless $1 eq $ans; print "ok $test\n"; $test++; } @@ -504,7 +501,7 @@ foreach $ans ('', 'c') { $_ = 'a'; foreach $ans ('', 'a', '') { /^|a|$/g; - print "not " unless $& eq $ans; + print "# \$& ='$&'\n# \$ans='$ans'\nnot " unless $& eq $ans; print "ok $test\n"; $test++; } @@ -545,6 +542,22 @@ $test++; print "ok $test\n"; $test++; + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/$lex_b(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; + + no re "eval"; $match = eval { /$a$c$a/ }; print "not " @@ -554,6 +567,23 @@ $test++; } { + local $lex_a = 2; + my $lex_a = 43; + my $lex_b = 17; + my $lex_c = 27; + my $lex_res = ($lex_b =~ qr/17(?{ $lex_c = $lex_a++ })/); + print "not " unless $lex_res eq '1'; + print "ok $test\n"; + $test++; + print "not " unless $lex_a eq '44'; + print "ok $test\n"; + $test++; + print "not " unless $lex_c eq '43'; + print "ok $test\n"; + $test++; +} + +{ package aa; $c = 2; $::c = 3; @@ -588,8 +618,12 @@ sub make_must_warn { my $for_future = make_must_warn('reserved for future extensions'); &$for_future('q(a:[b]:) =~ /[x[:foo:]]/'); -&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); -&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); + +#&$for_future('q(a=[b]=) =~ /[x[=foo=]]/'); +print "ok $test\n"; $test++; # now a fatal croak + +#&$for_future('q(a.[b].) =~ /[x[.foo.]]/'); +print "ok $test\n"; $test++; # now a fatal croak # test if failure of patterns returns empty list $_ = 'aaa'; @@ -689,6 +723,30 @@ print "not " print "ok $test\n"; $test++; +eval { $+[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { $-[0] = 13; }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @+ = (7, 6, 5); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + +eval { @- = qw(foo bar); }; +print "not " + if $@ !~ /^Modification of a read-only value attempted/; +print "ok $test\n"; +$test++; + /.(a)(ba*)?/; print "#$#-..$#+\nnot " if $#+ != 2 or $#- != 1; print "ok $test\n"; @@ -995,3 +1053,78 @@ $test++; "\n\n" =~ /\n+ $ \n/x or print "not "; print "ok $test\n"; $test++; + +[] =~ /^ARRAY/ or print "# [] \nnot "; +print "ok $test\n"; +$test++; + +eval << 'EOE'; +{ + package S; + use overload '""' => sub { 'Object S' }; + sub new { bless [] } +} +$a = 'S'->new; +EOE + +$a and $a =~ /^Object\sS/ or print "# '$a' \nnot "; +print "ok $test\n"; +$test++; + +# test result of match used as match (!) +'a1b' =~ ('xyz' =~ /y/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +'a1b' =~ ('xyz' =~ /t/) and $` eq 'a' or print "not "; +print "ok $test\n"; +$test++; + +$w = 0; +{ + local $SIG{__WARN__} = sub { $w = 1 }; + local $^W = 1; + $w = 1 if ("1\n" x 102) =~ /^\s*\n/m; +} +print $w ? "not " : "", "ok $test\n"; +$test++; + +my %space = ( spc => " ", + tab => "\t", + cr => "\r", + lf => "\n", + ff => "\f", +# There's no \v but the vertical tabulator seems miraculously +# be 11 both in ASCII and EBCDIC. + vt => chr(11), + false => "space" ); + +my @space0 = sort grep { $space{$_} =~ /\s/ } keys %space; +my @space1 = sort grep { $space{$_} =~ /[[:space:]]/ } keys %space; +my @space2 = sort grep { $space{$_} =~ /[[:blank:]]/ } keys %space; + +print "not " unless "@space0" eq "cr ff lf spc tab"; +print "ok $test # @space0\n"; +$test++; + +print "not " unless "@space1" eq "cr ff lf spc tab vt"; +print "ok $test # @space1\n"; +$test++; + +print "not " unless "@space2" eq "spc tab"; +print "ok $test # @space2\n"; +$test++; + +# bugid 20001021.005 - this caused a SEGV +print "not " unless undef =~ /^([^\/]*)(.*)$/; +print "ok $test\n"; +$test++; + +{ + # japhy -- added 03/03/2001 + () = (my $str = "abc") =~ /(...)/; + $str = "def"; + print "not " if $1 ne "abc"; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/pos.t b/contrib/perl5/t/op/pos.t index 46811b7..f3bc23c 100755 --- a/contrib/perl5/t/op/pos.t +++ b/contrib/perl5/t/op/pos.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..4\n"; $x='banana'; $x=~/.a/g; @@ -14,3 +14,10 @@ sub f { my $p=$_[0]; return $p } $x=~/.a/g; if (f(pos($x))==4) {print "ok 3\n"} else {print "not ok 3\n";} +# Is pos() set inside //g? (bug id 19990615.008) +$x = "test string?"; $x =~ s/\w/pos($x)/eg; +print "not " unless $x eq "0123 5678910?"; +print "ok 4\n"; + + + diff --git a/contrib/perl5/t/op/pwent.t b/contrib/perl5/t/op/pwent.t index ca14a99..d811f06 100755 --- a/contrib/perl5/t/op/pwent.t +++ b/contrib/perl5/t/op/pwent.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; eval {my @n = getpwuid 0}; if ($@ && $@ =~ /(The \w+ function is unimplemented)/) { print "1..0 # Skip: $1\n"; @@ -55,9 +55,9 @@ BEGIN { } } -# By now PW filehandle should be open and full of juicy password entries. +# By now the PW filehandle should be open and full of juicy password entries. -print "1..1\n"; +print "1..2\n"; # Go through at most this many users. # (note that the first entry has been read away by now) @@ -68,10 +68,17 @@ my $tst = 1; my %perfect; my %seen; +setpwent(); while (<PW>) { chomp; - my @s = split /:/; - my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s; + # LIMIT -1 so that users with empty shells don't fall off + my @s = split /:/, $_, -1; + my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s); + if ($^O eq 'darwin') { + ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9]; + } else { + ($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} }, $.; @@ -86,7 +93,7 @@ while (<PW>) { } # In principle we could whine if @s != 7 but do we know enough # of passwd file formats everywhere? - if (@s == 7) { + if (@s == 7 || ($^O eq 'darwin' && @s == 10)) { @n = getpwuid($uid_s); # 'nobody' et al. next unless @n; @@ -108,6 +115,7 @@ while (<PW>) { } $n++; } +endpwent(); if (keys %perfect == 0) { $max++; @@ -134,4 +142,29 @@ print "ok ", $tst++; print "\t# (not necessarily serious: run t/op/pwent.t by itself)" if $not; print "\n"; +# Test both the scalar and list contexts. + +my @pw1; + +setpwent(); +for (1..$max) { + my $pw = scalar getpwent(); + last unless defined $pw; + push @pw1, $pw; +} +endpwent(); + +my @pw2; + +setpwent(); +for (1..$max) { + my ($pw) = (getpwent()); + last unless defined $pw; + push @pw2, $pw; +} +endpwent(); + +print "not " unless "@pw1" eq "@pw2"; +print "ok ", $tst++, "\n"; + close(PW); diff --git a/contrib/perl5/t/op/quotemeta.t b/contrib/perl5/t/op/quotemeta.t index 60e5b7b..ea62ed8 100755 --- a/contrib/perl5/t/op/quotemeta.t +++ b/contrib/perl5/t/op/quotemeta.t @@ -2,18 +2,18 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } -print "1..15\n"; +print "1..17\n"; if ($Config{ebcdic} eq 'define') { $_=join "", map chr($_), 129..233; # 105 characters - 52 letters = 53 backslashes # 105 characters + 53 backslashes = 158 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 158 ){print "ok 1\n"} else {print "not ok 1\n"} # 104 non-backslash characters if (tr/\\//cd == 104){print "ok 2\n"} else {print "not ok 2\n"} @@ -22,7 +22,7 @@ if ($Config{ebcdic} eq 'define') { # 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes # 96 characters + 33 backslashes = 129 characters - $_=quotemeta $_; + $_= quotemeta $_; if ( length == 129 ){print "ok 1\n"} else {print "not ok 1\n"} # 95 non-backslash characters if (tr/\\//cd == 95){print "ok 2\n"} else {print "not ok 2\n"} @@ -42,3 +42,6 @@ print "\Q\u\LpE.X.R\EL\E." eq "Pe\\.x\\.rL." ? "ok 12\n" : "not ok 12 \n"; print "\Q\l\UPe*x*r\El\E*" eq "pE\\*X\\*Rl*" ? "ok 13\n" : "not ok 13 \n"; print "\U\lPerl\E\E\E\E" eq "pERL" ? "ok 14\n" : "not ok 14 \n"; print "\l\UPerl\E\E\E\E" eq "pERL" ? "ok 15\n" : "not ok 15 \n"; + +print length(quotemeta("\x{263a}")) == 1 ? "ok 16\n" : "not ok 16\n"; +print quotemeta("\x{263a}") eq "\x{263a}" ? "ok 17\n" : "not ok 17\n"; diff --git a/contrib/perl5/t/op/rand.t b/contrib/perl5/t/op/rand.t index 97019bb..83186ae 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"; - unshift @INC, "../lib" if -d "../lib"; + @INC = '../lib'; } use strict; diff --git a/contrib/perl5/t/op/re_tests b/contrib/perl5/t/op/re_tests index d506e6e..6477d67 100644 --- a/contrib/perl5/t/op/re_tests +++ b/contrib/perl5/t/op/re_tests @@ -45,9 +45,9 @@ 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 "b-a" in regexp -a[]b - c - /a[]b/: unmatched [] in regexp -a[ - c - /a[/: unmatched [] in regexp +a[b-a] - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +a[]b - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +a[ - c - Unmatched [ before HERE mark in regex m/a[ << HERE / a] a] y $& a] a[]]b a]b y $& a]b a[^bc]d aed y $& aed @@ -95,21 +95,21 @@ a[\S]b a-b y - - ab|cd abc y $& ab ab|cd abcd y $& ab ()ef def y $&-$1 ef- -*a - c - /*a/: ?+*{} follows nothing in regexp -(*)b - c - /(*)b/: ?+*{} follows nothing in regexp +*a - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +(*)b - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ $b b n - - a\ - c - Search pattern not terminated a\(b a(b y $&-$1 a(b- a\(*b ab y $& ab a\(*b a((b y $& a((b a\\b a\b y $& a\b -abc) - c - /abc)/: unmatched () in regexp -(abc - c - /(abc/: unmatched () in regexp +abc) - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +(abc - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ ((a)) abc y $&-$1-$2 a-a-a (a)b(c) abc y $&-$1-$2 abc-a-c a+b+c aabbabc y $& abc a{1,}b{1,}c aabbabc y $& abc -a** - c - /a**/: nested *?+ in regexp +a** - c - Nested quantifiers before HERE mark in regex m/a** << HERE / a.+?c abcabc y $& abc (a+|b)* ab y $&-$1 ab-b (a+|b){0,} ab y $&-$1 ab-b @@ -117,7 +117,7 @@ a.+?c abcabc y $& abc (a+|b){1,} ab y $&-$1 ab-b (a+|b)? ab y $&-$1 a-a (a+|b){0,1} ab y $&-$1 a-a -)( - c - /)(/: unmatched () in regexp +)( - c - Unmatched ) before HERE mark in regex m/) << HERE (/ [^ab]* cde y $& cde abc n - - a* y $& @@ -164,11 +164,11 @@ a(bc)d abcd y $1-\$1-\\$1 bc-$1-\bc a[-]?c ac y $& ac (abc)\1 abcabc y $1 abc ([a-c]*)\1 abcabc y $1 abc -\1 - c - /\1/: reference to nonexistent group -\2 - c - /\2/: reference to nonexistent group +\1 - c - Reference to nonexistent group +\2 - c - Reference to nonexistent group (a)|\1 a y - - (a)|\1 x n - - -(a)|\2 - c - /(a)|\2/: reference to nonexistent group +(a)|\2 - c - Reference to nonexistent group (([a-c])b*?\2)* ababbbcbc y $&-$1-$2 ababb-bb-b (([a-c])b*?\2){3} ababbbcbc y $&-$1-$2 ababbbcbc-cbc-c ((\3|b)\2(a)x)+ aaxabxbaxbbx n - - @@ -218,9 +218,9 @@ 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 "b-a" in regexp -'a[]b'i - c - /a[]b/: unmatched [] in regexp -'a['i - c - /a[/: unmatched [] in regexp +'a[b-a]'i - c - Invalid [] range "b-a" before HERE mark in regex m/a[b-a << HERE ]/ +'a[]b'i - c - Unmatched [ before HERE mark in regex m/a[ << HERE ]b/ +'a['i - c - Unmatched [ before HERE mark in regex m/a[ << HERE / 'a]'i A] y $& A] 'a[]]b'i A]B y $& A]B 'a[^bc]d'i AED y $& AED @@ -232,21 +232,21 @@ a[-]?c ac y $& ac 'ab|cd'i ABC y $& AB 'ab|cd'i ABCD y $& AB '()ef'i DEF y $&-$1 EF- -'*a'i - c - /*a/: ?+*{} follows nothing in regexp -'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp +'*a'i - c - Quantifier follows nothing before HERE mark in regex m/* << HERE a/ +'(*)b'i - c - Quantifier follows nothing before HERE mark in regex m/(* << HERE )b/ '$b'i B n - - 'a\'i - c - Search pattern not terminated 'a\(b'i A(B y $&-$1 A(B- 'a\(*b'i AB y $& AB 'a\(*b'i A((B y $& A((B 'a\\b'i A\B y $& A\B -'abc)'i - c - /abc)/: unmatched () in regexp -'(abc'i - c - /(abc/: unmatched () in regexp +'abc)'i - c - Unmatched ) before HERE mark in regex m/abc) << HERE / +'(abc'i - c - Unmatched ( before HERE mark in regex m/( << HERE abc/ '((a))'i ABC y $&-$1-$2 A-A-A '(a)b(c)'i ABC y $&-$1-$2 ABC-A-C 'a+b+c'i AABBABC y $& ABC 'a{1,}b{1,}c'i AABBABC y $& ABC -'a**'i - c - /a**/: nested *?+ in regexp +'a**'i - c - Nested quantifiers before HERE mark in regex m/a** << HERE / 'a.+?c'i ABCABC y $& ABC 'a.*?c'i ABCABC y $& ABC 'a.{0,5}?c'i ABCABC y $& ABC @@ -257,7 +257,7 @@ a[-]?c ac y $& ac '(a+|b)?'i AB y $&-$1 A-A '(a+|b){0,1}'i AB y $&-$1 A-A '(a+|b){0,1}?'i AB y $&-$1 - -')('i - c - /)(/: unmatched () in regexp +')('i - c - Unmatched ) before HERE mark in regex m/) << HERE (/ '[^ab]*'i CDE y $& CDE 'abc'i n - - 'a*'i y $& @@ -318,7 +318,7 @@ a(?:b|c|d){2}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}(.) acdbcdbe y $1 b a(?:b|c|d){4,5}?(.) acdbcdbe y $1 d ((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar -:(?: - c - /(?/: Sequence (? incomplete +:(?: - c - Sequence (? incomplete a(?:b|c|d){6,7}(.) acdbcdbe y $1 e a(?:b|c|d){6,7}?(.) acdbcdbe y $1 e a(?:b|c|d){5,6}(.) acdbcdbe y $1 e @@ -346,7 +346,7 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce (?<!c)b cb n - - (?<!c)b b y - - (?<!c)b b y $& b -(?<%)b - c - /(?<%)b/: Sequence (?%...) not recognized +(?<%)b - c - Sequence (?<%...) not recognized before HERE mark in regex m/(?<% << HERE )b/ (?:..)*a aba y $& aba (?:..)*?a aba y $& a ^(?:b|a(?=(.)))*\1 abc y $& ab @@ -397,10 +397,10 @@ a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce '(ab)\d\1'i ab4Ab y $1 ab foo\w*\d{4}baz foobar1234baz y $& foobar1234baz a(?{})b cabd y $& ab -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 - c - /a(?{"{"})b/: Sequence (?{...}) not terminated or not {}-balanced +a(?{)b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE )b/ +a(?{{})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE {})b/ +a(?{}})b - c - +a(?{"{"})b - c - Sequence (?{...}) not terminated or not {}-balanced before HERE mark in regex m/a(?{ << HERE "{"})b/ a(?{"\{"})b cabd y $& ab a(?{"{"}})b - c - Unmatched right curly bracket a(?{$bl="\{"}).b caxbd y $bl { @@ -441,8 +441,8 @@ x(~~)*(?:(?:F)?)? x~~ y - - ^(\(+)?blah(?(1)(\)))$ blah y ($2) () ^(\(+)?blah(?(1)(\)))$ blah) n - - ^(\(+)?blah(?(1)(\)))$ (blah n - - -(?(1?)a|b) a c - /(?(1?)a|b)/: Switch (?(number? not recognized -(?(1)a|b|c) a c - /(?(1)a|b|c)/: Switch (?(condition)... contains too many branches +(?(1?)a|b) a c - Switch condition not recognized before HERE mark in regex m/(?(1? << HERE )a|b)/ +(?(1)a|b|c) a c - Switch (?(condition)... contains too many branches (?(?{0})a|b) a n - - (?(?{0})b|a) a y $& a (?(?{1})b|a) a n - - @@ -473,10 +473,10 @@ $(?<=^(a)) a y $1 a ([[:]+) a:[b]: y $1 :[ ([[=]+) a=[b]= y $1 =[ ([[.]+) a.[b]. y $1 .[ -[a[:xyz: - c - /[a[:xyz:/: unmatched [] in regexp -[a[:xyz:] - c - Character class [:xyz:] unknown +[a[:xyz: - c - Unmatched [ before HERE mark in regex m/[ << HERE a[:xyz:/ +[a[:xyz:] - c - POSIX class [:xyz:] unknown before HERE mark in regex m/[a[:xyz:] << HERE / [a[:]b[:c] abc y $& abc -([a[:xyz:]b]+) pbaq c - Character class [:xyz:] unknown +([a[:xyz:]b]+) pbaq c - POSIX class [:xyz:] unknown before HERE mark in regex m/([a[:xyz:] << HERE b]+)/ [a[:]b[:c] abc y $& abc ([[:alpha:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd ([[:alnum:]]+) ABcd01Xy__-- ${nulnul}${ffff} y $1 ABcd01Xy @@ -503,13 +503,13 @@ $(?<=^(a)) a y $1 a ([[:^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 +[[:foo:]] - c - POSIX class [:foo:] unknown before HERE mark in regex m/[[:foo:] << HERE ]/ +[[:^foo:]] - c - POSIX class [:^foo:] unknown before HERE mark in regex m/[[:^foo:] << HERE ]/ ((?>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 +(?<=x+)y - c - Variable length lookbehind not implemented +a{37,17} - c - 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 @@ -750,3 +750,37 @@ tt+$ xxxtt y - - ^([a-z]:) C:/ n - - '^\S\s+aa$'m \nx aa y - - (^|a)b ab y - - +^([ab]*?)(b)?(c)$ abac y -$2- -- +(\w)?(abc)\1b abcab n - - +^(?:.,){2}c a,b,c y - - +^(.,){2}c a,b,c y $1 b, +^(?:[^,]*,){2}c a,b,c y - - +^([^,]*,){2}c a,b,c y $1 b, +^([^,]*,){3}d aaa,b,c,d y $1 c, +^([^,]*,){3,}d aaa,b,c,d y $1 c, +^([^,]*,){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3}d aaa,b,c,d y $1 c, +^([^,]{1,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,3},){0,3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3}d aaa,b,c,d y $1 c, +^([^,]{1,},){3,}d aaa,b,c,d y $1 c, +^([^,]{1,},){0,3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3}d aaa,b,c,d y $1 c, +^([^,]{0,3},){3,}d aaa,b,c,d y $1 c, +^([^,]{0,3},){0,3}d aaa,b,c,d y $1 c, +(?i) y - - +'(?!\A)x'm a\nxb\n y - - +^(a(b)?)+$ aba y -$1-$2- -a-- +^(aa(bb)?)+$ aabbaa y -$1-$2- -aa-- +'^.{9}abc.*\n'm 123\nabcabcabcabc\n y - - +^(a)?a$ a y -$1- -- +^(a)?(?(1)a|b)+$ a n - - +^(a\1?)(a\1?)(a\2?)(a\3?)$ aaaaaa y $1,$2,$3,$4 a,aa,a,aa +^(a\1?){4}$ aaaaaa y $1 aa +^(0+)?(?:x(1))? x1 y - - +^([0-9a-fA-F]+)(?:x([0-9a-fA-F]+)?)(?:x([0-9a-fA-F]+))? 012cxx0190 y - - +^(b+?|a){1,2}c bbbac y $1 a +^(b+?|a){1,2}c bbbbac y $1 a +\((\w\. \w+)\) cd. (A. Tw) y -$1- -A. Tw- +((?:aaaa|bbbb)cccc)? aaaacccc y - - +((?:aaaa|bbbb)cccc)? bbbbcccc y - - diff --git a/contrib/perl5/t/op/readdir.t b/contrib/perl5/t/op/readdir.t index d101c2f..00199b0 100755 --- a/contrib/perl5/t/op/readdir.t +++ b/contrib/perl5/t/op/readdir.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } eval 'opendir(NOSUCH, "no/such/directory");'; @@ -20,7 +20,11 @@ if (opendir(OP, "op")) { print "ok 1\n"; } else { print "not ok 1\n"; } @D = grep(/^[^\.].*\.t$/i, readdir(OP)); closedir(OP); -if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; } +## +## This range will have to adjust as the number of tests expands, +## as it's counting the number of .t files in src/t +## +if (@D > 90 && @D < 110) { print "ok 2\n"; } else { print "not ok 2\n"; } @R = sort @D; @G = sort <op/*.t>; diff --git a/contrib/perl5/t/op/regexp.t b/contrib/perl5/t/op/regexp.t index 4ffe136..4a4d42f 100755 --- a/contrib/perl5/t/op/regexp.t +++ b/contrib/perl5/t/op/regexp.t @@ -1,8 +1,5 @@ #!./perl -# XXX known to leak scalars -$ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; - # The tests are in a separate file 't/op/re_tests'. # Each line in that file is a separate test. # There are five columns, separated by tabs. @@ -26,6 +23,9 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; # Column 5 contains the expected result of double-quote # interpolating that string after the match, or start of error message. # +# Column 6, if present, contains a reason why the test is skipped. +# This is printed with "skipped", for harness to pick up. +# # \n in the tests are interpolated, as are variables of the form ${\w+}. # # If you want to add a regular expression test that can't be expressed @@ -33,7 +33,7 @@ $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } $iters = shift || 1; # Poor man performance suite, 10000 is OK. @@ -56,7 +56,7 @@ TEST: while (<TESTS>) { chomp; s/\\n/\n/g; - ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_); + ($pat, $subject, $result, $repl, $expect, $reason) = split(/\t/,$_,6); $input = join(':',$pat,$subject,$result,$repl,$expect); infty_subst(\$pat); infty_subst(\$expect); @@ -70,7 +70,8 @@ while (<TESTS>) { $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/; $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):\]/; + $skip = 1, $reason = 'utf8' + if ($^H &= ~0x00000008) && $pat =~ /\[:\^(alnum|print|word|ascii|xdigit):\]/; $result =~ s/B//i unless $skip; for $study ('', 'study \$subject') { $c = $iters; @@ -81,7 +82,8 @@ while (<TESTS>) { last; # no need to study a syntax error } elsif ( $skip ) { - print "ok $. # skipped\n"; next TEST; + print "ok $. # skipped", length($reason) ? " $reason" : '', "\n"; + next TEST; } elsif ($@) { print "not ok $. $input => error `$err'\n"; next TEST; diff --git a/contrib/perl5/t/op/runlevel.t b/contrib/perl5/t/op/runlevel.t index e988ad9..b6c128b 100755 --- a/contrib/perl5/t/op/runlevel.t +++ b/contrib/perl5/t/op/runlevel.t @@ -7,7 +7,7 @@ ## chdir 't' if -d 't'; -unshift @INC, "../lib"; +@INC = '../lib'; $Is_VMS = $^O eq 'VMS'; $Is_MSWin32 = $^O eq 'MSWin32'; $ENV{PERL5LIB} = "../lib" unless $Is_VMS; @@ -349,3 +349,18 @@ A 1 bar B 2 bar +######## +sub n { 0 } +sub f { my $x = shift; d(); } +f(n()); +f(); + +sub d { + my $i = 0; my @a; + while (do { { package DB; @a = caller($i++) } } ) { + @a = @DB::args; + for (@a) { print "$_\n"; $_ = '' } + } +} +EXPECT +0 diff --git a/contrib/perl5/t/op/sort.t b/contrib/perl5/t/op/sort.t index ba0a4c2..29aff1d 100755 --- a/contrib/perl5/t/op/sort.t +++ b/contrib/perl5/t/op/sort.t @@ -2,16 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..49\n"; - -# XXX known to leak scalars -{ - no warnings 'uninitialized'; - $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; -} +print "1..57\n"; # these shouldn't hang { @@ -270,3 +264,54 @@ 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"; + +# check if context for sort arguments is handled right + +$test = 49; +sub test_if_list { + my $gimme = wantarray; + print "not " unless $gimme; + ++$test; + print "ok $test\n"; +} +my $m = sub { $a <=> $b }; + +sub cxt_one { sort $m test_if_list() } +cxt_one(); +sub cxt_two { sort { $a <=> $b } test_if_list() } +cxt_two(); +sub cxt_three { sort &test_if_list() } +cxt_three(); + +sub test_if_scalar { + my $gimme = wantarray; + print "not " if $gimme or !defined($gimme); + ++$test; + print "ok $test\n"; +} + +$m = \&test_if_scalar; +sub cxt_four { sort $m 1,2 } +@x = cxt_four(); +sub cxt_five { sort { test_if_scalar($a,$b); } 1,2 } +@x = cxt_five(); +sub cxt_six { sort test_if_scalar 1,2 } +@x = cxt_six(); + +# test against a reentrancy bug +{ + package Bar; + sub compare { $a cmp $b } + sub reenter { my @force = sort compare qw/a b/ } +} +{ + my($def, $init) = (0, 0); + @b = sort { + $def = 1 if defined $Bar::a; + Bar::reenter() unless $init++; + $a <=> $b + } qw/4 3 1 2/; + print ("@b" eq '1 2 3 4' ? "ok 56\n" : "not ok 56\n"); + print "# x = '@b'\n"; + print !$def ? "ok 57\n" : "not ok 57\n"; +} diff --git a/contrib/perl5/t/op/split.t b/contrib/perl5/t/op/split.t index 8b9f4ad..9a6586d 100755 --- a/contrib/perl5/t/op/split.t +++ b/contrib/perl5/t/op/split.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $ - -print "1..25\n"; +print "1..29\n"; $FS = ':'; @@ -109,3 +107,23 @@ print $_ eq "aa b |\naa d |" ? "ok 24\n" : "not ok 24\n# `$_'\n"; $_ = "a : b :c: d"; @ary = split(/\s*:\s*/); if (($res = join(".",@ary)) eq "a.b.c.d") {print "ok 25\n";} else {print "not ok 25\n# res=`$res' != `a.b.c.d'\n";} + +# use of match result as pattern (!) +'p:q:r:s' eq join ':', split('abc' =~ /b/, 'p1q1r1s') or print "not "; +print "ok 26\n"; + +# /^/ treated as /^/m +$_ = join ':', split /^/, "ab\ncd\nef\n"; +print "not " if $_ ne "ab\n:cd\n:ef\n"; +print "ok 27\n"; + +# see if @a = @b = split(...) optimization works +@list1 = @list2 = split ('p',"a p b c p"); +print "not " if @list1 != @list2 or "@list1" ne "@list2" + or @list1 != 2 or "@list1" ne "a b c "; +print "ok 28\n"; + +# zero-width assertion +$_ = join ':', split /(?=\w)/, "rm b"; +print "not" if $_ ne "r:m :b"; +print "ok 29\n"; diff --git a/contrib/perl5/t/op/sprintf.t b/contrib/perl5/t/op/sprintf.t index 4d54d2c..f4af3cd 100755 --- a/contrib/perl5/t/op/sprintf.t +++ b/contrib/perl5/t/op/sprintf.t @@ -1,38 +1,310 @@ #!./perl -# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $ +# Tests sprintf, excluding handling of 64-bit integers or long +# doubles (if supported), of machine-specific short and long +# integers, machine-specific floating point exceptions (infinity, +# not-a-number ...), of the effects of locale, and of features +# specific to multi-byte characters (under use utf8 and such). BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } use warnings; -print "1..4\n"; +while (<DATA>) { + s/^\s*>//; s/<\s*$//; + push @tests, [split(/<\s*>/, $_, 4)]; +} + +print '1..', scalar @tests, "\n"; $SIG{__WARN__} = sub { if ($_[0] =~ /^Invalid conversion/) { - $w++; + $w = ' INVALID' } else { warn @_; } }; -$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"; -} +for ($i = 1; @tests; $i++) { + ($template, $data, $result, $comment) = @{shift @tests}; + $evalData = eval $data; + $w = undef; + $x = sprintf(">$template<", + defined @$evalData ? @$evalData : $evalData); + substr($x, -1, 0) = $w if $w; + # $x may have 3 exponent digits, not 2 + my $y = $x; + if ($y =~ s/([Ee][-+])0(\d)/$1$2/) { + # if result is left-adjusted, append extra space + if ($template =~ /%\+?\-/ and $result =~ / $/) { + $y =~ s/<$/ </; + } + # if result is zero-filled, add extra zero + elsif ($template =~ /%\+?0/ and $result =~ /^0/) { + $y =~ s/^>0/>00/; + } + # if result is right-adjusted, prepend extra space + elsif ($result =~ /^ /) { + $y =~ s/^>/> /; + } + } -for $i (2 .. 4) { - $f = ('%6 .6s', '%6. 6s', '%6.6 s')[$i - 2]; - $w = 0; - $x = sprintf($f, ''); - if ($x eq $f && $w == 1) { - print "ok $i\n"; - } else { - print "not ok $i '$x' '$f' '$w'\n"; + if ($x eq ">$result<") { + print "ok $i\n"; + } + elsif ($y eq ">$result<") # Some C libraries always give + { # three-digit exponent + print("ok $i # >$result< $x three-digit exponent accepted\n"); + } + elsif ($result =~ /[-+]\d{3}$/ && + # Suppress tests with modulo of exponent >= 100 on platforms + # which can't handle such magnitudes (or where we can't tell). + ((!eval {require POSIX}) || # Costly: only do this if we must! + (length(&POSIX::DBL_MAX) - rindex(&POSIX::DBL_MAX, '+')) == 3)) + { + print("ok $i # >$template< >$data< >$result<", + " Suppressed: exponent out of range?\n") + } + else { + $y = ($x eq $y ? "" : " => $y"); + print("not ok $i >$template< >$data< >$result< $x$y", + $comment ? " # $comment\n" : "\n"); } } + +# In each of the the following lines, there are three required fields: +# printf template, data to be formatted (as a Perl expression), and +# expected result of formatting. An optional fourth field can contain +# a comment. Each field is delimited by a starting '>' and a +# finishing '<'; any whitespace outside these start and end marks is +# not part of the field. If formatting requires more than one data +# item (for example, if variable field widths are used), the Perl data +# expression should return a reference to an array having the requisite +# number of elements. Even so, subterfuge is sometimes required: see +# tests for %n and %p. +# +# The following tests are not currently run, for the reasons stated: + +=pod + +=begin problematic + +>%.0f< >-0.1< >-0< >C library bug: no minus on VMS, HP-UX< +>%.0f< >1.5< >2< >Standard vague: no rounding rules< +>%.0f< >2.5< >2< >Standard vague: no rounding rules< + +=end problematic + +=cut + +# template data result +__END__ +>%6. 6s< >''< >%6. 6s INVALID< >(See use of $w in code above)< +>%6 .6s< >''< >%6 .6s INVALID< +>%6.6 s< >''< >%6.6 s INVALID< +>%A< >''< >%A INVALID< +>%B< >''< >%B INVALID< +>%C< >''< >%C INVALID< +>%D< >0x7fffffff< >2147483647< >Synonym for %ld< +>%E< >123456.789< >1.234568E+05< >Like %e, but using upper-case "E"< +>%F< >123456.789< >123456.789000< >Synonym for %f< +>%G< >1234567.89< >1.23457E+06< >Like %g, but using upper-case "E"< +>%G< >1234567e96< >1.23457E+102< +>%G< >.1234567e-101< >1.23457E-102< +>%G< >12345.6789< >12345.7< +>%H< >''< >%H INVALID< +>%I< >''< >%I INVALID< +>%J< >''< >%J INVALID< +>%K< >''< >%K INVALID< +>%L< >''< >%L INVALID< +>%M< >''< >%M INVALID< +>%N< >''< >%N INVALID< +>%O< >2**32-1< >37777777777< >Synonum for %lo< +>%P< >''< >%P INVALID< +>%Q< >''< >%Q INVALID< +>%R< >''< >%R INVALID< +>%S< >''< >%S INVALID< +>%T< >''< >%T INVALID< +>%U< >2**32-1< >4294967295< >Synonum for %lu< +>%V< >''< >%V INVALID< +>%W< >''< >%W INVALID< +>%X< >2**32-1< >FFFFFFFF< >Like %x, but with u/c letters< +>%#X< >2**32-1< >0XFFFFFFFF< +>%Y< >''< >%Y INVALID< +>%Z< >''< >%Z INVALID< +>%a< >''< >%a INVALID< +>%b< >2**32-1< >11111111111111111111111111111111< +>%+b< >2**32-1< >11111111111111111111111111111111< +>%#b< >2**32-1< >0b11111111111111111111111111111111< +>%34b< >2**32-1< > 11111111111111111111111111111111< +>%034b< >2**32-1< >0011111111111111111111111111111111< +>%-34b< >2**32-1< >11111111111111111111111111111111 < +>%-034b< >2**32-1< >11111111111111111111111111111111 < +>%c< >ord('A')< >A< +>%10c< >ord('A')< > A< +>%#10c< >ord('A')< > A< ># modifier: no effect< +>%010c< >ord('A')< >000000000A< +>%10lc< >ord('A')< > A< >l modifier: no effect< +>%10hc< >ord('A')< > A< >h modifier: no effect< +>%10.5c< >ord('A')< > A< >precision: no effect< +>%-10c< >ord('A')< >A < +>%d< >123456.789< >123456< +>%d< >-123456.789< >-123456< +>%d< >0< >0< +>%+d< >0< >+0< +>%0d< >0< >0< +>%.0d< >0< >< +>%+.0d< >0< >+< +>%.0d< >1< >1< +>%d< >1< >1< +>%+d< >1< >+1< +>%#3.2d< >1< > 01< ># modifier: no effect< +>%3.2d< >1< > 01< +>%03.2d< >1< >001< +>%-3.2d< >1< >01 < +>%-03.2d< >1< >01 < >zero pad + left just.: no effect< +>%d< >-1< >-1< +>%+d< >-1< >-1< +>%hd< >1< >1< >More extensive testing of< +>%ld< >1< >1< >length modifiers would be< +>%Vd< >1< >1< >platform-specific< +>%vd< >chr(1)< >1< +>%+vd< >chr(1)< >+1< +>%#vd< >chr(1)< >1< +>%vd< >"\01\02\03"< >1.2.3< +>%v.3d< >"\01\02\03"< >001.002.003< +>%v03d< >"\01\02\03"< >001.002.003< +>%v-3d< >"\01\02\03"< >1 .2 .3 < +>%v+-3d< >"\01\02\03"< >+1 .2 .3 < +>%v4.3d< >"\01\02\03"< > 001. 002. 003< +>%v04.3d< >"\01\02\03"< >0001.0002.0003< +>%*v02d< >['-', "\0\7\14"]< >00-07-12< +>%v.*d< >[3, "\01\02\03"]< >001.002.003< +>%v0*d< >[3, "\01\02\03"]< >001.002.003< +>%v-*d< >[3, "\01\02\03"]< >1 .2 .3 < +>%v+-*d< >[3, "\01\02\03"]< >+1 .2 .3 < +>%v*.*d< >[4, 3, "\01\02\03"]< > 001. 002. 003< +>%v0*.*d< >[4, 3, "\01\02\03"]< >0001.0002.0003< +>%*v0*d< >['-', 2, "\0\7\13"]< >00-07-11< +>%e< >1234.875< >1.234875e+03< +>%e< >0.000012345< >1.234500e-05< +>%e< >1234567E96< >1.234567e+102< +>%e< >0< >0.000000e+00< +>%e< >.1234567E-101< >1.234567e-102< +>%+e< >1234.875< >+1.234875e+03< +>%#e< >1234.875< >1.234875e+03< +>%e< >-1234.875< >-1.234875e+03< +>%+e< >-1234.875< >-1.234875e+03< +>%#e< >-1234.875< >-1.234875e+03< +>%.0e< >1234.875< >1e+03< +>%#.0e< >1234.875< >1.e+03< +>%.*e< >[0, 1234.875]< >1e+03< +>%.1e< >1234.875< >1.2e+03< +>%-12.4e< >1234.875< >1.2349e+03 < +>%12.4e< >1234.875< > 1.2349e+03< +>%+-12.4e< >1234.875< >+1.2349e+03 < +>%+12.4e< >1234.875< > +1.2349e+03< +>%+-12.4e< >-1234.875< >-1.2349e+03 < +>%+12.4e< >-1234.875< > -1.2349e+03< +>%f< >1234.875< >1234.875000< +>%+f< >1234.875< >+1234.875000< +>%#f< >1234.875< >1234.875000< +>%f< >-1234.875< >-1234.875000< +>%+f< >-1234.875< >-1234.875000< +>%#f< >-1234.875< >-1234.875000< +>%6f< >1234.875< >1234.875000< +>%*f< >[6, 1234.875]< >1234.875000< +>%.0f< >1234.875< >1235< +>%.1f< >1234.875< >1234.9< +>%-8.1f< >1234.875< >1234.9 < +>%8.1f< >1234.875< > 1234.9< +>%+-8.1f< >1234.875< >+1234.9 < +>%+8.1f< >1234.875< > +1234.9< +>%+-8.1f< >-1234.875< >-1234.9 < +>%+8.1f< >-1234.875< > -1234.9< +>%*.*f< >[5, 2, 12.3456]< >12.35< +>%f< >0< >0.000000< +>%.0f< >0< >0< +>%.0f< >2**38< >274877906944< >Should have exact int'l rep'n< +>%.0f< >0.1< >0< +>%.0f< >0.6< >1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >-0.6< >-1< >Known to fail with sfio and (irix|nonstop-ux|powerux)< +>%.0f< >1< >1< +>%#.0f< >1< >1.< +>%g< >12345.6789< >12345.7< +>%+g< >12345.6789< >+12345.7< +>%#g< >12345.6789< >12345.7< +>%.0g< >12345.6789< >1e+04< +>%#.0g< >12345.6789< >1.e+04< +>%.2g< >12345.6789< >1.2e+04< +>%.*g< >[2, 12345.6789]< >1.2e+04< +>%.9g< >12345.6789< >12345.6789< +>%12.9g< >12345.6789< > 12345.6789< +>%012.9g< >12345.6789< >0012345.6789< +>%-12.9g< >12345.6789< >12345.6789 < +>%*.*g< >[-12, 9, 12345.6789]< >12345.6789 < +>%-012.9g< >12345.6789< >12345.6789 < +>%g< >-12345.6789< >-12345.7< +>%+g< >-12345.6789< >-12345.7< +>%g< >1234567.89< >1.23457e+06< +>%+g< >1234567.89< >+1.23457e+06< +>%#g< >1234567.89< >1.23457e+06< +>%g< >-1234567.89< >-1.23457e+06< +>%+g< >-1234567.89< >-1.23457e+06< +>%#g< >-1234567.89< >-1.23457e+06< +>%g< >0.00012345< >0.00012345< +>%g< >0.000012345< >1.2345e-05< +>%g< >1234567E96< >1.23457e+102< +>%g< >.1234567E-101< >1.23457e-102< +>%g< >0< >0< +>%13g< >1234567.89< > 1.23457e+06< +>%+13g< >1234567.89< > +1.23457e+06< +>%013g< >1234567.89< >001.23457e+06< +>%-13g< >1234567.89< >1.23457e+06 < +>%h< >''< >%h INVALID< +>%i< >123456.789< >123456< >Synonym for %d< +>%j< >''< >%j INVALID< +>%k< >''< >%k INVALID< +>%l< >''< >%l INVALID< +>%m< >''< >%m INVALID< +>%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n< +>%o< >2**32-1< >37777777777< +>%+o< >2**32-1< >37777777777< +>%#o< >2**32-1< >037777777777< +>%d< >$p=sprintf('%p',$p);$p=~/^[0-9a-f]+$/< >1< >Coarse hack: hex from %p?< +>%#p< >''< >%#p INVALID< +>%q< >''< >%q INVALID< +>%r< >''< >%r INVALID< +>%s< >'string'< >string< +>%10s< >'string'< > string< +>%+10s< >'string'< > string< +>%#10s< >'string'< > string< +>%010s< >'string'< >0000string< +>%0*s< >[10, 'string']< >0000string< +>%-10s< >'string'< >string < +>%3s< >'string'< >string< +>%.3s< >'string'< >str< +>%.*s< >[3, 'string']< >str< +>%t< >''< >%t INVALID< +>%u< >2**32-1< >4294967295< +>%+u< >2**32-1< >4294967295< +>%#u< >2**32-1< >4294967295< +>%12u< >2**32-1< > 4294967295< +>%012u< >2**32-1< >004294967295< +>%-12u< >2**32-1< >4294967295 < +>%-012u< >2**32-1< >4294967295 < +>%v< >''< >%v INVALID< +>%w< >''< >%w INVALID< +>%x< >2**32-1< >ffffffff< +>%+x< >2**32-1< >ffffffff< +>%#x< >2**32-1< >0xffffffff< +>%10x< >2**32-1< > ffffffff< +>%010x< >2**32-1< >00ffffffff< +>%-10x< >2**32-1< >ffffffff < +>%-010x< >2**32-1< >ffffffff < +>%0-10x< >2**32-1< >ffffffff < +>%0*x< >[-10, ,2**32-1]< >ffffffff < +>%y< >''< >%y INVALID< +>%z< >''< >%z INVALID< diff --git a/contrib/perl5/t/op/stat.t b/contrib/perl5/t/op/stat.t index af4920c..1d8c7a3 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'; - unshift @INC, '../lib'; + @INC = '../lib'; } use Config; @@ -32,7 +32,7 @@ if (open(FOO, ">Op.stat.tmp")) { else { print "# res=$res, nlink=$nlink.\nnot ok 1\n"; } - if ($Is_MSWin32 or $Is_Cygwin || ($mtime && $mtime == $ctime)) { + if ($Is_MSWin32 or $Is_Cygwin or $Is_Dos || ($mtime && $mtime == $ctime)) { print "ok 2\n"; } else { @@ -80,6 +80,7 @@ else { print "not ok 4\n"; print "#4 If test op/stat.t fails test 4, check if you are on a tmpfs\n"; print "#4 of some sort. Building in /tmp sometimes has this problem.\n"; + print "#4 Also building on the ClearCase VOBS filesystem may cause this failure.\n"; } print "#4 :$mtime: should != :$ctime:\n"; @@ -177,14 +178,18 @@ if ($^O eq 'mpeix' or $^O eq 'amigaos' or $Is_Dosish or $Is_Cygwin) { $cnt = $uid = 0; die "Can't run op/stat.t test 35 without pwd working" unless $cwd; -($bin) = grep {-d} ($^O eq 'machten' ? qw(/usr/bin /bin) : qw(/bin /usr/bin)) - or print ("not ok 35\n"), goto tty_test; -opendir BIN, $bin or die "Can't opendir $bin: $!"; -while (defined($_ = readdir BIN)) { - $_ = "$bin/$_"; - $cnt++; - $uid++ if -u; - last if $uid && $uid < $cnt; +my @bin = grep {-d} ($^O eq 'machten' ? + qw(/usr/bin /bin) : + qw(/sbin /usr/sbin /bin /usr/bin)); +unless (@bin) { print ("not ok 35\n"), goto tty_test; } +for my $bin (@bin) { + opendir BIN, $bin or die "Can't opendir $bin: $!"; + while (defined($_ = readdir BIN)) { + $_ = "$bin/$_"; + $cnt++; + $uid++ if -u; + last if $uid && $uid < $cnt; + } } closedir BIN; diff --git a/contrib/perl5/t/op/subst.t b/contrib/perl5/t/op/subst.t index 9757f4c..7dd7a1c 100755 --- a/contrib/perl5/t/op/subst.t +++ b/contrib/perl5/t/op/subst.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/subst_amp.t b/contrib/perl5/t/op/subst_amp.t index e2e7c0e5..7189572 100755 --- a/contrib/perl5/t/op/subst_amp.t +++ b/contrib/perl5/t/op/subst_amp.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; require Config; import Config; } diff --git a/contrib/perl5/t/op/substr.t b/contrib/perl5/t/op/substr.t index 5764e67..85574d5 100755 --- a/contrib/perl5/t/op/substr.t +++ b/contrib/perl5/t/op/substr.t @@ -1,10 +1,12 @@ +#!./perl -print "1..125\n"; +print "1..174\n"; #P = start of string Q = start of substr R = end of substr S = end of string BEGIN { - unshift @INC, '../lib' if -d '../lib' ; + chdir 't' if -d 't'; + @INC = '../lib'; } use warnings ; @@ -268,3 +270,318 @@ 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'; + +{ + my $y = 10; + $y = "2" . $y; + ok 126, $y+0 == 210; +} + +# utf8 sanity +{ + my $x = substr("a\x{263a}b",0); + ok 127, length($x) == 3; + $x = substr($x,1,1); + ok 128, $x eq "\x{263a}"; + $x = $x x 2; + ok 129, length($x) == 2; + substr($x,0,1) = "abcd"; + ok 130, $x eq "abcd\x{263a}"; + ok 131, length($x) == 5; + $x = reverse $x; + ok 132, length($x) == 5; + ok 133, $x eq "\x{263a}dcba"; + + my $z = 10; + $z = "21\x{263a}" . $z; + ok 134, length($z) == 5; + ok 135, $z eq "21\x{263a}10"; +} + +# replacement should work on magical values +require Tie::Scalar; +my %data; +tie $data{'a'}, 'Tie::StdScalar'; # makes $data{'a'} magical +$data{a} = "firstlast"; +ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last"; + +# more utf8 + +# The following two originally from Ignasi Roca. + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF} +ok 137, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF} +ok 138, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +# more utf8 lval exercise + +$x = "\xF1\xF2\xF3"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 139, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 140, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 141, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 142, length($x) == 5 && + $x eq "\xF1\xF2\xF3\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 143, length($x) == 4 && + $x eq "\xF1\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 144, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 145, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 146, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 147, length($x) == 5 && + $x eq "\x{100}\xFF\xF1\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F1}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 148, length($x) == 4 && + $x eq "\xF1\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\xF1\xF2\xF3"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 149, length($x) == 5 && + $x eq "\xF1\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{F1}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +# And tests for already-UTF8 one + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}"; +ok 150, length($x) == 3 && + $x eq "\x{100}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 1) = "\x{100}\x{FF}"; +ok 151, length($x) == 4 && + $x eq "\x{100}\x{FF}\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, 2) = "\x{100}\xFF"; +ok 152, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, 1) = "\x{100}\xFF"; +ok 153, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 2, 1) = "\x{100}\xFF"; +ok 154, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 3, 1) = "\x{100}\xFF"; +ok 155, length($x) == 5 && + $x eq "\x{101}\x{F2}\x{F3}\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{F3}" && + substr($x, 3, 1) eq "\x{100}" && + substr($x, 4, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 1) = "\x{100}\xFF"; +ok 156, length($x) == 4 && + $x eq "\x{101}\xF2\x{100}\xFF" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, 0) = "\x{100}\xFF"; +ok 157, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -1) = "\x{100}\xFF"; +ok 158, length($x) == 3 && + $x eq "\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -2) = "\x{100}\xFF"; +ok 159, length($x) == 4 && + $x eq "\x{100}\xFF\xF2\xF3" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{F2}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 0, -3) = "\x{100}\xFF"; +ok 160, length($x) == 5 && + $x eq "\x{100}\xFF\x{101}\x{F2}\x{F3}" && + substr($x, 0, 1) eq "\x{100}" && + substr($x, 1, 1) eq "\x{FF}" && + substr($x, 2, 1) eq "\x{101}" && + substr($x, 3, 1) eq "\x{F2}" && + substr($x, 4, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, 1, -1) = "\x{100}\xFF"; +ok 161, length($x) == 4 && + $x eq "\x{101}\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{100}" && + substr($x, 2, 1) eq "\x{FF}" && + substr($x, 3, 1) eq "\x{F3}"; + +$x = "\x{101}\x{F2}\x{F3}"; +substr($x, -1, -1) = "\x{100}\xFF"; +ok 162, length($x) == 5 && + $x eq "\x{101}\xF2\x{100}\xFF\xF3" && + substr($x, 0, 1) eq "\x{101}" && + substr($x, 1, 1) eq "\x{F2}" && + substr($x, 2, 1) eq "\x{100}" && + substr($x, 3, 1) eq "\x{FF}" && + substr($x, 4, 1) eq "\x{F3}"; + +substr($x = "ab", 0, 0, "\x{100}\x{200}"); +ok 163, $x eq "\x{100}\x{200}ab"; + +substr($x = "\x{100}\x{200}", 0, 0, "ab"); +ok 164, $x eq "ab\x{100}\x{200}"; + +substr($x = "ab", 1, 0, "\x{100}\x{200}"); +ok 165, $x eq "a\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "ab"); +ok 166, $x eq "\x{100}ab\x{200}"; + +substr($x = "ab", 2, 0, "\x{100}\x{200}"); +ok 167, $x eq "ab\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "ab"); +ok 168, $x eq "\x{100}\x{200}ab"; + +substr($x = "\xFFb", 0, 0, "\x{100}\x{200}"); +ok 169, $x eq "\x{100}\x{200}\xFFb"; + +substr($x = "\x{100}\x{200}", 0, 0, "\xFFb"); +ok 170, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\xFFb", 1, 0, "\x{100}\x{200}"); +ok 171, $x eq "\xFF\x{100}\x{200}b"; + +substr($x = "\x{100}\x{200}", 1, 0, "\xFFb"); +ok 172, $x eq "\x{100}\xFFb\x{200}"; + +substr($x = "\xFFb", 2, 0, "\x{100}\x{200}"); +ok 173, $x eq "\xFFb\x{100}\x{200}"; + +substr($x = "\x{100}\x{200}", 2, 0, "\xFFb"); +ok 174, $x eq "\x{100}\x{200}\xFFb"; + diff --git a/contrib/perl5/t/op/taint.t b/contrib/perl5/t/op/taint.t index 6548b46..2958a37 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'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; } use strict; @@ -19,14 +19,20 @@ use Config; # just because Errno possibly failing. eval { require Errno; import Errno }; +use vars qw($ipcsysv); # did we manage to load IPC::SysV? + 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)); + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ + && ($Config{d_shm} || $Config{d_msg})) { + eval { require IPC::SysV }; + unless ($@) { + $ipcsysv++; + IPC::SysV->import(qw(IPC_PRIVATE IPC_RMID IPC_CREAT S_IRWXU)); + } } } @@ -98,7 +104,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..151\n"; +print "1..155\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -612,13 +618,17 @@ else { # test shmread { - if ($Config{d_shm}) { + unless ($ipcsysv) { + print "ok 150 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $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"; + my $id = shmget(IPC_PRIVATE, $size, S_IRWXU); + if (defined $id) { if (shmwrite($id, $sent, 0, 60)) { if (shmread($id, $rcvd, 0, 60)) { @@ -629,7 +639,7 @@ else { } else { warn "# shmwrite failed: $!\n"; } - shmctl($id, IPC_RMID, 0) || warn "# shmctl failed: $!\n"; + shmctl($id, IPC_RMID, 0) or warn "# shmctl failed: $!\n"; } else { warn "# shmget failed: $!\n"; } @@ -646,7 +656,11 @@ else { # test msgrcv { - if ($Config{d_msg}) { + unless ($ipcsysv) { + print "ok 151 # skipped: no IPC::SysV\n"; + last; + } + if ($Config{'extensions'} =~ /\bIPC\/SysV\b/ && $Config{d_msg}) { no strict 'subs'; my $id = msgget(IPC_PRIVATE, IPC_CREAT | S_IRWXU); @@ -665,7 +679,7 @@ else { } else { warn "# msgsnd failed\n"; } - msgctl($id, IPC_RMID, 0) || warn "# msgctl failed: $!\n"; + msgctl($id, IPC_RMID, 0) or warn "# msgctl failed: $!\n"; } else { warn "# msgget failed\n"; } @@ -680,3 +694,42 @@ else { } } +{ + # bug id 20001004.006 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + local $/; + my $a = <IN>; + my $b = <IN>; + print "not " unless tainted($a) && tainted($b) && !defined($b); + print "ok 152\n"; + close IN; +} + +{ + # bug id 20001004.007 + + open IN, "./TEST" or warn "$0: cannot read ./TEST: $!" ; + my $a = <IN>; + + my $c = { a => 42, + b => $a }; + print "not " unless !tainted($c->{a}) && tainted($c->{b}); + print "ok 153\n"; + + my $d = { a => $a, + b => 42 }; + print "not " unless tainted($d->{a}) && !tainted($d->{b}); + print "ok 154\n"; + + my $e = { a => 42, + b => { c => $a, d => 42 } }; + print "not " unless !tainted($e->{a}) && + !tainted($e->{b}) && + tainted($e->{b}->{c}) && + !tainted($e->{b}->{d}); + print "ok 155\n"; + + close IN; +} + diff --git a/contrib/perl5/t/op/tie.t b/contrib/perl5/t/op/tie.t index 9543420..cbf92c6 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'; -unshift @INC, "../lib"; +@INC = '../lib'; $ENV{PERL5LIB} = "../lib"; $|=1; @@ -44,6 +44,21 @@ untie %h; EXPECT ######## +# standard behaviour, without any extra references +use Tie::Hash ; +{package Tie::HashUntie; + use base 'Tie::StdHash'; + sub UNTIE + { + warn "Untied\n"; + } +} +tie %h, Tie::HashUntie; +untie %h; +EXPECT +Untied +######## + # standard behaviour, with 1 extra reference use Tie::Hash ; $a = tie %h, Tie::StdHash; diff --git a/contrib/perl5/t/op/tiearray.t b/contrib/perl5/t/op/tiearray.t index 25fda3f..8e78b2f 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'; - unshift @INC, '../lib'; + @INC = '../lib'; } my %seen; diff --git a/contrib/perl5/t/op/tiehandle.t b/contrib/perl5/t/op/tiehandle.t index 6ae3faa..b04bdb7 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'; - unshift @INC, '../lib'; + @INC = '../lib'; } my @expect; @@ -77,7 +77,7 @@ package main; use Symbol; -print "1..29\n"; +print "1..33\n"; my $fh = gensym; @@ -149,3 +149,19 @@ ok($data eq "qwerty"); @expect = (CLOSE => $ob); $r = close $fh; ok($r == 5); + +# Does aliasing work with tied FHs? +*ALIAS = *$fh; +@expect = (PRINT => $ob,"some","text"); +$r = print ALIAS @expect[2,3]; +ok($r == 1); + +{ + use warnings; + # Special case of aliasing STDERR, which used + # to dump core when warnings were enabled + *STDERR = *$fh; + @expect = (PRINT => $ob,"some","text"); + $r = print STDERR @expect[2,3]; + ok($r == 1); +} diff --git a/contrib/perl5/t/op/tr.t b/contrib/perl5/t/op/tr.t index 4e6667c..c7ba0d8 100755 --- a/contrib/perl5/t/op/tr.t +++ b/contrib/perl5/t/op/tr.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..4\n"; +print "1..54\n"; $_ = "abcdefghijklmnopqrstuvwxyz"; @@ -37,3 +37,275 @@ print "ok 3\n"; print "ok 4\n"; } # + +# make sure that tr cancels IOK and NOK +($x = 12) =~ tr/1/3/; +(my $y = 12) =~ tr/1/3/; +($f = 1.5) =~ tr/1/3/; +(my $g = 1.5) =~ tr/1/3/; +print "not " unless $x + $y + $f + $g == 71; +print "ok 5\n"; + +# make sure tr is harmless if not updating - see [ID 20000511.005] +$_ = 'fred'; +/([a-z]{2})/; +$1 =~ tr/A-Z//; +s/^(\s*)f/$1F/; +print "not " if $_ ne 'Fred'; +print "ok 6\n"; + +# check tr handles UTF8 correctly +($x = 256.65.258) =~ tr/a/b/; +print "not " if $x ne 256.65.258 or length $x != 3; +print "ok 7\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.66.258 or length $x != 3; +} +else { + print "not " if $x ne 256.65.258 or length $x != 3; +} +print "ok 8\n"; +# EBCDIC variants of the above tests +($x = 256.193.258) =~ tr/a/b/; +print "not " if $x ne 256.193.258 or length $x != 3; +print "ok 9\n"; +$x =~ tr/A/B/; +if (ord("\t") == 9) { # ASCII + print "not " if $x ne 256.193.258 or length $x != 3; +} +else { + print "not " if $x ne 256.194.258 or length $x != 3; +} +print "ok 10\n"; + +{ +if (ord("\t") == 9) { # ASCII + use utf8; +} +# 11 - changing UTF8 characters in a UTF8 string, same length. +$l = chr(300); $r = chr(400); +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{190}/; +printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3; +print "ok 11\n"; + +# 12 - changing UTF8 characters in UTF8 string, more bytes. +$x = 200.300.400; +$x =~ tr/\x{12c}/\x{be8}/; +printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3; +print "ok 12\n"; + +# 13 - introducing UTF8 characters to non-UTF8 string. +$x = 100.125.60; +$x =~ tr/\x{64}/\x{190}/; +printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3; +print "ok 13\n"; + +# 14 - removing UTF8 characters from UTF8 string +$x = 400.125.60; +$x =~ tr/\x{190}/\x{64}/; +printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3; +print "ok 14\n"; + +# 15 - counting UTF8 chars in UTF8 string +$x = 400.125.60.400; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 2; +print "ok 15\n"; + +# 16 - counting non-UTF8 chars in UTF8 string +$x = 60.400.125.60.400; +$y = $x =~ tr/\x{3c}/\x{3c}/; +print "not " if $y != 2; +print "ok 16\n"; + +# 17 - counting UTF8 chars in non-UTF8 string +$x = 200.125.60; +$y = $x =~ tr/\x{190}/\x{190}/; +print "not " if $y != 0; +print "ok 17\n"; +} + +# 18: test brokenness with tr/a-z-9//; +$_ = "abcdefghijklmnopqrstuvwxyz"; +eval "tr/a-z-9/ /"; +print (($@ =~ /^Ambiguous range in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 18\n"); + +# 19-21: Make sure leading and trailing hyphens still work +$_ = "car-rot9"; +tr/-a-m/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 19\n"); + +$_ = "car-rot9"; +tr/a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 20\n"); + +$_ = "car-rot9"; +tr/-a-m-/./; +print (($_ eq '..r.rot9') ? '' : 'not ', "ok 21\n"); + +$_ = "abcdefghijklmnop"; +tr/ae-hn/./; +print (($_ eq '.bcd....ijklm.op') ? '' : 'not ', "ok 22\n"); + +$_ = "abcdefghijklmnop"; +tr/a-cf-kn-p/./; +print (($_ eq '...de......lm...') ? '' : 'not ', "ok 23\n"); + +$_ = "abcdefghijklmnop"; +tr/a-ceg-ikm-o/./; +print (($_ eq '...d.f...j.l...p') ? '' : 'not ', "ok 24\n"); + +# 25: Test reversed range check +# 20000705 MJD +eval "tr/m-d/ /"; +print (($@ =~ /^Invalid \[\] range "m-d" in transliteration operator/ || $^V lt v5.7.0) + ? '' : 'not ', "ok 25\n"); + +# 26: test cannot update if read-only +eval '$1 =~ tr/x/y/'; +print (($@ =~ /^Modification of a read-only value attempted/) ? '' : 'not ', + "ok 26\n"); + +# 27: test can count read-only +'abcdef' =~ /(bcd)/; +print (( eval '$1 =~ tr/abcd//' == 3) ? '' : 'not ', "ok 27\n"); + +# 28: test lhs OK if not updating +print ((eval '"123" =~ tr/12//' == 2) ? '' : 'not ', "ok 28\n"); + +# 29: test lhs bad if updating +eval '"123" =~ tr/1/1/'; +print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|) + ? '' : 'not ', "ok 29\n"); + +# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac) +# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90) + +# Transliterate a byte to a byte, all four ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 30\n"; + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 31\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 32\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/; +print "not " unless $a eq v300.197.172.300.197.172; +print "ok 33\n"; + +# Transliterate a byte to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/; +print "not " unless $a eq v300.301.172.300.301.172; +print "ok 34\n"; + +# Transliterate a wide character to a byte. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/; +print "not " unless $a eq v195.196.172.195.196.172; +print "ok 35\n"; + +# Transliterate a wide character to a wide character. + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/; +print "not " unless $a eq v301.196.172.301.196.172; +print "ok 36\n"; + +# Transliterate both ways. + +($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/; +print "not " unless $a eq v195.301.172.195.301.172; +print "ok 37\n"; + +# Transliterate all (four) ways. + +($a = v300.196.172.300.196.172.400.198.144) =~ + tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/; +print "not " unless $a eq v197.301.173.197.301.173.401.198.144; +print "ok 38\n"; + +# Transliterate and count. + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/) == 2; +print "ok 39\n"; + +print "not " + unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2; +print "ok 40\n"; + +# Transliterate with complement. + +($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c; +print "not " unless $a eq v301.196.301.301.196.301; +print "ok 41\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c; +print "not " unless $a eq v300.197.197.300.197.197; +print "ok 42\n"; + +# Transliterate with deletion. + +($a = v300.196.172.300.196.172) =~ tr/\xc4//d; +print "not " unless $a eq v300.172.300.172; +print "ok 43\n"; + +($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d; +print "not " unless $a eq v196.172.196.172; +print "ok 44\n"; + +# Transliterate with squeeze. + +($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s; +print "not " unless $a eq v197.172.300.300.197.172; +print "ok 45\n"; + +($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s; +print "not " unless $a eq v196.172.301.196.172.172; +print "ok 46\n"; + +# Tricky cases by Simon Cozens. + +($a = v196.172.200) =~ tr/\x{12c}/a/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 47\n"; + +($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 48\n"; + +($a = v196.172.200) =~ tr/\x{12c}//d; +print "not " unless sprintf("%vd", $a) eq '196.172.200'; +print "ok 49\n"; + +# UTF8 range + +($a = v300.196.172.302.197.172) =~ tr/\x{12c}-\x{130}/\xc0-\xc4/; +print "not " unless $a eq v192.196.172.194.197.172; +print "ok 50\n"; + +($a = v300.196.172.302.197.172) =~ tr/\xc4-\xc8/\x{12c}-\x{130}/; +print "not " unless $a eq v300.300.172.302.301.172; +print "ok 51\n"; + +# misc +($a = "R0_001") =~ tr/R_//d; +print "not " if hex($a) != 1; +print "ok 52\n"; + +@a = (1,2); map { y/1/./ for $_ } @a; +print "not " if "@a" ne ". 2"; +print "ok 53\n"; + +@a = (1,2); map { y/1/./ for $_.'' } @a; +print "not " if "@a" ne "1 2"; +print "ok 54\n"; diff --git a/contrib/perl5/t/op/undef.t b/contrib/perl5/t/op/undef.t index 8944ee3..f6e36a5 100755 --- a/contrib/perl5/t/op/undef.t +++ b/contrib/perl5/t/op/undef.t @@ -2,7 +2,7 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib'; + @INC = '../lib'; } print "1..27\n"; diff --git a/contrib/perl5/t/op/universal.t b/contrib/perl5/t/op/universal.t index a6bd03d..e6db8e6 100755 --- a/contrib/perl5/t/op/universal.t +++ b/contrib/perl5/t/op/universal.t @@ -5,10 +5,11 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, '../lib' if -d '../lib'; + @INC = '../lib'; + $| = 1; } -print "1..73\n"; +print "1..80\n"; $a = {}; bless $a, "Bob"; @@ -28,6 +29,19 @@ sub new { bless {} } $Alice::VERSION = 2.718; +{ + package Cedric; + our @ISA; + use base qw(Human); +} + +{ + package Programmer; + our $VERSION = 1.667; + + sub write_perl { 1 } +} + package main; my $i = 2; @@ -45,12 +59,34 @@ test $a->isa("Human"); test ! $a->isa("Male"); +test ! $a->isa('Programmer'); + test $a->can("drink"); test $a->can("eat"); test ! $a->can("sleep"); +test (!Cedric->isa('Programmer')); + +test (Cedric->isa('Human')); + +push(@Cedric::ISA,'Programmer'); + +test (Cedric->isa('Programmer')); + +{ + package Alice; + base::->import('Programmer'); +} + +test $a->isa('Programmer'); +test $a->isa("Female"); + +@Cedric::ISA = qw(Bob); + +test (!Cedric->isa('Programmer')); + my $b = 'abc'; my @refs = qw(SCALAR SCALAR LVALUE GLOB ARRAY HASH CODE); my @vals = ( \$b, \3.14, \substr($b,1,1), \*b, [], {}, sub {} ); @@ -88,7 +124,7 @@ eval "use UNIVERSAL"; test $a->isa("UNIVERSAL"); -my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; +my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; # XXX import being here is really a bug if ('a' lt 'A') { test $sub2 eq "can import isa VERSION"; diff --git a/contrib/perl5/t/op/vec.t b/contrib/perl5/t/op/vec.t index bf60fc4..7fe0974 100755 --- a/contrib/perl5/t/op/vec.t +++ b/contrib/perl5/t/op/vec.t @@ -1,8 +1,6 @@ #!./perl -# $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $ - -print "1..15\n"; +print "1..30\n"; print vec($foo,0,1) == 0 ? "ok 1\n" : "not ok 1\n"; print length($foo) == 0 ? "ok 2\n" : "not ok 2\n"; @@ -25,3 +23,58 @@ vec($Vec, 0, 32) = 0xbaddacab; print $Vec eq "\xba\xdd\xac\xab" ? "ok 14\n" : "not ok 14\n"; print vec($Vec, 0, 32) == 3135089835 ? "ok 15\n" : "not ok 15\n"; +# ensure vec() handles numericalness correctly +$foo = $bar = $baz = 0; +vec($foo = 0,0,1) = 1; +vec($bar = 0,1,1) = 1; +$baz = $foo | $bar; +print $foo eq "1" && $foo == 1 ? "ok 16\n" : "not ok 16\n"; +print $bar eq "2" && $bar == 2 ? "ok 17\n" : "not ok 17\n"; +print "$foo $bar $baz" eq "1 2 3" ? "ok 18\n" : "not ok 18\n"; + +# error cases + +$x = eval { vec $foo, 0, 3 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 19\n"; +$x = eval { vec $foo, 0, 0 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 20\n"; +$x = eval { vec $foo, 0, -13 }; +print "not " if defined $x or $@ !~ /^Illegal number of bits in vec/; +print "ok 21\n"; +$x = eval { vec($foo, -1, 4) = 2 }; +print "not " if defined $x or $@ !~ /^Assigning to negative offset in vec/; +print "ok 22\n"; +print "not " if vec('abcd', 7, 8); +print "ok 23\n"; + +# UTF8 +# N.B. currently curiously coded to circumvent bugs elswhere in UTF8 handling + +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +print "not " if vec($x, 0, 8) != 255; +print "ok 24\n"; +eval { vec($foo, 1, 8) }; +print "not " if $@; +print "ok 25\n"; +eval { vec($foo, 1, 8) = 13 }; +print "not " if $@; +print "ok 26\n"; +print "not " if $foo ne "\xc4\x0d\xc3\xbf\xc3\xbe"; +print "ok 27\n"; +$foo = "\x{100}" . "\xff\xfe"; +$x = substr $foo, 1; +vec($x, 2, 4) = 7; +print "not " if $x ne "\xff\xf7"; +print "ok 28\n"; + +# mixed magic + +$foo = "\x61\x62\x63\x64\x65\x66"; +print "not " if vec(substr($foo, 2, 2), 0, 16) != 25444; +print "ok 29\n"; +vec(substr($foo, 1,3), 5, 4) = 3; +print "not " if $foo ne "\x61\x62\x63\x34\x65\x66"; +print "ok 30\n"; diff --git a/contrib/perl5/t/op/ver.t b/contrib/perl5/t/op/ver.t index b08849f..edfebd2 100755 --- a/contrib/perl5/t/op/ver.t +++ b/contrib/perl5/t/op/ver.t @@ -2,10 +2,10 @@ BEGIN { chdir 't' if -d 't'; - unshift @INC, "../lib"; + @INC = '../lib'; } -print "1..22\n"; +print "1..28\n"; my $test = 1; @@ -14,13 +14,24 @@ 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; +if (ord("\t") == 9) { # ASCII + print v111; + print v107.32; + print "$test\n"; ++$test; + + # hash keys too + $h{v111.107} = "ok"; + print "$h{ok} $test\n"; ++$test; +} +else { # EBCDIC + print v150; + print v146.64; + print "$test\n"; ++$test; + + # hash keys too + $h{v150.146} = "ok"; + print "$h{ok} $test\n"; ++$test; +} # poetry optimization should also sub v77 { "ok" } @@ -28,7 +39,12 @@ $x = v77; print "$x $test\n"; ++$test; # but not when dots are involved -$x = v77.78.79; +if (ord("\t") == 9) { # ASCII + $x = v77.78.79; +} +else { + $x = v212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -42,10 +58,20 @@ require 5.5.640; print "ok $test\n"; ++$test; # hash keys too -$h{111.107.32} = "ok"; +if (ord("\t") == 9) { # ASCII + $h{111.107.32} = "ok"; +} +else { + $h{150.146.64} = "ok"; +} print "$h{ok } $test\n"; ++$test; -$x = 77.78.79; +if (ord("\t") == 9) { # ASCII + $x = 77.78.79; +} +else { + $x = 212.213.214; +} print "not " unless $x eq "MNO"; print "ok $test\n"; ++$test; @@ -53,44 +79,103 @@ 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'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; +} +else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; +} 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'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; +} +else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; +} 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'; +if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; +} +else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; +} print "ok $test\n"; ++$test; print "not " unless sprintf("%*vb", "##", v1.22.333.4444) eq '1##10110##101001101##1000101011100'; print "ok $test\n"; ++$test; +print "not " unless sprintf("%vd", join("", map { chr } + unpack "U*", v2001.2002.2003)) + eq '2001.2002.2003'; +print "ok $test\n"; ++$test; + { use bytes; - print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108'; + } + else { + print "not " unless sprintf("%vd", "Perl") eq '215.133.153.147'; + } 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'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c'; + } + else { + print "not " unless sprintf("%vx", "Perl") eq 'd7.85.99.93'; + } 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'; + if (ord("\t") == 9) { # ASCII + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154'; + } + else { + print "not " unless sprintf("%*v#o", ":", "Perl") eq '0327:0205:0231:0223'; + } 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; } + +{ + # bug id 20000323.056 + + print "not " unless "\x{41}" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x41" eq +v65; + print "ok $test\n"; + $test++; + + print "not " unless "\x{c8}" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\xc8" eq +v200; + print "ok $test\n"; + $test++; + + print "not " unless "\x{221b}" eq v8731; + print "ok $test\n"; + $test++; +} diff --git a/contrib/perl5/t/op/wantarray.t b/contrib/perl5/t/op/wantarray.t index 0a47b6d..4b6f37c 100755 --- a/contrib/perl5/t/op/wantarray.t +++ b/contrib/perl5/t/op/wantarray.t @@ -1,6 +1,6 @@ #!./perl -print "1..3\n"; +print "1..7\n"; sub context { my ( $cona, $testnum ) = @_; my $conb = (defined wantarray) ? ( wantarray ? 'A' : 'S' ) : 'V'; @@ -13,4 +13,8 @@ sub context { context('V',1); $a = context('S',2); @a = context('A',3); +scalar context('S',4); +$a = scalar context('S',5); +($a) = context('A',6); +($a) = scalar context('S',7); 1; diff --git a/contrib/perl5/t/op/write.t b/contrib/perl5/t/op/write.t index 87d5042..5b01eb7 100755 --- a/contrib/perl5/t/op/write.t +++ b/contrib/perl5/t/op/write.t @@ -1,6 +1,6 @@ #!./perl -print "1..8\n"; +print "1..9\n"; my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat'; @@ -200,4 +200,21 @@ $this,$that write LEX; $that = 8; write LEX; + close LEX; } +# LEX_INTERPNORMAL test +my %e = ( a => 1 ); +format OUT4 = +@<<<<<< +"$e{a}" +. +open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; +write (OUT4); +close OUT4; +if (`$CAT Op_write.tmp` eq "1\n") { + print "ok 9\n"; + unlink "Op_write.tmp"; + } +else { + print "not ok 9\n"; + } |
