Integrate mainline

p4raw-id: //depot/perlio@11183

8 files changed, 143 insertions, 38 deletions

diff --git a/t/lib/warnings/op b/t/lib/warnings/op
index 2f847ad14c..0079146ad3 100644
--- a/t/lib/warnings/op
+++ b/t/lib/warnings/op
@@ -102,6 +102,11 @@
     %s() called too early to check prototype		[Perl_peep]
         fred() ; sub fred ($$) {}
 
+     Non-octal literal mode (%d) specified
+	(Did you mean 0%d instead?)
+	chmod 777, "foo";
+	mkdir "foo", 777;
+	umask 222;
 
     Mandatory Warnings 
     ------------------
@@ -926,3 +931,30 @@ unshift(@x);
 EXPECT
 Useless use of push with no values at - line 4.
 Useless use of unshift with no values at - line 5.
+########
+# op.c
+use warnings 'chmod' ;
+chmod 777;
+no warnings 'chmod' ;
+chmod 777;
+EXPECT
+Non-octal literal mode (777) specified at - line 3.
+	(Did you mean 0777 instead?)
+########
+# op.c
+use warnings 'umask' ;
+umask 222;
+no warnings 'umask' ;
+umask 222;
+EXPECT
+Non-octal literal mode (222) specified at - line 3.
+	(Did you mean 0222 instead?)
+########
+# op.c
+use warnings 'mkdir' ;
+mkdir "", 777;
+no warnings 'mkdir' ;
+mkdir "", 777;
+EXPECT
+Non-octal literal mode (777) specified at - line 3.
+	(Did you mean 0777 instead?)
diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index 242b0059fb..14b745da22 100644
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -46,18 +46,12 @@ toke.c	AOK
      warn(warn_reserved	
 	$a = abc;
 
-     chmod() mode argument is missing initial 0 
-	chmod 3;
-
      Possible attempt to separate words with commas 
 	@a = qw(a, b, c) ;
 
      Possible attempt to put comments in qw() list 
 	@a = qw(a b # c) ;
 
-     umask: argument is missing initial 0 
-	umask 3;
-
      %s (...) interpreted as function 
 	print ("")
 	printf ("")
@@ -262,14 +256,6 @@ EXPECT
 Unquoted string "abc" may clash with future reserved word at - line 3.
 ########
 # toke.c
-use warnings 'chmod' ;
-chmod 3;
-no warnings 'chmod' ;
-chmod 3;
-EXPECT
-chmod() mode argument is missing initial 0 at - line 3.
-########
-# toke.c
 use warnings 'qw' ;
 @a = qw(a, b, c) ;
 no warnings 'qw' ;
@@ -286,14 +272,6 @@ EXPECT
 Possible attempt to put comments in qw() list at - line 3.
 ########
 # toke.c
-use warnings 'umask' ;
-umask 3;
-no warnings 'umask' ;
-umask 3;
-EXPECT
-umask: argument is missing initial 0 at - line 3.
-########
-# toke.c
 use warnings 'syntax' ;
 print ("")
 EXPECT
diff --git a/t/op/numconvert.t b/t/op/numconvert.t
index d41594ea88..084092e534 100755
--- a/t/op/numconvert.t
+++ b/t/op/numconvert.t
@@ -224,9 +224,15 @@ for my $num_chain (1..$max_chain) {
 		     and $ans[0] == $ans[1] and $ans[0] <= ~0
                      # First must be in E notation (ie not just digits) and
                      # second must still be an integer.
+		     # eg 1.84467440737095516e+19
+		     # 1.84467440737095516e+19 for 64 bit mantissa is in the
+		     # integer range, so 1.84467440737095516e+19 + 0 is treated
+		     # as integer addition. [should it be?]
+		     # and 18446744073709551600 + 0 is 18446744073709551600
+		     # Which isn't the string you first thought of.
                      # I can't remember why there isn't symmetry in this
                      # exception, ie why only the first ops are tested for 'N'
-                     and $ans[0] !~ /^-?\d+$/ and $ans[0] !~ /^-?\d+$/) {
+                     and $ans[0] != /^-?\d+$/ and $ans[1] !~ /^-?\d+$/) {
 	      print "# ok, numerically equal - notation changed due to adding zero\n";
 	    } else {
 	      $nok++,
diff --git a/t/op/pack.t b/t/op/pack.t
index f9b35ae35a..dfecc6e573 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,8 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..160\n";
+print "1..161\n";
+# Note: All test numbers in comments are off by 1 after the comment below..
 
 $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
@@ -57,12 +58,17 @@ print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
 
 # check 'w'
 my $test=10;
-my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
+my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
          '4503599627365785','23728385234614992549757750638446');
 my $x = pack('w*', @x);
-my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
+my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A08080800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
 
-print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
+if ($x eq $y) {
+  print "ok $test\n";
+} else {
+  printf "not ok $test # %s\n", unpack 'H*', $x;
+}
+$test++;
 
 @y = unpack('w*', $y);
 my $a;
@@ -71,10 +77,12 @@ while ($a = pop @x) {
   print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
 }
 
+# XXX All test numbers in comments are off by 1 after this point.
+
 @y = unpack('w2', $x);
 
 print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
-print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
+print $y[1] == 130 ? "ok $test\n" : "not ok $test # $y[1]\n"; $test++;
 
 # test exeptions
 eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
@@ -362,6 +370,23 @@ print "ok ", $test++, "\n";
 
 # 144..152: /
 
+# Using Test considered bad plan in op/*.t ?
+
+sub report {
+  my ($pass, $test, $err, $wrong) = @_;
+  if ($pass) {
+    print "ok $test\n"
+  } else {
+    if ($err) {
+      chomp $err;
+      print "not ok $test # \$\@ = $err\n";
+    } else {
+      $wrong =~ s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge;
+      print "not ok $test # got $wrong\n";
+    }
+  }
+}
+
 my $z;
 eval { ($x) = unpack '/a*','hello' };
 print 'not ' unless $@; print "ok $test\n"; $test++;
@@ -373,8 +398,8 @@ 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* 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++;
+my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
+report ($z eq $expect, $test++, '', $z);
 
 eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' };
 print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
@@ -405,7 +430,8 @@ $z = pack <<EOP,'string','etc';
   n/a*			# Count as network short
   w/A*			# Count a  BER integer
 EOP
-print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+$expect = "\000\006string\003etc";
+report ($z eq $expect, $test++, '', $z);
 
 print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
 print "ok $test\n"; $test++;
diff --git a/t/op/pat.t b/t/op/pat.t
index 57f7cb7eb9..57dc2f24e1 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -6,7 +6,7 @@
 
 $| = 1;
 
-print "1..660\n";
+print "1..672\n";
 
 BEGIN {
     chdir 't' if -d 't';
@@ -1889,3 +1889,43 @@ $T="ok 659\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})d)(?{$z=$^N})e/ and $y eq "bc"
               {print $T} else {print "not $T"};
 $T="ok 660\n";if ($x =~ /(a([abcdefg]+)(?{$y=$^N})de)(?{$z=$^N})/ and $y eq "bc" and $z eq "abcde")
               {print $T} else {print "not $T"};
+
+# Test the Unicode script classes
+
+print "not " unless chr(0x100) =~ /\p{InLatin}/; # outside Latin-1
+print "ok 661\n";
+
+print "not " unless chr(0x212b) =~ /\p{InLatin}/; # Angstrom sign, very outside
+print "ok 662\n";
+
+print "not " unless chr(0x5d0) =~ /\p{InHebrew}/; # inside HebrewBlock
+print "ok 663\n";
+
+print "not " unless chr(0xfb4f) =~ /\p{InHebrew}/; # outside HebrewBlock
+print "ok 664\n";
+
+print "not " unless chr(0xb5) =~ /\p{InGreek}/; # singleton (not in a range)
+print "ok 665\n";
+
+print "not " unless chr(0x37a) =~ /\p{InGreek}/; # singleton
+print "ok 666\n";
+
+print "not " unless chr(0x386) =~ /\p{InGreek}/; # singleton
+print "ok 667\n";
+
+print "not " unless chr(0x387) =~ /\P{InGreek}/; # not there
+print "ok 668\n";
+
+print "not " unless chr(0x388) =~ /\p{InGreek}/; # range
+print "ok 669\n";
+
+print "not " unless chr(0x38a) =~ /\p{InGreek}/; # range
+print "ok 670\n";
+
+print "not " unless chr(0x38b) =~ /\P{InGreek}/; # not there
+print "ok 671\n";
+
+print "not " unless chr(0x38c) =~ /\p{InGreek}/; # singleton
+print "ok 672\n";
+
+
diff --git a/t/op/pos.t b/t/op/pos.t
index f3bc23c84a..7c4c1c567d 100755
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..4\n";
+print "1..7\n";
 
 $x='banana';
 $x=~/.a/g;
@@ -19,5 +19,21 @@ $x = "test string?"; $x =~ s/\w/pos($x)/eg;
 print "not " unless $x eq "0123 5678910?";
 print "ok 4\n";
 
-
-
+# bug ID 20010704.003
+use Tie::Scalar;
+tie $y[0], Tie::StdScalar or die $!;
+$y[0] = "aaa";
+$y[0] =~ /./g;
+if (pos($y[0]) == 1) {print "ok 5\n"} else {print "not ok 5\n"}
+
+$x = 0;
+$y[0] = "aaa";
+$y[$x] =~ /./g;
+if (pos($y[$x]) == 1) {print "ok 6\n"} else {print "not ok 6\n"}
+untie $y[0];
+
+tie $y{'abc'}, Tie::StdScalar or die $!;
+$y{'abc'} = "aaa";
+$y{'abc'} =~ /./g;
+if (pos($y{'abc'}) == 1) {print "ok 7\n"} else {print "not ok 7\n"}
+untie $y{'abc'};
diff --git a/t/op/study.t b/t/op/study.t
index 348de79ab5..0c111ea9cc 100755
--- a/t/op/study.t
+++ b/t/op/study.t
@@ -71,8 +71,12 @@ if (/^$_$/) {print "ok 23\n";} else {print "not ok 23\n";}
 $* = 1;		# test 3 only tested the optimized version--this one is for real
 if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
 
-# [ID 20010618.006] tests 25..26 may loop
-{
+if ($^O eq 'os390') {
+    # Even with the alarm() OS/390 can't manage these tests
+    # (Perl just goes into a busy loop, luckily an interruptable one)
+    for (25..26) { print "not ok $_ # compiler bug?\n" }
+} else {
+    # [ID 20010618.006] tests 25..26 may loop
     use Config;
     my $have_alarm = $Config{d_alarm};
     local $SIG{ALRM} = sub { die "timeout\n" };
@@ -96,3 +100,4 @@ if ("ab\ncd\n" =~ /^cd/) {print "ok 24\n";} else {print "not ok 24\n";}
 	print "not ok 26\t# " . $@ || "should not match\n";
     }
 }
+
diff --git a/t/op/write.t b/t/op/write.t
index ac6c03580a..c37de859c8 100755
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -273,7 +273,7 @@ else
 
 # 12..44: scary format testing from Merijn H. Brand
 
-if ($^O eq 'VMS' || $^O eq 'MSWin32') {
+if ($^O eq 'VMS' || $^O eq 'MSWin32' || $^O eq 'dos') {
   foreach (12..44) { print "ok $_ # skipped: '|-' and '-|' not supported\n"; }
   exit(0);
 }
@@ -289,7 +289,9 @@ my $tm =  1;		# Top margin (empty lines before first output)
 my $bm =  2;		# Bottom marging (empty lines between last text and footer)
 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>) {