X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=e8c2372954042a8771fac316a1cf152e5ad008bc;hb=d235852b65d51c442c4a84cfa07cd04d89233033;hp=0d1bc6ce1cbf0e4835debc9583c0f5818395107f;hpb=b5a0da183be05b17fe5f94a6d874ae3af91c12f3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 0d1bc6c..e8c2372 100644 --- a/sv.c +++ b/sv.c @@ -63,7 +63,7 @@ static void do_clean_all(pTHXo_ SV *sv); #define del_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ - if (PL_debug & 32768) \ + if (DEBUG_D_TEST) \ del_sv(p); \ else \ plant_SV(p); \ @@ -73,7 +73,7 @@ static void do_clean_all(pTHXo_ SV *sv); STATIC void S_del_sv(pTHX_ SV *p) { - if (PL_debug & 32768) { + if (DEBUG_D_TEST) { SV* sva; SV* sv; SV* svend; @@ -137,6 +137,7 @@ S_more_sv(pTHX) if (PL_nice_chunk) { sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); PL_nice_chunk = Nullch; + PL_nice_chunk_size = 0; } else { char *chunk; /* must use New here to match call to */ @@ -147,20 +148,24 @@ S_more_sv(pTHX) return sv; } -STATIC void +STATIC I32 S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; register SV* svend; + I32 visited = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != SVTYPEMASK) + if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { (FCALL)(aTHXo_ sv); + ++visited; + } } } + return visited; } void @@ -181,12 +186,14 @@ Perl_sv_clean_objs(pTHX) PL_in_clean_objs = FALSE; } -void +I32 Perl_sv_clean_all(pTHX) { + I32 cleaned; PL_in_clean_all = TRUE; - visit(do_clean_all); + cleaned = visit(do_clean_all); PL_in_clean_all = FALSE; + return cleaned; } void @@ -1424,12 +1431,12 @@ S_not_a_number(pTHX_ SV *sv) { char tmpbuf[64]; char *d = tmpbuf; - char *s; char *limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - for (s = SvPVX(sv); *s && d < limit; s++) { + char *s, *end; + for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { int ch = *s & 0xFF; if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; @@ -1452,6 +1459,10 @@ S_not_a_number(pTHX_ SV *sv) *d++ = '\\'; *d++ = '\\'; } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } else if (isPRINT_LC(ch)) *d++ = ch; else { @@ -1459,7 +1470,7 @@ S_not_a_number(pTHX_ SV *sv) *d++ = toCTRL(ch); } } - if (*s) { + if (s < end) { *d++ = '.'; *d++ = '.'; *d++ = '.'; @@ -1720,7 +1731,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } @@ -1974,7 +1985,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } @@ -2258,7 +2269,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } @@ -2448,6 +2459,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 +2528,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 +2544,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)) { @@ -2661,7 +2685,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) @@ -2871,7 +2895,8 @@ Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) char * Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { - return sv_2pv(sv,lp); + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); } char * @@ -2900,7 +2925,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (SvRV(tmpsv) != SvRV(sv))) + (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv)))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -2930,45 +2955,61 @@ Perl_sv_2bool(pTHX_ register SV *sv) =for apidoc sv_utf8_upgrade Convert the PV of an SV to its UTF8-encoded form. +Forces the SV to string form it it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. =cut */ -void +STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - char *s, *t, *e; + U8 *s, *t, *e; int hibit = 0; - if (!sv || !SvPOK(sv) || SvUTF8(sv)) - return; + if (!sv) + return 0; + + if (!SvPOK(sv)) { + STRLEN len = 0; + (void) sv_2pv(sv,&len); + if (!SvPOK(sv)) + return len; + } + + if (SvUTF8(sv)) + return SvCUR(sv); + + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } /* This function could be much more efficient if we had a FLAG in SVs * to signal if there are any hibit chars in the PV. * Given that there isn't make loop fast as possible */ - s = SvPVX(sv); - e = SvEND(sv); + s = (U8 *) SvPVX(sv); + e = (U8 *) SvEND(sv); t = s; while (t < e) { - if ((hibit = UTF8_IS_CONTINUED(*t++))) + U8 ch = *t++; + if ((hibit = !NATIVE_IS_INVARIANT(ch))) break; } - if (hibit) { STRLEN len; - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); - s = SvPVX(sv); - } + len = SvCUR(sv) + 1; /* Plus the \0 */ SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); SvCUR(sv) = len - 1; if (SvLEN(sv) != 0) Safefree(s); /* No longer using what was there before. */ SvLEN(sv) = len; /* No longer know the real size. */ - SvUTF8_on(sv); } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); + return SvCUR(sv); } /* @@ -2987,12 +3028,37 @@ 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); + U8 *s; + STRLEN len; - if (!utf8_to_bytes((U8*)c, &len)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); + s = (U8 *) SvPV(sv, len); + if (!utf8_to_bytes(s, &len)) { if (fail_ok) return FALSE; +#ifdef USE_BYTES_DOWNGRADES + else if (IN_BYTE) { + U8 *d = s; + U8 *e = (U8 *) SvEND(sv); + int first = 1; + while (s < e) { + UV ch = utf8n_to_uvchr(s,(e-s),&len,0); + if (first && ch > 255) { + if (PL_op) + Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", + PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); + first = 0; + } + *d++ = ch; + s += len; + } + *d = '\0'; + len = (d - (U8 *) SvPVX(sv)); + } +#endif else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", @@ -3003,9 +3069,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) } SvCUR(sv) = len; } - SvUTF8_off(sv); } - + SvUTF8_off(sv); return TRUE; } @@ -3013,7 +3078,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) =for apidoc sv_utf8_encode Convert the PV of an SV to UTF8-encoded, but then turn off the C -flag so that it looks like bytes again. Nothing calls this. +flag so that it looks like octets again. Used as a building block +for encode_utf8 in Encode.xs =cut */ @@ -3021,29 +3087,43 @@ flag so that it looks like bytes again. Nothing calls this. void Perl_sv_utf8_encode(pTHX_ register SV *sv) { - sv_utf8_upgrade(sv); + (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); } +/* +=for apidoc sv_utf8_decode + +Convert the octets in the PV from UTF-8 to chars. Scan for validity and then +turn of SvUTF8 if needed so that we see characters. Used as a building block +for decode_utf8 in Encode.xs + +=cut +*/ + + + bool Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOK(sv)) { - char *c; - char *e; - bool has_utf = FALSE; + U8 *c; + U8 *e; + + /* The octets may have got themselves encoded - get them back as bytes */ if (!sv_utf8_downgrade(sv, TRUE)) return FALSE; /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ - c = SvPVX(sv); - if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) + c = (U8 *) SvPVX(sv); + if (!is_utf8_string(c, SvCUR(sv)+1)) return FALSE; - e = SvEND(sv); + e = (U8 *) SvEND(sv); while (c < e) { - if (UTF8_IS_CONTINUED(*c++)) { + U8 ch = *c++; + if (!UTF8_IS_INVARIANT(ch)) { SvUTF8_on(sv); break; } @@ -3201,6 +3281,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 +3328,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 +3388,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 +3554,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 +3573,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 +3618,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); @@ -3733,8 +3826,9 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming =for apidoc sv_catpvn Concatenates the string onto the end of the string which is in the SV. The -C indicates number of bytes to copy. Handles 'get' magic, but not -'set' magic. See C. +C indicates number of bytes to copy. If the SV has the UTF8 +status set, then the bytes appended should be valid UTF8. +Handles 'get' magic, but not 'set' magic. See C. =cut */ @@ -3832,10 +3926,10 @@ Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv) =for apidoc sv_catpv Concatenates the string onto the end of the string which is in the SV. -Handles 'get' magic, but not 'set' magic. See C. +If the SV has the UTF8 status set, then the bytes appended should be +valid UTF8. Handles 'get' magic, but not 'set' magic. See C. -=cut -*/ +=cut */ void Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) @@ -3916,21 +4010,32 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#' || how == 'r') + + /* Some magic sontains a reference loop, where the sv and object refer to + each other. To prevent a avoid a reference loop that would prevent such + objects being freed, we look for such loops and if we find one we avoid + incrementing the object refcount. */ + if (!obj || obj == sv || how == '#' || how == 'r' || + (SvTYPE(obj) == SVt_PVGV && + (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || + GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || + GvFORM(obj) == (CV*)sv))) + { mg->mg_obj = obj; + } else { mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; } 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 +4177,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); @@ -4302,7 +4408,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ - djSP; + dSP; CV* destructor; SV tmpref; @@ -4637,8 +4743,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) len = 0; while (s < send) { STRLEN n; - - if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) { + /* Call utf8n_to_uvchr() to validate the sequence */ + utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); + if (n > 0) { s += n; len++; } @@ -4666,8 +4773,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) char *pv2; STRLEN cur2; I32 eq = 0; - bool pv1tmp = FALSE; - bool pv2tmp = FALSE; + char *tpv = Nullch; if (!sv1) { pv1 = ""; @@ -4685,40 +4791,34 @@ 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; + /* UTF-8ness differs */ 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; + /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */ + char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); + if (pv != pv1) + pv1 = tpv = pv; } else { - (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2); - { - IV scur2 = cur2; - if (scur2 < 0) { - Safefree(pv2); - return 0; - } - } - pv2tmp = TRUE; + /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */ + char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); + if (pv != pv2) + pv2 = tpv = pv; + } + if (is_utf8) { + /* Downgrade not possible - cannot be eq */ + return FALSE; } } if (cur1 == cur2) eq = memEQ(pv1, pv2, cur1); - if (pv1tmp) - Safefree(pv1); - if (pv2tmp) - Safefree(pv2); + if (tpv != Nullch) + Safefree(tpv); return eq; } @@ -5596,6 +5696,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); @@ -6087,18 +6193,21 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) char * Perl_sv_pvbyte(pTHX_ SV *sv) { + sv_utf8_downgrade(sv,0); return sv_pv(sv); } char * Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_downgrade(sv,0); return sv_pvn(sv,lp); } char * Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_downgrade(sv,0); return sv_pvn_force(sv,lp); } @@ -6323,6 +6432,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 +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C 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 @@ -6642,12 +6770,15 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) /* =for apidoc sv_catpvf -Processes its arguments like C and appends the formatted output -to an SV. Handles 'get' magic, but not 'set' magic. C must -typically be called after calling this function to handle 'set' magic. +Processes its arguments like C and appends the formatted +output to an SV. If the appended data contains "wide" characters +(including, but not limited to, SVs with a UTF-8 PV formatted with %s, +and characters >255 formatted with %c), the original SV might get +upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. +C must typically be called after calling this function +to handle 'set' magic. -=cut -*/ +=cut */ void Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) @@ -6704,7 +6835,7 @@ 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 +STATIC I32 S_expect_number(pTHX_ char** pattern) { I32 var = 0; @@ -6892,7 +7023,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; @@ -7012,9 +7143,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'c': uv = args ? va_arg(*args, int) : SvIVx(argsv); - if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { + if ((uv > 255 || + (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) + && !IN_BYTE) { eptr = (char*)utf8buf; - elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; + elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; is_utf = TRUE; } else { @@ -7098,7 +7231,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); + iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0); else { iv = *vecstr; ulen = 1; @@ -7178,7 +7311,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - uv = utf8_to_uv(vecstr, veclen, &ulen, 0); + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0); else { uv = *vecstr; ulen = 1; @@ -7552,8 +7685,8 @@ Perl_gp_dup(pTHX_ GP *gp) MAGIC * Perl_mg_dup(pTHX_ MAGIC *mg) { - MAGIC *mgret = (MAGIC*)NULL; - MAGIC *mgprev; + MAGIC *mgprev = (MAGIC*)NULL; + MAGIC *mgret; if (!mg) return (MAGIC*)NULL; /* look for it in the table first */ @@ -7564,10 +7697,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); - if (!mgret) - mgret = nmg; - else + if (mgprev) mgprev->mg_moremagic = nmg; + else + mgret = nmg; nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; @@ -7686,10 +7819,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) { @@ -7822,6 +8055,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); @@ -7969,7 +8214,7 @@ dup_pvcv: CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); - CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvGV(dstr) = gv_dup(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { /* XXX padlists are real, but pretend to be not */ @@ -7980,7 +8225,10 @@ dup_pvcv: } else CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + if (!CvANON(sstr) || CvCLONED(sstr)) + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + else + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; default: @@ -8034,7 +8282,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray) : Nullav); - ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; @@ -8288,6 +8536,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) TOPIV(nss,ix) = iv; break; case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv); break; @@ -8621,7 +8870,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_defgv = gv_dup(proto_perl->Idefgv); PL_argvgv = gv_dup(proto_perl->Iargvgv); PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); - PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack); /* shortcuts to regexp stuff */ PL_replgv = gv_dup(proto_perl->Ireplgv); @@ -8832,7 +9081,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 */ @@ -8896,7 +9145,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; @@ -9082,6 +9331,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