X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=251fd8ab494f30d87d013c4495bf746a2303e880;hb=64222d737f7f4bf669dcd822491f13de376b9ee5;hp=6ead8bb0f52cce2b4f2f7d7fc2038578f03ec1e0;hpb=081fc587427bbceff63d5141014aee022b3f9dd6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 6ead8bb..251fd8a 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,7 @@ /* sv.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,6 +24,24 @@ #define FCALL *f +#ifdef PERL_UTF8_CACHE_ASSERT +/* The cache element 0 is the Unicode offset; + * the cache element 1 is the byte offset of the element 0; + * the cache element 2 is the Unicode length of the substring; + * the cache element 3 is the byte length of the substring; + * The checking of the substring side would be good + * but substr() has enough code paths to make my head spin; + * if adding more checks watch out for the following tests: + * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t + * lib/utf8.t lib/Unicode/Collate/t/index.t + * --jhi + */ +#define ASSERT_UTF8_CACHE(cache) \ + STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END +#else +#define ASSERT_UTF8_CACHE(cache) NOOP +#endif + #ifdef PERL_COPY_ON_WRITE #define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv)) #define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next) @@ -3068,7 +3087,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = "REF"; else s = "SCALAR"; break; - case SVt_PVLV: s = "LVALUE"; break; + case SVt_PVLV: s = SvROK(sv) ? "REF":"LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; @@ -3079,7 +3098,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + if (HvNAME(SvSTASH(sv))) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + else + Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s); else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3669,7 +3691,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (dtype < SVt_RV) sv_upgrade(dstr, SVt_RV); else if (dtype == SVt_PVGV && - SvTYPE(SvRV(sstr)) == SVt_PVGV) { + SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -4497,6 +4519,8 @@ Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. Uses the "OOK hack". +Beware: after this function returns, C and SvPVX(sv) may no longer +refer to the same chunk of data. =cut */ @@ -4505,9 +4529,9 @@ void Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) { register STRLEN delta; - if (!ptr || !SvPOKp(sv)) return; + delta = ptr - SvPVX(sv); SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -4527,7 +4551,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) SvFLAGS(sv) |= SVf_OOK; } SvNIOK_off(sv); - delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; SvPVX(sv) += delta; @@ -5086,7 +5109,9 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) else { av = newAV(); sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); - SvREFCNT_dec(av); /* for sv_magic */ + /* av now has a refcnt of 2, which avoids it getting freed + * before us during global cleanup. The extra ref is removed + * by magic_killbackrefs() when tsv is being freed */ } if (AvFILLp(av) >= AvMAX(av)) { SV **svp = AvARRAY(av); @@ -5308,34 +5333,37 @@ Perl_sv_clear(pTHX_ register SV *sv) if (PL_defstash) { /* Still have a symbol table? */ dSP; CV* destructor; - SV tmpref; - Zero(&tmpref, 1, SV); - sv_upgrade(&tmpref, SVt_RV); - SvROK_on(&tmpref); - SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ - SvREFCNT(&tmpref) = 1; + do { stash = SvSTASH(sv); destructor = StashHANDLER(stash,DESTROY); if (destructor) { + SV* tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ ENTER; PUSHSTACKi(PERLSI_DESTROY); - SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); - PUSHs(&tmpref); + PUSHs(tmpref); PUTBACK; call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - SvREFCNT(sv)--; + + POPSTACK; SPAGAIN; LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV(tmpref) = 0; + SvROK_off(tmpref); + } + SvREFCNT_dec(tmpref); } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - del_XRV(SvANY(&tmpref)); if (SvREFCNT(sv)) { if (PL_in_clean_objs) @@ -5389,7 +5417,13 @@ Perl_sv_clear(pTHX_ register SV *sv) av_undef((AV*)sv); break; case SVt_PVLV: - SvREFCNT_dec(LvTARG(sv)); + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); goto freescalar; case SVt_PVGV: gp_free((GV*)sv); @@ -5639,8 +5673,12 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) U8 *s = (U8*)SvPV(sv, len); MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0; - if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) + if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) { ulen = mg->mg_len; +#ifdef PERL_UTF8_CACHE_ASSERT + assert(ulen == Perl_utf8_length(aTHX_ s, s + len)); +#endif + } else { ulen = Perl_utf8_length(aTHX_ s, s + len); if (!mg && !SvREADONLY(sv)) { @@ -5710,8 +5748,9 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I *mgp = mg_find(sv, PERL_MAGIC_utf8); if (*mgp && (*mgp)->mg_ptr) { *cachep = (STRLEN *) (*mgp)->mg_ptr; + ASSERT_UTF8_CACHE(*cachep); if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */ - found = TRUE; + found = TRUE; else { /* We will skip to the right spot. */ STRLEN forw = 0; STRLEN backw = 0; @@ -5783,7 +5822,24 @@ S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I } } } +#ifdef PERL_UTF8_CACHE_ASSERT + if (found) { + U8 *s = start; + I32 n = uoff; + + while (n-- && s < send) + s += UTF8SKIP(s); + + if (i == 0) { + assert(*offsetp == s - start); + assert((*cachep)[0] == (STRLEN)uoff); + assert((*cachep)[1] == *offsetp); + } + ASSERT_UTF8_CACHE(*cachep); + } +#endif } + return found; } @@ -5855,12 +5911,14 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) } *lenp = s - start; } + ASSERT_UTF8_CACHE(cache); } else { *offsetp = 0; if (lenp) *lenp = 0; } + return; } @@ -5904,13 +5962,13 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) mg = mg_find(sv, PERL_MAGIC_utf8); if (mg && mg->mg_ptr) { cache = (STRLEN *) mg->mg_ptr; - if (cache[1] == *offsetp) { + if (cache[1] == (STRLEN)*offsetp) { /* An exact match. */ *offsetp = cache[0]; return; } - else if (cache[1] < *offsetp) { + else if (cache[1] < (STRLEN)*offsetp) { /* We already know part of the way. */ len = cache[0]; s += cache[1]; @@ -5933,17 +5991,20 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) while (backw--) { p--; - while (UTF8_IS_CONTINUATION(*p)) + while (UTF8_IS_CONTINUATION(*p)) { p--; + backw--; + } ubackw++; } cache[0] -= ubackw; - + *offsetp = cache[0]; return; } } } + ASSERT_UTF8_CACHE(cache); } while (s < send) { @@ -6344,7 +6405,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) Stat_t st; if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { Off_t offset = PerlIO_tell(fp); - if (offset != (Off_t) -1) { + if (offset != (Off_t) -1 && st.st_size + append > offset) { (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); } } @@ -6369,6 +6430,8 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #else bytesread = PerlIO_read(fp, buffer, recsize); #endif + if (bytesread < 0) + bytesread = 0; SvCUR_set(sv, bytesread += append); buffer[bytesread] = '\0'; goto return_string_or_null; @@ -7761,7 +7824,10 @@ char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) { - return HvNAME(SvSTASH(sv)); + if (HvNAME(SvSTASH(sv))) + return HvNAME(SvSTASH(sv)); + else + return "__ANON__"; } else { switch (SvTYPE(sv)) { @@ -7780,7 +7846,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) return "REF"; else return "SCALAR"; - case SVt_PVLV: return "LVALUE"; + case SVt_PVLV: return SvROK(sv) ? "REF" : "LVALUE"; case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; @@ -7839,6 +7905,8 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) sv = (SV*)SvRV(sv); if (!SvOBJECT(sv)) return 0; + if (!HvNAME(SvSTASH(sv))) + return 0; return strEQ(HvNAME(SvSTASH(sv)), name); } @@ -8645,7 +8713,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vecsv = va_arg(*args, SV*); else vecsv = (evix ? evix <= svmax : svix < svmax) ? - svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef; + svargs[evix ? evix-1 : svix++] : &PL_sv_undef; dotstr = SvPVx(vecsv, dotstrlen); if (DO_UTF8(vecsv)) is_utf8 = TRUE; @@ -9306,6 +9374,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p = SvEND(sv); *p = '\0'; } + /* Use memchr() instead of strchr(), as eptr is not guaranteed */ + /* to point to a null-terminated string. */ + if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) && + (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) + Perl_warner(aTHX_ packWARN(WARN_PRINTF), + "Newline in left-justified string for %sprintf", + (PL_op->op_type == OP_PRTF) ? "" : "s"); have = esignlen + zeros + elen; need = (have > width ? have : width); @@ -9863,9 +9938,20 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) /* Special case - not normally malloced for some reason */ if (SvREADONLY(sstr) && SvFAKE(sstr)) { /* A "shared" PV - clone it as unshared string */ - SvFAKE_off(dstr); - SvREADONLY_off(dstr); - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if(SvPADTMP(sstr)) { + /* However, some of them live in the pad + and they should not have these flags + turned off */ + + SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr), + SvUVX(sstr)); + SvUVX(dstr) = SvUVX(sstr); + } else { + + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvFAKE_off(dstr); + SvREADONLY_off(dstr); + } } else { /* Some other special case - random pointer */ @@ -9989,7 +10075,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) Perl_rvpv_dup(aTHX_ dstr, sstr, param); LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); + if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dstr) = dstr; + else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */ + LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param); + else + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); LvTYPE(dstr) = LvTYPE(sstr); break; case SVt_PVGV: @@ -10044,12 +10135,21 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) IoPAGE(dstr) = IoPAGE(sstr); IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); + if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treaded differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param); + } else { + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); + } IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); IoTYPE(dstr) = IoTYPE(sstr); IoFLAGS(dstr) = IoFLAGS(sstr); @@ -10692,6 +10792,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); @@ -10723,6 +10825,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; + PL_savestack_ix = 0; + PL_savestack_max = -1; PL_retstack = 0; PL_sig_pending = 0; Zero(&PL_debug_pad, 1, struct perl_debug_pad); @@ -11176,6 +11280,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* sort() routine */ PL_sort_RealCmp = proto_perl->Isort_RealCmp; + /* Not really needed/useful since the reenrant_retint is "volatile", + * but do it for consistency's sake. */ + PL_reentrant_retint = proto_perl->Ireentrant_retint; + + /* Hooks to shared SVs and locks. */ + PL_sharehook = proto_perl->Isharehook; + PL_lockhook = proto_perl->Ilockhook; + PL_unlockhook = proto_perl->Iunlockhook; + PL_threadhook = proto_perl->Ithreadhook; + + PL_runops_std = proto_perl->Irunops_std; + PL_runops_dbg = proto_perl->Irunops_dbg; + +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; +#endif + /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; @@ -11193,6 +11314,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; + PL_hash_seed = proto_perl->Ihash_seed; PL_uudmap['M'] = 0; /* reinits on demand */ PL_bitcount = Nullch; /* reinits on demand */ @@ -11317,9 +11439,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_protect = proto_perl->Tprotect; #endif PL_errors = sv_dup_inc(proto_perl->Terrors, param); - PL_av_fetch_sv = Nullsv; - PL_hv_fetch_sv = Nullsv; - Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ + PL_hv_fetch_ent_mh = Nullhe; PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; @@ -11354,6 +11474,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regstartp = (I32*)NULL; PL_regendp = (I32*)NULL; PL_reglastparen = (U32*)NULL; + PL_reglastcloseparen = (U32*)NULL; PL_regtill = Nullch; PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0;