Integrate mainline

p4raw-id: //depot/perlio@14885

8 files changed, 291 insertions, 35 deletions

diff --git a/t/base/num.t b/t/base/num.t
index b3cde2e866..f75e73d428 100644
--- a/t/base/num.t
+++ b/t/base/num.t
@@ -68,20 +68,25 @@ print $a + 1 == 2     ? "ok 18\n" : "not ok 18 #" . $a + 1 . "\n";
 $a = -1.; "$a";
 print $a + 1 == 0     ? "ok 19\n" : "not ok 19 #" . $a + 1 . "\n";
 
+sub ok { # Can't assume too much of floating point numbers.
+    my ($a, $b, $c);
+    abs($a - $b) <= $c;
+}
+
 $a = 0.1; "$a";
-print $a + 1 == 1.1   ? "ok 20\n" : "not ok 20 #" . $a + 1 . "\n";
+print ok($a + 1,  1.1,  0.05)   ? "ok 20\n" : "not ok 20 #" . $a + 1 . "\n";
 
 $a = -0.1; "$a";
-print $a + 1 == 0.9   ? "ok 21\n" : "not ok 21 #" . $a + 1 . "\n";
+print ok($a + 1,  0.9,  0.05)   ? "ok 21\n" : "not ok 21 #" . $a + 1 . "\n";
 
 $a = .1; "$a";
-print $a + 1 == 1.1   ? "ok 22\n" : "not ok 22 #" . $a + 1 . "\n";
+print ok($a + 1,  1.1,  0.005)  ? "ok 22\n" : "not ok 22 #" . $a + 1 . "\n";
 
 $a = -.1; "$a";
-print $a + 1 == 0.9   ? "ok 23\n" : "not ok 23 #" . $a + 1 . "\n";
+print ok($a + 1,  0.9,  0.05)   ? "ok 23\n" : "not ok 23 #" . $a + 1 . "\n";
 
 $a = 10.01; "$a";
-print $a + 1 == 11.01 ? "ok 24\n" : "not ok 24 #" . $a + 1 . "\n";
+print ok($a + 1, 11.01, 0.005) ? "ok 24\n" : "not ok 24 #" . $a + 1 . "\n";
 
 $a = 1e3; "$a";
 print $a + 1 == 1001  ? "ok 25\n" : "not ok 25 #" . $a + 1 . "\n";
diff --git a/t/io/fs.t b/t/io/fs.t
index f3c49c9118..8e74a810c4 100755
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -39,7 +39,9 @@ my $needs_fh_reopen =
     # Not needed on HPFS, but needed on HPFS386 ?!
     || $^O eq 'os2';
 
-plan tests => 32;
+$needs_fh_reopen = 1 if (defined &Win32::IsWin95 && Win32::IsWin95());
+
+plan tests => 36;
 
 
 if (($^O eq 'MSWin32') || ($^O eq 'NetWare')) {
@@ -249,7 +251,14 @@ SKIP: {
 
     ok(-z "Iofs.tmp",    "truncation to zero bytes");
 
+#these steps are necessary to check if file is really truncated
+#On Win95, FH is updated, but file properties aren't
     open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
+    print FH "x\n" x 200;
+    close FH;
+
+
+       open(FH, ">>Iofs.tmp") or die "Can't open Iofs.tmp for appending";
 
     binmode FH;
     select FH;
@@ -265,8 +274,8 @@ SKIP: {
     if ($needs_fh_reopen) {
 	close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
     }
-
-    is(-s "Iofs.tmp", 200, "fh resize to 200 working");
+       
+    is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
 
     ok(truncate(FH, 0), "fh resize to zero");
 
@@ -274,8 +283,13 @@ SKIP: {
 	close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
     }
 
-    ok(-z "Iofs.tmp", "fh resize to zero working");
+    ok(-z "Iofs.tmp", "fh resize to zero working (filename check)");
+
+       ok(truncate(FH, 200), "fh resize to 200");
+       is(-s FH, 200, "fh resize to 200 working (FH check)");
 
+       ok(truncate(FH, 0), "fh resize to 0");
+       ok(-z FH, "fh resize to 0 working (FH check)");
     close FH;
 }
 
diff --git a/t/lib/Math/BigFloat/Subclass.pm b/t/lib/Math/BigFloat/Subclass.pm
index ca9bbcecb0..82ad7e6c83 100644
--- a/t/lib/Math/BigFloat/Subclass.pm
+++ b/t/lib/Math/BigFloat/Subclass.pm
@@ -12,7 +12,9 @@ use vars qw($VERSION @ISA $PACKAGE
 
 @ISA = qw(Exporter Math::BigFloat);
 
-$VERSION = 0.02;
+$VERSION = 0.03;
+
+use overload; 		# inherit overload from BigInt
 
 # Globals
 $accuracy = $precision = undef;
@@ -34,4 +36,9 @@ sub new
         return $self;
 }
 
+BEGIN
+  {
+  *objectify = \&Math::BigInt::objectify;
+  }
+
 1;
diff --git a/t/lib/Math/BigInt/Subclass.pm b/t/lib/Math/BigInt/Subclass.pm
index 03795da8ff..0ec798b2ef 100644
--- a/t/lib/Math/BigInt/Subclass.pm
+++ b/t/lib/Math/BigInt/Subclass.pm
@@ -13,7 +13,9 @@ use vars qw($VERSION @ISA $PACKAGE @EXPORT_OK
 @ISA = qw(Exporter Math::BigInt);
 @EXPORT_OK = qw(bgcd);
 
-$VERSION = 0.02;
+$VERSION = 0.03;
+
+use overload;	# inherit overload from BigInt
 
 # Globals
 $accuracy = $precision = undef;
diff --git a/t/op/gv.t b/t/op/gv.t
index 9380735a1d..9ce11354a3 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -11,7 +11,7 @@ BEGIN {
 
 use warnings;
 
-print "1..44\n";
+print "1..47\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -193,5 +193,20 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 43\n";
     print $g;
 }
 
+{
+    my $w = '';
+    $SIG{__WARN__} = sub { $w = $_[0] };
+    sub abc1 ();
+    local *abc1 = sub { };
+    print $w eq '' ? "ok 45\n" : "not ok 45\n# $w";
+    sub abc2 ();
+    local *abc2;
+    *abc2 = sub { };
+    print $w eq '' ? "ok 46\n" : "not ok 46\n# $w";
+    sub abc3 ();
+    *abc3 = sub { };
+    print $w =~ /Prototype mismatch/ ? "ok 47\n" : "not ok 47\n# $w";
+}
+
 __END__
 ok 44
diff --git a/t/op/pack.t b/t/op/pack.t
index 6bbd737d0a..0782d46855 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 1477;
+plan tests => 5619;
 
 use strict;
 use warnings;
@@ -711,3 +711,161 @@ foreach (
     eval { my $t=unpack("P*", "abc") };
     like($@, qr/P must have an explicit size/);
 }
+
+{   # Grouping constructs
+    my (@a, @b);
+    @a = unpack '(SL)',   pack 'SLSLSL', 67..90;
+    is("@a", "67 68");
+    @a = unpack '(SL)3',   pack 'SLSLSL', 67..90;
+    @b = (67..72);
+    is("@a", "@b");
+    @a = unpack '(SL)3',   pack 'SLSLSLSL', 67..90;
+    is("@a", "@b");
+    @a = unpack '(SL)[3]', pack 'SLSLSLSL', 67..90;
+    is("@a", "@b");
+    @a = unpack '(SL)[2] SL', pack 'SLSLSLSL', 67..90;
+    is("@a", "@b");
+    @a = unpack 'A/(SL)',  pack 'ASLSLSLSL', 3, 67..90;
+    is("@a", "@b");
+    @a = unpack 'A/(SL)SL',  pack 'ASLSLSLSL', 2, 67..90;
+    is("@a", "@b");
+    @a = unpack '(SL)*',   pack 'SLSLSLSL', 67..90;
+    @b = (67..74);
+    is("@a", "@b");
+    @a = unpack '(SL)*SL',   pack 'SLSLSLSL', 67..90;
+    is("@a", "@b");
+    eval { @a = unpack '(*SL)',   '' };
+    like($@, qr/\(\)-group starts with a count/);
+    eval { @a = unpack '(3SL)',   '' };
+    like($@, qr/\(\)-group starts with a count/);
+    eval { @a = unpack '([3]SL)',   '' };
+    like($@, qr/\(\)-group starts with a count/);
+    eval { @a = pack '(*SL)' };
+    like($@, qr/\(\)-group starts with a count/);
+    @a = unpack '(SL)3 SL',   pack '(SL)4', 67..74;
+    is("@a", "@b");
+    @a = unpack '(SL)3 SL',   pack '(SL)[4]', 67..74;
+    is("@a", "@b");
+    @a = unpack '(SL)3 SL',   pack '(SL)*', 67..74;
+    is("@a", "@b");
+}
+
+{  # Repeat count [SUBEXPR]
+   my @codes = qw( x A Z a c C B b H h s v n S i I l V N L p P f F d
+		   s! S! i! I! l! L! j J);
+   my $G;
+   if (eval { pack 'q', 1 } ) {
+     push @codes, qw(q Q);
+   } else {
+     push @codes, qw(c C);	# Keep the count the same
+   }
+   if (eval { pack 'D', 1 } ) {
+     push @codes, 'D';
+   } else {
+     push @codes, 'd';	# Keep the count the same
+   }
+
+   my %val;
+   @val{@codes} = map { / [Xx]  (?{ undef })
+			| [AZa] (?{ 'something' })
+			| C     (?{ 214 })
+			| c     (?{ 114 })
+			| [Bb]  (?{ '101' })
+			| [Hh]  (?{ 'b8' })
+			| [svnSiIlVNLqQjJ]  (?{ 10111 })
+			| [FfDd]  (?{ 1.36514538e67 })
+			| [pP]  (?{ "try this buffer" })
+			/x; $^R } @codes;
+   my @end = (0x12345678, 0x23456781, 0x35465768, 0x15263748);
+   my $end = "N4";
+
+   for my $type (@codes) {
+     my @list = $val{$type};
+     @list = () unless defined $list[0];
+     for my $count ('', '3', '[11]') {
+       my $c = 1;
+       $c = $1 if $count =~ /(\d+)/;
+       my @list1 = @list;
+       @list1 = (@list1) x $c unless $type =~ /[XxAaZBbHhP]/;
+       for my $groupend ('', ')2', ')[8]') {
+	   my $groupbegin = ($groupend ? '(' : '');
+	   $c = 1;
+	   $c = $1 if $groupend =~ /(\d+)/;
+	   my @list2 = (@list1) x $c;
+
+	   my $junk1 = "$groupbegin $type$count $groupend";
+	   # print "# junk1=$junk1\n";
+	   my $p = pack $junk1, @list2;
+	   my $half = int( (length $p)/2 );
+	   for my $move ('', "X$half", "X!$half", 'x1', 'x!8', "x$half") {
+	     my $junk = "$junk1 $move";
+	     # print "# junk='$junk', list=(@list2)\n";
+	     $p = pack "$junk $end", @list2, @end;
+	     my @l = unpack "x[$junk] $end", $p;
+	     is(scalar @l, scalar @end);
+	     is("@l", "@end", "skipping x[$junk]");
+	   }
+       }
+     }
+   }
+}
+
+# / is recognized after spaces in scalar context
+# XXXX no spaces are allowed in pack...  In pack only before the slash...
+is(scalar unpack('A /A Z20', pack 'A/A* Z20', 'bcde', 'xxxxx'), 'bcde');
+is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
+
+{ # X! and x!
+  my $t = 'C[3]  x!8 C[2]';
+  my @a = (0x73..0x77);
+  my $p = pack($t, @a);
+  is($p, "\x73\x74\x75\0\0\0\0\0\x76\x77");
+  my @b = unpack $t, $p;
+  is(scalar @b, scalar @a);
+  is("@b", "@a", 'x!8');
+  $t = 'x[5] C[6] X!8 C[2]';
+  @a = (0x73..0x7a);
+  $p = pack($t, @a);
+  is($p, "\0\0\0\0\0\x73\x74\x75\x79\x7a");
+  @b = unpack $t, $p;
+  @a = (0x73..0x75, 0x79, 0x7a, 0x79, 0x7a);
+  is(scalar @b, scalar @a);
+  is("@b", "@a");
+}
+
+{ # struct {char c1; double d; char cc[2];}
+  my $t = 'C x![d] d C[2]';
+  my @a = (173, 1.283476517e-45, 42, 215);
+  my $p = pack $t, @a;
+  ok( length $p);
+  my @b = unpack "$t X[$t] $t", $p;	# Extract, step back, extract again
+  is(scalar @b, 2 * scalar @a);
+  is("@b", "@a @a");
+
+  my $warning;
+  local $SIG{__WARN__} = sub {
+      $warning = $_[0];
+  };
+  @b = unpack "x[C] x[$t] X[$t] X[C] $t", "$p\0";
+
+  is($warning, undef);
+  is(scalar @b, scalar @a);
+  is("@b", "@a");
+}
+
+is(length(pack("j", 0)), $Config{ivsize});
+is(length(pack("J", 0)), $Config{uvsize});
+is(length(pack("F", 0)), $Config{nvsize});
+
+numbers ('j', -2147483648, -1, 0, 1, 2147483647);
+numbers ('J', 0, 1, 2147483647, 2147483648, 4294967295);
+numbers ('F', -(2**34), -1, 0, 1, 2**34);
+SKIP: {
+    my $t = eval { unpack("D*", pack("D", 12.34)) };
+
+    skip "Long doubles not in use", 56 if $@ =~ /Invalid type in pack/;
+
+    is(length(pack("D", 0)), $Config{longdblsize});
+    numbers ('D', -(2**34), -1, 0, 1, 2**34);
+}
+
diff --git a/t/op/pat.t b/t/op/pat.t
index 9af93597f4..86025d1fa6 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..854\n";
+print "1..855\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -1422,16 +1422,21 @@ print "ok 247\n";
 	    print "ok $test\n"; $test++;
 	}
 	print "# IsASCII\n";
-	if ($code le '00007f') {
-	    print "not " unless $char =~ /\p{IsASCII}/;
-	    print "ok $test\n"; $test++;
-	    print "not " if     $char =~ /\P{IsASCII}/;
-	    print "ok $test\n"; $test++;
+	if (ord("A") == 193) {
+	    print "ok $test # Skip: in EBCDIC\n"; $test++;
+	    print "ok $test # Skip: in EBCDIC\n"; $test++;
 	} else {
-	    print "not " if     $char =~ /\p{IsASCII}/;
-	    print "ok $test\n"; $test++;
-	    print "not " unless $char =~ /\P{IsASCII}/;
-	    print "ok $test\n"; $test++;
+	    if ($code le '00007f') {
+		print "not " unless $char =~ /\p{IsASCII}/;
+		print "ok $test\n"; $test++;
+		print "not " if     $char =~ /\P{IsASCII}/;
+		print "ok $test\n"; $test++;
+	    } else {
+		print "not " if     $char =~ /\p{IsASCII}/;
+		print "ok $test\n"; $test++;
+		print "not " unless $char =~ /\P{IsASCII}/;
+		print "ok $test\n"; $test++;
+	    }
 	}
 	print "# IsCntrl\n";
 	if ($class =~ /^C/) {
@@ -1928,20 +1933,26 @@ print "ok 671\n";
 print "not " unless chr(0x38c) =~ /\p{IsGreek}/; # singleton
 print "ok 672\n";
 
+if (ord("A") == 65) {
 ##
 ## Test [:cntrl:]...
 ##
 ## Should probably put in tests for all the POSIX stuff, but not sure how to
 ## guarantee a specific locale......
 ##
-$AllBytes = join('', map { chr($_) } 0..255);
-($x = $AllBytes) =~ s/[[:cntrl:]]//g;
-if ($x ne join('', map { chr($_) } 0x20..0x7E, 0x80..0xFF)) { print "not " };
-print "ok 673\n";
+    $AllBytes = join('', map { chr($_) } 0..255);
+    ($x = $AllBytes) =~ s/[[:cntrl:]]//g;
+    if ($x ne join('', map { chr($_) } 0x20..0x7E, 0x80..0xFF)) {
+	print "not ";
+    }
+    print "ok 673\n";
 
-($x = $AllBytes) =~ s/[^[:cntrl:]]//g;
-if ($x ne join('', map { chr($_) } 0..0x1F, 0x7F)) { print "not " };
-print "ok 674\n";
+    ($x = $AllBytes) =~ s/[^[:cntrl:]]//g;
+    if ($x ne join('', map { chr($_) } 0..0x1F, 0x7F)) { print "not " }
+    print "ok 674\n";
+} else {
+    print "ok $_ # Skip: EBCDIC\n" for 673..674;
+}
 
 # With /s modifier UTF8 chars were interpreted as bytes
 {
@@ -2279,7 +2290,7 @@ print "# some Unicode properties\n";
     print "not " unless "a\x{100}" =~ /A/i;
     print "ok 754\n";
 
-    print "not " unless "A\x{100}" =~ /A/i;
+    print "not " unless "A\x{100}" =~ /a/i;
     print "ok 755\n";
 
     print "not " unless "a\x{100}" =~ /a/i;
@@ -2303,7 +2314,7 @@ print "# some Unicode properties\n";
     print "not " unless "a\x{100}" =~ /A\x{100}/i;
     print "ok 762\n";
 
-    print "not " unless "A\x{100}" =~ /A\x{100}/i;
+    print "not " unless "A\x{100}" =~ /a\x{100}/i;
     print "ok 763\n";
 
     print "not " unless "a\x{100}" =~ /a\x{100}/i;
@@ -2315,7 +2326,7 @@ print "# some Unicode properties\n";
     print "not " unless "a\x{100}" =~ /[A]/i;
     print "ok 766\n";
 
-    print "not " unless "A\x{100}" =~ /[A]/i;
+    print "not " unless "A\x{100}" =~ /[a]/i;
     print "ok 767\n";
 
     print "not " unless "a\x{100}" =~ /[a]/i;
@@ -2662,3 +2673,19 @@ print "# some Unicode properties\n";
     print "\x{400}AB"        =~ /(?<=\x{400}.)B/ ? "ok 853\n" : "not ok 853\n";
     print "\x{500\x{600}}B"  =~ /(?<=\x{500}.)B/ ? "ok 854\n" : "not ok 854\n";
 }
+
+{
+    print "# [ID 20020124.005]\n";
+
+    # Fixed by #14795.
+
+    $char = "\x{f00f}";
+    $x = "$char b $char";
+
+    $x =~ s{($char)}{
+	"c" =~ /d/;
+	"x";
+    }ge;
+
+    print $x eq "x b x" ? "ok 855\n" : "not ok 855\n";
+}
diff --git a/t/op/taint.t b/t/op/taint.t
index 8591b347e0..b045c493e1 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -119,7 +119,7 @@ print PROG 'print "@ARGV\n"', "\n";
 close PROG;
 my $echo = "$Invoke_Perl $ECHO";
 
-print "1..183\n";
+print "1..203\n";
 
 # First, let's make sure that Perl is checking the dangerous
 # environment variables. Maybe they aren't set yet, so we'll
@@ -837,7 +837,7 @@ else {
 
     use warnings;
 
-    $SIG{__WARN__} = sub { print "not " };
+    local $SIG{__WARN__} = sub { print "not " };
 
     sub fmi {
 	my $divnum = shift()/1;
@@ -927,3 +927,31 @@ else
     eval { system { "echo" } "/arg0", "arg1" };
     test 183, $@ =~ /^Insecure \$ENV/;
 }
+{
+    # bug 20020208.005 plus some extras
+    # single arg exec/system are tests 80-83
+    use if $] lt '5.009', warnings => FATAL => 'taint';
+    my $err = $] ge '5.009' ? qr/^Insecure dependency/ 
+                            : qr/^Use of tainted arguments/;
+    test 184, eval { exec $TAINT, $TAINT } eq '', 'exec';
+    test 185, $@ =~ $err, $@;
+    test 186, eval { exec $TAINT $TAINT } eq '', 'exec';
+    test 187, $@ =~ $err, $@;
+    test 188, eval { exec $TAINT $TAINT, $TAINT } eq '', 'exec';
+    test 189, $@ =~ $err, $@;
+    test 190, eval { exec $TAINT 'notaint' } eq '', 'exec';
+    test 191, $@ =~ $err, $@;
+    test 192, eval { exec {'notaint'} $TAINT } eq '', 'exec';
+    test 193, $@ =~ $err, $@;
+
+    test 194, eval { system $TAINT, $TAINT } eq '', 'system';
+    test 195, $@ =~ $err, $@;
+    test 196, eval { system $TAINT $TAINT } eq '', 'exec';
+    test 197, $@ =~ $err, $@;
+    test 198, eval { system $TAINT $TAINT, $TAINT } eq '', 'exec';
+    test 199, $@ =~ $err, $@;
+    test 200, eval { system $TAINT 'notaint' } eq '', 'exec';
+    test 201, $@ =~ $err, $@;
+    test 202, eval { system {'notaint'} $TAINT } eq '', 'exec';
+    test 203, $@ =~ $err, $@;
+}