X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9fd2152b911b1c311a72e55728050bfa2fc67ca6..ba88ff58c874dab4a59e79f78f1a38a1bf872cbc:/sv.c diff --git a/sv.c b/sv.c index 207b759..3736ba8 100644 --- a/sv.c +++ b/sv.c @@ -477,7 +477,7 @@ do_clean_objs(pTHX_ SV *const ref) } else { SvROK_off(ref); SvRV_set(ref, NULL); - SvREFCNT_dec(target); + SvREFCNT_dec_NN(target); } } } @@ -505,27 +505,27 @@ do_clean_named_objs(pTHX_ SV *const sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob SV object:\n "), sv_dump(obj))); GvSV(sv) = NULL; - SvREFCNT_dec(obj); + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob AV object:\n "), sv_dump(obj))); GvAV(sv) = NULL; - SvREFCNT_dec(obj); + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob HV object:\n "), sv_dump(obj))); GvHV(sv) = NULL; - SvREFCNT_dec(obj); + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob CV object:\n "), sv_dump(obj))); GvCV_set(sv, NULL); - SvREFCNT_dec(obj); + SvREFCNT_dec_NN(obj); } - SvREFCNT_dec(sv); /* undo the inc above */ + SvREFCNT_dec_NN(sv); /* undo the inc above */ } /* clear any IO slots in a GV which hold objects (except stderr, defout); @@ -546,9 +546,9 @@ do_clean_named_io_objs(pTHX_ SV *const sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob IO object:\n "), sv_dump(obj))); GvIOp(sv) = NULL; - SvREFCNT_dec(obj); + SvREFCNT_dec_NN(obj); } - SvREFCNT_dec(sv); /* undo the inc above */ + SvREFCNT_dec_NN(sv); /* undo the inc above */ } /* Void wrapper to pass to visit() */ @@ -607,7 +607,7 @@ do_clean_all(pTHX_ SV *const sv) } DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } /* @@ -1246,12 +1246,12 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) assert(!SvPAD_TYPED(sv)); break; default: - if (old_type_details->cant_upgrade) + if (UNLIKELY(old_type_details->cant_upgrade)) 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) + if (UNLIKELY(old_type > new_type)) Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", (int)old_type, (int)new_type); @@ -1386,7 +1386,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) SvNV_set(sv, 0); #endif - if (new_type == SVt_PVIO) { + if (UNLIKELY(new_type == SVt_PVIO)) { IO * const io = MUTABLE_IO(sv); GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); @@ -1399,7 +1399,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; } - if (new_type == SVt_REGEXP) + if (UNLIKELY(new_type == SVt_REGEXP)) sv->sv_u.svu_rx = (regexp *)new_body; else if (old_type < SVt_PV) { /* referant will be NULL unless the old type was SVt_IV emulating @@ -3741,7 +3741,7 @@ static void S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) { SV * const sref = SvRV(sstr); - SV *dref = NULL; + SV *dref; const int intro = GvINTRO(dstr); SV **location; U8 import_flag = 0; @@ -3787,10 +3787,26 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) GvCVGEN(dstr) = 0; /* Switch off cacheness. */ } } - SAVEGENERICSV(*location); - } - else - dref = *location; + /* SAVEt_GVSLOT takes more room on the savestack and has more + overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs + leave_scope needs access to the GV so it can reset method + caches. We must use SAVEt_GVSLOT whenever the type is + SVt_PVCV, even if the stash is anonymous, as the stash may + gain a name somehow before leave_scope. */ + if (stype == SVt_PVCV) { + /* There is no save_pushptrptrptr. Creating it for this + one call site would be overkill. So inline the ss add + routines here. */ + dSS_ADD; + SS_ADD_PTR(dstr); + SS_ADD_PTR(location); + SS_ADD_PTR(SvREFCNT_inc(*location)); + SS_ADD_UV(SAVEt_GVSLOT); + SS_ADD_END(4); + } + else SAVEGENERICSV(*location); + } + dref = *location; if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { CV* const cv = MUTABLE_CV(*location); if (cv) { @@ -3824,7 +3840,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - if(GvSTASH(dstr)) mro_method_changed_in(GvSTASH(dstr)); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if(GvSTASH(dstr)) gv_method_changed(dstr); /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ } *location = SvREFCNT_inc_simple_NN(sref); if (import_flag && !(GvFLAGS(dstr) & import_flag) @@ -3907,7 +3923,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) } break; } - SvREFCNT_dec(dref); + if (!intro) SvREFCNT_dec(dref); if (SvTAINTED(sstr)) SvTAINT(dstr); return; @@ -4257,10 +4273,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) #ifdef PERL_ANY_COW && ((flags & SV_COW_SHARED_HASH_KEYS) ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS # ifdef PERL_OLD_COPY_ON_WRITE + && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS && SvTYPE(sstr) >= SVt_PVIV # else + && !(SvFLAGS(dstr) & SVf_BREAK) && !(sflags & SVf_IsCOW) && GE_COW_THRESHOLD(cur) && cur+1 < len && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1) @@ -4931,7 +4948,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) SvANY(temp) = temp_p; temp->sv_u.svu_rx = (regexp *)temp_p; - SvREFCNT_dec(temp); + SvREFCNT_dec_NN(temp); } else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); } @@ -5522,7 +5539,7 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) tsv = SvRV(sv); Perl_sv_add_backref(aTHX_ tsv, sv); SvWEAKREF_on(sv); - SvREFCNT_dec(tsv); + SvREFCNT_dec_NN(tsv); return sv; } @@ -5818,7 +5835,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) } if (is_array) { AvFILLp(av) = -1; - SvREFCNT_dec(av); /* remove extra count added by sv_add_backref() */ + SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ } return; } @@ -6035,7 +6052,7 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) : newSVpvn_flags( "__ANON__", 8, 0 ); sv_catpvs(gvname, "::__ANON__"); anongv = gv_fetchsv(gvname, GV_ADDMULTI, SVt_PVCV); - SvREFCNT_dec(gvname); + SvREFCNT_dec_NN(gvname); CvANON_on(cv); CvCVGV_RC_on(cv); @@ -6240,6 +6257,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) PL_last_in_gv = NULL; else if ((const GV *)sv == PL_statgv) PL_statgv = NULL; + else if ((const GV *)sv == PL_stderrgv) + PL_stderrgv = NULL; case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -6392,9 +6411,9 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) continue; } #endif - if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + if (SvIMMORTAL(sv)) { /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = (~(U32)0)/2; + SvREFCNT(sv) = SvREFCNT_IMMORTAL; continue; } break; @@ -6471,7 +6490,7 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { SvRV_set(tmpref, NULL); SvROK_off(tmpref); } - SvREFCNT_dec(tmpref); + SvREFCNT_dec_NN(tmpref); } } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); @@ -6494,8 +6513,6 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { SvOBJECT_off(sv); /* Curse the object. */ SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ SvREFCNT_dec(stash); /* possibly of changed persuasion */ - if (SvTYPE(sv) != SVt_PVIO) - --PL_sv_objcount;/* XXX Might want something more general */ } return TRUE; } @@ -6532,76 +6549,85 @@ Normally called via a wrapper macro C. void Perl_sv_free(pTHX_ SV *const sv) { - dVAR; - if (!sv) - return; - if (SvREFCNT(sv) == 0) { - if (SvFLAGS(sv) & SVf_BREAK) - /* this SV's refcnt has been artificially decremented to - * trigger cleanup */ - return; - if (PL_in_clean_all) /* All is fair */ - return; - if (SvREADONLY(sv) && SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = (~(U32)0)/2; - 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); -#endif - } -#ifdef DEBUG_LEAKING_SCALARS_ABORT - abort(); -#endif - return; - } - if (--(SvREFCNT(sv)) > 0) - return; - Perl_sv_free2(aTHX_ sv); + SvREFCNT_dec(sv); } + +/* Private helper function for SvREFCNT_dec(). + * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */ + void -Perl_sv_free2(pTHX_ SV *const sv) +Perl_sv_free2(pTHX_ SV *const sv, const U32 rc) { dVAR; PERL_ARGS_ASSERT_SV_FREE2; + if (rc == 1) { + /* normal case */ + SvREFCNT(sv) = 0; + #ifdef DEBUGGING - if (SvTEMP(sv)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), - "Attempt to free temp prematurely: SV 0x%"UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); - return; + if (SvTEMP(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + return; + } +#endif + if (SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = SvREFCNT_IMMORTAL; + return; + } + sv_clear(sv); + if (! SvREFCNT(sv)) /* may have have been resurrected */ + del_SV(sv); + return; } + + /* handle exceptional cases */ + + assert(rc == 0); + + if (SvFLAGS(sv) & SVf_BREAK) + /* this SV's refcnt has been artificially decremented to + * trigger cleanup */ + return; + if (PL_in_clean_all) /* All is fair */ + return; + if (SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = SvREFCNT_IMMORTAL; + 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); #endif - if (SvREADONLY(sv) && SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = (~(U32)0)/2; - return; } - sv_clear(sv); - if (! SvREFCNT(sv)) - del_SV(sv); +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif + } + /* =for apidoc sv_len @@ -7353,7 +7379,7 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) } /* Now both are in UTF-8. */ if (cur1 != cur2) { - SvREFCNT_dec(svrecode); + SvREFCNT_dec_NN(svrecode); return FALSE; } } @@ -7411,7 +7437,6 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, dVAR; STRLEN cur1, cur2; const char *pv1, *pv2; - char *tpv = NULL; I32 cmp; SV *svrecode = NULL; @@ -7475,8 +7500,6 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, } SvREFCNT_dec(svrecode); - if (tpv) - Safefree(tpv); return cmp; } @@ -7641,29 +7664,111 @@ S_sv_gets_append_to_utf8(pTHX_ SV *const sv, PerlIO *const fp, I32 append) static char * S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) { - I32 bytesread; - const U32 recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ + SSize_t bytesread; + const STRLEN recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ /* Grab the size of the record we're getting */ - char *const buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; + char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append; + + /* Go yank in */ #ifdef VMS +#include int fd; -#endif + Stat_t st; - /* Go yank in */ -#ifdef VMS - /* VMS wants read instead of fread, because fread doesn't respect */ - /* RMS record boundaries. This is not necessarily a good thing to be */ - /* doing, but we've got no other real choice - except avoid stdio - as implementation - perhaps write a :vms layer ? - */ + /* With a true, record-oriented file on VMS, we need to use read directly + * to ensure that we respect RMS record boundaries. The user is responsible + * for providing a PL_rs value that corresponds to the FAB$W_MRS (maximum + * record size) field. N.B. This is likely to produce invalid results on + * varying-width character data when a record ends mid-character. + */ fd = PerlIO_fileno(fp); - if (fd != -1) { + if (fd != -1 + && PerlLIO_fstat(fd, &st) == 0 + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC + || st.st_fab_rfm == FAB$C_FIX)) { + bytesread = PerlLIO_read(fd, buffer, recsize); } - else /* in-memory file from PerlIO::Scalar */ + else /* in-memory file from PerlIO::Scalar + * or not a record-oriented file + */ #endif { bytesread = PerlIO_read(fp, buffer, recsize); + + /* At this point, the logic in sv_get() means that sv will + be treated as utf-8 if the handle is utf8. + */ + if (PerlIO_isutf8(fp) && bytesread > 0) { + char *bend = buffer + bytesread; + char *bufp = buffer; + size_t charcount = 0; + bool charstart = TRUE; + STRLEN skip = 0; + + while (charcount < recsize) { + /* count accumulated characters */ + while (bufp < bend) { + if (charstart) { + skip = UTF8SKIP(bufp); + } + if (bufp + skip > bend) { + /* partial at the end */ + charstart = FALSE; + break; + } + else { + ++charcount; + bufp += skip; + charstart = TRUE; + } + } + + if (charcount < recsize) { + STRLEN readsize; + STRLEN bufp_offset = bufp - buffer; + SSize_t morebytesread; + + /* originally I read enough to fill any incomplete + character and the first byte of the next + character if needed, but if there's many + multi-byte encoded characters we're going to be + making a read call for every character beyond + the original read size. + + So instead, read the rest of the character if + any, and enough bytes to match at least the + start bytes for each character we're going to + read. + */ + if (charstart) + readsize = recsize - charcount; + else + readsize = skip - (bend - bufp) + recsize - charcount - 1; + buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; + bend = buffer + bytesread; + morebytesread = PerlIO_read(fp, bend, readsize); + if (morebytesread <= 0) { + /* we're done, if we still have incomplete + characters the check code in sv_gets() will + warn about them. + + I'd originally considered doing + PerlIO_ungetc() on all but the lead + character of the incomplete character, but + read() doesn't do that, so I don't. + */ + break; + } + + /* prepare to scan some more */ + bytesread += morebytesread; + bend = buffer + bytesread; + bufp = buffer + bufp_offset; + } + } + } } if (bytesread < 0) @@ -8464,7 +8569,7 @@ Perl_sv_2mortal(pTHX_ SV *const sv) dVAR; if (!sv) return NULL; - if (SvREADONLY(sv) && SvIMMORTAL(sv)) + if (SvIMMORTAL(sv)) return sv; PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); @@ -8587,7 +8692,8 @@ Perl_newSVhek(pTHX_ const HEK *const 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. If the C parameter +created first. Turns on the SvIsCOW flag (or READONLY +and FAKE in 5.16 and earlier). If the C parameter is non-zero, that value is used; otherwise the hash is computed. The string's hash can later be retrieved from the SV with the C macro. The idea here is @@ -9394,10 +9500,10 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name) /* =for apidoc newSVrv -Creates a new SV for the RV, C, to point to. If C is not an RV then -it will be upgraded to one. If C is non-null then the new SV will -be blessed in the specified package. The new SV is returned and its -reference count is 1. +Creates a new SV for the existing RV, C, to point to. If C is not an +RV then it will be upgraded to one. If C is non-null then the new +SV will be blessed in the specified package. The new SV is returned and its +reference count is 1. The reference count 1 is owned by C. =cut */ @@ -9586,14 +9692,10 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef)) Perl_croak_no_modify(); if (SvOBJECT(tmpRef)) { - if (SvTYPE(tmpRef) != SVt_PVIO) - --PL_sv_objcount; SvREFCNT_dec(SvSTASH(tmpRef)); } } SvOBJECT_on(tmpRef); - if (SvTYPE(tmpRef) != SVt_PVIO) - ++PL_sv_objcount; SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); @@ -9695,7 +9797,7 @@ Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was assigned to as BEGIN {$a = \"Foo"} will fail. */ if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) - SvREFCNT_dec(target); + SvREFCNT_dec_NN(target); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ sv_2mortal(target); /* Schedule for freeing later */ } @@ -11223,13 +11325,13 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p have = esignlen + zeros + elen; if (have < zeros) - croak_memory_wrap(); + Perl_croak_memory_wrap(); need = (have > width ? have : width); gap = need - have; if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) - croak_memory_wrap(); + Perl_croak_memory_wrap(); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -12329,9 +12431,6 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) } } - if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) - ++PL_sv_objcount; - return dstr; } @@ -12610,6 +12709,14 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ break; + case SAVEt_GVSLOT: /* any slot in GV */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ sv = (const SV *) POPPTR(ss,ix); @@ -13020,7 +13127,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Zero(&PL_body_roots, 1, PL_body_roots); PL_sv_count = 0; - PL_sv_objcount = 0; PL_sv_root = NULL; PL_sv_arenaroot = NULL; @@ -13056,7 +13162,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_minus_F = proto_perl->Iminus_F; PL_doswitches = proto_perl->Idoswitches; PL_dowarn = proto_perl->Idowarn; +#ifdef PERL_SAWAMPERSAND PL_sawampersand = proto_perl->Isawampersand; +#endif PL_unsafe = proto_perl->Iunsafe; PL_perldb = proto_perl->Iperldb; PL_perl_destruct_level = proto_perl->Iperl_destruct_level; @@ -13179,7 +13287,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_last_swash_tmps = (U8*)NULL; PL_last_swash_slen = 0; - PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; if (flags & CLONEf_COPY_STACKS) { @@ -13470,67 +13577,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_ASCII = sv_dup_inc(proto_perl->IASCII, param); PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); - PL_PerlSpace = sv_dup_inc(proto_perl->IPerlSpace, param); - PL_XPerlSpace = sv_dup_inc(proto_perl->IXPerlSpace, param); - - PL_L1PosixAlnum = sv_dup_inc(proto_perl->IL1PosixAlnum, param); - PL_PosixAlnum = sv_dup_inc(proto_perl->IPosixAlnum, param); - - PL_L1PosixAlpha = sv_dup_inc(proto_perl->IL1PosixAlpha, param); - PL_PosixAlpha = sv_dup_inc(proto_perl->IPosixAlpha, param); - - PL_PosixBlank = sv_dup_inc(proto_perl->IPosixBlank, param); - PL_XPosixBlank = sv_dup_inc(proto_perl->IXPosixBlank, param); - - PL_L1Cased = sv_dup_inc(proto_perl->IL1Cased, param); - - PL_PosixCntrl = sv_dup_inc(proto_perl->IPosixCntrl, param); - PL_XPosixCntrl = sv_dup_inc(proto_perl->IXPosixCntrl, param); - - PL_PosixDigit = sv_dup_inc(proto_perl->IPosixDigit, param); - - PL_L1PosixGraph = sv_dup_inc(proto_perl->IL1PosixGraph, param); - PL_PosixGraph = sv_dup_inc(proto_perl->IPosixGraph, param); - - PL_L1PosixLower = sv_dup_inc(proto_perl->IL1PosixLower, param); - PL_PosixLower = sv_dup_inc(proto_perl->IPosixLower, param); - - PL_L1PosixPrint = sv_dup_inc(proto_perl->IL1PosixPrint, param); - PL_PosixPrint = sv_dup_inc(proto_perl->IPosixPrint, param); - - PL_L1PosixPunct = sv_dup_inc(proto_perl->IL1PosixPunct, param); - PL_PosixPunct = sv_dup_inc(proto_perl->IPosixPunct, param); - - PL_PosixSpace = sv_dup_inc(proto_perl->IPosixSpace, param); - PL_XPosixSpace = sv_dup_inc(proto_perl->IXPosixSpace, param); - - PL_L1PosixUpper = sv_dup_inc(proto_perl->IL1PosixUpper, param); - PL_PosixUpper = sv_dup_inc(proto_perl->IPosixUpper, param); - - PL_L1PosixWord = sv_dup_inc(proto_perl->IL1PosixWord, param); - PL_PosixWord = sv_dup_inc(proto_perl->IPosixWord, param); - - PL_PosixXDigit = sv_dup_inc(proto_perl->IPosixXDigit, param); - PL_XPosixXDigit = sv_dup_inc(proto_perl->IXPosixXDigit, param); - - PL_VertSpace = sv_dup_inc(proto_perl->IVertSpace, param); - PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param); PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param); /* utf8 character class swashes */ - PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); - PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); - PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); - PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); - PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); - PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); - PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); - PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); + for (i = 0; i < POSIX_SWASH_COUNT; i++) { + PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param); + } + for (i = 0; i < POSIX_CC_COUNT; i++) { + PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param); + PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param); + PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); + } PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param); PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); - PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param); PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); @@ -13538,6 +13599,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param); + PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param); PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); PL_utf8_foldable = sv_dup_inc(proto_perl->Iutf8_foldable, param); @@ -13728,7 +13790,7 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) } while (++svp <= last); AvREAL_off(unreferenced); } - SvREFCNT_dec(unreferenced); + SvREFCNT_dec_NN(unreferenced); } void @@ -13795,18 +13857,18 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) void Perl_init_constants(pTHX) { - SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; + SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; SvANY(&PL_sv_undef) = NULL; SvANY(&PL_sv_no) = new_XPVNV(); - SvREFCNT(&PL_sv_no) = (~(U32)0)/2; + SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK; SvANY(&PL_sv_yes) = new_XPVNV(); - SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; + SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK |SVp_POK|SVf_POK; @@ -14077,7 +14139,7 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, Perl_sv_catpvf(aTHX_ name, "{%s}", pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL, PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); } else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { *SvPVX(name) = '$';