X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4b8f2e61a9bd693bb1aedb3127f6c5d2e1d8c5dc..5c35adbb8fc4c988807097c4d379e2485ada5865:/sv.c diff --git a/sv.c b/sv.c index d5655b3..3e7c3ff 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_parser && PL_parser->copline == NOLINE) ? - (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_parser->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))); @@ -538,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 */ @@ -549,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*) \ @@ -780,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. */ @@ -869,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 }, @@ -887,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) @@ -911,7 +915,12 @@ 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)) }, - + + /* 32 */ + { sizeof(struct xregexp), copy_length(struct xregexp, xrx_regexp), 0, + SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct xregexp)) + }, + /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -1088,6 +1097,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 @@ -1106,8 +1118,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); @@ -1116,11 +1129,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 @@ -1165,9 +1173,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: @@ -1175,8 +1190,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); @@ -1201,6 +1214,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; @@ -1220,11 +1238,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); @@ -1246,13 +1259,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); } @@ -1275,6 +1311,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: @@ -1323,8 +1360,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) 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", @@ -1457,12 +1497,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; @@ -1560,7 +1597,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); @@ -2495,6 +2531,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. @@ -2634,22 +2693,20 @@ 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))) - { + } else if (SvTYPE(referent) == SVt_REGEXP) { char *str = NULL; I32 haseval = 0; U32 flags = 0; - (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); + struct magic temp; + temp.mg_obj + = (SV*)((struct xregexp *)SvANY(referent))->xrx_regexp; + assert(temp.mg_obj); + (str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval); if (flags & 1) SvUTF8_on(sv); else @@ -2734,15 +2791,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)) { @@ -2762,8 +2820,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 @@ -3378,7 +3438,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; @@ -3396,7 +3455,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)) { @@ -3405,7 +3468,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); @@ -3424,10 +3486,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) { @@ -3529,7 +3587,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; } @@ -3616,9 +3674,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. @@ -3998,7 +4058,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); @@ -4992,13 +5052,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; } @@ -5060,11 +5116,22 @@ Perl_sv_clear(pTHX_ register SV *sv) /* 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 { @@ -5138,6 +5205,9 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; + case SVt_REGEXP: + ReREFCNT_dec(((struct xregexp *)SvANY(sv))->xrx_regexp); + goto freescalar; case SVt_PVCV: case SVt_PVFM: cv_undef((CV*)sv); @@ -5188,7 +5258,6 @@ Perl_sv_clear(pTHX_ register SV *sv) /* 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)) @@ -5388,7 +5457,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; @@ -7050,11 +7119,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 */ @@ -7207,7 +7276,7 @@ Perl_newSVuv(pTHX_ UV u) /* =for apidoc newSV_type -Creates a new SV, of the type specificied. The reference count for the new SV +Creates a new SV, of the type specified. The reference count for the new SV is set to 1. =cut @@ -7236,7 +7305,7 @@ SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { dVAR; - register SV *sv = newSV_type(SVt_RV); + register SV *sv = newSV_type(SVt_IV); SvTEMP_off(tmpRef); SvRV_set(sv, tmpRef); SvROK_on(sv); @@ -7598,7 +7667,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); @@ -7612,7 +7682,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 */ @@ -7680,7 +7750,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: @@ -7704,6 +7773,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"; /* FIXME? to "REGEXP" */ default: return "UNKNOWN"; } } @@ -7791,15 +7861,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); @@ -7942,6 +8008,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)) { @@ -8592,10 +8660,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; @@ -8615,13 +8684,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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), @@ -9185,7 +9247,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV : 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) */ @@ -9486,7 +9550,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. @@ -9959,10 +10023,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); } } @@ -9985,10 +10046,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); } } @@ -10018,8 +10079,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; } @@ -10029,16 +10089,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: { @@ -10063,6 +10123,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: @@ -10117,6 +10178,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVMG: break; + case SVt_REGEXP: + ((struct xregexp *)SvANY(dstr))->xrx_regexp + = CALLREGDUPE(((struct xregexp *)SvANY(dstr))->xrx_regexp, + param); + break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ @@ -10897,6 +10963,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); @@ -10931,6 +10998,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); @@ -11136,7 +11204,6 @@ 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_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ @@ -11157,7 +11224,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sub_generation = proto_perl->Isub_generation; PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); - PL_delayedisa = hv_dup_inc(proto_perl->Idelayedisa, param); /* funky return mechanisms */ PL_forkprocess = proto_perl->Iforkprocess; @@ -11260,11 +11326,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_runops = proto_perl->Irunops; -#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_subline = proto_perl->Isubline; @@ -11341,6 +11402,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_destroyhook = proto_perl->Idestroyhook; #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; @@ -11454,7 +11516,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Sv = NULL; PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Ina; + my_perl->Ina = proto_perl->Ina; PL_statbuf = proto_perl->Istatbuf; PL_statcache = proto_perl->Istatcache; @@ -12064,10 +12126,23 @@ 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))