X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=a59af0d02e3b897ed07db4cc32142ebb25e8aa58;hb=b68c599a1231c4d11ec0b0a667ce0c407c357eab;hp=38d7da70615b5baf28df9acc17375e54e0308534;hpb=878090d5582120ef9336936d4fc06895b4fd242a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 38d7da7..a59af0d 100644 --- a/sv.c +++ b/sv.c @@ -246,8 +246,13 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) ((PL_copline == NOLINE) ? - (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); + sv->sv_debug_line = (U16) (PL_parser + ? PL_parser->copline == NOLINE + ? PL_curcop + ? CopLINE(PL_curcop) + : 0 + : PL_parser->copline + : 0); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; @@ -349,7 +354,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif - /* Must always set typemask because it's awlays checked in on cleanup + /* Must always set typemask because it's always checked in on cleanup when the arenas are walked looking for objects. */ SvFLAGS(sv) = SVTYPEMASK; sv++; @@ -462,7 +467,8 @@ do_clean_named_objs(pTHX_ SV *sv) SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || - (GvIO(sv) && SvOBJECT(GvIO(sv))) || + /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ + (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); @@ -502,10 +508,6 @@ do_clean_all(pTHX_ SV *sv) dVAR; DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; - if (PL_comppad == (AV*)sv) { - PL_comppad = NULL; - PL_curpad = NULL; - } SvREFCNT_dec(sv); } @@ -542,7 +544,8 @@ Perl_sv_clean_all(pTHX) memory in the last arena-set (1/2 on average). In trade, we get back the 1st slot in each arena (ie 1.7% of a CV-arena, less for smaller types). The recovery of the wasted space allows use of - small arenas for large, rare body types, + small arenas for large, rare body types, by changing array* fields + in body_details_by_type[] below. */ struct arena_desc { char *arena; /* the raw storage, allocated aligned */ @@ -553,7 +556,7 @@ struct arena_desc { struct arena_set; /* Get the maximum number of elements in set[] such that struct arena_set - will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and + will fit within PERL_ARENA_SIZE, which is probably just under 4K, and therefore likely to be 1 aligned memory page. */ #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ @@ -690,8 +693,8 @@ Perl_get_arena(pTHX_ size_t arena_size, U32 misc) Newx(adesc->arena, arena_size, char); adesc->size = arena_size; adesc->misc = misc; - DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %d\n", - curr, (void*)adesc->arena, arena_size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", + curr, (void*)adesc->arena, (UV)arena_size)); return adesc->arena; } @@ -784,16 +787,16 @@ are used for this, except for arena_size. For the sv-types that have no bodies, arenas are not used, so those PL_body_roots[sv_type] are unused, and can be overloaded. In something of a special case, SVt_NULL is borrowed for HE arenas; -PL_body_roots[SVt_NULL] is filled by S_more_he, but the +PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the bodies_by_type[SVt_NULL] slot is not used, as the table is not -available in hv.c, +available in hv.c. -PTEs also use arenas, but are never seen in Perl_sv_upgrade. -Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so -they can just use the same allocation semantics. At first, PTEs were -also overloaded to a non-body sv-type, but this yielded hard-to-find -malloc bugs, so was simplified by claiming a new slot. This choice -has no consequence at this time. +PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, +they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can +just use the same allocation semantics. At first, PTEs were also +overloaded to a non-body sv-type, but this yielded hard-to-find malloc +bugs, so was simplified by claiming a new slot. This choice has no +consequence at this time. */ @@ -873,7 +876,7 @@ static const struct body_details bodies_by_type[] = { FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, /* The bind placeholder pretends to be an RV for now. - Also it's marked as "can't upgrade" top stop anyone using it before it's + Also it's marked as "can't upgrade" to stop anyone using it before it's implemented. */ { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, @@ -891,9 +894,6 @@ static const struct body_details bodies_by_type[] = { { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, - /* RVs are in the head now. */ - { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 }, - /* 8 bytes on most ILP32 with IEEE doubles */ { sizeof(xpv_allocated), copy_length(XPV, xpv_len) @@ -915,7 +915,14 @@ static const struct body_details bodies_by_type[] = { /* 28 */ { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - + + /* something big */ + { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated), + + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur), + SVt_REGEXP, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(struct regexp_allocated)) + }, + /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -928,13 +935,13 @@ static const struct body_details bodies_by_type[] = { copy_length(XPVAV, xmg_stash) - relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), + relative_STRUCT_OFFSET(xpvav_allocated, XPVAV, xav_fill), - SVt_PVAV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) }, + SVt_PVAV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvav_allocated)) }, { sizeof(xpvhv_allocated), copy_length(XPVHV, xmg_stash) - relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), + relative_STRUCT_OFFSET(xpvhv_allocated, XPVHV, xhv_fill), - SVt_PVHV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) }, + SVt_PVHV, TRUE, NONV, HASARENA, FIT_ARENA(0, sizeof(xpvhv_allocated)) }, /* 56 */ { sizeof(xpvcv_allocated), sizeof(xpvcv_allocated), @@ -1092,6 +1099,9 @@ S_new_body(pTHX_ svtype sv_type) #endif +static const struct body_details fake_rv = + { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; + /* =for apidoc sv_upgrade @@ -1110,8 +1120,9 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) void* new_body; const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; - const struct body_details *const old_type_details + const struct body_details *old_type_details = bodies_by_type + old_type; + SV *referant = NULL; if (new_type != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -1120,11 +1131,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) if (old_type == new_type) return; - if (old_type > new_type) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)old_type, (int)new_type); - - old_body = SvANY(sv); /* Copying structures onto other structures that have been neatly zeroed @@ -1169,9 +1175,16 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) case SVt_NULL: break; case SVt_IV: - if (new_type < SVt_PVIV) { - new_type = (new_type == SVt_NV) - ? SVt_PVNV : SVt_PVIV; + if (SvROK(sv)) { + referant = SvRV(sv); + old_type_details = &fake_rv; + if (new_type == SVt_NV) + new_type = SVt_PVNV; + } else { + if (new_type < SVt_PVIV) { + new_type = (new_type == SVt_NV) + ? SVt_PVNV : SVt_PVIV; + } } break; case SVt_NV: @@ -1179,8 +1192,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) new_type = SVt_PVNV; } break; - case SVt_RV: - break; case SVt_PV: assert(new_type > SVt_PV); assert(SVt_IV < SVt_PV); @@ -1205,6 +1216,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, sv_reftype(sv, 0), (UV) old_type, (UV) new_type); } + + if (old_type > new_type) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); + new_type_details = bodies_by_type + new_type; SvFLAGS(sv) &= ~SVTYPEMASK; @@ -1224,11 +1240,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) SvANY(sv) = new_XNV(); SvNV_set(sv, 0); return; - case SVt_RV: - assert(old_type == SVt_NULL); - SvANY(sv) = &sv->sv_u.svu_rv; - SvRV_set(sv, 0); - return; case SVt_PVHV: case SVt_PVAV: assert(new_type_details->body_size); @@ -1250,13 +1261,36 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) AvMAX(sv) = -1; AvFILLp(sv) = -1; AvREAL_only(sv); + if (old_type_details->body_size) { + AvALLOC(sv) = 0; + } else { + /* It will have been zeroed when the new body was allocated. + Lets not write to it, in case it confuses a write-back + cache. */ + } + } else { + assert(!SvOK(sv)); + SvOK_off(sv); +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(sv); /* key-sharing on by default */ +#endif + HvMAX(sv) = 7; /* (start with 8 buckets) */ + if (old_type_details->body_size) { + HvFILL(sv) = 0; + } else { + /* It will have been zeroed when the new body was allocated. + Lets not write to it, in case it confuses a write-back + cache. */ + } } /* SVt_NULL isn't the only thing upgraded to AV or HV. The target created by newSVrv also is, and it can have magic. However, it never has SvPVX set. */ - if (old_type >= SVt_RV) { + if (old_type == SVt_IV) { + assert(!SvROK(sv)); + } else if (old_type >= SVt_PV) { assert(SvPVX_const(sv) == 0); } @@ -1279,6 +1313,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: + case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1320,14 +1355,18 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) * NV slot, but the new one does, then we need to initialise the * freshly created NV slot with whatever the correct bit pattern is * for 0.0 */ - if (old_type_details->zero_nv && !new_type_details->zero_nv) + if (old_type_details->zero_nv && !new_type_details->zero_nv + && !isGV_with_GP(sv)) SvNV_set(sv, 0); #endif if (new_type == SVt_PVIO) IoPAGE_LEN(sv) = 60; - if (old_type < SVt_RV) - SvPV_set(sv, NULL); + if (old_type < SVt_PV) { + /* referant will be NULL unless the old type was SVt_IV emulating + SVt_RV */ + sv->sv_u.svu_rv = referant; + } break; default: Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", @@ -1360,17 +1399,18 @@ wrapper instead. int Perl_sv_backoff(pTHX_ register SV *sv) { + STRLEN delta; + const char * const s = SvPVX_const(sv); PERL_UNUSED_CONTEXT; assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); assert(SvTYPE(sv) != SVt_PVAV); - if (SvIVX(sv)) { - const char * const s = SvPVX_const(sv); - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } + + SvOOK_offset(sv, delta); + + SvLEN_set(sv, SvLEN(sv) + delta); + SvPV_set(sv, SvPVX(sv) - delta); + Move(s, SvPVX(sv), SvCUR(sv)+1, char); SvFLAGS(sv) &= ~SVf_OOK; return 0; } @@ -1460,12 +1500,9 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; case SVt_NV: - sv_upgrade(sv, SVt_PVNV); + sv_upgrade(sv, SVt_IV); break; - case SVt_RV: case SVt_PV: sv_upgrade(sv, SVt_PVIV); break; @@ -1563,7 +1600,6 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_IV: sv_upgrade(sv, SVt_NV); break; - case SVt_RV: case SVt_PV: case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); @@ -1612,7 +1648,7 @@ S_not_a_number(pTHX_ SV *sv) const char *pv; if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpvs("")); + dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; @@ -1826,10 +1862,13 @@ S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ STATIC int -S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) +S_sv_2iuv_non_preserve(pTHX_ register SV *sv +# ifdef DEBUGGING + , I32 numtype +# endif + ) { dVAR; - PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); @@ -1910,7 +1949,11 @@ S_sv_2iuv_common(pTHX_ SV *sv) { we're outside the range of NV integer precision */ #endif ) { - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + if (SvNOK(sv)) + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + else { + /* scalar has trailing garbage, eg "42a" */ + } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), @@ -1949,6 +1992,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif + && SvNOK(sv) ) SvIOK_on(sv); SvIsUV_on(sv); @@ -2102,10 +2146,20 @@ S_sv_2iuv_common(pTHX_ SV *sv) { 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ +# ifdef DEBUGGING sv_2iuv_non_preserve (sv, numtype); +# else + sv_2iuv_non_preserve (sv); +# endif } } #endif /* NV_PRESERVES_UV */ + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvIOKp_on() rather than SvIOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); } } else { @@ -2374,11 +2428,15 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvIOKp(sv)) { SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV - SvNOK_on(sv); + if (SvIOK(sv)) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else /* Only set the public NV OK flag if this NV preserves the IV */ /* Check it's not 0xFFFFFFFFFFFFFFFF */ - if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + if (SvIOK(sv) && + SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) : (SvIVX(sv) == I_V(SvNVX(sv)))) SvNOK_on(sv); else @@ -2397,7 +2455,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else SvNV_set(sv, Atof(SvPVX_const(sv))); - SvNOK_on(sv); + if (numtype) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else SvNV_set(sv, Atof(SvPVX_const(sv))); /* Only set the public NV OK flag if this NV preserves the value in @@ -2464,6 +2525,12 @@ Perl_sv_2nv(pTHX_ register SV *sv) } } } + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvNOKp_on() rather than SvNOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); #endif /* NV_PRESERVES_UV */ } else { @@ -2498,6 +2565,29 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } +/* +=for apidoc sv_2num + +Return an SV with the numeric value of the source SV, doing any necessary +reference or overload conversion. You must use the C macro to +access this function. + +=cut +*/ + +SV * +Perl_sv_2num(pTHX_ register SV *sv) +{ + if (!SvROK(sv)) + return sv; + if (SvAMAGIC(sv)) { + SV * const tmpsv = AMG_CALLun(sv,numer); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return sv_2num(tmpsv); + } + return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); +} + /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. @@ -2637,28 +2727,31 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) STRLEN len; char *retval; char *buffer; - MAGIC *mg; const SV *const referent = (SV*)SvRV(sv); if (!referent) { len = 7; retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_PVMG - && ((SvFLAGS(referent) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) - == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(referent, PERL_MAGIC_qr))) - { - char *str = NULL; - I32 haseval = 0; - U32 flags = 0; - (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); - if (flags & 1) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - PL_reginterp_cnt += haseval; - return str; + } else if (SvTYPE(referent) == SVt_REGEXP) { + const REGEXP * const re = (REGEXP *)referent; + I32 seen_evals = 0; + + assert(re); + + /* If the regex is UTF-8 we want the containing scalar to + have an UTF-8 flag too */ + if (RX_UTF8(re)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + + if ((seen_evals = RX_SEEN_EVALS(re))) + PL_reginterp_cnt += seen_evals; + + if (lp) + *lp = RX_WRAPLEN(re); + + return RX_WRAPPED(re); } else { const char *const typestr = sv_reftype(referent, 0); const STRLEN typelen = strlen(typestr); @@ -2724,10 +2817,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); return (char *)""; } } @@ -2737,15 +2832,16 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; + STRLEN len; if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); + len = ebuf - ptr; /* inlined from sv_setpvn */ - SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); - Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); + s = SvGROW_mutable(sv, len + 1); + Move(ptr, s, len, char); + s += len; *s = '\0'; } else if (SvNOKp(sv)) { @@ -2765,8 +2861,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } errno = olderrno; #ifdef FIXNEGATIVEZERO - if (*s == '-' && s[1] == '0' && !s[2]) - my_strlcpy(s, "0", SvLEN(s)); + if (*s == '-' && s[1] == '0' && !s[2]) { + s[0] = '0'; + s[1] = 0; + } #endif while (*s) s++; #ifdef hcx @@ -2778,10 +2876,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) if (isGV_with_GP(sv)) return glob_2pv((GV *)sv, lp); - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); @@ -2809,7 +2909,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) Copies a stringified representation of the source SV into the destination SV. Automatically performs any necessary mg_get and coercion of numeric values into strings. Guaranteed to preserve -UTF-8 flag even from overloaded objects. Similar in nature to +UTF8 flag even from overloaded objects. Similar in nature to sv_2pv[_flags] but operates directly on an SV instead of just the string. Mostly uses sv_2pv_flags to do its work, except when that would lose the UTF-8'ness of the PV. @@ -3148,6 +3248,8 @@ copy-ish functions and macros use this underneath. static void S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) { + I32 mro_changes = 0; /* 1 = method, 2 = isa */ + if (dtype != SVt_PVGV) { const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); @@ -3177,6 +3279,28 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } #endif + if(GvGP((GV*)sstr)) { + /* If source has method cache entry, clear it */ + if(GvCVGEN(sstr)) { + SvREFCNT_dec(GvCV(sstr)); + GvCV(sstr) = NULL; + GvCVGEN(sstr) = 0; + } + /* If source has a real method, then a method is + going to change */ + else if(GvCV((GV*)sstr)) { + mro_changes = 1; + } + } + + /* If dest already had a real method, that's a change as well */ + if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { + mro_changes = 1; + } + + if(strEQ(GvNAME((GV*)dstr),"ISA")) + mro_changes = 2; + gp_free((GV*)dstr); isGV_with_GP_off(dstr); (void)SvOK_off(dstr); @@ -3191,6 +3315,8 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) GvIMPORTED_on(dstr); } GvMULTI_on(dstr); + if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr)); + else if(mro_changes) mro_method_changed_in(GvSTASH(dstr)); return; } @@ -3240,18 +3366,18 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { common: if (intro) { if (stype == SVt_PVCV) { - if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) { + /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/ + if (GvCVGEN(dstr)) { SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = NULL; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - PL_sub_generation++; } } SAVEGENERICSV(*location); } else dref = *location; - if (stype == SVt_PVCV && *location != sref) { + if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { CV* const cv = (CV*)*location; if (cv) { if (!GvCVGEN((GV*)dstr) && @@ -3290,7 +3416,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - PL_sub_generation++; + if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ } *location = sref; if (import_flag && !(GvFLAGS(dstr) & import_flag) @@ -3355,7 +3481,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_upgrade(dstr, SVt_IV); break; case SVt_NV: - case SVt_RV: case SVt_PV: sv_upgrade(dstr, SVt_PVIV); break; @@ -3373,7 +3498,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) assert(!SvTAINTED(sstr)); return; } - goto undef_sstr; + if (!SvROK(sstr)) + goto undef_sstr; + if (dtype < SVt_PV && dtype != SVt_IV) + sv_upgrade(dstr, SVt_IV); + break; case SVt_NV: if (SvNOK(sstr)) { @@ -3382,7 +3511,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_IV: sv_upgrade(dstr, SVt_NV); break; - case SVt_RV: case SVt_PV: case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); @@ -3401,10 +3529,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } goto undef_sstr; - case SVt_RV: - if (dtype < SVt_RV) - sv_upgrade(dstr, SVt_RV); - break; case SVt_PVFM: #ifdef PERL_OLD_COPY_ON_WRITE if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { @@ -3414,6 +3538,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } /* Fall through */ #endif + case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3506,7 +3631,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dtype >= SVt_PV) { - if (dtype == SVt_PVGV) { + if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { glob_assign_ref(dstr, sstr); return; } @@ -3593,9 +3718,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* and won't be needed again, potentially */ !(PL_op && PL_op->op_type == OP_AASSIGN)) #ifdef PERL_OLD_COPY_ON_WRITE - && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV) + && ((flags & SV_COW_SHARED_HASH_KEYS) + ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS + && SvTYPE(sstr) >= SVt_PVIV)) + : 1) #endif ) { /* Failed the swipe test, and it's not a shared hash key either. @@ -3685,7 +3812,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -3975,7 +4101,7 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) SvCUR_set(sv, len); SvLEN_set(sv, allocate); if (!(flags & SV_HAS_TRAILING_NUL)) { - *SvEND(sv) = '\0'; + ptr[len] = '\0'; } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); @@ -4124,13 +4250,22 @@ refer to the same chunk of data. void Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) { - register STRLEN delta; + STRLEN delta; + STRLEN old_delta; + U8 *p; +#ifdef DEBUGGING + const U8 *real_start; +#endif + if (!ptr || !SvPOKp(sv)) return; delta = ptr - SvPVX_const(sv); + if (!delta) { + /* Nothing to do. */ + return; + } + assert(ptr > SvPVX_const(sv)); SV_CHECK_THINKFIRST(sv); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -4140,17 +4275,40 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvIV_set(sv, 0); - /* Same SvOOK_on but SvOOK_on does a SvIOK_off - and we do that anyway inside the SvNIOK_off - */ SvFLAGS(sv) |= SVf_OOK; + old_delta = 0; + } else { + SvOOK_offset(sv, old_delta); } - SvNIOK_off(sv); SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); SvPV_set(sv, SvPVX(sv) + delta); - SvIV_set(sv, SvIVX(sv) + delta); + + p = (U8 *)SvPVX_const(sv); + + delta += old_delta; + +#ifdef DEBUGGING + real_start = p - delta; +#endif + + assert(delta); + if (delta < 0x100) { + *--p = (U8) delta; + } else { + *--p = 0; + p -= sizeof(STRLEN); + Copy((U8*)&delta, p, sizeof(STRLEN), U8); + } + +#ifdef DEBUGGING + /* Fill the preceding buffer with sentinals to verify that no-one is + using it. */ + while (p > real_start) { + --p; + *p = (U8)PTR2UV(p); + } +#endif } /* @@ -4233,7 +4391,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* const csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -4349,9 +4507,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, dVAR; MAGIC* mg; - if (SvTYPE(sv) < SVt_PVMG) { - SvUPGRADE(sv, SVt_PVMG); - } + SvUPGRADE(sv, SVt_PVMG); Newxz(mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC_set(sv, mg); @@ -4367,7 +4523,6 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || - how == PERL_MAGIC_qr || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || @@ -4909,10 +5064,8 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, else if ((i = mid - big)) { /* faster from front */ midend -= littlelen; mid = midend; + Move(big, midend - i, i, char); sv_chop(bigstr,midend-i); - big += i; - while (i--) - *--midend = *--big; if (littlelen) Move(little, mid, littlelen,char); } @@ -4971,13 +5124,9 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) #else StructCopy(nsv,sv,SV); #endif - /* Currently could join these into one piece of pointer arithmetic, but - it would be unclear. */ - if(SvTYPE(sv) == SVt_IV) + if(SvTYPE(sv) == SVt_IV) { SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - else if (SvTYPE(sv) == SVt_RV) { - SvANY(sv) = &sv->sv_u.svu_rv; } @@ -5030,19 +5179,32 @@ Perl_sv_clear(pTHX_ register SV *sv) const U32 type = SvTYPE(sv); const struct body_details *const sv_type_details = bodies_by_type + type; + HV *stash; assert(sv); assert(SvREFCNT(sv) == 0); + assert(SvTYPE(sv) != SVTYPEMASK); if (type <= SVt_IV) { /* See the comment in sv.h about the collusion between this early return and the overloading of the NULL and IV slots in the size table. */ + if (SvROK(sv)) { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + SvREFCNT_dec(target); + } + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; return; } if (SvOBJECT(sv)) { - if (PL_defstash) { /* Still have a symbol table? */ + if (PL_defstash && /* Still have a symbol table? */ + SvDESTROYABLE(sv)) + { dSP; HV* stash; do { @@ -5116,6 +5278,10 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; + case SVt_REGEXP: + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); + goto freescalar; case SVt_PVCV: case SVt_PVFM: cv_undef((CV*)sv); @@ -5125,6 +5291,10 @@ Perl_sv_clear(pTHX_ register SV *sv) hv_undef((HV*)sv); break; case SVt_PVAV: + if (PL_comppad == (AV*)sv) { + PL_comppad = NULL; + PL_curpad = NULL; + } av_undef((AV*)sv); break; case SVt_PVLV: @@ -5137,25 +5307,33 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); case SVt_PVGV: if (isGV_with_GP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); if (GvNAME_HEK(sv)) unshare_hek(GvNAME_HEK(sv)); - /* If we're in a stash, we don't own a reference to it. However it does - have a back reference to us, which needs to be cleared. */ - if (!SvVALID(sv) && GvSTASH(sv)) - sv_del_backref((SV*)GvSTASH(sv), sv); - } + /* If we're in a stash, we don't own a reference to it. However it does + have a back reference to us, which needs to be cleared. */ + if (!SvVALID(sv) && (stash = GvSTASH(sv))) + sv_del_backref((SV*)stash, sv); + } + /* FIXME. There are probably more unreferenced pointers to SVs in the + interpreter struct that we should check and tidy in a similar + fashion to this: */ + if ((GV*)sv == PL_last_in_gv) + PL_last_in_gv = NULL; case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: + case SVt_PV: freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { - SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); /* Don't even bother with turning off the OOK flag. */ } - case SVt_PV: - case SVt_RV: if (SvROK(sv)) { SV * const target = SvRV(sv); if (SvWEAKREF(sv)) @@ -5257,13 +5435,28 @@ Perl_sv_free(pTHX_ SV *sv) return; } if (ckWARN_d(WARN_INTERNAL)) { +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + Perl_dump_sv_child(aTHX_ sv); +#else + #ifdef DEBUG_LEAKING_SCALARS + sv_dump(sv); + #endif +#ifdef DEBUG_LEAKING_SCALARS_ABORT + if (PL_warnhook == PERL_WARNHOOK_FATAL + || ckDEAD(packWARN(WARN_INTERNAL))) { + /* Don't let Perl_warner cause us to escape our fate: */ + abort(); + } +#endif + /* This may not return: */ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar: SV 0x%"UVxf pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); -#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - Perl_dump_sv_child(aTHX_ sv); #endif } +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif return; } if (--(SvREFCNT(sv)) > 0) @@ -5351,7 +5544,7 @@ Perl_sv_len_utf8(pTHX_ register SV *sv) if (PL_utf8cache) { STRLEN ulen; - MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0; + MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; if (mg && mg->mg_len != -1) { ulen = mg->mg_len; @@ -5909,8 +6102,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) * invalidate pv1, so we may need to make a copy */ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { pv1 = SvPV_const(sv1, cur1); - sv1 = sv_2mortal(newSVpvn(pv1, cur1)); - if (SvUTF8(sv2)) SvUTF8_on(sv1); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); } pv1 = SvPV_const(sv1, cur1); } @@ -6067,7 +6259,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 'use bytes' aware, handles get magic, and will coerce its args to strings -if necessary. See also C. See also C. +if necessary. See also C. =cut */ @@ -6609,8 +6801,15 @@ Perl_sv_inc(pTHX_ register SV *sv) return; } 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); + } (void)SvNOK_only(sv); - SvNV_set(sv, SvNVX(sv) + 1.0); + SvNV_set(sv, was + 1.0); return; } @@ -6754,8 +6953,10 @@ Perl_sv_dec(pTHX_ register SV *sv) SvUV_set(sv, SvUVX(sv) - 1); } } else { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (NV)IV_MIN - 1.0); + if (SvIVX(sv) == IV_MIN) { + sv_setnv(sv, (NV)IV_MIN); + goto oops_its_num; + } else { (void)SvIOK_only(sv); SvIV_set(sv, SvIVX(sv) - 1); @@ -6764,9 +6965,19 @@ Perl_sv_dec(pTHX_ register SV *sv) return; } if (flags & SVp_NOK) { - SvNV_set(sv, SvNVX(sv) - 1.0); - (void)SvNOK_only(sv); - return; + oops_its_num: + { + 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); + } + (void)SvNOK_only(sv); + SvNV_set(sv, was - 1.0); + return; + } } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVIV) @@ -6866,6 +7077,40 @@ Perl_sv_newmortal(pTHX) return sv; } + +/* +=for apidoc newSVpvn_flags + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. If the C argument is NULL the new SV will be undefined. +Currently the only flag bits accepted are C and C. +If C is set, then C is called on the result before +returning. If C is set, then it will be set on the new SV. +C is a convenience wrapper for this function, defined as + + #define newSVpvn_utf8(s, len, u) \ + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + +=cut +*/ + +SV * +Perl_newSVpvn_flags(pTHX_ const char *s, STRLEN len, U32 flags) +{ + dVAR; + register SV *sv; + + /* All the flags we don't support must be zero. + And we're new code so I'm going to assert this from the start. */ + assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); + new_SV(sv); + sv_setpvn(sv,s,len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + /* =for apidoc sv_2mortal @@ -6935,7 +7180,6 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } - /* =for apidoc newSVhek @@ -7013,11 +7257,11 @@ Perl_newSVhek(pTHX_ const HEK *hek) Creates a new SV with its SvPVX_const pointing to a shared string in the string table. If the string does not already exist in the table, it is created -first. Turns on READONLY and FAKE. The string's hash is stored in the UV -slot of the SV; if the C parameter is non-zero, that value is used; -otherwise the hash is computed. The idea here is that as the string table -is used for shared hash keys these strings will have SvPVX_const == HeKEY and -hash lookup will avoid string compare. +first. Turns on READONLY and FAKE. If the C parameter is non-zero, that +value is used; otherwise the hash is computed. The string's hash can be later +be retrieved from the SV with the C macro. The idea here is +that as the string table is used for shared hash keys these strings will have +SvPVX_const == HeKEY and hash lookup will avoid string compare. =cut */ @@ -7168,6 +7412,25 @@ Perl_newSVuv(pTHX_ UV u) } /* +=for apidoc newSV_type + +Creates a new SV, of the type specified. The reference count for the new SV +is set to 1. + +=cut +*/ + +SV * +Perl_newSV_type(pTHX_ svtype type) +{ + register SV *sv; + + new_SV(sv); + sv_upgrade(sv, type); + return sv; +} + +/* =for apidoc newRV_noinc Creates an RV wrapper for an SV. The reference count for the original @@ -7180,10 +7443,7 @@ SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { dVAR; - register SV *sv; - - new_SV(sv); - sv_upgrade(sv, SVt_RV); + register SV *sv = newSV_type(SVt_IV); SvTEMP_off(tmpRef); SvRV_set(sv, tmpRef); SvROK_on(sv); @@ -7252,10 +7512,17 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) if (!*s) { /* reset ?? searches */ MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); if (mg) { - PMOP *pm = (PMOP *) mg->mg_obj; - while (pm) { - pm->op_pmdynflags &= ~PMdf_USED; - pm = pm->op_pmnext; + const U32 count = mg->mg_len / sizeof(PMOP**); + PMOP **pmp = (PMOP**) mg->mg_ptr; + PMOP *const *const end = pmp + count; + + while (pmp < end) { +#ifdef USE_ITHREADS + SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); +#else + (*pmp)->op_pmflags &= ~PMf_USED; +#endif + ++pmp; } } return; @@ -7538,7 +7805,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) else Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + if ((SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) + || isGV_with_GP(sv)) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); s = sv_2pv_flags(sv, &len, flags); @@ -7552,7 +7820,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) SvGROW(sv, len + 1); Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); - *SvEND(sv) = '\0'; + SvPVX(sv)[len] = '\0'; } if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ @@ -7620,7 +7888,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_NULL: case SVt_IV: case SVt_NV: - case SVt_RV: case SVt_PV: case SVt_PVIV: case SVt_PVNV: @@ -7644,6 +7911,7 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; + case SVt_REGEXP: return "REGEXP"; default: return "UNKNOWN"; } } @@ -7731,15 +7999,11 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SvFLAGS(rv) = 0; SvREFCNT(rv) = refcnt; - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_IV); } else if (SvROK(rv)) { SvREFCNT_dec(SvRV(rv)); - } else if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); - else if (SvTYPE(rv) > SVt_RV) { - SvPV_free(rv); - SvCUR_set(rv, 0); - SvLEN_set(rv, 0); + } else { + prepare_SV_for_RV(rv); } SvOK_off(rv); @@ -7882,6 +8146,8 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvIsCOW(tmpRef)) + sv_force_normal_flags(tmpRef, 0); if (SvREADONLY(tmpRef)) Perl_croak(aTHX_ PL_no_modify); if (SvOBJECT(tmpRef)) { @@ -7918,6 +8184,7 @@ S_sv_unglob(pTHX_ SV *sv) { dVAR; void *xpvmg; + HV *stash; SV * const temp = sv_newmortal(); assert(SvTYPE(sv) == SVt_PVGV); @@ -7925,6 +8192,8 @@ S_sv_unglob(pTHX_ SV *sv) gv_efullname3(temp, (GV *) sv, "*"); if (GvGP(sv)) { + if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + mro_method_changed_in(stash); gp_free((GV*)sv); } if (GvSTASH(sv)) { @@ -8529,10 +8798,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV %p include pointer address (standard) %-p (SVf) include an SV (previously %_) %-p include an SV with precision - %1p (VDf) include a v-string (as %vd) %p reserved for future extensions Robin Barker 2005-07-14 + + %1p (VDf) removed. RMB 2007-10-19 */ char* r = q; bool sv = FALSE; @@ -8547,18 +8817,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV has_precis = TRUE; } argsv = (SV*)va_arg(*args, void*); - eptr = SvPVx_const(argsv, elen); + eptr = SvPV_const(argsv, elen); if (DO_UTF8(argsv)) is_utf8 = TRUE; goto string; } -#if vdNUMBER - else if (n == vdNUMBER) { /* VDf */ - vectorize = TRUE; - VECTORIZE_ARGS - goto format_vd; - } -#endif else if (n) { if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), @@ -8679,12 +8942,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto unknown; } vecsv = sv_newmortal(); - /* scan_vstring is expected to be called during - * tokenization, so we need to fake up the end - * of the buffer for it - */ - PL_bufend = version + veclen; - scan_vstring(version, vecsv); + scan_vstring(version, version + veclen, vecsv); vecstr = (U8*)SvPV_const(vecsv, veclen); vec_utf8 = DO_UTF8(vecsv); Safefree(version); @@ -8811,7 +9069,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'c': if (vectorize) goto unknown; - uv = (args) ? va_arg(*args, int) : SvIVx(argsv); + uv = (args) ? va_arg(*args, int) : SvIV(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -8845,7 +9103,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - eptr = SvPVx_const(argsv, elen); + eptr = SvPV_const(argsv, elen); if (DO_UTF8(argsv)) { I32 old_precis = precis; if (has_precis && precis < elen) { @@ -8917,7 +9175,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - IV tiv = SvIVx(argsv); /* work around GCC bug #13488 */ + IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'h': iv = (short)tiv; break; case 'l': iv = (long)tiv; break; @@ -9002,7 +9260,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else { - UV tuv = SvUVx(argsv); /* work around GCC bug #13488 */ + UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'h': uv = (unsigned short)tuv; break; case 'l': uv = (unsigned long)tuv; break; @@ -9124,10 +9382,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #else va_arg(*args, double) #endif - : SvNVx(argsv); + : SvNV(argsv); need = 0; - if (c != 'e' && c != 'E') { + /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything + else. frexp() has some unspecified behaviour for those three */ + if (c != 'e' && c != 'E' && (nv * 0) == 0) { i = PERL_INT_MIN; /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this will cast our (long double) to (double) */ @@ -9350,7 +9610,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else { const STRLEN old_elen = elen; - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); sv_utf8_upgrade(nsv); eptr = SvPVX_const(nsv); elen = SvCUR(nsv); @@ -9428,7 +9688,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV All the macros and functions in this section are for the private use of the main function, perl_clone(). -The foo_dup() functions make an exact copy of an existing foo thinngy. +The foo_dup() functions make an exact copy of an existing foo thingy. During the course of a cloning, a hash table is used to map old addresses to new addresses. The table is created and manipulated with the ptr_table_* functions. @@ -9514,9 +9774,47 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->multi_close = proto->multi_close; parser->multi_open = proto->multi_open; parser->multi_start = proto->multi_start; + parser->multi_end = proto->multi_end; parser->pending_ident = proto->pending_ident; parser->preambled = proto->preambled; parser->sublex_info = proto->sublex_info; /* XXX not quite right */ + parser->linestr = sv_dup_inc(proto->linestr, param); + parser->expect = proto->expect; + parser->copline = proto->copline; + parser->last_lop_op = proto->last_lop_op; + parser->lex_state = proto->lex_state; + parser->rsfp = fp_dup(proto->rsfp, '<', param); + /* rsfp_filters entries have fake IoDIRP() */ + parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); + parser->in_my = proto->in_my; + parser->in_my_stash = hv_dup(proto->in_my_stash, param); + parser->error_count = proto->error_count; + + + parser->linestr = sv_dup_inc(proto->linestr, param); + + { + char * const ols = SvPVX(proto->linestr); + char * const ls = SvPVX(parser->linestr); + + parser->bufptr = ls + (proto->bufptr >= ols ? + proto->bufptr - ols : 0); + parser->oldbufptr = ls + (proto->oldbufptr >= ols ? + proto->oldbufptr - ols : 0); + parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? + proto->oldoldbufptr - ols : 0); + parser->linestart = ls + (proto->linestart >= ols ? + proto->linestart - ols : 0); + parser->last_uni = ls + (proto->last_uni >= ols ? + proto->last_uni - ols : 0); + parser->last_lop = ls + (proto->last_lop >= ols ? + proto->last_lop - ols : 0); + + parser->bufend = ls + SvCUR(parser->linestr); + } + + Copy(proto->tokenbuf, parser->tokenbuf, 256, char); + #ifdef PERL_MAD parser->endwhite = proto->endwhite; @@ -9531,6 +9829,13 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->thisstuff = proto->thisstuff; parser->thistoken = proto->thistoken; parser->thiswhite = proto->thiswhite; + + Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE); + parser->curforce = proto->curforce; +#else + Copy(proto->nextval, parser->nextval, 5, YYSTYPE); + Copy(proto->nexttype, parser->nexttype, 5, I32); + parser->nexttoke = proto->nexttoke; #endif return parser; } @@ -9629,17 +9934,17 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; + /* FIXME for plugins if (mg->mg_type == PERL_MAGIC_qr) { nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); } - else if(mg->mg_type == PERL_MAGIC_backref) { + else + */ + if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by 1. */ nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); } - else if (mg->mg_type == PERL_MAGIC_symtab) { - nmg->mg_obj = mg->mg_obj; - } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) ? sv_dup_inc(mg->mg_obj, param) @@ -9859,10 +10164,7 @@ Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) } else { /* Copy the NULL */ - if (SvTYPE(dstr) == SVt_RV) - SvRV_set(dstr, NULL); - else - SvPV_set(dstr, NULL); + SvPV_set(dstr, NULL); } } @@ -9874,8 +10176,14 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) dVAR; SV *dstr; - if (!sstr || SvTYPE(sstr) == SVTYPEMASK) + if (!sstr) + return NULL; + if (SvTYPE(sstr) == SVTYPEMASK) { +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif return NULL; + } /* look for it in the table first */ dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); if (dstr) @@ -9885,10 +10193,10 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /** We are joining here so we don't want do clone something that is bad **/ if (SvTYPE(sstr) == SVt_PVHV) { - const char * const hvname = HvNAME_get(sstr); + const HEK * const hvname = HvNAME_HEK(sstr); if (hvname) /** don't clone stashes if they already exist **/ - return (SV*)gv_stashpv(hvname,0); + return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0); } } @@ -9918,8 +10226,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /* don't clone objects whose class has asked us not to */ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { - SvFLAGS(dstr) &= ~SVTYPEMASK; - SvOBJECT_off(dstr); + SvFLAGS(dstr) = 0; return dstr; } @@ -9929,16 +10236,16 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_IV: SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvIV_set(dstr, SvIVX(sstr)); + if(SvROK(sstr)) { + Perl_rvpv_dup(aTHX_ dstr, sstr, param); + } else { + SvIV_set(dstr, SvIVX(sstr)); + } break; case SVt_NV: SvANY(dstr) = new_XNV(); SvNV_set(dstr, SvNVX(sstr)); break; - case SVt_RV: - SvANY(dstr) = &(dstr->sv_u.svu_rv); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; /* case SVt_BIND: */ default: { @@ -9963,6 +10270,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVAV: case SVt_PVCV: case SVt_PVLV: + case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -10017,6 +10325,10 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVMG: break; + case SVt_REGEXP: + /* FIXME for plugins */ + re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); + break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ @@ -10046,7 +10358,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) IoOFP(dstr) = IoIFP(dstr); else IoOFP(dstr) = fp_dup(IoOFP(dstr), IoTYPE(dstr), param); - /* PL_rsfp_filters entries have fake IoDIRP() */ + /* PL_parser->rsfp_filters entries have fake IoDIRP() */ if(IoFLAGS(dstr) & IOf_FAKE_DIRP) { /* I have no idea why fake dirp (rsfps) should be treated differently but otherwise @@ -10134,6 +10446,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) ? (AV*) SvREFCNT_inc( sv_dup((SV*)saux->xhv_backreferences, param)) : 0; + + daux->xhv_mro_meta = saux->xhv_mro_meta + ? mro_meta_dup(saux->xhv_mro_meta, param) + : 0; + /* Record stashes for possible cloning in Perl_clone(). */ if (hvname) av_push(param->stashes, dstr); @@ -10196,69 +10513,55 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) return ncxs; /* create anew and remember what it is */ - Newxz(ncxs, max + 1, PERL_CONTEXT); + Newx(ncxs, max + 1, PERL_CONTEXT); ptr_table_store(PL_ptr_table, cxs, ncxs); + Copy(cxs, ncxs, max + 1, PERL_CONTEXT); while (ix >= 0) { - PERL_CONTEXT * const cx = &cxs[ix]; PERL_CONTEXT * const ncx = &ncxs[ix]; - ncx->cx_type = cx->cx_type; - if (CxTYPE(cx) == CXt_SUBST) { + if (CxTYPE(ncx) == CXt_SUBST) { Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); } else { - ncx->blk_oldsp = cx->blk_oldsp; - ncx->blk_oldcop = cx->blk_oldcop; - ncx->blk_oldmarksp = cx->blk_oldmarksp; - ncx->blk_oldscopesp = cx->blk_oldscopesp; - ncx->blk_oldpm = cx->blk_oldpm; - ncx->blk_gimme = cx->blk_gimme; - switch (CxTYPE(cx)) { + switch (CxTYPE(ncx)) { case CXt_SUB: - ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 - ? cv_dup_inc(cx->blk_sub.cv, param) - : cv_dup(cx->blk_sub.cv,param)); - ncx->blk_sub.argarray = (cx->blk_sub.hasargs - ? av_dup_inc(cx->blk_sub.argarray, param) + ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 + ? cv_dup_inc(ncx->blk_sub.cv, param) + : cv_dup(ncx->blk_sub.cv,param)); + ncx->blk_sub.argarray = (CxHASARGS(ncx) + ? av_dup_inc(ncx->blk_sub.argarray, + param) : NULL); - ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); - ncx->blk_sub.olddepth = cx->blk_sub.olddepth; - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.lval = cx->blk_sub.lval; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray, + param); ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_sub.oldcomppad); + ncx->blk_sub.oldcomppad); break; case CXt_EVAL: - ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; - ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); - ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; - ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); - ncx->blk_eval.retop = cx->blk_eval.retop; + ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, + param); + ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); break; case CXt_LOOP: - ncx->blk_loop.label = cx->blk_loop.label; - ncx->blk_loop.resetsp = cx->blk_loop.resetsp; - ncx->blk_loop.my_op = cx->blk_loop.my_op; - ncx->blk_loop.iterdata = (CxPADLOOP(cx) - ? cx->blk_loop.iterdata - : gv_dup((GV*)cx->blk_loop.iterdata, param)); + ncx->blk_loop.iterdata = (CxPADLOOP(ncx) + ? ncx->blk_loop.iterdata + : gv_dup((GV*)ncx->blk_loop.iterdata, + param)); ncx->blk_loop.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_loop.oldcomppad); - ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); - ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); - ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); - ncx->blk_loop.iterix = cx->blk_loop.iterix; - ncx->blk_loop.itermax = cx->blk_loop.itermax; + ncx->blk_loop.oldcomppad); + ncx->blk_loop.itersave = sv_dup_inc(ncx->blk_loop.itersave, + param); + ncx->blk_loop.iterlval = sv_dup_inc(ncx->blk_loop.iterlval, + param); + ncx->blk_loop.iterary = av_dup_inc(ncx->blk_loop.iterary, + param); break; case CXt_FORMAT: - ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param); - ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); - ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); + ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); + ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, + param); break; case CXt_BLOCK: case CXt_NULL: @@ -10354,9 +10657,9 @@ ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { dVAR; - ANY * const ss = proto_perl->Tsavestack; - const I32 max = proto_perl->Tsavestack_max; - I32 ix = proto_perl->Tsavestack_ix; + ANY * const ss = proto_perl->Isavestack; + const I32 max = proto_perl->Isavestack_max; + I32 ix = proto_perl->Isavestack_ix; ANY *nss; SV *sv; GV *gv; @@ -10487,7 +10790,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = ptr; o = (OP*)ptr; OP_REFCNT_LOCK; - OpREFCNT_inc(o); + (void) OpREFCNT_inc(o); OP_REFCNT_UNLOCK; break; default: @@ -10601,10 +10904,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) = pv_dup(old_state->re_state_reginput); new_state->re_state_regeol = pv_dup(old_state->re_state_regeol); - new_state->re_state_regstartp - = (I32*) any_dup(old_state->re_state_regstartp, proto_perl); - new_state->re_state_regendp - = (I32*) any_dup(old_state->re_state_regendp, proto_perl); + new_state->re_state_regoffs + = (regexp_paren_pair*) + any_dup(old_state->re_state_regoffs, proto_perl); new_state->re_state_reglastparen = (U32*) any_dup(old_state->re_state_reglastparen, proto_perl); @@ -10681,7 +10983,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(hvname))); + mXPUSHs(newSVhek(hvname)); PUTBACK; call_sv((SV*)GvCV(cloner), G_SCALAR); SPAGAIN; @@ -10793,6 +11095,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -10827,6 +11130,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -10913,7 +11217,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } - PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); + PL_curcop = (COP*)any_dup(proto_perl->Icurcop, proto_perl); +#ifdef PERL_DEBUG_READONLY_OPS + PL_slabs = NULL; + PL_slab_count = 0; +#endif /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; @@ -10942,7 +11250,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; - PL_preprocess = proto_perl->Ipreprocess; PL_minus_n = proto_perl->Iminus_n; PL_minus_p = proto_perl->Iminus_p; PL_minus_l = proto_perl->Iminus_l; @@ -10985,26 +11292,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regmatch_slab = NULL; /* Clone the regex array */ - PL_regex_padav = newAV(); - { - const I32 len = av_len((AV*)proto_perl->Iregex_padav); - SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - IV i; - av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param)); - for(i = 1; i <= len; i++) { - const SV * const regex = regexen[i]; - SV * const sv = - SvREPADTMP(regex) - ? sv_dup_inc(regex, param) - : SvREFCNT_inc( - newSViv(PTR2IV(CALLREGDUPE( - INT2PTR(REGEXP *, SvIVX(regex)), param)))) - ; - if (SvFLAGS(regex) & SVf_BREAK) - SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ - av_push(PL_regex_padav, sv); - } - } + /* ORANGE FIXME for plugins, probably in the SV dup code. + newSViv(PTR2IV(CALLREGDUPE( + INT2PTR(REGEXP *, SvIVX(regex)), param)))) + */ + PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); PL_regex_pad = AvARRAY(PL_regex_padav); /* shortcuts to various I/O objects */ @@ -11028,13 +11320,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); - PL_DBassertion = sv_dup(proto_perl->IDBassertion, param); - PL_lineary = av_dup(proto_perl->Ilineary, param); PL_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ - PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); - PL_curstash = hv_dup(proto_perl->Tcurstash, param); + PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); + PL_curstash = hv_dup(proto_perl->Icurstash, param); PL_debstash = hv_dup(proto_perl->Idebstash, param); PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); @@ -11049,6 +11339,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_initav = av_dup_inc(proto_perl->Iinitav, param); PL_sub_generation = proto_perl->Isub_generation; + PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); /* funky return mechanisms */ PL_forkprocess = proto_perl->Iforkprocess; @@ -11075,7 +11366,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* runtime control stuff */ PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); - PL_copline = proto_perl->Icopline; PL_filemode = proto_perl->Ifilemode; PL_lastfd = proto_perl->Ilastfd; @@ -11104,14 +11394,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newx(PL_my_cxt_list, PL_my_cxt_size, void *); Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); #ifdef PERL_GLOBAL_STRUCT_PRIVATE - Newx(PL_my_cxt_keys, PL_my_cxt_size, char *); + Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); Copy(proto_perl->Imy_cxt_keys, PL_my_cxt_keys, PL_my_cxt_size, char *); #endif } else { PL_my_cxt_list = (void**)NULL; #ifdef PERL_GLOBAL_STRUCT_PRIVATE - PL_my_cxt_keys = (void**)NULL; + PL_my_cxt_keys = (const char**)NULL; #endif } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); @@ -11119,9 +11409,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); PL_profiledata = NULL; - PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); - /* PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); PL_compcv = cv_dup(proto_perl->Icompcv, param); @@ -11155,52 +11442,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); - -#ifdef CSH - PL_cshlen = proto_perl->Icshlen; - PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ -#endif - PL_parser = parser_dup(proto_perl->Iparser, param); - PL_lex_state = proto_perl->Ilex_state; - -#ifdef PERL_MAD - Copy(proto_perl->Inexttoke, PL_nexttoke, 5, NEXTTOKE); - PL_curforce = proto_perl->Icurforce; -#else - Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE); - Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); - PL_nexttoke = proto_perl->Inexttoke; -#endif - - PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); - i = proto_perl->Ibufptr - SvPVX_const(proto_perl->Ilinestr); - PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ioldoldbufptr - SvPVX_const(proto_perl->Ilinestr); - PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilinestart - SvPVX_const(proto_perl->Ilinestr); - PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); - - PL_expect = proto_perl->Iexpect; - - PL_multi_end = proto_perl->Imulti_end; - - PL_error_count = proto_perl->Ierror_count; PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); - i = proto_perl->Ilast_uni - SvPVX_const(proto_perl->Ilinestr); - PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - i = proto_perl->Ilast_lop - SvPVX_const(proto_perl->Ilinestr); - PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); - PL_last_lop_op = proto_perl->Ilast_lop_op; - PL_in_my = proto_perl->Iin_my; - PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); #ifdef FCRYPT PL_cryptseen = proto_perl->Icryptseen; #endif @@ -11272,9 +11518,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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; + PL_destroyhook = proto_perl->Idestroyhook; #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; @@ -11289,7 +11533,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */ PL_bitcount = NULL; /* reinits on demand */ if (proto_perl->Ipsig_pend) { @@ -11312,54 +11555,54 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_psig_name = (SV**)NULL; } - /* thrdvar.h stuff */ + /* intrpvar.h stuff */ 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; - PL_tmps_floor = proto_perl->Ttmps_floor; + PL_tmps_ix = proto_perl->Itmps_ix; + PL_tmps_max = proto_perl->Itmps_max; + PL_tmps_floor = proto_perl->Itmps_floor; Newxz(PL_tmps_stack, PL_tmps_max, SV*); i = 0; while (i <= PL_tmps_ix) { - PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Itmps_stack[i], param); ++i; } /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; Newxz(PL_markstack, i, I32); - PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max - - proto_perl->Tmarkstack); - PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr - - proto_perl->Tmarkstack); - Copy(proto_perl->Tmarkstack, PL_markstack, + PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max + - proto_perl->Imarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr + - proto_perl->Imarkstack); + Copy(proto_perl->Imarkstack, PL_markstack, PL_markstack_ptr - PL_markstack + 1, I32); /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] * NOTE: unlike the others! */ - PL_scopestack_ix = proto_perl->Tscopestack_ix; - PL_scopestack_max = proto_perl->Tscopestack_max; + PL_scopestack_ix = proto_perl->Iscopestack_ix; + PL_scopestack_max = proto_perl->Iscopestack_max; Newxz(PL_scopestack, PL_scopestack_max, I32); - Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); + PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Tcurstack, param); - PL_mainstack = av_dup(proto_perl->Tmainstack, param); + PL_curstack = av_dup(proto_perl->Icurstack, param); + PL_mainstack = av_dup(proto_perl->Imainstack, param); /* next PUSHs() etc. set *(PL_stack_sp+1) */ PL_stack_base = AvARRAY(PL_curstack); - PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp - - proto_perl->Tstack_base); + PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp + - proto_perl->Istack_base); PL_stack_max = PL_stack_base + AvMAX(PL_curstack); /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] * NOTE: unlike the others! */ - PL_savestack_ix = proto_perl->Tsavestack_ix; - PL_savestack_max = proto_perl->Tsavestack_max; + PL_savestack_ix = proto_perl->Isavestack_ix; + PL_savestack_max = proto_perl->Isavestack_max; /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ PL_savestack = ss_dup(proto_perl, param); } @@ -11372,9 +11615,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * non-refcount means (eg a temp in @_); otherwise they will be * orphaned */ - for (i = 0; i<= proto_perl->Ttmps_ix; i++) { + for (i = 0; i<= proto_perl->Itmps_ix; i++) { SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, - proto_perl->Ttmps_stack[i]); + proto_perl->Itmps_stack[i]); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); @@ -11382,50 +11625,50 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } } - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_start_env = proto_perl->Istart_env; /* XXXXXX */ PL_top_env = &PL_start_env; - PL_op = proto_perl->Top; + PL_op = proto_perl->Iop; PL_Sv = NULL; PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Tna; + my_perl->Ina = proto_perl->Ina; - PL_statbuf = proto_perl->Tstatbuf; - PL_statcache = proto_perl->Tstatcache; - PL_statgv = gv_dup(proto_perl->Tstatgv, param); - PL_statname = sv_dup_inc(proto_perl->Tstatname, param); + PL_statbuf = proto_perl->Istatbuf; + PL_statcache = proto_perl->Istatcache; + PL_statgv = gv_dup(proto_perl->Istatgv, param); + PL_statname = sv_dup_inc(proto_perl->Istatname, param); #ifdef HAS_TIMES - PL_timesbuf = proto_perl->Ttimesbuf; + PL_timesbuf = proto_perl->Itimesbuf; #endif - PL_tainted = proto_perl->Ttainted; - PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ - PL_rs = sv_dup_inc(proto_perl->Trs, param); - PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); - PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); - PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param); - PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ - PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param); - PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param); - PL_formtarget = sv_dup(proto_perl->Tformtarget, param); - - PL_restartop = proto_perl->Trestartop; - PL_in_eval = proto_perl->Tin_eval; - PL_delaymagic = proto_perl->Tdelaymagic; - PL_dirty = proto_perl->Tdirty; - PL_localizing = proto_perl->Tlocalizing; - - PL_errors = sv_dup_inc(proto_perl->Terrors, param); + PL_tainted = proto_perl->Itainted; + PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ + PL_rs = sv_dup_inc(proto_perl->Irs, param); + PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); + PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param); + PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); + PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ + PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); + PL_bodytarget = sv_dup_inc(proto_perl->Ibodytarget, param); + PL_formtarget = sv_dup(proto_perl->Iformtarget, param); + + PL_restartop = proto_perl->Irestartop; + PL_in_eval = proto_perl->Iin_eval; + PL_delaymagic = proto_perl->Idelaymagic; + PL_dirty = proto_perl->Idirty; + PL_localizing = proto_perl->Ilocalizing; + + PL_errors = sv_dup_inc(proto_perl->Ierrors, param); PL_hv_fetch_ent_mh = NULL; - PL_modcount = proto_perl->Tmodcount; + PL_modcount = proto_perl->Imodcount; PL_lastgotoprobe = NULL; - PL_dumpindent = proto_perl->Tdumpindent; + PL_dumpindent = proto_perl->Idumpindent; - PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); - PL_sortstash = hv_dup(proto_perl->Tsortstash, param); - PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); - PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); + PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl); + PL_sortstash = hv_dup(proto_perl->Isortstash, param); + PL_firstgv = gv_dup(proto_perl->Ifirstgv, param); + PL_secondgv = gv_dup(proto_perl->Isecondgv, param); PL_efloatbuf = NULL; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */ @@ -11436,20 +11679,28 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_maxscream = -1; /* reinits on demand */ PL_lastscream = NULL; - PL_watchaddr = NULL; - PL_watchok = NULL; - PL_regdummy = proto_perl->Tregdummy; + PL_regdummy = proto_perl->Iregdummy; PL_colorset = 0; /* reinits PL_colors[] */ /*PL_colors[6] = {0,0,0,0,0,0};*/ /* Pluggable optimizer */ - PL_peepp = proto_perl->Tpeepp; + PL_peepp = proto_perl->Ipeepp; PL_stashcache = newHV(); + PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, + proto_perl->Iwatchaddr); + PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; + if (PL_debug && PL_watchaddr) { + PerlIO_printf(Perl_debug_log, + "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n", + PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), + PTR2UV(PL_watchok)); + } + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -11466,7 +11717,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); + mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -11582,8 +11833,9 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, XPUSHs(encoding); XPUSHs(dsv); XPUSHs(ssv); - XPUSHs(offsv = sv_2mortal(newSViv(*offset))); - XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); + offsv = newSViv(*offset); + mXPUSHs(offsv); + mXPUSHp(tstr, tlen); PUTBACK; call_method("cat_decode", G_SCALAR); SPAGAIN; @@ -11637,7 +11889,7 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) return NULL; if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } } return NULL; @@ -11701,8 +11953,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, } } else { - U32 unused; - CV * const cv = find_runcv(&unused); + CV * const cv = find_runcv(NULL); SV *sv; AV *av; @@ -11982,6 +12233,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_PRTF: case OP_PRINT: + case OP_SAY: /* skip filehandle as it can't produce 'undef' warning */ o = cUNOPx(obase)->op_first; if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) @@ -11991,14 +12243,27 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_RV2SV: case OP_CUSTOM: - case OP_ENTERSUB: match = 1; /* XS or custom code could trigger random warnings */ goto do_op; + case OP_ENTERSUB: + case OP_GOTO: + /* XXX tmp hack: these two may call an XS sub, and currently + XS subs don't have a SUB entry on the context stack, so CV and + pad determination goes wrong, and BAD things happen. So, just + don't try to determine the value under those circumstances. + Need a better fix at dome point. DAPM 11/2007 */ + break; + + case OP_POS: + /* def-ness of rval pos() is independent of the def-ness of its arg */ + if ( !(obase->op_flags & OPf_MOD)) + break; + case OP_SCHOMP: case OP_CHOMP: if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpvs("${$/}")); + return newSVpvs_flags("${$/}", SVs_TEMP); /*FALLTHROUGH*/ default: