X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=45248db00b84df58d30b406626ebcea8c6e26d3f;hb=edb47d5e45750eb7ab61981e15a22f43672ff4f4;hp=cf9a6ffe80038d2ff69e011931f49617103a6638;hpb=6dfeccca7d595e9c94766acdd058cec56fa67315;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index cf9a6ff..45248db 100644 --- a/sv.c +++ b/sv.c @@ -353,10 +353,9 @@ S_del_sv(pTHX_ SV *p) } } if (!ok) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-arena SV: 0x%"UVxf - pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free non-arena SV: 0x%"UVxf + pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); return; } } @@ -1457,14 +1456,14 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) (unsigned long)new_type); } - if (old_type_details->arena) { - /* If there was an old body, then we need to free it. - Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ + if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */ #ifdef PURIFY my_safefree(old_body); #else + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); del_body((void*)((char*)old_body + old_type_details->offset), &PL_body_roots[old_type]); #endif @@ -3251,7 +3250,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST return SvCUR(sv); } - if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */ + if (SvCUR(sv) == 0) { + if (extra) SvGROW(sv, extra); + } else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag @@ -3892,7 +3893,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } /* Fall through */ #endif - case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3915,6 +3915,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } break; + case SVt_REGEXP: + if (dtype < SVt_REGEXP) + sv_upgrade(dstr, SVt_REGEXP); + break; + /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: @@ -4005,9 +4010,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Undefined value assigned to typeglob"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Undefined value assigned to typeglob"); } else { GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); @@ -4018,6 +4022,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } } } + else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { + reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); + } else if (sflags & SVp_POK) { bool isSwipe = 0; @@ -5239,8 +5246,7 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) if (!SvROK(sv)) Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); return sv; } tsv = SvRV(sv); @@ -5918,10 +5924,9 @@ Perl_sv_free2(pTHX_ SV *const sv) #ifdef DEBUGGING if (SvTEMP(sv)) { - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Attempt to free temp prematurely: SV 0x%"UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); return; } #endif @@ -6290,7 +6295,13 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b } assert(cache); - if (PL_utf8cache < 0) { + if (PL_utf8cache < 0 && SvPOKp(sv)) { + /* SvPOKp() because it's possible that sv has string overloading, and + therefore is a reference, hence SvPVX() is actually a pointer. + This cures the (very real) symptoms of RT 69422, but I'm not actually + sure whether we should even be caching the results of UTF-8 + operations on overloading, given that nothing stops overloading + returning a different value every time it's called. */ const U8 *start = (const U8 *) SvPVX_const(sv); const STRLEN realutf8 = utf8_length(start, start + byte); @@ -7278,10 +7289,10 @@ Perl_sv_inc(pTHX_ register SV *const sv) if (flags & SVp_NOK) { const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && - was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { - Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when incrementing %" NVff " by 1", - was); + was >= NV_OVERFLOWS_INTEGERS_AT) { + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); } (void)SvNOK_only(sv); SvNV_set(sv, was + 1.0); @@ -7444,10 +7455,10 @@ Perl_sv_dec(pTHX_ register SV *const sv) { const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && - was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { - Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when decrementing %" NVff " by 1", - was); + was <= -NV_OVERFLOWS_INTEGERS_AT) { + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); } (void)SvNOK_only(sv); SvNV_set(sv, was - 1.0); @@ -7498,6 +7509,16 @@ Perl_sv_dec(pTHX_ register SV *const sv) sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ } +/* this define is used to eliminate a chunk of duplicated but shared logic + * it has the suffix __SV_C to signal that it isnt API, and isnt meant to be + * used anywhere but here - yves + */ +#define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ + STMT_START { \ + EXTEND_MORTAL(1); \ + PL_tmps_stack[++PL_tmps_ix] = (AnSv); \ + } STMT_END + /* =for apidoc sv_mortalcopy @@ -7522,8 +7543,7 @@ Perl_sv_mortalcopy(pTHX_ SV *const oldstr) new_SV(sv); sv_setsv(sv,oldstr); - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; + PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); return sv; } @@ -7547,8 +7567,7 @@ Perl_sv_newmortal(pTHX) new_SV(sv); SvFLAGS(sv) = SVs_TEMP; - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; + PUSH_EXTEND_MORTAL__SV_C(sv); return sv; } @@ -7582,11 +7601,19 @@ Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); new_SV(sv); sv_setpvn(sv,s,len); + + /* This code used to a sv_2mortal(), however we now unroll the call to sv_2mortal() + * and do what it does outselves here. + * Since we have asserted that flags can only have the SVf_UTF8 and/or SVs_TEMP flags + * set above we can use it to enable the sv flags directly (bypassing SvTEMP_on), which + * in turn means we dont need to mask out the SVf_UTF8 flag below, which means that we + * eleminate quite a few steps than it looks - Yves (explaining patch by gfx) + */ + SvFLAGS(sv) |= flags; if(flags & SVs_TEMP){ - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; + PUSH_EXTEND_MORTAL__SV_C(sv); } return sv; @@ -7612,8 +7639,7 @@ Perl_sv_2mortal(pTHX_ register SV *const sv) return NULL; if (SvREADONLY(sv) && SvIMMORTAL(sv)) return sv; - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = sv; + PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); return sv; } @@ -7977,8 +8003,7 @@ Perl_newSVsv(pTHX_ register SV *const old) if (!old) return NULL; if (SvTYPE(old) == SVTYPEMASK) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); return NULL; } new_SV(sv); @@ -8145,7 +8170,7 @@ Perl_sv_2io(pTHX_ SV *const sv) Using various gambits, try to get a CV from an SV; in addition, try if possible to set C<*st> and C<*gvp> to the stash and GV associated with it. -The flags in C are passed to sv_fetchsv. +The flags in C are passed to gv_fetchsv. =cut */ @@ -9423,9 +9448,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, goto string; } else if (n) { - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "internal %%p might conflict with future printf extensions"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "internal %%p might conflict with future printf extensions"); } } q = r; @@ -11761,6 +11785,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; @@ -11799,6 +11824,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; @@ -12153,7 +12179,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* utf8 character classes */ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); - PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param); PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); @@ -12241,8 +12266,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tmps_max = proto_perl->Itmps_max; PL_tmps_floor = proto_perl->Itmps_floor; Newx(PL_tmps_stack, PL_tmps_max, SV*); - sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix, - param); + sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, + PL_tmps_ix+1, param); /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; @@ -12261,6 +12286,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); +#ifdef DEBUGGING + Newxz(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); +#endif /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); @@ -12294,8 +12323,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, proto_perl->Itmps_stack[i])); if (nsv && !SvREFCNT(nsv)) { - EXTEND_MORTAL(1); - PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); + PUSH_EXTEND_MORTAL__SV_C(SvREFCNT_inc_simple(nsv)); } } }