Integrate from mainperl.

p4raw-id: //depot/cfgperl@3381

17 files changed, 342 insertions, 25 deletions

diff --git a/t/harness b/t/harness
index 88bcb38fba..174b318576 100644
--- a/t/harness
+++ b/t/harness
@@ -19,15 +19,43 @@ $Test::Harness::verbose = shift if @ARGV && $ARGV[0] eq '-v';
 @tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests;
 
 Test::Harness::runtests @tests;
-
-%infinite = ('comp/require.t', 1, 'op/bop.t', 1, 'lib/hostname.t', 1 );
+exit(0) unless -e "../testcompile";
+
+%infinite =   qw(
+		op/bop.t		1
+		lib/hostname.t		1
+		);
+#fudge DATA for now.
+%datahandle = qw(
+		lib/bigint.t		1
+		lib/bigintpm.t		1
+		lib/bigfloat.t	 	1
+		lib/bigfloatpm.t	1
+		);
+
+my $dhwrapper = <<'EOT';
+open DATA,"<".__FILE__;
+until (($_=<DATA>) =~ /^__END__/) {};
+EOT
 
 @tests = grep (!$infinite{$_}, @tests);
-
-if (-e "../testcompile") 
-{ 
-	print "The tests ", join(' ', keys(%infinite)), 
-							" generate infinite loops! Skipping!\n";
-
-	$ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; 
+@tests = map {
+		 my $new = $_;
+		 if ($datahandle{$_}) {
+		     $new .= '.t';
+		     local(*F, *T);
+		     open(F,"<$_") or die "Can't open $_: $!";
+		     open(T,">$new") or die "Can't open $new: $!";
+		     print T $dhwrapper, <F>;
+		     close F;
+		     close T;
+		 }
+		 $new;
+	     } @tests;
+
+print "The tests ", join(' ', keys(%infinite)), 
+	" generate infinite loops! Skipping!\n";
+$ENV{'COMPILE_TEST'} = 1; Test::Harness::runtests @tests; 
+foreach (keys %datahandle) {
+     unlink "$_.t";
 }
diff --git a/t/io/fs.t b/t/io/fs.t
index 04f5dbc6d1..b92ef8eccd 100755
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -10,7 +10,7 @@ BEGIN {
 use Config;
 
 $Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
-	      $^O eq 'os2' or $^O eq 'mint');
+	      $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/);
 
 print "1..28\n";
 
diff --git a/t/io/tell.t b/t/io/tell.t
index afcfcb5800..8df0228c31 100755
--- a/t/io/tell.t
+++ b/t/io/tell.t
@@ -6,8 +6,11 @@ print "1..21\n";
 
 $TST = 'tst';
 
+$Is_Dosish = ($^O eq 'MSWin32' or $^O eq 'dos' or
+	      $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/);
+
 open($TST, '../Configure') || (die "Can't open ../Configure");
-binmode $TST if $^O eq 'MSWin32';
+binmode $TST if $Is_Dosish;
 if (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
 
 $firstline = <$TST>;
diff --git a/t/lib/anydbm.t b/t/lib/anydbm.t
index 4d33e2233a..a38b5f680e 100755
--- a/t/lib/anydbm.t
+++ b/t/lib/anydbm.t
@@ -12,6 +12,9 @@ use Fcntl;
 
 print "1..12\n";
 
+$Is_Dosish = ($^O eq 'amigaos' || $^O eq 'MSWin32' or $^O eq 'dos' or
+	      $^O eq 'os2' or $^O eq 'mint' or $^O =~ /cygwin/);
+
 unlink <Op_dbmx*>;
 
 umask(0);
@@ -22,7 +25,7 @@ $Dfile = "Op_dbmx.pag";
 if (! -e $Dfile) {
 	($Dfile) = <Op_dbmx*>;
 }
-if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'dos') {
+if ($Is_Dosish) {
     print "ok 2 # Skipped: different file permission semantics\n";
 }
 else {
diff --git a/t/lib/io_linenum.t b/t/lib/io_linenum.t
new file mode 100755
index 0000000000..0d28e1898c
--- /dev/null
+++ b/t/lib/io_linenum.t
@@ -0,0 +1,69 @@
+#!./perl
+
+# test added 29th April 1998 by Paul Johnson (pjcj@transeda.com)
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, '../lib' if -d '../lib';
+}
+
+use strict;
+use IO::File;
+use Test;
+
+BEGIN {
+    plan tests => 9 #, todo => [10]
+}
+
+sub lineno
+{
+  my ($f) = @_;
+  my $l;
+  $l .= "$. ";
+  $l .= $f->input_line_number;
+  $l .= " $.";
+  $l;
+}
+
+sub OK
+{
+  my $s = select STDOUT;                     # work around a bug in Test.pm 1.04
+  &ok;
+  select $s;
+}
+
+my $t;
+
+open (Q, __FILE__) or die $!;
+my $w = IO::File->new(__FILE__) or die $!;
+
+<Q> for (1 .. 10);
+OK(lineno($w), "10 0 10");
+
+$w->getline for (1 .. 5);
+OK(lineno($w), "5 5 5");
+
+<Q>;
+OK(lineno($w), "11 5 11");
+
+$w->getline;
+OK(lineno($w), "6 6 6");
+
+$t = tell Q;         # tell Q; provokes a warning - the world is full of bugs...
+OK(lineno($w), "11 6 11");
+
+<Q>;
+OK(lineno($w), "12 6 12");
+
+select Q;
+OK(lineno($w), "12 6 12");
+
+<Q> for (1 .. 10);
+OK(lineno($w), "22 6 22");
+
+$w->getline for (1 .. 5);
+OK(lineno($w), "11 11 11");
+__END__
+# This test doesn't work.  It probably won't until local $. does.
+$t = tell Q;
+OK(lineno($w), "22 11 22", 'waiting for local $.');
diff --git a/t/lib/odbm.t b/t/lib/odbm.t
index c5458d5e19..0ef2592c93 100755
--- a/t/lib/odbm.t
+++ b/t/lib/odbm.t
@@ -215,6 +215,8 @@ EOM
    sub checkOutput
    {
        my($fk, $sk, $fv, $sv) = @_ ;
+       print "# ", join('|', $fetch_key, $fk, $store_key, $sk,
+			$fetch_value, $fv, $store_value, $sv, $_), "\n";
        return
            $fetch_key eq $fk && $store_key eq $sk && 
 	   $fetch_value eq $fv && $store_value eq $sv &&
diff --git a/t/lib/tie-stdhandle.t b/t/lib/tie-stdhandle.t
index c74669a5b3..cb8303d94d 100755
--- a/t/lib/tie-stdhandle.t
+++ b/t/lib/tie-stdhandle.t
@@ -10,7 +10,7 @@ tie *tst,Tie::StdHandle;
 
 $f = 'tst';
 
-print "1..12\n";   
+print "1..13\n";   
 
 # my $file tests
 
diff --git a/t/op/filetest.t b/t/op/filetest.t
index 9228b5730b..1e095be7e1 100644
--- a/t/op/filetest.t
+++ b/t/op/filetest.t
@@ -5,8 +5,10 @@
 
 BEGIN {
     chdir 't' if -d 't';
+    unshift @INC, '../lib' if -d '../lib';
 }
 
+use Config;
 print "1..10\n";
 
 print "not " unless -d 'op';
@@ -50,8 +52,12 @@ eval '$> = $oldeuid';	# switch uid back (may not be implemented)
 
 # this would fail for the euid 1
 # (unless we have unpacked the source code as uid 1...)
-print "not " unless -w 'op';
-print "ok 8\n";
+if ($Config{d_seteuid}) {
+    print "not " unless -w 'op';
+    print "ok 8\n";
+} else {
+    print "ok 8 #skipped, no seteuid\n";
+}
 
 print "not " unless -x 'op'; # Hohum.  Are directories -x everywhere?
 print "ok 9\n";
diff --git a/t/op/magic.t b/t/op/magic.t
index 9b819a8d7b..8486512b35 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -120,8 +120,9 @@ ok 18, $$ > 0, $$;
     $script = "$wd/show-shebang";
     if ($Is_MSWin32) {
 	chomp($wd = `cd`);
-	$perl = "$wd\\perl.exe";
-	$script = "$wd\\show-shebang.bat";
+	$wd =~ s|\\|/|g;
+	$perl = "$wd/perl.exe";
+	$script = "$wd/show-shebang.bat";
 	$headmaybe = <<EOH ;
 \@rem ='
 \@echo off
diff --git a/t/op/numconvert.t b/t/op/numconvert.t
new file mode 100755
index 0000000000..405f721d20
--- /dev/null
+++ b/t/op/numconvert.t
@@ -0,0 +1,193 @@
+#!./perl
+
+#
+# test the conversion operators
+#
+# Notations:
+#
+# "N p i N vs N N":  Apply op-N, then op-p, then op-i, then reporter-N
+# Compare with application of op-N, then reporter-N
+# Right below are descriptions of different ops and reporters.
+
+# We do not use these subroutines any more, sub overhead makes a "switch"
+# solution better:
+
+# obviously, 0, 1 and 2, 3 are destructive.  (XXXX 64-bit? 4 destructive too)
+
+# *0 = sub {--$_[0]};		# -
+# *1 = sub {++$_[0]};		# +
+
+# # Converters
+# *2 = sub { $_[0] = $max_uv & $_[0]}; # U
+# *3 = sub { use integer; $_[0] += $zero}; # I
+# *4 = sub { $_[0] += $zero};	# N
+# *5 = sub { $_[0] = "$_[0]" };	# P
+
+# # Side effects
+# *6 = sub { $max_uv & $_[0]};	# u
+# *7 = sub { use integer; $_[0] + $zero};	# i
+# *8 = sub { $_[0] + $zero};	# n
+# *9 = sub { $_[0] . "" };	# p
+
+# # Reporters
+# sub a2 { sprintf "%u", $_[0] }	# U
+# sub a3 { sprintf "%d", $_[0] }	# I
+# sub a4 { sprintf "%g", $_[0] }	# N
+# sub a5 { "$_[0]" }		# P
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict 'vars';
+
+my $max_chain = $ENV{PERL_TEST_NUMCONVERTS};
+unless (defined $max_chain) {
+  my $is_debug;
+  eval <<'EOE';
+    use Config;
+    $is_debug = 1 if $Config{ccflags} =~ /-DDEBUGGING\b/;
+EOE
+  $max_chain = $is_debug ? 3 : 2;
+}
+
+# Bulk out if unsigned type is hopelessly wrong:
+my $max_uv1 = ~0;
+my $max_uv2 = sprintf "%u", $max_uv1 ** 6; # 6 is an arbitrary number here
+my $big_iv = do {use integer; $max_uv1 * 16}; # 16 is an arbitrary number here
+
+if ($max_uv1 ne $max_uv2 or $big_iv > $max_uv1) {
+  print "1..0\n# Unsigned arithmetic is not sane\n";
+  exit 0;
+}
+
+my $st_t = 4*4;			# We try 4 initializers and 4 reporters
+
+my $num = 0;
+$num += 10**$_ - 4**$_ for 1.. $max_chain;
+$num *= $st_t;
+print "1..$num\n";		# In fact 15 times more subsubtests...
+
+my $max_uv = ~0;
+my $max_iv = int($max_uv/2);
+my $zero = 0;
+
+my $l_uv = length $max_uv;
+my $l_iv = length $max_iv;
+
+# Hope: the first digits are good
+my $larger_than_uv = substr 97 x 100, 0, $l_uv;
+my $smaller_than_iv = substr 12 x 100, 0, $l_iv;
+my $yet_smaller_than_iv = substr 97 x 100, 0, ($l_iv - 1);
+
+my @list = (1, $yet_smaller_than_iv, $smaller_than_iv, $max_iv, $max_iv + 1,
+	    $max_uv, $max_uv + 1);
+unshift @list, (reverse map -$_, @list), 0; # 15 elts
+@list = map "$_", @list; # Normalize
+
+# print "@list\n";
+
+
+my @opnames = split //, "-+UINPuinp";
+
+# @list = map { 2->($_), 3->($_), 4->($_), 5->($_),  } @list; # Prepare input
+
+#print "@list\n";
+#print "'@ops'\n";
+
+my $test = 1;
+my $nok;
+for my $num_chain (1..$max_chain) {
+  my @ops = map [split //], grep /[4-9]/,
+    map { sprintf "%0${num_chain}d", $_ }  0 .. 10**$num_chain - 1;
+
+  #@ops = ([]) unless $num_chain;
+  #@ops = ([6, 4]);
+
+  # print "'@ops'\n";
+  for my $op (@ops) {
+    for my $first (2..5) {
+      for my $last (2..5) {
+	$nok = 0;
+	my @otherops = grep $_ <= 3, @$op;
+	my @curops = ($op,\@otherops);
+
+	for my $num (@list) {
+	  my $inpt;
+	  my @ans;
+
+	  for my $short (0, 1) {
+	    # undef $inpt;	# Forget all we had - some bugs were masked
+
+	    $inpt = $num;	# Try to not contaminate $num...
+	    $inpt = "$inpt";
+	    if ($first == 2) {
+	      $inpt = $max_uv & $inpt; # U 2
+	    } elsif ($first == 3) {
+	      use integer; $inpt += $zero; # I 3
+	    } elsif ($first == 4) {
+	      $inpt += $zero;	# N 4
+	    } else {
+	      $inpt = "$inpt";	# P 5
+	    }
+
+	    # Saves 20% of time - not with this logic:
+	    #my $tmp = $inpt;
+	    #my $tmp1 = $num;
+	    #next if $num_chain > 1
+	    #  and "$tmp" ne "$tmp1"; # Already the coercion gives problems...
+
+	    for my $curop (@{$curops[$short]}) {
+	      if ($curop < 5) {
+		if ($curop < 3) {
+		  if ($curop == 0) {
+		    --$inpt;	# - 0
+		  } elsif ($curop == 1) {
+		    ++$inpt;	# + 1
+		  } else {
+		    $inpt = $max_uv & $inpt; # U 2
+		  }
+		} elsif ($curop == 3) {
+		  use integer; $inpt += $zero;
+		} else {
+		  $inpt += $zero; # N 4
+		}
+	      } elsif ($curop < 8) {
+		if ($curop == 5) {
+		  $inpt = "$inpt"; # P 5
+		} elsif ($curop == 6) {
+		  $max_uv & $inpt; # u 6
+		} else {
+		  use integer; $inpt + $zero;
+		}
+	      } elsif ($curop == 8) {
+		$inpt + $zero;	# n 8
+	      } else {
+		$inpt . "";	# p 9
+	      }
+	    }
+
+	    if ($last == 2) {
+	      $inpt = sprintf "%u", $inpt; # U 2
+	    } elsif ($last == 3) {
+	      $inpt = sprintf "%d", $inpt; # I 3
+	    } elsif ($last == 4) {
+	      $inpt = sprintf "%g", $inpt; # N 4
+	    } else {
+	      $inpt = "$inpt";	# P 5
+	    }
+	    push @ans, $inpt;
+	  }
+	  $nok++,
+	    print "# '$ans[0]' ne '$ans[1]',\t$num\t=> @opnames[$first,@{$curops[0]},$last] vs @opnames[$first,@{$curops[1]},$last]\n"
+	      if $ans[0] ne $ans[1];
+	}
+	print "not " if $nok;
+	print "ok $test\n";
+	#print $txt if $nok;
+	$test++;
+      }
+    }
+  }
+}
diff --git a/t/op/re_tests b/t/op/re_tests
index 5abe217b05..ba824aeefa 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -475,6 +475,7 @@ $(?<=^(a))	a	y	$1	a
 ([[.]+)	a.[b].	y	$1	.[
 [a[:xyz:	-	c	-	/[a[:xyz:/: unmatched [] in regexp
 [a[:xyz:]	-	c	-	/[a[:xyz:]/: unmatched [] in regexp
+[a[:]b[:c]	abc	y	$&	abc
 ([a[:xyz:]b]+)	pbaq	y	$1	ba
 ((?>a+)b)	aaab	y	$1	aaab
 (?>(a+))b	aaab	y	$1	aaa
diff --git a/t/op/stat.t b/t/op/stat.t
index 6f2d00b7e6..ae627f6070 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -13,7 +13,7 @@ print "1..58\n";
 
 $Is_MSWin32 = $^O eq 'MSWin32';
 $Is_Dos = $^O eq 'dos';
-$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32;
+$Is_Dosish = $Is_Dos || $^O eq 'os2' || $Is_MSWin32 || $^O =~ /cygwin/;
 chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`));
 
 $DEV = `ls -l /dev` unless $Is_Dosish;
@@ -93,6 +93,9 @@ foreach ((12,13,14,15,16,17)) {
     print "ok $_\n";		#deleted tests
 }
 
+# in ms windows, Op.stat.tmp inherits owner uid from directory
+# not sure about os/2, but chown is harmless anyway
+chown $>,'Op.stat.tmp';
 chmod 0700,'Op.stat.tmp';
 if (-r 'Op.stat.tmp') {print "ok 18\n";} else {print "not ok 18\n";}
 if (-w 'Op.stat.tmp') {print "ok 19\n";} else {print "not ok 19\n";}
diff --git a/t/op/taint.t b/t/op/taint.t
index d75bc1807a..fdd1c79b83 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -19,6 +19,13 @@ use Config;
 # just because Errno possibly failing.
 eval { require Errno; import Errno };
 
+BEGIN {
+  if ($^O eq 'VMS' && !defined($Config{d_setenv})) {
+      $ENV{PATH} = $ENV{PATH};
+      $ENV{TERM} = $ENV{TERM} ne ''? $ENV{TERM} : 'dummy';
+  }
+}
+
 my $Is_VMS = $^O eq 'VMS';
 my $Is_MSWin32 = $^O eq 'MSWin32';
 my $Is_Dos = $^O eq 'dos';
@@ -33,7 +40,7 @@ if ($Is_VMS) {
     }
     eval <<EndOfCleanup;
 	END {
-	    \$ENV{PATH} = '';
+	    \$ENV{PATH} = '' if $Config{d_setenv};
 	    warn "# Note: logical name 'PATH' may have been deleted\n";
 	    \@ENV{keys %old} = values %old;
 	}
diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio
index cd0d55831a..97f0804bfa 100644
--- a/t/pragma/warn/doio
+++ b/t/pragma/warn/doio
@@ -44,7 +44,8 @@
 __END__
 # doio.c
 use warning 'io' ;
-open(F, "|$^X -e 1|")
+open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|");
+close(F);
 EXPECT
 Can't do bidirectional pipe at - line 3.
 ########
@@ -111,4 +112,4 @@ use warning 'io' ;
 exec "lskdjfalksdjfdjfkls", "abc" ;
 EXPECT
 OPTION regex
-Can't exec "lskdjfalksdjfdjfkls": .+
+Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+
diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg
index 44e7634952..14307e0de0 100644
--- a/t/pragma/warn/mg
+++ b/t/pragma/warn/mg
@@ -16,8 +16,8 @@ No such signal: SIGFRED at - line 3.
 ########
 # mg.c
 use warning 'signal' ;
-if ($^O eq 'MSWin32') {
-    print "SKIPPED\n# win32, can't kill() to raise()\n"; exit;
+if ($^O eq 'MSWin32' || $^O eq 'VMS') {
+    print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit;
 }
 $|=1;
 $SIG{"INT"} = "fred"; kill "INT",$$;
diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys
index 7588827744..8f2c255bc3 100644
--- a/t/pragma/warn/pp_sys
+++ b/t/pragma/warn/pp_sys
@@ -113,7 +113,7 @@ ghi
 .
 $= = 1 ;
 $- =1 ;
-open STDOUT, ">/dev/null" ;
+open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
 write ;
 EXPECT
 page overflow at - line 13.
diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv
index 0f1d83c2e5..f453de96d3 100644
--- a/t/pragma/warn/sv
+++ b/t/pragma/warn/sv
@@ -181,7 +181,7 @@ Subroutine fred redefined at - line 5.
 ########
 # sv.c
 use warning 'printf' ;
-open F, ">/dev/null" ;
+open F, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ;
 printf F "%q\n" ;
 my $a = sprintf "%q" ;
 printf F "%" ;