X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c2c1cc03d073c8d2dfb56dbfd010e8fc4d52e5e3;hb=917b24923c0362e8f2d8d1f3f612150902a8f3eb;hp=21596fa8ddf55786c82592fb3d28badff715db62;hpb=3332b3c19f862e846dac4c8041a3c82ef7dd289e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 21596fa..c2c1cc0 100644 --- a/sv.c +++ b/sv.c @@ -1567,7 +1567,7 @@ STATIC int S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) { NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */ UV nv_as_uv = U_V(nv); /* these are not in simple variables. */ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype)); if (nv_as_uv <= (UV)IV_MAX) { (void)SvIOKp_on(sv); (void)SvNOKp_on(sv); @@ -1625,7 +1625,7 @@ S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) { #else /* We've just lost integer precision, nothing we could do. */ SvUVX(sv) = nv_as_uv; - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype)); /* UV and NV slots equally valid only if we have casting symmetry. */ if (numtype & IS_NUMBER_NOT_INT) { SvIsUV_on(sv); @@ -1648,7 +1648,7 @@ S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) { STATIC int S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype) { - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -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)) { @@ -2930,18 +2943,27 @@ 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; int hibit = 0; - if (!sv || !SvPOK(sv) || SvUTF8(sv)) - return; + if (!sv) + return 0; + + if (!SvPOK(sv)) + (void) SvPV_nolen(sv); + + if (SvUTF8(sv)) + return SvCUR(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. @@ -2957,6 +2979,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); @@ -2967,8 +2990,10 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv) 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,10 +3012,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 { @@ -3013,7 +3041,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,17 +3050,30 @@ 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; + + /* The octets may have got themselves encoded - get them back as bytes */ if (!sv_utf8_downgrade(sv, TRUE)) return FALSE; @@ -3201,6 +3243,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 +3290,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 +3350,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 && @@ -3440,7 +3494,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } - if ((sflags & SVf_UTF8) && !IN_BYTE) + if (sflags & SVf_UTF8) SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { @@ -3462,8 +3516,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 +3535,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 +3580,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); @@ -3916,21 +3971,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 +4138,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 +4752,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 +5655,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 +6388,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 @@ -6704,6 +6788,21 @@ 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); } +STATIC I32 +S_expect_number(pTHX_ char** pattern) +{ + I32 var = 0; + switch (**pattern) { + case '1': case '2': case '3': + case '4': case '5': case '6': + case '7': case '8': case '9': + while (isDIGIT(**pattern)) + var = var * 10 + (*(*pattern)++ - '0'); + } + return var; +} +#define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern)) + /* =for apidoc sv_vcatpvfn @@ -6764,7 +6863,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool alt = FALSE; bool left = FALSE; bool vectorize = FALSE; - bool utf = FALSE; + bool vectorarg = FALSE; + bool vec_utf = FALSE; char fill = ' '; char plus = 0; char intsize = 0; @@ -6801,10 +6901,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN gap; char *dotstr = "."; STRLEN dotstrlen = 1; - I32 epix = 0; /* explicit parameter index */ + I32 efix = 0; /* explicit format parameter index */ I32 ewix = 0; /* explicit width index */ + I32 epix = 0; /* explicit precision index */ + I32 evix = 0; /* explicit vector index */ bool asterisk = FALSE; + /* echo everything up to the next format specification */ for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { sv_catpvn(sv, p, q - p); @@ -6813,6 +6916,25 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (q++ >= patend) break; +/* + We allow format specification elements in this order: + \d+\$ explicit format parameter index + [-+ 0#]+ flags + \*?(\d+\$)?v vector with optional (optionally specified) arg + \d+|\*(\d+\$)? width using optional (optionally specified) arg + \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg + [hlqLV] size + [%bcdefginopsux_DFOUX] format (mandatory) +*/ + if (EXPECT_NUMBER(q, width)) { + if (*q == '$') { + ++q; + efix = width; + } else { + goto gotwidth; + } + } + /* FLAGS */ while (*q) { @@ -6836,63 +6958,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; continue; - case '*': /* printf("%*vX",":",$ipv6addr) */ - if (q[1] != 'v') - break; - q++; - if (args) - vecsv = va_arg(*args, SV*); - else if (svix < svmax) - vecsv = svargs[svix++]; - else - continue; - dotstr = SvPVx(vecsv,dotstrlen); - if (DO_UTF8(vecsv)) - is_utf = TRUE; - /* FALL THROUGH */ - - case 'v': - vectorize = TRUE; - q++; - continue; - default: break; } break; } - /* WIDTH */ - - scanwidth: - + tryasterisk: if (*q == '*') { - if (asterisk) - goto unknown; + q++; + if (EXPECT_NUMBER(q, ewix)) + if (*q++ != '$') + goto unknown; asterisk = TRUE; + } + if (*q == 'v') { q++; + if (vectorize) + goto unknown; + if ((vectorarg = asterisk)) { + evix = ewix; + ewix = 0; + asterisk = FALSE; + } + vectorize = TRUE; + goto tryasterisk; } - switch (*q) { - case '1': case '2': case '3': - case '4': case '5': case '6': - case '7': case '8': case '9': - width = 0; - while (isDIGIT(*q)) - width = width * 10 + (*q++ - '0'); - if (*q == '$') { - if (asterisk && ewix == 0) { - ewix = width; - width = 0; - q++; - goto scanwidth; - } else if (epix == 0) { - epix = width; - width = 0; - q++; - goto scanwidth; - } else - goto unknown; + if (!asterisk) + EXPECT_NUMBER(q, width); + + if (vectorize) { + if (vectorarg) { + if (args) + vecsv = va_arg(*args, SV*); + else + vecsv = (evix ? evix <= svmax : svix < svmax) ? + svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef; + dotstr = SvPVx(vecsv, dotstrlen); + if (DO_UTF8(vecsv)) + is_utf = TRUE; + } + if (args) { + vecsv = va_arg(*args, SV*); + vecstr = (U8*)SvPVx(vecsv,veclen); + vec_utf = DO_UTF8(vecsv); + } + else if (efix ? efix <= svmax : svix < svmax) { + vecsv = svargs[efix ? efix-1 : svix++]; + vecstr = (U8*)SvPVx(vecsv,veclen); + vec_utf = DO_UTF8(vecsv); + } + else { + vecstr = (U8*)""; + veclen = 0; } } @@ -6905,19 +7024,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV left |= (i < 0); width = (i < 0) ? -i : i; } + gotwidth: /* PRECISION */ if (*q == '.') { q++; if (*q == '*') { + q++; + if (EXPECT_NUMBER(q, epix) && *q++ != '$') + goto unknown; if (args) i = va_arg(*args, int); else i = (ewix ? ewix <= svmax : svix < svmax) ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0; precis = (i < 0) ? 0 : i; - q++; } else { precis = 0; @@ -6927,23 +7049,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV has_precis = TRUE; } - if (vectorize) { - if (args) { - vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPVx(vecsv,veclen); - utf = DO_UTF8(vecsv); - } - else if (epix ? epix <= svmax : svix < svmax) { - vecsv = svargs[epix ? epix-1 : svix++]; - vecstr = (U8*)SvPVx(vecsv,veclen); - utf = DO_UTF8(vecsv); - } - else { - vecstr = (U8*)""; - veclen = 0; - } - } - /* SIZE */ switch (*q) { @@ -6975,21 +7080,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* CONVERSION */ + if (*q == '%') { + eptr = q++; + elen = 1; + goto string; + } + + if (!args) + argsv = (efix ? efix <= svmax : svix < svmax) ? + svargs[efix ? efix-1 : svix++] : &PL_sv_undef; + switch (c = *q++) { /* STRINGS */ - case '%': - eptr = q - 1; - elen = 1; - goto string; - case 'c': - if (args) - uv = va_arg(*args, int); - else - uv = (epix ? epix <= svmax : svix < svmax) ? - SvIVx(svargs[epix ? epix-1 : svix++]) : 0; + uv = args ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { eptr = (char*)utf8buf; elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; @@ -7018,8 +7124,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV elen = sizeof nullstr - 1; } } - else if (epix ? epix <= svmax : svix < svmax) { - argsv = svargs[epix ? epix-1 : svix++]; + else { eptr = SvPVx(argsv, elen); if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { @@ -7043,7 +7148,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV */ if (!args) goto unknown; - argsv = va_arg(*args,SV*); + argsv = va_arg(*args, SV*); eptr = SvPVx(argsv, elen); if (DO_UTF8(argsv)) is_utf = TRUE; @@ -7059,11 +7164,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'p': if (alt) goto unknown; - if (args) - uv = PTR2UV(va_arg(*args, void*)); - else - uv = (epix ? epix <= svmax : svix < svmax) ? - PTR2UV(svargs[epix ? epix-1 : svix++]) : 0; + uv = PTR2UV(args ? va_arg(*args, void*) : argsv); base = 16; goto integer; @@ -7078,11 +7179,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'i': if (vectorize) { STRLEN ulen; - if (!veclen) { - vectorize = FALSE; - break; - } - if (utf) + if (!veclen) + continue; + if (vec_utf) iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); else { iv = *vecstr; @@ -7103,8 +7202,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - iv = (epix ? epix <= svmax : svix < svmax) ? - SvIVx(svargs[epix ? epix-1 : svix++]) : 0; + iv = SvIVx(argsv); switch (intsize) { case 'h': iv = (short)iv; break; default: break; @@ -7161,11 +7259,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (vectorize) { STRLEN ulen; vector: - if (!veclen) { - vectorize = FALSE; - break; - } - if (utf) + if (!veclen) + continue; + if (vec_utf) uv = utf8_to_uv(vecstr, veclen, &ulen, 0); else { uv = *vecstr; @@ -7186,8 +7282,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - uv = (epix ? epix <= svmax : svix < svmax) ? - SvUVx(svargs[epix ? epix-1 : svix++]) : 0; + uv = SvUVx(argsv); switch (intsize) { case 'h': uv = (unsigned short)uv; break; default: break; @@ -7276,11 +7371,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* This is evil, but floating point is even more evil */ vectorize = FALSE; - if (args) - nv = va_arg(*args, NV); - else - nv = (epix ? epix <= svmax : svix < svmax) ? - SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0; + nv = args ? va_arg(*args, NV) : SvNVx(argsv); need = 0; if (c != 'e' && c != 'E') { @@ -7360,8 +7451,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif } } - else if (epix ? epix <= svmax : svix < svmax) - sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i); + else + sv_setuv_mg(argsv, (UV)i); continue; /* not "break" */ /* UNKNOWN */ @@ -7396,7 +7487,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); @@ -7426,7 +7517,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) { @@ -7435,7 +7526,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 @@ -7679,10 +7770,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) { @@ -7815,6 +8006,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); @@ -8440,6 +8643,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; + PL_sig_pending = 0; # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -8466,6 +8670,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; + PL_sig_pending = 0; # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -8823,7 +9028,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 */ @@ -8865,12 +9070,18 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_uudmap['M'] = 0; /* reinits on demand */ PL_bitcount = Nullch; /* reinits on demand */ + if (proto_perl->Ipsig_pend) { + Newz(0, PL_psig_pend, SIG_SIZE, int); + } + else { + PL_psig_pend = (int*)NULL; + } + if (proto_perl->Ipsig_ptr) { - int sig_num[] = { SIG_NUM }; - Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); - Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); - for (i = 1; PL_sig_name[i]; i++) { - PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); + Newz(0, PL_psig_ptr, SIG_SIZE, SV*); + Newz(0, PL_psig_name, SIG_SIZE, SV*); + for (i = 1; i < SIG_SIZE; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); } } @@ -8881,7 +9092,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; @@ -9067,6 +9278,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