Change 13612: Integrate various changes from maint-5.6/perl/.

[email protected] (Chris Nandor) Tue, 11 Dec 2001 01:24:21 -0500
Newsgroups perl.perl5.changes.mac
Message-ID <p05100310b83b570dd7b8@[10.0.1.177]>
Change 13612 by pudge@pudge-mobile on 2001/12/11 04:58:52

	Integrate various changes from maint-5.6/perl/.

Affected files ...

.... //depot/maint-5.6/macperl/op.c#4 integrate
.... //depot/maint-5.6/macperl/pp.c#3 integrate
.... //depot/maint-5.6/macperl/pp_hot.c#3 integrate
.... //depot/maint-5.6/macperl/t/io/pipe.t#2 integrate
.... //depot/maint-5.6/macperl/t/op/cmp.t#2 integrate
.... //depot/maint-5.6/macperl/t/op/misc.t#5 integrate
.... //depot/maint-5.6/macperl/t/op/system_tests#2 integrate
.... //depot/maint-5.6/macperl/util.c#6 integrate
.... //depot/maint-5.6/macperl/win32/perlhost.h#5 integrate
.... //depot/maint-5.6/macperl/win32/win32.c#8 integrate

Differences ...

==== //depot/maint-5.6/macperl/op.c#4 (text) ====
Index: perl/op.c
--- perl/op.c.~1~	Mon Dec 10 22:15:05 2001
+++ perl/op.c	Mon Dec 10 22:15:05 2001
@@ -4086,6 +4086,10 @@
 void
 Perl_cv_undef(pTHX_ CV *cv)
 {
+    CV *outsidecv;
+    CV *freecv = Nullcv;
+    bool is_eval = CvEVAL(cv) && !CvGV(cv);	/* is this eval"" ? */
+
 #ifdef USE_THREADS
     if (CvMUTEXP(cv)) {
 	MUTEX_DESTROY(CvMUTEXP(cv));
@@ -4113,27 +4117,50 @@
     }
     SvPOK_off((SV*)cv);		/* forget prototype */
     CvGV(cv) = Nullgv;
+    outsidecv = CvOUTSIDE(cv);
     /* Since closure prototypes have the same lifetime as the containing
      * CV, they don't hold a refcount on the outside CV.  This avoids
      * the refcount loop between the outer CV (which keeps a refcount to
      * the closure prototype in the pad entry for pp_anoncode()) and the
-     * closure prototype, and the ensuing memory leak.  This does not
-     * apply to closures generated within eval"", since eval"" CVs are
-     * ephemeral. --GSAR */
-    if (!CvANON(cv) || CvCLONED(cv)
-	|| (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
-	    && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
-    {
-	SvREFCNT_dec(CvOUTSIDE(cv));
-    }
+     * closure prototype, and the ensuing memory leak.  --GSAR */
+    if (!CvANON(cv) || CvCLONED(cv))
+	freecv = outsidecv;
     CvOUTSIDE(cv) = Nullcv;
     if (CvPADLIST(cv)) {
 	/* may be during global destruction */
 	if (SvREFCNT(CvPADLIST(cv))) {
-	    I32 i = AvFILLp(CvPADLIST(cv));
-	    while (i >= 0) {
-		SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
-		SV* sv = svp ? *svp : Nullsv;
+	    AV *padlist = CvPADLIST(cv);
+	    I32 ix;
+	    if (is_eval) {
+		/* inner references to eval's cv must be fixed up */
+		AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+		AV *comppad = (AV*)AvARRAY(padlist)[1];
+		SV **namepad = AvARRAY(comppad_name);
+		SV **curpad = AvARRAY(comppad);
+		for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+		    SV *namesv = namepad[ix];
+		    if (namesv && namesv != &PL_sv_undef
+			&& *SvPVX(namesv) == '&')
+		    {
+			CV *innercv = (CV*)curpad[ix];
+			if (innercv && SvTYPE(innercv) == SVt_PVCV
+			    && CvOUTSIDE(innercv) == cv)
+			{
+			    CvOUTSIDE(innercv) = outsidecv;
+			    if (!CvANON(innercv) || CvCLONED(innercv)) {
+				(void)SvREFCNT_inc(outsidecv);
+				if (SvREFCNT(cv))
+				    SvREFCNT_dec(cv);
+			    }
+			}
+		    }
+		}
+	    }
+	    if (freecv)
+		SvREFCNT_dec(freecv);
+	    ix = AvFILLp(padlist);
+	    while (ix >= 0) {
+		SV* sv = AvARRAY(padlist)[ix--];
 		if (!sv)
 		    continue;
 		if (sv == (SV*)PL_comppad_name)
@@ -4148,6 +4175,8 @@
 	}
 	CvPADLIST(cv) = Nullav;
     }
+    else if (freecv)
+	SvREFCNT_dec(freecv);
     CvFLAGS(cv) = 0;
 }
 
@@ -4682,17 +4711,12 @@
 	}
     }
 
-    /* If a potential closure prototype, don't keep a refcount on
-     * outer CV, unless the latter happens to be a passing eval"".
+    /* If a potential closure prototype, don't keep a refcount on outer CV.
      * This is okay as the lifetime of the prototype is tied to the
      * lifetime of the outer CV.  Avoids memory leak due to reference
      * loop. --GSAR */
-    if (!name && CvOUTSIDE(cv)
-	&& !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
-	     && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
-    {
+    if (!name)
 	SvREFCNT_dec(CvOUTSIDE(cv));
-    }
 
     if (name || aname) {
 	char *s;

==== //depot/maint-5.6/macperl/pp.c#3 (text) ====
Index: perl/pp.c
--- perl/pp.c.~1~	Mon Dec 10 22:15:05 2001
+++ perl/pp.c	Mon Dec 10 22:15:05 2001
@@ -1211,7 +1211,8 @@
     dSP; tryAMAGICbinSET(ne,0);
 #ifndef NV_PRESERVES_UV
     if (SvROK(TOPs) && SvROK(TOPm1s)) {
-	SETs(boolSV(SvRV(TOPs) != SvRV(TOPm1s)));
+        SP--;
+	SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s)));
 	RETURN;
     }
 #endif
@@ -1227,7 +1228,9 @@
     dSP; dTARGET; tryAMAGICbin(ncmp,0);
 #ifndef NV_PRESERVES_UV
     if (SvROK(TOPs) && SvROK(TOPm1s)) {
-	SETi(PTR2UV(SvRV(TOPs)) - PTR2UV(SvRV(TOPm1s)));
+        UV right = PTR2UV(SvRV(POPs));
+        UV left = PTR2UV(SvRV(TOPs));
+	SETi((left > right) - (left < right));
 	RETURN;
     }
 #endif

==== //depot/maint-5.6/macperl/pp_hot.c#3 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c.~1~	Mon Dec 10 22:15:05 2001
+++ perl/pp_hot.c	Mon Dec 10 22:15:05 2001
@@ -232,7 +232,8 @@
     dSP; tryAMAGICbinSET(eq,0);
 #ifndef NV_PRESERVES_UV
     if (SvROK(TOPs) && SvROK(TOPm1s)) {
-	SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s)));
+        SP--;
+	SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 	RETURN;
     }
 #endif

==== //depot/maint-5.6/macperl/t/io/pipe.t#2 (xtext) ====
Index: perl/t/io/pipe.t
--- perl/t/io/pipe.t.~1~	Mon Dec 10 22:15:05 2001
+++ perl/t/io/pipe.t	Mon Dec 10 22:15:05 2001
@@ -11,7 +11,7 @@
 }
 
 $| = 1;
-print "1..15\n";
+print "1..16\n";
 
 # External program 'tr' assumed.
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
@@ -174,3 +174,21 @@
 }
 print "ok 15\n";
 $? = 0;
+
+# check that child is reaped if the piped program can't be executed
+{
+  local $SIG{CHLD} = 'DEFAULT';
+  open NIL, '/no_such_process |';
+  close NIL;
+
+  my $child = 0;
+  eval {
+    local $SIG{ALRM} = sub { die; };
+    alarm 2;
+    $child = wait;
+    alarm 0;
+  };
+
+  print "not " if $child != -1;
+  print "ok 16\n";
+}

==== //depot/maint-5.6/macperl/t/op/cmp.t#2 (xtext) ====
Index: perl/t/op/cmp.t
--- perl/t/op/cmp.t.~1~	Mon Dec 10 22:15:05 2001
+++ perl/t/op/cmp.t	Mon Dec 10 22:15:05 2001
@@ -1,35 +1,218 @@
 #!./perl
 
-@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1);
+BEGIN {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+}
+
+# 2s complement assumption. Won't break test, just makes the internals of
+# the SVs less interesting if were not on 2s complement system.
+my $uv_max = ~0;
+my $uv_maxm1 = ~0 ^ 1;
+my $uv_big = $uv_max;
+$uv_big = ($uv_big - 20000) | 1;
+my ($iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big, $iv_small);
+$iv_max = $uv_max; # Do copy, *then* divide
+$iv_max /= 2;
+$iv_min = $iv_max;
+{
+  use integer;
+  $iv0 = 2 - 2;
+  $iv1 = 3 - 2;
+  $ivm1 = 2 - 3;
+  $iv_max -= 1;
+  $iv_min += 0;
+  $iv_big = $iv_max - 3;
+  $iv_small = $iv_min + 2;
+}
+my $uv_bigi = $iv_big;
+$uv_bigi |= 0x0;
+
+my @array = qw(perl rules);
+
+# Seems one needs to perform the maths on 'Inf' to get the NV correctly primed.
+@FOO = ('s', 'N/A', 'a', 'NaN', -1, undef, 0, 1, 3.14, 1e37, 0.632120558, -.5,
+	'Inf'+1, '-Inf'-1, 0x0, 0x1, 0x5, 0xFFFFFFFF, $uv_max, $uv_maxm1,
+	$uv_big, $uv_bigi, $iv0, $iv1, $ivm1, $iv_min, $iv_max, $iv_big,
+	$iv_small, \$array[0], \$array[0], \$array[1], \$^X);
 
-$expect = ($#FOO+2) * ($#FOO+1);
+$expect = 7 * ($#FOO+2) * ($#FOO+1);
 print "1..$expect\n";
 
+sub nok ($$$$$$$$) {
+  my ($test, $left, $threeway, $right, $result, $i, $j, $boolean) = @_;
+  $result = defined $result ? "'$result'" : 'undef';
+  print "not ok $test # ($left <=> $right) gives: $result \$i=$i \$j=$j, $boolean disagrees\n";
+}
+
 my $ok = 0;
 for my $i (0..$#FOO) {
     for my $j ($i..$#FOO) {
 	$ok++;
-	my $cmp = $FOO[$i] <=> $FOO[$j];
-	if (!defined($cmp) ||
-	    $cmp == -1 && $FOO[$i] < $FOO[$j] ||
-	    $cmp == 0  && $FOO[$i] == $FOO[$j] ||
-	    $cmp == 1  && $FOO[$i] > $FOO[$j])
+	# Comparison routines may convert these internally, which would change
+	# what is used to determine the comparison on later runs. Hence copy
+	my ($i1, $i2, $i3, $i4, $i5, $i6, $i7, $i8, $i9, $i10,
+	    $i11, $i12, $i13, $i14, $i15, $i16, $i17) =
+	  ($FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+	   $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i],
+	   $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i], $FOO[$i]);
+	my ($j1, $j2, $j3, $j4, $j5, $j6, $j7, $j8, $j9, $j10,
+	    $j11, $j12, $j13, $j14, $j15, $j16, $j17) =
+	  ($FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+	   $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j],
+	   $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j], $FOO[$j]);
+	my $cmp = $i1 <=> $j1;
+	if (!defined($cmp) ? !($i2 < $j2)
+	    : ($cmp == -1 && $i2 < $j2 ||
+	       $cmp == 0  && !($i2 < $j2) ||
+	       $cmp == 1  && !($i2 < $j2)))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<');
+	}
+	$ok++;
+	if (!defined($cmp) ? !($i4 == $j4)
+	    : ($cmp == -1 && !($i4 == $j4) ||
+	       $cmp == 0  && $i4 == $j4 ||
+	       $cmp == 1  && !($i4 == $j4)))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '==');
+	}
+	$ok++;
+	if (!defined($cmp) ? !($i5 > $j5)
+	    : ($cmp == -1 && !($i5 > $j5) ||
+	       $cmp == 0  && !($i5 > $j5) ||
+	       $cmp == 1  && ($i5 > $j5)))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>');
+	}
+	$ok++;
+	if (!defined($cmp) ? !($i6 >= $j6)
+	    : ($cmp == -1 && !($i6 >= $j6) ||
+	       $cmp == 0  && $i6 >= $j6 ||
+	       $cmp == 1  && $i6 >= $j6))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '>=');
+	}
+	$ok++;
+	# OK, so the docs are wrong it seems. NaN != NaN
+	if (!defined($cmp) ? ($i7 != $j7)
+	    : ($cmp == -1 && $i7 != $j7 ||
+	       $cmp == 0  && !($i7 != $j7) ||
+	       $cmp == 1  && $i7 != $j7))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '!=');
+	}
+	$ok++;
+	if (!defined($cmp) ? !($i8 <= $j8)
+	    : ($cmp == -1 && $i8 <= $j8 ||
+	       $cmp == 0  && $i8 <= $j8 ||
+	       $cmp == 1  && !($i8 <= $j8)))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=');
+	}
+	$ok++;
+        my $pmc =  $j16 <=> $i16; # cmp it in reverse
+        # Should give -ve of other answer, or undef for NaNs
+        # a + -a should be zero. not zero is truth. which avoids using ==
+	if (defined($cmp) ? !($cmp + $pmc) : !defined $pmc)
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, '<=> transposed');
+	}
+
+
+	# String comparisons
+	$ok++;
+	$cmp = $i9 cmp $j9;
+	if ($cmp == -1 && $i10 lt $j10 ||
+	    $cmp == 0  && !($i10 lt $j10) ||
+	    $cmp == 1  && !($i10 lt $j10))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'lt');
+	}
+	$ok++;
+	if ($cmp == -1 && !($i11 eq $j11) ||
+	    $cmp == 0  && ($i11 eq $j11) ||
+	    $cmp == 1  && !($i11 eq $j11))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'eq');
+	}
+	$ok++;
+	if ($cmp == -1 && !($i12 gt $j12) ||
+	    $cmp == 0  && !($i12 gt $j12) ||
+	    $cmp == 1  && ($i12 gt $j12))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'gt');
+	}
+	$ok++;
+	if ($cmp == -1 && $i13 le $j13 ||
+	    $cmp == 0  && ($i13 le $j13) ||
+	    $cmp == 1  && !($i13 le $j13))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'le');
+	}
+	$ok++;
+	if ($cmp == -1 && ($i14 ne $j14) ||
+	    $cmp == 0  && !($i14 ne $j14) ||
+	    $cmp == 1  && ($i14 ne $j14))
+	{
+	    print "ok $ok\n";
+	}
+	else {
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ne');
+	}
+	$ok++;
+	if ($cmp == -1 && !($i15 ge $j15) ||
+	    $cmp == 0  && ($i15 ge $j15) ||
+	    $cmp == 1  && ($i15 ge $j15))
 	{
 	    print "ok $ok\n";
 	}
 	else {
-	    print "not ok $ok ($FOO[$i] <=> $FOO[$j]) gives: '$cmp'\n";
+	    nok ($ok, $i3, 'cmp', $j3, $cmp, $i, $j, 'ge');
 	}
 	$ok++;
-	$cmp = $FOO[$i] cmp $FOO[$j];
-	if ($cmp == -1 && $FOO[$i] lt $FOO[$j] ||
-	    $cmp == 0  && $FOO[$i] eq $FOO[$j] ||
-	    $cmp == 1  && $FOO[$i] gt $FOO[$j])
+        $pmc =  $j17 cmp $i17; # cmp it in reverse
+        # Should give -ve of other answer
+        # a + -a should be zero. not zero is truth. which avoids using ==
+	if (!($cmp + $pmc))
 	{
 	    print "ok $ok\n";
 	}
 	else {
-	    print "not ok $ok ($FOO[$i] cmp $FOO[$j]) gives '$cmp'\n";
+	    nok ($ok, $i3, '<=>', $j3, $cmp, $i, $j, 'cmp transposed');
 	}
     }
 }

==== //depot/maint-5.6/macperl/t/op/misc.t#5 (xtext) ====
==== //depot/maint-5.6/macperl/t/op/system_tests#2 (text) ====
Index: perl/t/op/system_tests
--- perl/t/op/system_tests.~1~	Mon Dec 10 22:15:05 2001
+++ perl/t/op/system_tests	Mon Dec 10 22:15:05 2001
@@ -1,5 +1,6 @@
 #!perl
 
+use Config;
 use Cwd;
 use strict;
 
@@ -80,6 +81,7 @@
   ["\ta b c ", " "],
   ["", "\ta b c ", "abc"],
   [" ", "\ta b c ", "abc"],
+  ['" "', 'a" "b" "c', "abc"],
 );
 
 print "1.." . (@commands * @av * 2) . "\n";
@@ -89,21 +91,29 @@
 	my @cmds = defined($cmds) ? (ref($cmds) ? @$cmds : $cmds) : ();
 	my @args = defined($args) ? (ref($args) ? @$args : $args) : ();
 	print "######## [@cmds]\n";
-	print "<", join('><', $cmds[$#cmds], @args), ">\n";
+	print "<", join('><',
+			$cmds[$#cmds],
+			map { my $x = $_; $x =~ s/"//g; $x } @args),
+	      ">\n";
 	if (system(@cmds,@args) != 0) {
 	    print "Failed, status($?)\n";
-#	    print "Running again in debug mode\n";
-#	    $^D = 1; # -Dp
-#	    system(@cmds,@args);
+	    if ($Config{ccflags} =~ /\bDDEBUGGING\b/) {
+		print "Running again in debug mode\n";
+		$^D = 1; # -Dp
+		system(@cmds,@args);
+	    }
 	}
 	$^D = 0;
-	my $cmdstr = join " ", map { /\s|^$/ ? qq["$_"] : $_ } @cmds, @args;
+	my $cmdstr = join " ", map { /\s|^$/ && !/\"/
+				    ? qq["$_"] : $_ } @cmds, @args;
 	print "######## '$cmdstr'\n";
 	if (system($cmdstr) != 0) {
 	    print "Failed, status($?)\n";
-#	    print "Running again in debug mode\n";
-#	    $^D = 1; # -Dp
-#	    system($cmdstr);
+	    if ($Config{ccflags} =~ /\bDDEBUGGING\b/) {
+		print "Running again in debug mode\n";
+		$^D = 1; # -Dp
+		system($cmdstr);
+	    }
 	}
 	$^D = 0;
     }

==== //depot/maint-5.6/macperl/util.c#6 (text) ====
Index: perl/util.c
--- perl/util.c.~1~	Mon Dec 10 22:15:05 2001
+++ perl/util.c	Mon Dec 10 22:15:05 2001
@@ -2422,8 +2422,13 @@
 	PerlLIO_close(pp[0]);
 	did_pipes = 0;
 	if (n) {			/* Error */
+	    int pid2, status;
+	    PerlLIO_close(p[This]);
 	    if (n != sizeof(int))
 		Perl_croak(aTHX_ "panic: kid popen errno read");
+	    do {
+		pid2 = wait4pid(pid, &status, 0);
+	    } while (pid2 == -1 && errno == EINTR);
 	    errno = errkid;		/* Propagate errno from kid */
 	    return Nullfp;
 	}

==== //depot/maint-5.6/macperl/win32/perlhost.h#5 (text) ====
Index: perl/win32/perlhost.h
--- perl/win32/perlhost.h.~1~	Mon Dec 10 22:15:05 2001
+++ perl/win32/perlhost.h	Mon Dec 10 22:15:05 2001
@@ -197,6 +197,7 @@
 
     DWORD   m_dwEnvCount;
     LPSTR*  m_lppEnvList;
+    BOOL    m_bTopLevel;	// is this a toplevel host?
 };
 
 
@@ -1898,6 +1899,7 @@
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = TRUE;
 
     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
@@ -1946,6 +1948,7 @@
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = FALSE;
 
     CopyMemory(&m_hostperlMem, &perlMem, sizeof(perlMem));
     CopyMemory(&m_hostperlMemShared, &perlMemShared, sizeof(perlMemShared));
@@ -2000,6 +2003,7 @@
 
     m_dwEnvCount = 0;
     m_lppEnvList = NULL;
+    m_bTopLevel = FALSE;
 
     /* duplicate environment info */
     LPSTR lpPtr;
@@ -2313,7 +2317,7 @@
 	    ch = *++lpPtr;
 	    *lpPtr = 0;
 	    Add(lpStr);
-	    if (!w32_pseudo_id)
+	    if (m_bTopLevel)
 		(void)win32_putenv(lpStr);
 	    *lpPtr = ch;
 	}
@@ -2328,7 +2332,7 @@
 CPerlHost::Getenv(const char *varname)
 {
     dTHXo;
-    if (w32_pseudo_id) {
+    if (!m_bTopLevel) {
 	char *pEnv = Find(varname);
 	if (pEnv && *pEnv)
 	    return pEnv;
@@ -2341,7 +2345,7 @@
 {
     dTHXo;
     Add(envstring);
-    if (!w32_pseudo_id)
+    if (m_bTopLevel)
 	return win32_putenv(envstring);
 
     return 0;

==== //depot/maint-5.6/macperl/win32/win32.c#8 (text) ====
Index: perl/win32/win32.c
--- perl/win32/win32.c.~1~	Mon Dec 10 22:15:05 2001
+++ perl/win32/win32.c	Mon Dec 10 22:15:05 2001
@@ -3151,23 +3151,25 @@
 	    if (!curlen) {
 		do_quote = 1;
 	    }
+	    else if (quote_next) {
+		/* see if it really is multiple arguments pretending to
+		 * be one and force a set of quotes around it */
+		if (*find_next_space(arg))
+		    do_quote = 1;
+	    }
 	    else if (!(arg[0] == '"' && curlen > 1 && arg[curlen-1] == '"')) {
 		STRLEN i = 0;
 		while (i < curlen) {
 		    if (isSPACE(arg[i])) {
 			do_quote = 1;
+		    }
+		    else if (arg[i] == '"') {
+			do_quote = 0;
 			break;
 		    }
 		    i++;
 		}
 	    }
-	    else if (quote_next) {
-		/* ok, we know the argument already has quotes; see if it
-		 * really is multiple arguments pretending to be one and
-		 * force a set of quotes around it */
-		if (*find_next_space(arg))
-		    do_quote = 1;
-	    }
 	}
 
 	if (do_quote)
@@ -3194,7 +3196,7 @@
 		    extra_quotes = TRUE;
 		}
 		else {
-		    /* single argument, force quoting if unquoted */
+		    /* single argument, force quoting if it has spaces */
 		    quote_next = TRUE;
 		}
 	    }
End of Patch.