X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=e9dda52808ed2d33f2d2291b4fbe1216c35426d8;hb=e1c57cef4ab5e7ff7a568c339d671a16148368b3;hp=526ed08394db961c3a166b926ffa20a39cb76c20;hpb=211dfcf14199529e353c08dea10d7050e6a4a22a;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/sv.c b/sv.c
index 526ed08..e9dda52 100644
--- a/sv.c
+++ b/sv.c
@@ -2448,6 +2448,9 @@ Perl_looks_like_number(pTHX_ SV *sv)
     I32 numtype = 0;
     I32 sawinf  = 0;
     STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+    bool specialradix = FALSE;
+#endif
 
     if (SvPOK(sv)) {
 	sbegin = SvPVX(sv);
@@ -2514,10 +2517,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
 
         if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-	    || IS_NUMERIC_RADIX(*s)
+	    || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
 	    ) {
-	    s++;
+#ifdef USE_LOCALE_NUMERIC
+	    if (specialradix)
+		s += SvCUR(PL_numeric_radix);
+	    else
+#endif
+		s++;
 	    numtype |= IS_NUMBER_NOT_INT;
             while (isDIGIT(*s))  /* optional digits after the radix */
                 s++;
@@ -2525,10 +2533,15 @@ Perl_looks_like_number(pTHX_ SV *sv)
     }
     else if (*s == '.'
 #ifdef USE_LOCALE_NUMERIC
-	    || IS_NUMERIC_RADIX(*s)
+	    || (specialradix = IS_NUMERIC_RADIX(s))
 #endif
 	    ) {
-        s++;
+#ifdef USE_LOCALE_NUMERIC
+	if (specialradix)
+	    s += SvCUR(PL_numeric_radix);
+	else
+#endif
+	    s++;
 	numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
         /* no digits before the radix means we need digits after it */
         if (isDIGIT(*s)) {
@@ -2957,6 +2970,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 
     if (hibit) {
 	STRLEN len;
+
 	if (SvREADONLY(sv) && SvFAKE(sv)) {
 	    sv_force_normal(sv);
 	    s = SvPVX(sv);
@@ -2987,10 +3001,13 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 {
     if (SvPOK(sv) && SvUTF8(sv)) {
         if (SvCUR(sv)) {
-	    char *c = SvPVX(sv);
-	    STRLEN len = SvCUR(sv);
+	    char *s;
+	    STRLEN len;
 
-	    if (!utf8_to_bytes((U8*)c, &len)) {
+	    if (SvREADONLY(sv) && SvFAKE(sv))
+		sv_force_normal(sv);
+	    s = SvPV(sv, len);
+	    if (!utf8_to_bytes((U8*)s, &len)) {
 	        if (fail_ok)
 		    return FALSE;
 		else {
@@ -3031,7 +3048,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
     if (SvPOK(sv)) {
         char *c;
         char *e;
-        bool has_utf = FALSE;
+
         if (!sv_utf8_downgrade(sv, TRUE))
 	    return FALSE;
 
@@ -3201,6 +3218,13 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 		     && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
 		Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
 		      GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
 	    (void)SvOK_off(dstr);
 	    GvINTRO_off(dstr);		/* one-shot flag */
 	    gp_free((GV*)dstr);
@@ -3241,6 +3265,12 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 		SV *dref = 0;
 		int intro = GvINTRO(dstr);
 
+#ifdef GV_SHARED_CHECK
+                if (GvSHARED((GV*)dstr)) {
+                    Perl_croak(aTHX_ PL_no_modify);
+                }
+#endif
+
 		if (intro) {
 		    GP *gp;
 		    gp_free((GV*)dstr);
@@ -3295,7 +3325,6 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 			    if (!GvCVGEN((GV*)dstr) &&
 				(CvROOT(cv) || CvXSUB(cv)))
 			    {
- 				SV *const_sv;
 				/* ahem, death to those who redefine
 				 * active sort subs */
 				if (PL_curstackinfo->si_type == PERLSI_SORT &&
@@ -3462,8 +3491,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 	if (sflags & SVf_IOK)
 	    (void)SvIOK_only(dstr);
 	else {
-	    SvOK_off(dstr);
-	    SvIOKp_on(dstr);
+	    (void)SvOK_off(dstr);
+	    (void)SvIOKp_on(dstr);
 	}
 	/* XXXX Do we want to set IsUV for IV(ROK)?  Be extra safe... */
 	if (sflags & SVf_IVisUV)
@@ -3481,7 +3510,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
 	if (sflags & SVf_NOK)
 	    (void)SvNOK_only(dstr);
 	else {
-	    SvOK_off(dstr);
+	    (void)SvOK_off(dstr);
 	    SvNOKp_on(dstr);
 	}
 	SvNVX(dstr) = SvNVX(sstr);
@@ -3526,16 +3555,17 @@ void
 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
 {
     register char *dptr;
-    {
-        /* len is STRLEN which is unsigned, need to copy to signed */
-	IV iv = len;
-	assert(iv >= 0);
-    }
+
     SV_CHECK_THINKFIRST(sv);
     if (!ptr) {
 	(void)SvOK_off(sv);
 	return;
     }
+    else {
+        /* len is STRLEN which is unsigned, need to copy to signed */
+	IV iv = len;
+	assert(iv >= 0);
+    }
     (void)SvUPGRADE(sv, SVt_PV);
 
     SvGROW(sv, len + 1);
@@ -3926,11 +3956,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     mg->mg_type = how;
     mg->mg_len = namlen;
-    if (name)
+    if (name) {
 	if (namlen >= 0)
 	    mg->mg_ptr = savepvn(name, namlen);
 	else if (namlen == HEf_SVKEY)
 	    mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+    }
 
     switch (how) {
     case 0:
@@ -4072,11 +4103,12 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type)
 	    *mgp = mg->mg_moremagic;
 	    if (vtbl && vtbl->svt_free)
 		CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
-	    if (mg->mg_ptr && mg->mg_type != 'g')
+	    if (mg->mg_ptr && mg->mg_type != 'g') {
 		if (mg->mg_len >= 0)
 		    Safefree(mg->mg_ptr);
 		else if (mg->mg_len == HEf_SVKEY)
 		    SvREFCNT_dec((SV*)mg->mg_ptr);
+            }
 	    if (mg->mg_flags & MGf_REFCOUNTED)
 		SvREFCNT_dec(mg->mg_obj);
 	    Safefree(mg);
@@ -4685,30 +4717,22 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
 
     /* do not utf8ize the comparands as a side-effect */
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+	bool is_utf8 = TRUE;
+
 	if (PL_hints & HINT_UTF8_DISTINCT)
 	    return FALSE;
 
 	if (SvUTF8(sv1)) {
-	    (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
-	    {
-		IV scur1 = cur1;
-		if (scur1 < 0) {
-		    Safefree(pv1);
-		    return 0;
-		}
-	    }
-	    pv1tmp = TRUE;
+	    char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+
+	    if ((pv1tmp = (pv != pv1)))
+		pv1 = pv;
 	}
 	else {
-	    (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
-	    {
-		IV scur2 = cur2;
-		if (scur2 < 0) {
-		    Safefree(pv2);
-		    return 0;
-		}
-	    }
-	    pv2tmp = TRUE;
+	    char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+
+	    if ((pv2tmp = (pv != pv2)))
+		pv2 = pv;
 	}
     }
 
@@ -5596,6 +5620,12 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
         len = -len;
         is_utf8 = TRUE;
     }
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+	STRLEN tmplen = len;
+	/* See the note in hv.c:hv_fetch() --jhi */
+	src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+	len = tmplen;
+    }
     if (!hash)
 	PERL_HASH(hash, src, len);
     new_SV(sv);
@@ -6323,6 +6353,25 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
 }
 
 /*
+=for apidoc sv_setref_uv
+
+Copies an unsigned integer into a new SV, optionally blessing the SV.  The C<rv>
+argument will be upgraded to an RV.  That RV will be modified to point to
+the new SV.  The C<classname> argument indicates the package for the
+blessing.  Set C<classname> to C<Nullch> to avoid the blessing.  The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
+SV*
+Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+{
+    sv_setuv(newSVrv(rv,classname), uv);
+    return rv;
+}
+
+/*
 =for apidoc sv_setref_nv
 
 Copies a double into a new SV, optionally blessing the SV.  The C<rv>
@@ -6704,8 +6753,8 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
-I32
-S_expect_number(char** pattern)
+STATIC I32
+S_expect_number(pTHX_ char** pattern)
 {
     I32 var = 0;
     switch (**pattern) {
@@ -6717,7 +6766,7 @@ S_expect_number(char** pattern)
     }
     return var;
 }
-#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(&pattern))
+#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
 
 /*
 =for apidoc sv_vcatpvfn
@@ -6780,7 +6829,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	bool left = FALSE;
 	bool vectorize = FALSE;
 	bool vectorarg = FALSE;
-	bool utf = FALSE;
+	bool vec_utf = FALSE;
 	char fill = ' ';
 	char plus = 0;
 	char intsize = 0;
@@ -6892,7 +6941,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    q++;
 	    if (vectorize)
 		goto unknown;
-	    if (vectorarg = asterisk) {
+	    if ((vectorarg = asterisk)) {
 		evix = ewix;
 		ewix = 0;
 		asterisk = FALSE;
@@ -6911,26 +6960,24 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		else
 		    vecsv = (evix ? evix <= svmax : svix < svmax) ?
 			svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
-		dotstr = (U8*)SvPVx(vecsv, dotstrlen);
+		dotstr = SvPVx(vecsv, dotstrlen);
 		if (DO_UTF8(vecsv))
 		    is_utf = TRUE;
 	    }
 	    if (args) {
 		vecsv = va_arg(*args, SV*);
 		vecstr = (U8*)SvPVx(vecsv,veclen);
-		utf = DO_UTF8(vecsv);
+		vec_utf = DO_UTF8(vecsv);
 	    }
 	    else if (efix ? efix <= svmax : svix < svmax) {
 		vecsv = svargs[efix ? efix-1 : svix++];
 		vecstr = (U8*)SvPVx(vecsv,veclen);
-		utf = DO_UTF8(vecsv);
+		vec_utf = DO_UTF8(vecsv);
 	    }
 	    else {
 		vecstr = (U8*)"";
 		veclen = 0;
 	    }
-	    if (DO_UTF8(vecsv))
-		is_utf = TRUE;
 	}
 
 	if (asterisk) {
@@ -7099,7 +7146,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		STRLEN ulen;
 		if (!veclen)
 		    continue;
-		if (utf)
+		if (vec_utf)
 		    iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    iv = *vecstr;
@@ -7179,7 +7226,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	vector:
 		if (!veclen)
 		    continue;
-		if (utf)
+		if (vec_utf)
 		    uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
 		else {
 		    uv = *vecstr;
@@ -7369,7 +7416,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
 		}
 	    }
-	    else 
+	    else
 		sv_setuv_mg(argsv, (UV)i);
 	    continue;	/* not "break" */
 
@@ -7405,7 +7452,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* ... right here, because formatting flags should not apply */
 	    SvGROW(sv, SvCUR(sv) + elen + 1);
 	    p = SvEND(sv);
-	    memcpy(p, eptr, elen);
+	    Copy(eptr, p, elen, char);
 	    p += elen;
 	    *p = '\0';
 	    SvCUR(sv) = p - SvPVX(sv);
@@ -7435,7 +7482,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		*p++ = '0';
 	}
 	if (elen) {
-	    memcpy(p, eptr, elen);
+	    Copy(eptr, p, elen, char);
 	    p += elen;
 	}
 	if (gap && left) {
@@ -7444,7 +7491,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	}
 	if (vectorize) {
 	    if (veclen) {
-		memcpy(p, dotstr, dotstrlen);
+		Copy(dotstr, p, dotstrlen, char);
 		p += dotstrlen;
 	    }
 	    else
@@ -7688,10 +7735,110 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
     }
 }
 
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+{
+    register PTR_TBL_ENT_t **array;
+    register PTR_TBL_ENT_t *entry;
+    register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
+    UV riter = 0;
+    UV max;
+
+    if (!tbl || !tbl->tbl_items) {
+        return;
+    }
+
+    array = tbl->tbl_ary;
+    entry = array[0];
+    max = tbl->tbl_max;
+
+    for (;;) {
+        if (entry) {
+            oentry = entry;
+            entry = entry->next;
+            Safefree(oentry);
+        }
+        if (!entry) {
+            if (++riter > max) {
+                break;
+            }
+            entry = array[riter];
+        }
+    }
+
+    tbl->tbl_items = 0;
+}
+
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+{
+    if (!tbl) {
+        return;
+    }
+    ptr_table_clear(tbl);
+    Safefree(tbl->tbl_ary);
+    Safefree(tbl);
+}
+
 #ifdef DEBUGGING
 char *PL_watch_pvx;
 #endif
 
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+    GV *gv = (GV*)sstr;
+    SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+    if (GvIO(gv) || GvFORM(gv)) {
+        GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+    }
+    else if (!GvCV(gv)) {
+        GvCV(gv) = (CV*)sv;
+    }
+    else {
+        /* CvPADLISTs cannot be shared */
+        if (!CvXSUB(GvCV(gv))) {
+            GvSHARED_off(gv);
+        }
+    }
+
+    if (!GvSHARED(gv)) {
+#if 0
+        PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+                      HvNAME(GvSTASH(gv)), GvNAME(gv));
+#endif
+        return Nullsv;
+    }
+
+    /* 
+     * write attempts will die with
+     * "Modification of a read-only value attempted"
+     */
+    if (!GvSV(gv)) {
+        GvSV(gv) = sv;
+    }
+    else {
+        SvREADONLY_on(GvSV(gv));
+    }
+
+    if (!GvAV(gv)) {
+        GvAV(gv) = (AV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    if (!GvHV(gv)) {
+        GvHV(gv) = (HV*)sv;
+    }
+    else {
+        SvREADONLY_on(GvAV(gv));
+    }
+
+    return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
 SV *
 Perl_sv_dup(pTHX_ SV *sstr)
 {
@@ -7824,6 +7971,18 @@ Perl_sv_dup(pTHX_ SV *sstr)
 	LvTYPE(dstr)	= LvTYPE(sstr);
 	break;
     case SVt_PVGV:
+	if (GvSHARED((GV*)sstr)) {
+            SV *share;
+            if ((share = gv_share(sstr))) {
+                del_SV(dstr);
+                dstr = share;
+#if 0
+                PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+                              HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+                break;
+            }
+	}
 	SvANY(dstr)	= new_XPVGV();
 	SvCUR(dstr)	= SvCUR(sstr);
 	SvLEN(dstr)	= SvLEN(sstr);
@@ -8834,7 +8993,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_numeric_name	= SAVEPV(proto_perl->Inumeric_name);
     PL_numeric_standard	= proto_perl->Inumeric_standard;
     PL_numeric_local	= proto_perl->Inumeric_local;
-    PL_numeric_radix	= proto_perl->Inumeric_radix;
+    PL_numeric_radix	= sv_dup_inc(proto_perl->Inumeric_radix);
 #endif /* !USE_LOCALE_NUMERIC */
 
     /* utf8 character classes */
@@ -8878,7 +9037,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     if (proto_perl->Ipsig_pend) {
 	Newz(0, PL_psig_pend, SIG_SIZE, int);
-    } 
+    }
     else {
 	PL_psig_pend	= (int*)NULL;
     }
@@ -8898,7 +9057,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* thrdvar.h stuff */
 
-    if (flags & 1) {
+    if (flags & CLONEf_COPY_STACKS) {
 	/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
 	PL_tmps_ix		= proto_perl->Ttmps_ix;
 	PL_tmps_max		= proto_perl->Ttmps_max;
@@ -9084,6 +9243,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_reginterp_cnt	= 0;
     PL_reg_starttry	= 0;
 
+    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+    }
+
 #ifdef PERL_OBJECT
     return (PerlInterpreter*)pPerl;
 #else