X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c2c1cc03d073c8d2dfb56dbfd010e8fc4d52e5e3;hb=917b24923c0362e8f2d8d1f3f612150902a8f3eb;hp=09ca49a67ef7695e8b40da24a6e9b51cf2c74058;hpb=eff180cdf66484c41f3aacf26a4fd81d2be06de0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 09ca49a..c2c1cc0 100644 --- a/sv.c +++ b/sv.c @@ -2448,7 +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); @@ -2518,9 +2520,11 @@ Perl_looks_like_number(pTHX_ SV *sv) || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { +#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 */ @@ -2532,9 +2536,11 @@ Perl_looks_like_number(pTHX_ SV *sv) || (specialradix = IS_NUMERIC_RADIX(s)) #endif ) { +#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 */ @@ -2937,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. @@ -2975,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); } /* @@ -3024,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 */ @@ -3032,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; @@ -3212,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); @@ -3252,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); @@ -3306,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 && @@ -3473,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) @@ -3492,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); @@ -3928,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: @@ -4084,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); @@ -4704,17 +4759,15 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (SvUTF8(sv1)) { char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); - if (is_utf8) - return 0; - pv1tmp = (pv != pv1); - pv1 = pv; + + if ((pv1tmp = (pv != pv1))) + pv1 = pv; } else { char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); - if (is_utf8) - return 0; - pv2tmp = (pv != pv2); - pv2 = pv; + + if ((pv2tmp = (pv != pv2))) + pv2 = pv; } } @@ -5602,8 +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)) - src = (char*)bytes_from_utf8((U8*)src, (STRLEN*)&len, &is_utf8); + 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); @@ -6331,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 @@ -6712,7 +6788,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; @@ -6900,7 +6976,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; @@ -7694,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) { @@ -7830,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); @@ -8840,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 */ @@ -8904,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; @@ -9090,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