Integrate mainline (a while ago)

p4raw-id: //depot/perlio@15195

7 files changed, 153 insertions, 35 deletions

diff --git a/t/base/num.t b/t/base/num.t
index f75e73d428..37ef9fa1ce 100644
--- a/t/base/num.t
+++ b/t/base/num.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..30\n";
+print "1..45\n";
 
 # First test whether the number stringification works okay.
 # (Testing with == would exercize the IV/NV part, not the PV.)
@@ -105,3 +105,51 @@ print $a + 1 == 0x101 ? "ok 29\n" : "not ok 29 #" . $a + 1 . "\n";
 
 $a = 1000; "$a";
 print $a + 1 == 1001  ? "ok 30\n" : "not ok 30 #" . $a + 1 . "\n";
+
+# back to some basic stringify tests
+# we expect NV stringification to work according to C sprintf %.*g rules
+
+$a = 0.01; "$a";
+print $a eq "0.01"    ? "ok 31\n" : "not ok 31 # $a\n";
+
+$a = 0.001; "$a";
+print $a eq "0.001"   ? "ok 32\n" : "not ok 32 # $a\n";
+
+$a = 0.0001; "$a";
+print $a eq "0.0001"  ? "ok 33\n" : "not ok 33 # $a\n";
+
+$a = 0.00009; "$a";
+print $a eq "9e-05" || $a eq "9e-005" ? "ok 34\n"  : "not ok 34 # $a\n";
+
+$a = 1.1; "$a";
+print $a eq "1.1"     ? "ok 35\n" : "not ok 35 # $a\n";
+
+$a = 1.01; "$a";
+print $a eq "1.01"    ? "ok 36\n" : "not ok 36 # $a\n";
+
+$a = 1.001; "$a";
+print $a eq "1.001"   ? "ok 37\n" : "not ok 37 # $a\n";
+
+$a = 1.0001; "$a";
+print $a eq "1.0001"  ? "ok 38\n" : "not ok 38 # $a\n";
+
+$a = 1.00001; "$a";
+print $a eq "1.00001" ? "ok 39\n" : "not ok 39 # $a\n";
+
+$a = 1.000001; "$a";
+print $a eq "1.000001" ? "ok 40\n" : "not ok 40 # $a\n";
+
+$a = 0.; "$a";
+print $a eq "0"       ? "ok 41\n" : "not ok 41 # $a\n";
+
+$a = 100000.; "$a";
+print $a eq "100000"  ? "ok 42\n" : "not ok 42 # $a\n";
+
+$a = -100000.; "$a";
+print $a eq "-100000" ? "ok 43\n" : "not ok 43 # $a\n";
+
+$a = 123.456; "$a";
+print $a eq "123.456" ? "ok 44\n" : "not ok 44 # $a\n";
+
+$a = 1e34; "$a";
+print $a eq "1e+34" || $a eq "1e+034" ? "ok 45\n" : "not ok 45 $a\n";
diff --git a/t/io/fs.t b/t/io/fs.t
index 8e74a810c4..c30e14acf6 100755
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -275,7 +275,11 @@ SKIP: {
 	close (FH); open (FH, ">>Iofs.tmp") or die "Can't reopen Iofs.tmp";
     }
        
-    is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
+    if ($^O eq 'vos') {
+     is(-s "Iofs.tmp", 200, "TODO - hit VOS bug posix-973 - fh resize to 200 working (filename check)");
+    } else {
+     is(-s "Iofs.tmp", 200, "fh resize to 200 working (filename check)");
+    }
 
     ok(truncate(FH, 0), "fh resize to zero");
 
diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index 5349f505f7..8dc0bf90a4 100644
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -419,9 +419,19 @@ use warnings qw(unopened closed) ;
 getc FOO;
 close STDIN;
 getc STDIN;
+# Create an empty file
+$file = 'getcwarn.tmp';
+open FH1, ">$file" or die "# $!"; close FH1;
+open FH2, $file    or die "# $!";
+getc FH2; # Should not warn at EOF
+close FH2;
+getc FH2; # Warns, now
+unlink $file;
 no warnings qw(unopened closed) ;
 getc FOO;
 getc STDIN;
+getc FH2;
 EXPECT
 getc() on unopened filehandle FOO at - line 3.
 getc() on closed filehandle STDIN at - line 5.
+getc() on closed filehandle FH2 at - line 12.
diff --git a/t/op/flip.t b/t/op/flip.t
index d9fa736d54..70666ac658 100755
--- a/t/op/flip.t
+++ b/t/op/flip.t
@@ -4,7 +4,7 @@
 
 chdir 't' if -d 't';
 
-print "1..10\n";
+print "1..15\n";
 
 @a = (1,2,3,4,5,6,7,8,9,10,11,12);
 
@@ -19,6 +19,9 @@ if ($y eq '12E0123E0') {print "ok 7\n";} else {print "not ok 7\n";}
 
 @a = ('a','b','c','d','e','f','g');
 
+{
+local $.;
+
 open(of,'harness') or die "Can't open harness: $!";
 while (<of>) {
     (3 .. 5) && ($foo .= $_);
@@ -34,5 +37,32 @@ 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;
+    $x = 1..10;
+    print "ok 10\n";
+}
+
 }
+
+if (!defined $.) { print "ok 11\n" } else { print "not ok 11 # $.\n" }
+
+use warnings;
+my $warn='';
+$SIG{__WARN__} = sub { $warn .= join '', @_ };
+
+if (0..2) { print "ok 12\n" } else { print "not ok 12\n" }
+
+if ($warn =~ /uninitialized/) { print "ok 13\n" } else { print "not ok 13\n" }
+$warn = '';
+
+$x = "foo".."bar";
+
+if ((() = ($warn =~ /isn't numeric/g)) == 2) {
+    print "ok 14\n"
+}
+else {
+    print "not ok 14\n"
+}
+$warn = '';
+
+$. = 15;
+if (15..0) { print "ok 15\n" } else { print "not ok 15\n" }
diff --git a/t/op/pack.t b/t/op/pack.t
index 0782d46855..6b812363b2 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -840,7 +840,9 @@ is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
   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");
+  $b = "@b";
+  $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble
+  is($b, "@a @a");
 
   my $warning;
   local $SIG{__WARN__} = sub {
@@ -850,7 +852,9 @@ is(scalar unpack('A /A /A Z20', '3004bcde'), 'bcde');
 
   is($warning, undef);
   is(scalar @b, scalar @a);
-  is("@b", "@a");
+  $b = "@b";
+  $b =~ s/(?:17000+|16999+)\d+(e-45) /17$1 /gi; # stringification is gamble
+  is($b, "@a");
 }
 
 is(length(pack("j", 0)), $Config{ivsize});
diff --git a/t/op/pat.t b/t/op/pat.t
index b3db7ded17..4fb3d45e5e 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..858\n";
+print "1..860\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -2675,22 +2675,6 @@ print "# some Unicode properties\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";
-}
-
-{
     print "# UTF-8 hash keys and /\$/\n";
     # http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2002-01/msg01327.html
 
@@ -2698,7 +2682,7 @@ print "# some Unicode properties\n";
     my $v = substr($u,0,1);
     my $w = substr($u,1,1);
     my %u = ( $u => $u, $v => $v, $w => $w );
-    my $i = 856; 
+    my $i = 855; 
     for (keys %u) {
 	my $m1 = /^\w*$/ ? 1 : 0;
 	my $m2 = $u{$_}=~/^\w*$/ ? 1 : 0;
@@ -2706,3 +2690,19 @@ print "# some Unicode properties\n";
 	$i++;
     }
 }
+
+{
+    print "# [ID 20020124.005]\n";
+    # Fixed by #14795.
+    my $i = 858;
+    for my $char ("a", "\x{df}", "\x{100}"){
+	$x = "$char b $char";
+	$x =~ s{($char)}{
+	    "c" =~ /c/;
+	    "x";
+	}ge;
+	print substr($x,0,1) eq substr($x,-1,1) ?
+	    "ok $i\n" : "not ok $i # debug: $x\n";
+ 	$i++;
+   }
+}
diff --git a/t/op/write.t b/t/op/write.t
index 24759965a4..e08a64bebf 100755
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..44\n";
+print "1..47\n";
 
 my $CAT = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'VMS') ? 'type'
 	: ($^O eq 'MacOS') ? 'catenate'
@@ -271,20 +271,46 @@ if (`$CAT Op_write.tmp` eq $right)
 else
     { print "not ok 11\n"; }
 
-# 12..44: scary format testing from Merijn H. Brand
+# 12..47: scary format testing from Merijn H. Brand
 
 if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos' ||
     ($^O eq 'os2' and not eval '$OS2::can_fork')) {
-  foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
+  foreach (12..47) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
   exit(0);
 }
 
 use strict;	# Amazed that this hackery can be made strict ...
 
+my $test = 12;
+
 # Just a complete test for format, including top-, left- and bottom marging
 # and format detection through glob entries
 
+format EMPTY =
+.
+
+format Comment =
+ok @<<<<<
+$test
+.
+
+$= = 10;
+
+# [ID 20020227.005] format bug with undefined _TOP
+{   local $~ = "Comment";
+    write;
+    $test++;
+    print $- == 9
+	? "ok $test\n" : "not ok $test # TODO \$- = $- instead of 9\n";
+    $test++;
+    print $^ ne "Comment_TOP"
+	? "ok $test\n" : "not ok $test # TODO \$^ = $^ instead of 'STDOUT_TOP'\n";
+    $test++;
+    }
+
+   $^  = "STDOUT_TOP";
    $=  =  7;		# Page length
+   $-  =  0;		# Lines left
 my $ps = $^L; $^L = "";	# Catch the page separator
 my $tm =  1;		# Top margin (empty lines before first output)
 my $bm =  2;		# Bottom marging (empty lines between last text and footer)
@@ -293,14 +319,13 @@ my $lm =  4;		# Left margin (indent in spaces)
 select ((select (STDOUT), $| = 1)[0]);
 if ($lm > 0 and !open STDOUT, "|-") {	# Left margin (in this test ALWAYS set)
     select ((select (STDOUT), $| = 1)[0]);
-    my $i = 12;
     my $s = " " x $lm;
     while (<STDIN>) {
 	s/^/$s/;
-	print + ($_ eq <DATA> ? "" : "not "), "ok ", $i++, "\n";
+	print + ($_ eq <DATA> ? "" : "not "), "ok ", $test++, "\n";
 	}
     close STDIN;
-    print + (<DATA>?"not ":""), "ok ", $i++, "\n";
+    print + (<DATA>?"not ":""), "ok ", $test++, "\n";
     close STDOUT;
     exit;
     }
@@ -334,9 +359,6 @@ format TOP =
 $tm
 .
 
-format EmptyTOP =
-.
-
 format ENTRY =
 @ @<<<<~~
 @{(shift @E)||["",""]}
@@ -359,7 +381,7 @@ sub has_format ($)
     $@?0:1;
     } # has_format
 
-$^ = has_format ("TOP") ? "TOP" : "EmptyTOP";
+$^ = has_format ("TOP") ? "TOP" : "EMPTY";
 has_format ("ENTRY") or die "No format defined for ENTRY";
 foreach my $e ( [ map { [ $_, "Test$_"   ] } 1 .. 7 ],
 		[ map { [ $_, "${_}tseT" ] } 1 .. 5 ]) {
@@ -377,7 +399,7 @@ if (has_format ("EOF")) {
 
 close STDOUT;
 
-# That was test 44.
+# That was test 47.
 
 __END__