Change 29943 by [EMAIL PROTECTED] on 2007/01/24 12:06:54
Integrate:
[ 27567]
Subject: [PATCH] Re: [perl #38779] NAN's on Win32
From: Dominic Dunlop <[EMAIL PROTECTED]>
Date: Wed, 22 Mar 2006 15:18:33 +0100
Message-Id: <[EMAIL PROTECTED]>
[ 27576]
Subject: RE: [PATCH, no, really!] Re: [perl #38779] NAN's on Win32
From: "Jan Dubois" <[EMAIL PROTECTED]>
Date: Wed, 22 Mar 2006 22:49:11 -0800
Message-ID: <[EMAIL PROTECTED]>
Also, back out change #27567.
[ 27577]
Further adjustement to change #27576 by Jan Dubois
(this change being blead-specific, while #27576 is
integrable to maint)
[ 27637]
Fix bug #38815 (localising keys which are UTF-8 encoded didn't delete
them correctly on scope exit)
[ 27638]
Localising hash slices with UTF-8 encoded keys was also buggy.
(See also change 27637)
[ 27698]
Subject: revisited: pow.t test failures on AIX 5.1 perl588 with
-Duselongdouble
From: "John L. Allen" <[EMAIL PROTECTED]>
Date: Thu, 30 Mar 2006 17:53:13 -0500 (EST)
Message-ID: <[EMAIL PROTECTED]>
[ 27725]
Assigning undef to an entry in %ENV shouldn't produce warnings, even
though it's silently converted to ""
[ 27731]
Subject: Re: Smoke [5.9.4] 27728 FAIL(F) MSWin32 WinXP/.Net SP2 (x86/2
cpu)
From: Rafael Garcia-Suarez <[EMAIL PROTECTED]>
Date: Thu, 6 Apr 2006 14:32:50 +0200
Message-ID: <[EMAIL PROTECTED]>
[ 27736]
Make perl_fini() run when compiling perl with
the Sun WorkShop compiler.
[ 27756]
Subject: [PATCH] pp_sys.c: some Coverity findings: NULL guards for
format cv
From: [EMAIL PROTECTED] (Jarkko Hietaniemi)
Message-Id: <[EMAIL PROTECTED]>
Date: Sat, 8 Apr 2006 18:55:41 +0300 (EEST)
[ 27761]
Perl_unsharepvn() was no longer being used in core, and changes to
S_unshare_hek_or_pvn() had broken it. Now fixed and tested.
Affected files ...
... //depot/maint-5.8/perl/README.win32#18 integrate
... //depot/maint-5.8/perl/ext/XS/APItest/APItest.xs#14 integrate
... //depot/maint-5.8/perl/ext/XS/APItest/t/hash.t#7 integrate
... //depot/maint-5.8/perl/hv.c#101 integrate
... //depot/maint-5.8/perl/mg.c#131 integrate
... //depot/maint-5.8/perl/perl.c#191 integrate
... //depot/maint-5.8/perl/pp.c#119 integrate
... //depot/maint-5.8/perl/pp_hot.c#118 integrate
... //depot/maint-5.8/perl/pp_sys.c#126 integrate
... //depot/maint-5.8/perl/scope.c#59 integrate
... //depot/maint-5.8/perl/sv.c#304 integrate
... //depot/maint-5.8/perl/t/lib/warnings/mg#3 integrate
... //depot/maint-5.8/perl/t/op/local.t#9 integrate
... //depot/maint-5.8/perl/t/op/write.t#12 integrate
... //depot/maint-5.8/perl/win32/win32.h#9 integrate
Differences ...
==== //depot/maint-5.8/perl/ext/XS/APItest/APItest.xs#14 (text) ====
Index: perl/ext/XS/APItest/APItest.xs
--- perl/ext/XS/APItest/APItest.xs#13~27926~ 2006-04-20 14:03:43.000000000
-0700
+++ perl/ext/XS/APItest/APItest.xs 2007-01-24 04:06:54.000000000 -0800
@@ -176,7 +176,26 @@
PPCODE:
test_freeent(&Perl_hv_delayfree_ent);
XSRETURN(4);
-
+
+SV *
+test_share_unshare_pvn(input)
+ PREINIT:
+ SV *output;
+ STRLEN len;
+ U32 hash;
+ char *pvx;
+ char *p;
+ INPUT:
+ SV *input
+ CODE:
+ pvx = SvPV(input, len);
+ PERL_HASH(hash, pvx, len);
+ p = sharepvn(pvx, len, hash);
+ RETVAL = newSVpvn(p, len);
+ unsharepvn(p, len, hash);
+ OUTPUT:
+ RETVAL
+
=pod
sub TIEHASH { bless {}, $_[0] }
==== //depot/maint-5.8/perl/ext/XS/APItest/t/hash.t#7 (text) ====
Index: perl/ext/XS/APItest/t/hash.t
--- perl/ext/XS/APItest/t/hash.t#6~22634~ 2004-04-01 08:49:54.000000000
-0800
+++ perl/ext/XS/APItest/t/hash.t 2007-01-24 04:06:54.000000000 -0800
@@ -55,6 +55,12 @@
"hv_store doesn't insert a key with the raw utf8 on a tied hash");
}
+
+foreach my $in ("", "N", "a\0b") {
+ my $got = XS::APItest::Hash::test_share_unshare_pvn($in);
+ is ($got, $in, "test_share_unshare_pvn");
+}
+
exit;
################################ The End ################################
==== //depot/maint-5.8/perl/hv.c#101 (text) ====
Index: perl/hv.c
--- perl/hv.c#100~29925~ 2007-01-22 14:10:59.000000000 -0800
+++ perl/hv.c 2007-01-24 04:06:54.000000000 -0800
@@ -1928,7 +1928,6 @@
register HE *entry;
register HE **oentry;
HE **first;
- bool found = 0;
bool is_utf8 = FALSE;
int k_flags = 0;
const char * const save = str;
@@ -1959,10 +1958,8 @@
first = oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
if (hek) {
for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry)
{
- if (HeKEY_hek(entry) != hek)
- continue;
- found = 1;
- break;
+ if (HeKEY_hek(entry) == hek)
+ break;
}
} else {
const int flags_masked = k_flags & HVhek_MASK;
@@ -1975,13 +1972,12 @@
continue;
if (HeKFLAGS(entry) != flags_masked)
continue;
- found = 1;
break;
}
}
- if (found) {
- if (--HeVAL(entry) == Nullsv) {
+ if (entry) {
+ if (--HeVAL(entry) == NULL) {
*oentry = HeNEXT(entry);
if (!*first) {
/* There are now no entries in our slot. */
@@ -1994,7 +1990,7 @@
}
UNLOCK_STRTAB_MUTEX;
- if (!found && ckWARN_d(WARN_INTERNAL))
+ if (!entry && ckWARN_d(WARN_INTERNAL))
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free non-existent shared string '%s'%s"
pTHX__FORMAT,
==== //depot/maint-5.8/perl/mg.c#131 (text) ====
Index: perl/mg.c
--- perl/mg.c#130~29929~ 2007-01-22 15:29:42.000000000 -0800
+++ perl/mg.c 2007-01-24 04:06:54.000000000 -0800
@@ -1051,8 +1051,8 @@
int
Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
{
- STRLEN len, klen;
- const char *s = SvPV_const(sv,len);
+ STRLEN len = 0, klen;
+ const char *s = SvOK(sv) ? SvPV_const(sv,len) : "";
const char * const ptr = MgPV_const(mg,klen);
my_setenv((char *)ptr, (char *)s);
@@ -1062,7 +1062,7 @@
if (!len) {
SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE);
if (valp)
- s = SvPV_const(*valp, len);
+ s = SvOK(*valp) ? SvPV_const(*valp, len) : "";
}
#endif
==== //depot/maint-5.8/perl/perl.c#191 (text) ====
Index: perl/perl.c
--- perl/perl.c#190~29925~ 2007-01-22 14:10:59.000000000 -0800
+++ perl/perl.c 2007-01-24 04:06:54.000000000 -0800
@@ -1435,6 +1435,8 @@
#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) &&
!defined(__GNUC__)
#pragma fini "perl_fini"
+#elif defined(__sun) && !defined(__GNUC__)
+#pragma fini (perl_fini)
#endif
static void
==== //depot/maint-5.8/perl/pp.c#119 (text) ====
Index: perl/pp.c
--- perl/pp.c#118~29939~ 2007-01-23 15:38:58.000000000 -0800
+++ perl/pp.c 2007-01-24 04:06:54.000000000 -0800
@@ -1020,7 +1020,47 @@
#endif
{
dPOPTOPnnrl;
+
+#if defined(USE_LONG_DOUBLE) && defined(HAS_AIX_POWL_NEG_BASE_BUG)
+ /*
+ We are building perl with long double support and are on an AIX OS
+ afflicted with a powl() function that wrongly returns NaNQ for any
+ negative base. This was reported to IBM as PMR #23047-379 on
+ 03/06/2006. The problem exists in at least the following versions
+ of AIX and the libm fileset, and no doubt others as well:
+
+ AIX 4.3.3-ML10 bos.adt.libm 4.3.3.50
+ AIX 5.1.0-ML04 bos.adt.libm 5.1.0.29
+ AIX 5.2.0 bos.adt.libm 5.2.0.85
+
+ So, until IBM fixes powl(), we provide the following workaround to
+ handle the problem ourselves. Our logic is as follows: for
+ negative bases (left), we use fmod(right, 2) to check if the
+ exponent is an odd or even integer:
+
+ - if odd, powl(left, right) == -powl(-left, right)
+ - if even, powl(left, right) == powl(-left, right)
+
+ If the exponent is not an integer, the result is rightly NaNQ, so
+ we just return that (as NV_NAN).
+ */
+
+ if (left < 0.0) {
+ NV mod2 = Perl_fmod( right, 2.0 );
+ if (mod2 == 1.0 || mod2 == -1.0) { /* odd integer */
+ SETn( -Perl_pow( -left, right) );
+ } else if (mod2 == 0.0) { /* even integer */
+ SETn( Perl_pow( -left, right) );
+ } else { /* fractional power */
+ SETn( NV_NAN );
+ }
+ } else {
+ SETn( Perl_pow( left, right) );
+ }
+#else
SETn( Perl_pow( left, right) );
+#endif /* HAS_AIX_POWL_NEG_BASE_BUG */
+
#ifdef PERL_PRESERVE_IVUV
if (is_int)
SvIV_please(TOPs);
@@ -1736,8 +1776,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left < right));
+#else
dPOPnv;
SETs(boolSV(TOPn < value));
+#endif
RETURN;
}
}
@@ -1812,8 +1859,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left > right));
+#else
dPOPnv;
SETs(boolSV(TOPn > value));
+#endif
RETURN;
}
}
@@ -1888,8 +1942,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left <= right));
+#else
dPOPnv;
SETs(boolSV(TOPn <= value));
+#endif
RETURN;
}
}
@@ -1964,8 +2025,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left >= right));
+#else
dPOPnv;
SETs(boolSV(TOPn >= value));
+#endif
RETURN;
}
}
@@ -2033,8 +2101,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETYES;
+ SETs(boolSV(left != right));
+#else
dPOPnv;
SETs(boolSV(TOPn != value));
+#endif
RETURN;
}
}
@@ -3952,7 +4027,8 @@
else {
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
+ SAVEDELETE(hv, savepvn(key,keylen),
+ SvUTF8(keysv) ? -keylen : keylen);
}
}
}
==== //depot/maint-5.8/perl/pp_hot.c#118 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#117~29929~ 2007-01-22 15:29:42.000000000 -0800
+++ perl/pp_hot.c 2007-01-24 04:06:54.000000000 -0800
@@ -358,8 +358,15 @@
}
#endif
{
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ dPOPTOPnnrl;
+ if (Perl_isnan(left) || Perl_isnan(right))
+ RETSETNO;
+ SETs(boolSV(left == right));
+#else
dPOPnv;
SETs(boolSV(TOPn == value));
+#endif
RETURN;
}
}
@@ -1816,7 +1823,8 @@
if (!preeminent) {
STRLEN keylen;
const char * const key = SvPV_const(keysv, keylen);
- SAVEDELETE(hv, savepvn(key,keylen), keylen);
+ SAVEDELETE(hv, savepvn(key,keylen),
+ SvUTF8(keysv) ? -(I32)keylen : keylen);
} else
save_helem(hv, keysv, svp);
}
==== //depot/maint-5.8/perl/pp_sys.c#126 (text) ====
Index: perl/pp_sys.c
--- perl/pp_sys.c#125~29920~ 2007-01-22 11:20:43.000000000 -0800
+++ perl/pp_sys.c 2007-01-24 04:06:54.000000000 -0800
@@ -1366,15 +1366,13 @@
gv_efullname4(sv, fgv, NULL, FALSE);
name = SvPV_nolen_const(sv);
if (name && *name)
- DIE(aTHX_ "Undefined top format \"%s\" called",name);
+ DIE(aTHX_ "Undefined top format \"%s\" called", name);
+ else
+ DIE(aTHX_ "Undefined top format called");
}
- /* why no:
- else
- DIE(aTHX_ "Undefined top format called");
- ?*/
- if (CvCLONE(cv))
+ if (cv && CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
- return doform(cv,gv,PL_op);
+ return doform(cv, gv, PL_op);
}
forget_top:
==== //depot/maint-5.8/perl/scope.c#59 (text) ====
Index: perl/scope.c
--- perl/scope.c#58~29929~ 2007-01-22 15:29:42.000000000 -0800
+++ perl/scope.c 2007-01-24 04:06:54.000000000 -0800
@@ -837,7 +837,7 @@
ptr = SSPOPPTR;
hv = (HV*)ptr;
ptr = SSPOPPTR;
- (void)hv_delete(hv, (char*)ptr, (U32)SSPOPINT, G_DISCARD);
+ (void)hv_delete(hv, (char*)ptr, (I32)SSPOPINT, G_DISCARD);
SvREFCNT_dec(hv);
Safefree(ptr);
break;
==== //depot/maint-5.8/perl/sv.c#304 (text) ====
Index: perl/sv.c
--- perl/sv.c#303~29926~ 2007-01-22 14:47:32.000000000 -0800
+++ perl/sv.c 2007-01-24 04:06:54.000000000 -0800
@@ -1840,6 +1840,13 @@
certainly cast into the IV range at IV_MAX, whereas the correct
answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
cases go to UV */
+#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+ if (Perl_isnan(SvNVX(sv))) {
+ SvUV_set(sv, 0);
+ SvIsUV_on(sv);
+ return FALSE;
+ }
+#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
==== //depot/maint-5.8/perl/t/lib/warnings/mg#3 (text) ====
Index: perl/t/lib/warnings/mg
--- perl/t/lib/warnings/mg#2~22089~ 2004-01-07 05:19:41.000000000 -0800
+++ perl/t/lib/warnings/mg 2007-01-24 04:06:54.000000000 -0800
@@ -55,3 +55,8 @@
length $3;
EXPECT
Use of uninitialized value in length at - line 3.
+########
+# mg.c
+use warnings 'uninitialized';
+$ENV{FOO} = undef; # should not warn
+EXPECT
==== //depot/maint-5.8/perl/t/op/local.t#9 (xtext) ====
Index: perl/t/op/local.t
--- perl/t/op/local.t#8~29939~ 2007-01-23 15:38:58.000000000 -0800
+++ perl/t/op/local.t 2007-01-24 04:06:54.000000000 -0800
@@ -5,7 +5,7 @@
@INC = qw(. ../lib);
require './test.pl';
}
-plan tests => 95;
+plan tests => 113;
my $list_assignment_supported = 1;
@@ -369,3 +369,50 @@
::ok(f1() eq "f1", "localised sub restored");
::ok(f2() eq "f2", "localised sub restored");
}
+
+# Localising unicode keys (bug #38815)
+{
+ my %h;
+ $h{"\243"} = "pound";
+ $h{"\302\240"} = "octects";
+ is(scalar keys %h, 2);
+ {
+ my $unicode = chr 256;
+ my $ambigous = "\240" . $unicode;
+ chop $ambigous;
+ local $h{$unicode} = 256;
+ local $h{$ambigous} = 160;
+
+ is(scalar keys %h, 4);
+ is($h{"\243"}, "pound");
+ is($h{$unicode}, 256);
+ is($h{$ambigous}, 160);
+ is($h{"\302\240"}, "octects");
+ }
+ is(scalar keys %h, 2);
+ is($h{"\243"}, "pound");
+ is($h{"\302\240"}, "octects");
+}
+
+# And with slices
+{
+ my %h;
+ $h{"\243"} = "pound";
+ $h{"\302\240"} = "octects";
+ is(scalar keys %h, 2);
+ {
+ my $unicode = chr 256;
+ my $ambigous = "\240" . $unicode;
+ chop $ambigous;
+ local @h{$unicode, $ambigous} = (256, 160);
+
+ is(scalar keys %h, 4);
+ is($h{"\243"}, "pound");
+ is($h{$unicode}, 256);
+ is($h{$ambigous}, 160);
+ is($h{"\302\240"}, "octects");
+ }
+ is(scalar keys %h, 2);
+ is($h{"\243"}, "pound");
+ is($h{"\302\240"}, "octects");
+}
==== //depot/maint-5.8/perl/t/op/write.t#12 (xtext) ====
Index: perl/t/op/write.t
--- perl/t/op/write.t#11~22987~ 2004-06-23 08:54:27.000000000 -0700
+++ perl/t/op/write.t 2007-01-24 04:06:54.000000000 -0800
@@ -597,7 +597,7 @@
}
}
close FROM_CHILD;
- print + (@data?"not ":""), "ok ", $test++, " - too litle output\n";
+ print + (@data?"not ":""), "ok ", $test++, " - too little output\n";
exit;
}
==== //depot/maint-5.8/perl/win32/win32.h#9 (text) ====
Index: perl/win32/win32.h
--- perl/win32/win32.h#8~28442~ 2006-06-27 15:20:20.000000000 -0700
+++ perl/win32/win32.h 2007-01-24 04:06:54.000000000 -0800
@@ -212,6 +212,11 @@
#define snprintf _snprintf
#define vsnprintf _vsnprintf
+#if _MSC_VER < 1300
+/* VC6 has broken NaN semantics: NaN == NaN returns true instead of false */
+#define NAN_COMPARE_BROKEN 1
+#endif
+
#endif /* _MSC_VER */
#ifdef __MINGW32__ /* Minimal Gnu-Win32 */
End of Patch.
