[win32] integrate mainline, plus a few small win32 enhancements

 - remove Win32::GetCurrentDirectory()
 - add Win32::Sleep() for compat
 - add smarter utime() from Jan Dubois, and export it as win32_utime()

p4raw-id: //depot/win32/perl@486

10 files changed, 269 insertions, 62 deletions

diff --git a/t/comp/proto.t b/t/comp/proto.t
index d1cfede8af..2a4c9ccce5 100755
--- a/t/comp/proto.t
+++ b/t/comp/proto.t
@@ -16,7 +16,7 @@ BEGIN {
 
 use strict;
 
-print "1..76\n";
+print "1..80\n";
 
 my $i = 1;
 
@@ -362,20 +362,35 @@ printf "ok %d\n",$i++;
 ##
 ##
 
-testing \&an_array_ref, '\@';
+testing \&array_ref_plus, '\@@';
 
-sub an_array_ref (\@) {
+sub array_ref_plus (\@@) {
     print "# \@_ = (",join(",",@_),")\n";
-    print "not " unless ref($_[0]) && 1 == @{$_[0]};
+    print "not " unless @_ == 2 && ref($_[0]) && 1 == @{$_[0]} && $_[1] eq 'x';
     printf "ok %d\n",$i++;
     @{$_[0]} = (qw(ok)," ",$i++,"\n");
 }
 
 @array = ('a');
-an_array_ref @array;
+{ my @more = ('x');
+  array_ref_plus @array, @more; }
 print "not " unless @array == 4;
 print @array;
 
+my $p;
+print "not " if defined prototype('CORE::print');
+print "ok ", $i++, "\n";
+
+print "not " if defined prototype('CORE::system');
+print "ok ", $i++, "\n";
+
+print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
+print "ok ", $i++, "\n";
+
+print "# CORE:Foo => ($p), \$@ => `$@'\nnot " 
+    if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Cannot find an opnumber/;
+print "ok ", $i++, "\n";
+
 # correctly note too-short parameter lists that don't end with '$',
 #  a possible regression.
 
diff --git a/t/lib/complex.t b/t/lib/complex.t
index 3390334d34..2783e42f66 100755
--- a/t/lib/complex.t
+++ b/t/lib/complex.t
@@ -3,13 +3,9 @@
 # $RCSfile: complex.t,v $
 #
 # Regression tests for the Math::Complex pacakge
-# -- Raphael Manfredi	September 1996
-# -- Jarkko Hietaniemi	March-October 1997
-# -- Daniel S. Lewart	September-October 1997
-
-$VERSION = '1.05';
-
-# $Id: complex.t,v 1.1 1997/10/15 10:02:15 jhi Exp jhi $
+# -- Raphael Manfredi	since Sep 1996
+# -- Jarkko Hietaniemi	since Mar 1997
+# -- Daniel S. Lewart	since Sep 1997
 
 BEGIN {
     chdir 't' if -d 't';
@@ -18,6 +14,8 @@ BEGIN {
 
 use Math::Complex;
 
+$VERSION = sprintf("%s", q$Id: complex.t,v 1.8 1998/02/05 16:03:39 jhi Exp $ =~ /(\d+\.d+)/);
+
 my ($args, $op, $target, $test, $test_set, $try, $val, $zvalue, @set, @val);
 
 $test = 0;
@@ -26,7 +24,7 @@ my @script = (
     'my ($res, $s0,$s1,$s2,$s3,$s4,$s5,$s6,$s7,$s8,$s9,$s10, $z0,$z1,$z2);' .
 	"\n\n"
 );
-my $eps = 1e-11;
+my $eps = 1e-13;
 
 while (<DATA>) {
 	s/^\s+//;
@@ -59,16 +57,70 @@ while (<DATA>) {
 	}
 }
 
+#
+
+sub test_mutators {
+    my $op;
+
+    $test++;
+push(@script, <<'EOT');
+{
+    my $z = cplx(  1,  1);
+    $z->Re(2);
+    $z->Im(3);
+    print 'not ' unless Re($z) == 2 and Im($z) == 3;
+EOT
+    push(@script, qq(print "ok $test\\n"}\n));
+
+    $test++;
+push(@script, <<'EOT');
+{
+    my $z = cplx(  1,  1);
+    $z->abs(3 * sqrt(2));
+    print 'not ' unless (abs($z) - 3 * sqrt(2)) < $eps and
+                        (arg($z) - pi / 4     ) < $eps and
+                        (Re($z) - 3           ) < $eps and
+                        (Im($z) - 3           ) < $eps;
+EOT
+    push(@script, qq(print "ok $test\\n"}\n));
+
+    $test++;
+push(@script, <<'EOT');
+{
+    my $z = cplx(  1,  1);
+    $z->arg(-3 / 4 * pi);
+    print 'not ' unless (arg($z) + 3 / 4 * pi) < $eps and
+                        (abs($z) - sqrt(2)   ) < $eps and
+                        (Re($z) + 1          ) < $eps and
+                        (Im($z) + 1          ) < $eps;
+EOT
+    push(@script, qq(print "ok $test\\n"}\n));
+}
+
+test_mutators();
+
+my $constants = '
+my $i    = cplx(0,  1);
+my $pi   = cplx(pi, 0);
+my $pii  = cplx(0, pi);
+my $pip2 = cplx(pi/2, 0);
+my $zero = cplx(0, 0);
+';
+
+push(@script, $constants);
+
+
 # test the divbyzeros
 
 sub test_dbz {
     for my $op (@_) {
 	$test++;
 
-#	push(@script, qq(print "# '$op'\n";));
-	push(@script, qq(eval '$op';));
-	push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);));
-	push(@script, qq( print "ok $test\\n";\n));
+	push(@script, <<EOT);
+eval '$op';
+print 'not ' unless (\$@ =~ /Division by zero/);
+EOT
+        push(@script, qq(print "ok $test\\n";\n));
     }
 }
 
@@ -78,41 +130,40 @@ sub test_loz {
     for my $op (@_) {
 	$test++;
 
-#	push(@script, qq(print "# '$op'\n";));
-	push(@script, qq(eval '$op';));
-	push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);));
-	push(@script, qq( print "ok $test\\n";\n));
+	push(@script, <<EOT);
+eval '$op';
+print 'not ' unless (\$@ =~ /Logarithm of zero/);
+EOT
+        push(@script, qq(print "ok $test\\n";\n));
     }
 }
 
-my $minusi = cplx(0, -1);
-
 test_dbz(
 	 'i/0',
-#	 'tan(pi/2)',	# may succeed thanks to floating point inaccuracies
-#	 'sec(pi/2)',	# may succeed thanks to floating point inaccuracies
-	 'csc(0)',
-	 'cot(0)',
-	 'atan(i)',
-	 'atan($minusi)',
-	 'asec(0)',
+	 'acot(0)',
+	 'acot(+$i)',
+#	 'acoth(-1)',	# Log of zero.
+	 'acoth(0)',
+	 'acoth(+1)',
 	 'acsc(0)',
-	 'acot(i)',
-	 'acot($minusi)',
-#	 'tanh(pi/2)',	# may succeed thanks to floating point inaccuracies
-#	 'sech(pi/2)',	# may succeed thanks to floating point inaccuracies
-	 'csch(0)',
-	 'coth(0)',
-	 'atanh(1)',
-	 'asech(0)',
 	 'acsch(0)',
-	 'acoth(1)',
+	 'asec(0)',
+	 'asech(0)',
+	 'atan(-$i)',
+	 'atan($i)',
+#	 'atanh(-1)',	# Log of zero.
+	 'atanh(+1)',
+	 'cot(0)',
+	 'coth(0)',
+	 'csc(0)',
+	 'tan($pip2)',
+	 'csch(0)',
+	 'tan($pip2)',
 	);
 
-my $zero = cplx(0, 0);
-
 test_loz(
 	 'log($zero)',
+	 'acot(-$i)',
 	 'atanh(-1)',
 	 'acoth(-1)',
 	);
@@ -120,12 +171,13 @@ test_loz(
 # test the 0**0
 
 sub test_ztz {
-	$test++;
+    $test++;
 
-#	push(@script, qq(print "# 0**0\n";));
-	push(@script, qq(eval 'cplx(0)**cplx(0)';));
-	push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);));
-	push(@script, qq( print "ok $test\\n";\n));
+    push(@script, <<'EOT');
+eval 'cplx(0)**cplx(0)';
+print 'not ' unless ($@ =~ /zero raised to the zeroth/);
+EOT
+    push(@script, qq(print "ok $test\\n";\n));
 }
 
 test_ztz;
@@ -136,10 +188,11 @@ sub test_broot {
     for my $op (@_) {
 	$test++;
 
-#	push(@script, qq(print "# root(2, $op)\n";));
-	push(@script, qq(eval 'root(2, $op)';));
-	push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);));
-	push(@script, qq( print "ok $test\\n";\n));
+	push(@script, <<EOT);
+eval 'root(2, $op)';
+print 'not ' unless (\$@ =~ /root must be/);
+EOT
+        push(@script, qq(print "ok $test\\n";\n));
     }
 }
 
@@ -200,7 +253,7 @@ EOB
 			$test++;
 			# check that the rhs has not changed
 			push @script, qq(print "not " unless (\$zbr == \$z1r and \$zbi == \$z1i););
-			push @script, qq( print "ok $test\\n";\n);
+			push @script, qq(print "ok $test\\n";\n);
 			push @script, "}\n";
 		}
 	}
@@ -226,6 +279,9 @@ sub value {
 	if (/^\s*\((.*),(.*)\)/) {
 		return "cplx($1,$2)";
 	}
+	elsif (/^\s*([\-\+]?(?:\d+(\.\d+)?|\.\d+)(?:[e[\-\+]\d+])?)/) {
+		return "cplx($1,0)";
+	}
 	elsif (/^\s*\[(.*),(.*)\]/) {
 		return "cplxe($1,$2)";
 	}
diff --git a/t/lib/ph.t b/t/lib/ph.t
new file mode 100755
index 0000000000..d0a48f6c51
--- /dev/null
+++ b/t/lib/ph.t
@@ -0,0 +1,98 @@
+#!./perl
+
+# Check for presence and correctness of .ph files; for now,
+# just socket.ph and pals.
+#   -- Kurt Starsinic <kstar@isinet.com>
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use Config;
+
+# All the constants which Socket.pm tries to make available:
+my @possibly_defined = qw(
+    INADDR_ANY INADDR_LOOPBACK INADDR_NONE AF_802 AF_APPLETALK AF_CCITT
+    AF_CHAOS AF_DATAKIT AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK
+    AF_INET AF_LAT AF_MAX AF_NBS AF_NIT AF_NS AF_OSI AF_OSINET AF_PUP
+    AF_SNA AF_UNIX AF_UNSPEC AF_X25 MSG_DONTROUTE MSG_MAXIOVLEN MSG_OOB
+    MSG_PEEK PF_802 PF_APPLETALK PF_CCITT PF_CHAOS PF_DATAKIT PF_DECnet PF_DLI
+    PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_LAT PF_MAX PF_NBS PF_NIT
+    PF_NS PF_OSI PF_OSINET PF_PUP PF_SNA PF_UNIX PF_UNSPEC PF_X25 SOCK_DGRAM
+    SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM SOL_SOCKET SOMAXCONN
+    SO_ACCEPTCONN SO_BROADCAST SO_DEBUG SO_DONTLINGER SO_DONTROUTE SO_ERROR
+    SO_KEEPALIVE SO_LINGER SO_OOBINLINE SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO
+    SO_REUSEADDR SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO SO_TYPE SO_USELOOPBACK
+);
+
+
+# The libraries which I'm going to require:
+my @libs = qw(Socket "sys/types.ph" "sys/socket.ph" "netinet/in.ph");
+
+
+# These are defined by Socket.pm even if the C header files don't define them:
+my %ok_to_miss = (
+    INADDR_NONE         => 1,
+    INADDR_LOOPBACK     => 1,
+);
+
+
+my $total_tests = scalar @libs + scalar @possibly_defined;
+my $i           = 0;
+
+print "1..$total_tests\n";
+
+
+foreach (@libs) {
+    $i++;
+
+    if (eval "require $_" ) {
+        print "ok $i\n";
+    } else {
+        print "# Skipping tests; $_ may be missing\n";
+        foreach ($i .. $total_tests) { print "ok $_\n" }
+        exit;
+    }
+}
+
+
+foreach (@possibly_defined) {
+    $i++;
+
+    $pm_val = eval "Socket::$_()";
+    $ph_val = eval "main::$_()";
+
+    if (defined $pm_val and !defined $ph_val) {
+        if ($ok_to_miss{$_}) { print "ok $i\n" }
+        else                 { print "not ok $i\n" }
+        next;
+    } elsif (defined $ph_val and !defined $pm_val) {
+        print "not ok $i\n";
+        next;
+    }
+
+    # Socket.pm converts these to network byte order, so we convert the
+    # socket.ph version to match; note that these cases skip the following
+    # `elsif', which is only applied to _numeric_ values, not literal
+    # bitmasks.
+    if ($_ eq 'INADDR_ANY'
+    or  $_ eq 'INADDR_LOOPBACK'
+    or  $_ eq 'INADDR_NONE') {
+        $ph_val = pack("N*", $ph_val);  # htonl(3) equivalent
+    }
+
+    # Since Socket.pm and socket.ph wave their hands over macros differently,
+    # they could return functionally equivalent bitmaps with different numeric
+    # interpretations (due to sign extension).  The only apparent case of this
+    # is SO_DONTLINGER (only on Solaris, and deprecated, at that):
+    elsif ($pm_val != $ph_val) {
+        $pm_val = oct(sprintf "0x%lx", $pm_val);
+        $ph_val = oct(sprintf "0x%lx", $ph_val);
+    }
+
+    if ($pm_val == $ph_val) { print "ok $i\n" }
+    else                    { print "not ok $i\n" }
+}
+
+
diff --git a/t/lib/posix.t b/t/lib/posix.t
index 6ae88c0dd2..d63e695f02 100755
--- a/t/lib/posix.t
+++ b/t/lib/posix.t
@@ -10,11 +10,11 @@ BEGIN {
     }
 }
 
-use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write);
+use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write);
 use strict subs;
 
 $| = 1;
-print "1..17\n";
+print "1..18\n";
 
 $testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";
 read($testfd, $buffer, 9) if $testfd > 2;
@@ -80,6 +80,12 @@ if ($Config{d_strtoul}) {
 # Pick up whether we're really able to dynamically load everything.
 print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n";
 
+# This can coredump if struct tm has a timezone field and we
+# didn't detect it.  If this fails, try adding
+# -DSTRUCT_TM_HASZONE to your cflags when compiling ext/POSIX/POSIX.c.
+# See ext/POSIX/hints/sunos_4.pl and ext/POSIX/hints/linux.pl 
+print POSIX::strftime("ok 18 # %H:%M, on %D\n", localtime());
+
 $| = 0;
 print '@#!*$@(!@#$';
 _exit(0);
diff --git a/t/op/gv.t b/t/op/gv.t
index ece32d936c..55e7429adc 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -4,7 +4,7 @@
 # various typeglob tests
 #
 
-print "1..11\n";
+print "1..13\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -57,3 +57,11 @@ if (defined $baa) {
   print ref(\$baa) eq 'GLOB' ? "ok 11\n" : "not ok 11\n";
 }
 
+# nested package globs
+# NOTE:  It's probably OK if these semantics change, because the
+#        fact that %X::Y:: is stored in %X:: isn't documented.
+#        (I hope.)
+
+{ package Foo::Bar }
+print exists $Foo::{'Bar::'} ? "ok 12\n" : "not ok 12\n";
+print $Foo::{'Bar::'} eq '*Foo::Bar::' ? "ok 13\n" : "not ok 13\n";
diff --git a/t/op/local.t b/t/op/local.t
index f527c9c9a9..3e30306218 100755
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
 
-print "1..23\n";
+print "1..24\n";
 
 sub foo {
     local($a, $b) = @_;
@@ -52,3 +52,9 @@ print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 22\n";
 
 eval 'local(%$e)';
 print +($@ =~ /Can't localize through a reference/) ? "" : "not ", "ok 23\n";
+
+# check for scope leakage
+$a = 'outer';
+if (1) { local $a = 'inner' }
+print +($a eq 'outer') ? "" : "not ", "ok 24\n";
+
diff --git a/t/op/misc.t b/t/op/misc.t
index 326273aff1..7a7fc334d3 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -338,6 +338,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.
 ########
 /(?{"{"}})/	# Check it outside of eval too
diff --git a/t/op/my.t b/t/op/my.t
index 06c6963534..d439bebd86 100755
--- a/t/op/my.t
+++ b/t/op/my.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: my.t,v $
 
-print "1..28\n";
+print "1..30\n";
 
 sub foo {
     my($a, $b) = @_;
@@ -83,3 +83,11 @@ foreach my $i (26, 27) {
 
 print "not " if $i ne "outer";
 print "ok 28\n";
+
+# Ensure that C<my @y> (without parens) doesn't force scalar context.
+my @x;
+{ @x = my @y }
+print +(@x ? "not " : ""), "ok 29\n";
+{ @x = my %y }
+print +(@x ? "not " : ""), "ok 30\n";
+
diff --git a/t/op/pat.t b/t/op/pat.t
index a9e6869a4a..5d8bf8ad78 100755
--- a/t/op/pat.t
+++ b/t/op/pat.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: pat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:12 $
 
-print "1..100\n";
+print "1..101\n";
 
 $x = "abc\ndef\n";
 
@@ -274,7 +274,7 @@ $_ = " a (bla()) and x(y b((l)u((e))) and b(l(e)e)e";
 $expect = "(bla()) ((l)u((e))) (l(e)e)";
 
 sub matchit { 
-  m'
+  m/
      (
        \( 
        (?{ $c = 1 })		# Initialize
@@ -301,7 +301,7 @@ sub matchit {
        (?!
        )			# Fail
      )				# Otherwise the chunk 1 may succeed with $c>0
-   'xg;
+   /xg;
 }
 
 push @ans, $res while $res = matchit;
@@ -321,9 +321,15 @@ print "not " if "@ans" ne 'a/ b';
 print "ok $test\n";
 $test++;
 
-$code = '$blah = 45';
+$code = '{$blah = 45}';
 $blah = 12;
-/(?{$code})/;			
+/(?$code)/;			
+print "not " if $blah != 45;
+print "ok $test\n";
+$test++;
+
+$blah = 12;
+/(?{$blah = 45})/;			
 print "not " if $blah != 45;
 print "ok $test\n";
 $test++;
diff --git a/t/op/vec.t b/t/op/vec.t
index 97b6d60989..71171447d6 100755
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: vec.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:36 $
 
-print "1..13\n";
+print "1..15\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";
@@ -21,4 +21,7 @@ print vec($foo,1,8) == 0xf1 ? "ok 10\n" : "not ok 10\n";
 print ((ord(substr($foo,1,1)) & 255) == 0xf1 ? "ok 11\n" : "not ok 11\n");
 print vec($foo,2,4) == 1 ? "ok 12\n" : "not ok 12\n";
 print vec($foo,3,4) == 15 ? "ok 13\n" : "not ok 13\n";
+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";