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.