X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d016601746b09e0f0a7eb2148b6eb594d3992339..b6ba113734f2321504b9a5e58f1b107f427927a3:/mg.c diff --git a/mg.c b/mg.c index 5eca2e51..0cb6052 100644 --- a/mg.c +++ b/mg.c @@ -76,6 +76,7 @@ void setegid(uid_t id); #endif /* + * Pre-magic setup and post-magic takedown. * Use the "DESTRUCTOR" scope cleanup to reinstate magic. */ @@ -84,6 +85,7 @@ struct magic_state { I32 mgs_ss_ix; U32 mgs_magical; bool mgs_readonly; + bool mgs_bumped; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -92,29 +94,36 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { dVAR; MGS* mgs; + bool bumped = FALSE; PERL_ARGS_ASSERT_SAVE_MAGIC; assert(SvMAGICAL(sv)); - /* Turning READONLY off for a copy-on-write scalar (including shared - hash keys) is a bad idea. */ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); + + /* we shouldn't really be called here with RC==0, but it can sometimes + * happen via mg_clear() (which also shouldn't be called when RC==0, + * but it can happen). Handle this case gracefully(ish) by not RC++ + * and thus avoiding the resultant double free */ + if (SvREFCNT(sv) > 0) { + /* guard against sv getting freed midway through the mg clearing, + * by holding a private reference for the duration. */ + SvREFCNT_inc_simple_void_NN(sv); + bumped = TRUE; + } SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; mgs->mgs_magical = SvMAGICAL(sv); - mgs->mgs_readonly = SvREADONLY(sv) != 0; + mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv); mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ + mgs->mgs_bumped = bumped; SvMAGICAL_off(sv); - SvREADONLY_off(sv); - if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) { - /* No public flags are set, so promote any private flags to public. */ - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - } + /* Turning READONLY off for a copy-on-write scalar (including shared + hash keys) is a bad idea. */ + if (!SvIsCOW(sv)) SvREADONLY_off(sv); } /* @@ -150,45 +159,10 @@ Perl_mg_magical(pTHX_ SV *sv) } } - -/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */ - -STATIC bool -S_is_container_magic(const MAGIC *mg) -{ - assert(mg); - switch (mg->mg_type) { - case PERL_MAGIC_bm: - case PERL_MAGIC_fm: - case PERL_MAGIC_regex_global: - case PERL_MAGIC_nkeys: -#ifdef USE_LOCALE_COLLATE - case PERL_MAGIC_collxfrm: -#endif - case PERL_MAGIC_qr: - case PERL_MAGIC_taint: - case PERL_MAGIC_vec: - case PERL_MAGIC_vstring: - case PERL_MAGIC_utf8: - case PERL_MAGIC_substr: - case PERL_MAGIC_defelem: - case PERL_MAGIC_arylen: - case PERL_MAGIC_pos: - case PERL_MAGIC_backref: - case PERL_MAGIC_arylen_p: - case PERL_MAGIC_rhash: - case PERL_MAGIC_symtab: - case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */ - return 0; - default: - return 1; - } -} - /* =for apidoc mg_get -Do magic after a value is retrieved from the SV. See C. +Do magic before a value is retrieved from the SV. See C. =cut */ @@ -198,24 +172,13 @@ Perl_mg_get(pTHX_ SV *sv) { dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); - const bool was_temp = cBOOL(SvTEMP(sv)); + bool saved = FALSE; bool have_new = 0; MAGIC *newmg, *head, *cur, *mg; - /* guard against sv having being freed midway by holding a private - reference. */ PERL_ARGS_ASSERT_MG_GET; - /* sv_2mortal has this side effect of turning on the TEMP flag, which can - cause the SV's buffer to get stolen (and maybe other stuff). - So restore it. - */ - sv_2mortal(SvREFCNT_inc_simple_NN(sv)); - if (!was_temp) { - SvTEMP_off(sv); - } - - save_magic(mgs_ix, sv); + if (PL_localizing == 1 && sv == DEFSV) return 0; /* We must call svt_get(sv, mg) for each valid entry in the linked list of magic. svt_get() may delete the current entry, add new @@ -227,7 +190,14 @@ Perl_mg_get(pTHX_ SV *sv) MAGIC * const nextmg = mg->mg_moremagic; /* it may delete itself */ if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { - CALL_FPTR(vtbl->svt_get)(aTHX_ sv, mg); + + /* taint's mg get is so dumb it doesn't need flag saving */ + if (!saved && mg->mg_type != PERL_MAGIC_taint) { + save_magic(mgs_ix, sv); + saved = TRUE; + } + + vtbl->svt_get(aTHX_ sv, mg); /* guard against magic having been deleted - eg FETCH calling * untie */ @@ -240,6 +210,10 @@ Perl_mg_get(pTHX_ SV *sv) if (mg->mg_flags & MGf_GSKIP) (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; } + else if (vtbl == &PL_vtbl_utf8) { + /* get-magic can reallocate the PV */ + magic_setutf8(sv, mg); + } mg = nextmg; @@ -262,13 +236,9 @@ Perl_mg_get(pTHX_ SV *sv) } } - restore_magic(INT2PTR(void *, (IV)mgs_ix)); + if (saved) + restore_magic(INT2PTR(void *, (IV)mgs_ix)); - if (SvREFCNT(sv) == 1) { - /* We hold the last reference to this SV, which implies that the - SV was deleted as a side effect of the routines we called. */ - SvOK_off(sv); - } return 0; } @@ -290,6 +260,8 @@ Perl_mg_set(pTHX_ SV *sv) PERL_ARGS_ASSERT_MG_SET; + if (PL_localizing == 2 && sv == DEFSV) return 0; + save_magic(mgs_ix, sv); for (mg = SvMAGIC(sv); mg; mg = nextmg) { @@ -299,10 +271,11 @@ Perl_mg_set(pTHX_ SV *sv) mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; } - if (PL_localizing == 2 && !S_is_container_magic(mg)) + if (PL_localizing == 2 + && PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) continue; if (vtbl && vtbl->svt_set) - CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg); + vtbl->svt_set(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); @@ -312,7 +285,13 @@ Perl_mg_set(pTHX_ SV *sv) /* =for apidoc mg_length -Report on the SV's length. See C. +This function is deprecated. + +It reports on the SV's length in bytes, calling length magic if available, +but does not set the UTF8 flag on the sv. It will fall back to 'get' +magic if there is no 'length' magic, but with no indication as to +whether it called 'get' magic. It assumes the sv is a PVMG or +higher. Use sv_len() instead. =cut */ @@ -332,21 +311,13 @@ Perl_mg_length(pTHX_ SV *sv) const I32 mgs_ix = SSNEW(sizeof(MGS)); save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ - len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); + len = vtbl->svt_len(aTHX_ sv, mg); restore_magic(INT2PTR(void*, (IV)mgs_ix)); return len; } } - { - /* You can't know whether it's UTF-8 until you get the string again... - */ - const U8 *s = (U8*)SvPV_const(sv, len); - - if (DO_UTF8(sv)) { - len = utf8_length(s, s + len); - } - } + (void)SvPV_const(sv, len); return len; } @@ -364,7 +335,7 @@ Perl_mg_size(pTHX_ SV *sv) I32 len; save_magic(mgs_ix, sv); /* omit MGf_GSKIP -- not changed here */ - len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg); + len = vtbl->svt_len(aTHX_ sv, mg); restore_magic(INT2PTR(void*, (IV)mgs_ix)); return len; } @@ -408,13 +379,33 @@ Perl_mg_clear(pTHX_ SV *sv) nextmg = mg->mg_moremagic; /* it may delete itself */ if (vtbl && vtbl->svt_clear) - CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg); + vtbl->svt_clear(aTHX_ sv, mg); } restore_magic(INT2PTR(void*, (IV)mgs_ix)); return 0; } +static MAGIC* +S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags) +{ + PERL_UNUSED_CONTEXT; + + assert(flags <= 1); + + if (sv) { + MAGIC *mg; + + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + if (mg->mg_type == type && (!flags || mg->mg_virtual == vtbl)) { + return mg; + } + } + } + + return NULL; +} + /* =for apidoc mg_find @@ -426,15 +417,22 @@ Finds the magic pointer for type matching the SV. See C. MAGIC* Perl_mg_find(pTHX_ const SV *sv, int type) { - PERL_UNUSED_CONTEXT; - if (sv) { - MAGIC *mg; - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - if (mg->mg_type == type) - return mg; - } - } - return NULL; + return S_mg_findext_flags(aTHX_ sv, type, NULL, 0); +} + +/* +=for apidoc mg_findext + +Finds the magic pointer of C with the given C for the C. See +C. + +=cut +*/ + +MAGIC* +Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl) +{ + return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1); } /* @@ -456,7 +454,7 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){ - count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen); + count += vtbl->svt_copy(aTHX_ sv, mg, nsv, key, klen); } else { const char type = mg->mg_type; @@ -497,19 +495,22 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) PERL_ARGS_ASSERT_MG_LOCALIZE; + if (nsv == DEFSV) + return; + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if (!S_is_container_magic(mg)) + if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) continue; if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) - (void)CALL_FPTR(vtbl->svt_local)(aTHX_ nsv, mg); + (void)vtbl->svt_local(aTHX_ nsv, mg); else sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl, mg->mg_ptr, mg->mg_len); /* container types should remain read-only across localization */ - SvFLAGS(nsv) |= SvREADONLY(sv); + if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv); } if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { @@ -522,6 +523,24 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) } } +#define mg_free_struct(sv, mg) S_mg_free_struct(aTHX_ sv, mg) +static void +S_mg_free_struct(pTHX_ SV *sv, MAGIC *mg) +{ + const MGVTBL* const vtbl = mg->mg_virtual; + if (vtbl && vtbl->svt_free) + vtbl->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + } + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); +} + /* =for apidoc mg_free @@ -539,19 +558,8 @@ Perl_mg_free(pTHX_ SV *sv) PERL_ARGS_ASSERT_MG_FREE; for (mg = SvMAGIC(sv); mg; mg = moremagic) { - const MGVTBL* const vtbl = mg->mg_virtual; moremagic = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); - } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); + mg_free_struct(sv, mg); SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); @@ -559,6 +567,39 @@ Perl_mg_free(pTHX_ SV *sv) return 0; } +/* +=for apidoc Am|void|mg_free_type|SV *sv|int how + +Remove any magic of type I from the SV I. See L. + +=cut +*/ + +void +Perl_mg_free_type(pTHX_ SV *sv, int how) +{ + MAGIC *mg, *prevmg, *moremg; + PERL_ARGS_ASSERT_MG_FREE_TYPE; + for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { + MAGIC *newhead; + moremg = mg->mg_moremagic; + if (mg->mg_type == how) { + /* temporarily move to the head of the magic chain, in case + custom free code relies on this historical aspect of mg_free */ + if (prevmg) { + prevmg->mg_moremagic = moremg; + mg->mg_moremagic = SvMAGIC(sv); + SvMAGIC_set(sv, mg); + } + newhead = mg->mg_moremagic; + mg_free_struct(sv, mg); + SvMAGIC_set(sv, newhead); + mg = prevmg; + } + } + mg_magical(sv); +} + #include U32 @@ -570,7 +611,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; if (PL_curpm) { - register const REGEXP * const rx = PM_GETRE(PL_curpm); + const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { if (mg->mg_obj) { /* @+ */ /* return the number possible */ @@ -591,6 +632,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) return (U32)-1; } +/* @-, @+ */ + int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { @@ -599,18 +642,18 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; if (PL_curpm) { - register const REGEXP * const rx = PM_GETRE(PL_curpm); + const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - register const I32 paren = mg->mg_len; - register I32 s; - register I32 t; + const I32 paren = mg->mg_len; + I32 s; + I32 t; if (paren < 0) return 0; if (paren <= (I32)RX_NPARENS(rx) && (s = RX_OFFS(rx)[paren].start) != -1 && (t = RX_OFFS(rx)[paren].end) != -1) { - register I32 i; + I32 i; if (mg->mg_obj) /* @+ */ i = t; else /* @- */ @@ -619,7 +662,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (i > 0 && RX_MATCH_UTF8(rx)) { const char * const b = RX_SUBBEG(rx); if (b) - i = utf8_length((U8*)b, (U8*)(b+i)); + i = RX_SUBCOFFSET(rx) + + utf8_length((U8*)b, + (U8*)(b-RX_SUBOFFSET(rx)+i)); } sv_setiv(sv, i); @@ -629,6 +674,8 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) return 0; } +/* @-, @+ */ + int Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) { @@ -639,85 +686,6 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) NORETURN_FUNCTION_END; } -U32 -Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) -{ - dVAR; - register I32 paren; - register I32 i; - register const REGEXP * rx; - const char * const remaining = mg->mg_ptr + 1; - - PERL_ARGS_ASSERT_MAGIC_LEN; - - switch (*mg->mg_ptr) { - case '\020': - if (*remaining == '\0') { /* ^P */ - break; - } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - goto do_prematch; - } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - goto do_postmatch; - } - break; - case '\015': /* $^MATCH */ - if (strEQ(remaining, "ATCH")) { - goto do_match; - } else { - break; - } - case '`': - do_prematch: - paren = RX_BUFF_IDX_PREMATCH; - goto maybegetparen; - case '\'': - do_postmatch: - paren = RX_BUFF_IDX_POSTMATCH; - goto maybegetparen; - case '&': - do_match: - paren = RX_BUFF_IDX_FULLMATCH; - goto maybegetparen; - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - paren = atoi(mg->mg_ptr); - maybegetparen: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - getparen: - i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren); - - if (i < 0) - Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); - return i; - } else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } - case '+': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTPAREN(rx); - if (paren) - goto getparen; - } - return 0; - case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTCLOSEPAREN(rx); - if (paren) - goto getparen; - } - return 0; - } - magic_get(sv,mg); - if (!SvPOK(sv) && SvNIOK(sv)) { - sv_2pv(sv, 0); - } - if (SvPOK(sv)) - return SvCUR(sv); - return 0; -} - #define SvRTRIM(sv) STMT_START { \ if (SvPOK(sv)) { \ STRLEN len = SvCUR(sv); \ @@ -740,30 +708,31 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) sv_setpvs(sv, ""); SvUTF8_off(sv); if ((CopHINTS_get(c) & HINT_LEXICAL_IO_IN)) { - SV *const value = Perl_refcounted_he_fetch(aTHX_ - c->cop_hints_hash, - 0, "open<", 5, 0, 0); + SV *const value = cop_hints_fetch_pvs(c, "open<", 0); assert(value); sv_catsv(sv, value); } sv_catpvs(sv, "\0"); if ((CopHINTS_get(c) & HINT_LEXICAL_IO_OUT)) { - SV *const value = Perl_refcounted_he_fetch(aTHX_ - c->cop_hints_hash, - 0, "open>", 5, 0, 0); + SV *const value = cop_hints_fetch_pvs(c, "open>", 0); assert(value); sv_catsv(sv, value); } } } +#ifdef VMS +#include +#include +#endif + int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { dVAR; - register I32 paren; - register char *s = NULL; - register REGEXP *rx; + I32 paren; + const char *s = NULL; + REGEXP *rx; const char * const remaining = mg->mg_ptr + 1; const char nextchar = *remaining; @@ -771,7 +740,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ - sv_setsv(sv, PL_bodytarget); + if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); + else sv_setsv(sv, &PL_sv_undef); + if (SvTAINTED(PL_bodytarget)) + SvTAINTED_on(sv); break; case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ if (nextchar == '\0') { @@ -789,8 +761,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (nextchar == '\0') { #if defined(VMS) { -# include -# include char msg[255]; $DESCRIPTOR(msgdsc,msg); sv_setnv(sv,(NV) vaxc$errno); @@ -840,12 +810,32 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\006': /* ^F */ sv_setiv(sv, (IV)PL_maxsysfd); break; + case '\007': /* ^GLOBAL_PHASE */ + if (strEQ(remaining, "LOBAL_PHASE")) { + sv_setpvn(sv, PL_phase_names[PL_phase], + strlen(PL_phase_names[PL_phase])); + } + break; case '\010': /* ^H */ sv_setiv(sv, (IV)PL_hints); break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ break; + case '\014': /* ^LAST_FH */ + if (strEQ(remaining, "AST_FH")) { + if (PL_last_in_gv) { + assert(isGV_with_GP(PL_last_in_gv)); + SV_CHECK_THINKFIRST_COW_DROP(sv); + prepare_SV_for_RV(sv); + SvOK_off(sv); + SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); + SvROK_on(sv); + sv_rvweaken(sv); + } + else sv_setsv_nomg(sv, NULL); + } + break; case '\017': /* ^O & ^OPEN */ if (nextchar == '\0') { sv_setpv(sv, PL_osname); @@ -855,13 +845,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); } break; - case '\020': + case '\020': if (nextchar == '\0') { /* ^P */ sv_setiv(sv, (IV)PL_perldb); } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - goto do_prematch_fetch; + + paren = RX_BUFF_IDX_CARET_PREMATCH; + goto do_numbuf_fetch; } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - goto do_postmatch_fetch; + paren = RX_BUFF_IDX_CARET_POSTMATCH; + goto do_numbuf_fetch; } break; case '\023': /* ^S */ @@ -883,8 +876,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(remaining, "AINT")) - sv_setiv(sv, PL_tainting - ? (PL_taint_warn || PL_unsafe ? -1 : 1) + sv_setiv(sv, TAINTING_get + ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) : 0); break; case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ @@ -903,83 +896,67 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_STD) { - sv_setpvn( - sv, - (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring, - WARNsize - ); + sv_setsv(sv, &PL_sv_undef); + break; } else if (PL_compiling.cop_warnings == pWARN_ALL) { /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ - HV * const bits=get_hv("warnings::Bits", 0); - if (bits) { - SV ** const bits_all = hv_fetchs(bits, "all", FALSE); - if (bits_all) - sv_setsv(sv, *bits_all); - } - else { - sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - } + HV * const bits = get_hv("warnings::Bits", 0); + SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL; + if (bits_all) + sv_copypv(sv, *bits_all); + else + sv_setpvn(sv, WARN_ALLstring, WARNsize); } else { sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1), *PL_compiling.cop_warnings); } - SvPOK_only(sv); } break; case '\015': /* $^MATCH */ if (strEQ(remaining, "ATCH")) { + paren = RX_BUFF_IDX_CARET_FULLMATCH; + goto do_numbuf_fetch; + } + case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - /* - * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj)); - * XXX Does the new way break anything? - */ - paren = atoi(mg->mg_ptr); /* $& is in [0] */ - CALLREG_NUMBUF_FETCH(rx,paren,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - } + /* + * Pre-threads, this was paren = atoi(GvENAME((const GV *)mg->mg_obj)); + * XXX Does the new way break anything? + */ + paren = atoi(mg->mg_ptr); /* $& is in [0] */ + do_numbuf_fetch: + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + CALLREG_NUMBUF_FETCH(rx,paren,sv); + break; + } + sv_setsv(sv,&PL_sv_undef); break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (RX_LASTPAREN(rx)) { - CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv); - break; - } + paren = RX_LASTPAREN(rx); + if (paren) + goto do_numbuf_fetch; } sv_setsv(sv,&PL_sv_undef); break; case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (RX_LASTCLOSEPAREN(rx)) { - CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv); - break; - } - + paren = RX_LASTCLOSEPAREN(rx); + if (paren) + goto do_numbuf_fetch; } sv_setsv(sv,&PL_sv_undef); break; case '`': - do_prematch_fetch: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF_FETCH(rx,-2,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - break; + paren = RX_BUFF_IDX_PREMATCH; + goto do_numbuf_fetch; case '\'': - do_postmatch_fetch: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF_FETCH(rx,-1,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - break; + paren = RX_BUFF_IDX_POSTMATCH; + goto do_numbuf_fetch; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -996,9 +973,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '^': - if (!isGV_with_GP(PL_defoutgv)) - s = ""; - else if (GvIOp(PL_defoutgv)) + if (GvIOp(PL_defoutgv)) s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); @@ -1008,9 +983,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - if (!isGV_with_GP(PL_defoutgv)) - s = ""; - else if (GvIOp(PL_defoutgv)) + if (GvIOp(PL_defoutgv)) s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); @@ -1033,7 +1006,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '/': break; case '[': - sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)); + sv_setiv(sv, 0); break; case '|': if (GvIO(PL_defoutgv)) @@ -1042,7 +1015,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\\': if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); + else + sv_setsv(sv, &PL_sv_undef); break; + case '$': /* $$ */ + { + IV const pid = (IV)PerlProc_getpid(); + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) { + /* never set manually, or at least not since last fork */ + sv_setiv(sv, pid); + /* never unsafe, even if reading in a tainted expression */ + SvTAINTED_off(sv); + } + /* else a value has been assigned manually, so do nothing */ + } + break; + case '!': { dSAVE_ERRNO; @@ -1057,8 +1045,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); - if (SvPOKp(sv)) - SvPOK_on(sv); /* may have got removed during taint processing */ RESTORE_ERRNO; } @@ -1066,16 +1052,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvNOK_on(sv); /* what a wonderful hack! */ break; case '<': - sv_setiv(sv, (IV)PL_uid); + sv_setiv(sv, (IV)PerlProc_getuid()); break; case '>': - sv_setiv(sv, (IV)PL_euid); + sv_setiv(sv, (IV)PerlProc_geteuid()); break; case '(': - sv_setiv(sv, (IV)PL_gid); + sv_setiv(sv, (IV)PerlProc_getgid()); goto add_groups; case ')': - sv_setiv(sv, (IV)PL_egid); + sv_setiv(sv, (IV)PerlProc_getegid()); add_groups: #ifdef HAS_GETGROUPS { @@ -1113,17 +1099,31 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) { dVAR; STRLEN len = 0, klen; - const char *s = SvOK(sv) ? SvPV_const(sv,len) : ""; - const char * const ptr = MgPV_const(mg,klen); - my_setenv(ptr, s); + const char * const key = MgPV_const(mg,klen); + const char *s = NULL; PERL_ARGS_ASSERT_MAGIC_SETENV; + SvGETMAGIC(sv); + if (SvOK(sv)) { + /* defined environment variables are byte strings; unfortunately + there is no SvPVbyte_force_nomg(), so we must do this piecewise */ + (void)SvPV_force_nomg_nolen(sv); + sv_utf8_downgrade(sv, /* fail_ok */ TRUE); + if (SvUTF8(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); + SvUTF8_off(sv); + } + s = SvPVX(sv); + len = SvCUR(sv); + } + my_setenv(key, s); /* does the deed */ + #ifdef DYNAMIC_ENV_FETCH /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { - SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE); + SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); if (valp) s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; } @@ -1132,12 +1132,11 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ - if (PL_tainting) { + if (TAINTING_get) { MgTAINTEDDIR_off(mg); #ifdef VMS - if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { + if (s && klen == 8 && strEQ(key, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt; - Stat_t sbuf; int i = 0, j = 0; my_strlcpy(eltbuf, s, sizeof(eltbuf)); @@ -1162,7 +1161,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); } #endif /* VMS */ - if (s && klen == 4 && strEQ(ptr,"PATH")) { + if (s && klen == 4 && strEQ(key,"PATH")) { const char * const strend = s + len; while (s < strend) { @@ -1261,7 +1260,9 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETSIG; if (!i) { - mg->mg_private = i = whichsig(MgPV_nolen_const(mg)); + STRLEN siglen; + const char * sig = MgPV_const(mg, siglen); + mg->mg_private = i = whichsig_pvn(sig, siglen); } if (i > 0) { @@ -1292,7 +1293,6 @@ int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_CLEARSIG; - PERL_UNUSED_ARG(sv); magic_setsig(NULL, mg); return sv_unmagic(sv, mg->mg_type); @@ -1377,6 +1377,14 @@ Perl_csighandler_init(void) } #endif +#if defined HAS_SIGPROCMASK +static void +unblock_sigmask(pTHX_ void* newset) +{ + sigprocmask(SIG_UNBLOCK, (sigset_t*)newset, NULL); +} +#endif + void Perl_despatch_signals(pTHX) { @@ -1386,15 +1394,38 @@ Perl_despatch_signals(pTHX) for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { dSAVE_ERRNO; - PERL_BLOCKSIG_ADD(set, sig); +#ifdef HAS_SIGPROCMASK + /* From sigaction(2) (FreeBSD man page): + * | Signal routines normally execute with the signal that + * | caused their invocation blocked, but other signals may + * | yet occur. + * Emulation of this behavior (from within Perl) is enabled + * using sigprocmask + */ + int was_blocked; + sigset_t newset, oldset; + + sigemptyset(&newset); + sigaddset(&newset, sig); + sigprocmask(SIG_BLOCK, &newset, &oldset); + was_blocked = sigismember(&oldset, sig); + if (!was_blocked) { + SV* save_sv = newSVpvn((char *)(&newset), sizeof(sigset_t)); + ENTER; + SAVEFREESV(save_sv); + SAVEDESTRUCTOR_X(unblock_sigmask, SvPV_nolen(save_sv)); + } +#endif PL_psig_pend[sig] = 0; - PERL_BLOCKSIG_BLOCK(set); #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) (*PL_sighandlerp)(sig, NULL, NULL); #else (*PL_sighandlerp)(sig); #endif - PERL_BLOCKSIG_UNBLOCK(set); +#ifdef HAS_SIGPROCMASK + if (!was_blocked) + LEAVE; +#endif RESTORE_ERRNO; } } @@ -1417,14 +1448,14 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) sigset_t set, save; SV* save_sv; #endif - register const char *s = MgPV_const(mg,len); + const char *s = MgPV_const(mg,len); PERL_ARGS_ASSERT_MAGIC_SETSIG; if (*s == '_') { - if (strEQ(s,"__DIE__")) + if (memEQs(s, len, "__DIE__")) svp = &PL_diehook; - else if (strEQ(s,"__WARN__") + else if (memEQs(s, len, "__WARN__") && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { /* Merge the existing behaviours, which are as follows: magic_setsig, we always set svp to &PL_warnhook @@ -1432,8 +1463,11 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) For magic_clearsig, we don't change the warnings handler if it's set to the &PL_warnhook. */ svp = &PL_warnhook; - } else if (sv) - Perl_croak(aTHX_ "No such hook: %s", s); + } else if (sv) { + SV *tmp = sv_newmortal(); + Perl_croak(aTHX_ "No such hook: %s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } i = 0; if (svp && *svp) { if (*svp != PERL_WARNHOOK_FATAL) @@ -1444,12 +1478,15 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { i = (I16)mg->mg_private; if (!i) { - i = whichsig(s); /* ...no, a brick */ + i = whichsig_pvn(s, len); /* ...no, a brick */ mg->mg_private = (U16)i; } if (i <= 0) { - if (sv) - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) { + SV *tmp = sv_newmortal(); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } return 0; } #ifdef HAS_SIGPROCMASK @@ -1505,7 +1542,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } else { sv = NULL; } - if (sv && strEQ(s,"IGNORE")) { + if (sv && memEQs(s, len,"IGNORE")) { if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; @@ -1515,7 +1552,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) #endif } } - else if (!sv || strEQ(s,"DEFAULT") || !len) { + else if (!sv || memEQs(s, len,"DEFAULT") || !len) { if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; @@ -1574,44 +1611,40 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARISA; /* Bail out if destruction is going on */ - if(PL_dirty) return 0; + if(PL_phase == PERL_PHASE_DESTRUCT) return 0; if (sv) av_clear(MUTABLE_AV(sv)); - /* XXX Once it's possible, we need to - detect that our @ISA is aliased in - other stashes, and act on the stashes - of all of the aliases */ + if (SvTYPE(mg->mg_obj) != SVt_PVGV && SvSMAGICAL(mg->mg_obj)) + /* This occurs with setisa_elem magic, which calls this + same function. */ + mg = mg_find(mg->mg_obj, PERL_MAGIC_isa); + + if (SvTYPE(mg->mg_obj) == SVt_PVAV) { /* multiple stashes */ + SV **svp = AvARRAY((AV *)mg->mg_obj); + I32 items = AvFILLp((AV *)mg->mg_obj) + 1; + while (items--) { + stash = GvSTASH((GV *)*svp++); + if (stash && HvENAME(stash)) mro_isa_changed_in(stash); + } + + return 0; + } - /* The first case occurs via setisa, - the second via setisa_elem, which - calls this same magic */ stash = GvSTASH( - SvTYPE(mg->mg_obj) == SVt_PVGV - ? (const GV *)mg->mg_obj - : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj + (const GV *)mg->mg_obj ); - if (stash) + /* The stash may have been detached from the symbol table, so check its + name before doing anything. */ + if (stash && HvENAME_get(stash)) mro_isa_changed_in(stash); return 0; } int -Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) -{ - dVAR; - PERL_ARGS_ASSERT_MAGIC_SETAMAGIC; - PERL_UNUSED_ARG(sv); - PERL_UNUSED_ARG(mg); - PL_amagic_generation++; - - return 0; -} - -int Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) { HV * const hv = MUTABLE_HV(LvTARG(sv)); @@ -1623,7 +1656,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) - i = HvKEYS(hv); + i = HvUSEDKEYS(hv); else { while (hv_iternext(hv)) i++; @@ -1650,13 +1683,20 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) Invoke a magic method (like FETCH). -* sv and mg are the tied thinggy and the tie magic; -* meth is the name of the method to call; -* argc is the number of args (in addition to $self) to pass to the method; - the args themselves are any values following the argc argument. -* flags: - G_DISCARD: invoke method with G_DISCARD flag and don't return a value - G_UNDEF_FILL: fill the stack with argc pointers to PL_sv_undef. +C and C are the tied thingy and the tie magic. + +C is the name of the method to call. + +C is the number of args (in addition to $self) to pass to the method. + +The C can be: + + G_DISCARD invoke method with G_DISCARD flag and don't + return a value + G_UNDEF_FILL fill the stack with argc pointers to + PL_sv_undef + +The arguments themselves are any values following the C argument. Returns the SV (if any) returned by the method, or NULL on failure. @@ -1675,6 +1715,15 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, PERL_ARGS_ASSERT_MAGIC_METHCALL; ENTER; + + if (flags & G_WRITING_TO_STDERR) { + SAVETMPS; + + save_re_context(); + SAVESPTR(PL_stderrgv); + PL_stderrgv = NULL; + } + PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); @@ -1704,6 +1753,8 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, ret = *PL_stack_sp--; } POPSTACK; + if (flags & G_WRITING_TO_STDERR) + FREETMPS; LEAVE; return ret; } @@ -1781,7 +1832,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) * fake up a temporary tainted value (this is easier than temporarily * re-enabling magic on sv). */ - if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint)) + if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) && (tmg->mg_len & 1)) { val = sv_mortalcopy(sv); @@ -1799,6 +1850,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_CLEARPACK; + if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; return magic_methpack(sv,mg,"DELETE"); } @@ -1898,11 +1950,17 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) if (svp && SvIOKp(*svp)) { OP * const o = INT2PTR(OP*,SvIVX(*svp)); if (o) { +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(OpSLAB(o)); +#endif /* set or clear breakpoint in the relevant control op */ if (i) o->op_flags |= OPf_SPECIAL; else o->op_flags &= ~OPf_SPECIAL; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_ro(OpSLAB(o)); +#endif } } return 0; @@ -1917,7 +1975,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETARYLEN; if (obj) { - sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop)); + sv_setiv(sv, AvFILL(obj)); } else { SvOK_off(sv); } @@ -1933,7 +1991,7 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETARYLEN; if (obj) { - av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop)); + av_fill(obj, SvIV(sv)); } else { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Attempt to set length of freed array"); @@ -1942,6 +2000,25 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) } int +Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg) +{ + dVAR; + + PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P; + PERL_UNUSED_ARG(sv); + + /* Reset the iterator when the array is cleared */ +#if IVSIZE == I32SIZE + *((IV *) &(mg->mg_len)) = 0; +#else + if (mg->mg_ptr) + *((IV *) mg->mg_ptr) = 0; +#endif + + return 0; +} + +int Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) { dVAR; @@ -1981,7 +2058,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) I32 i = found->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); - sv_setiv(sv, i + CopARYBASE_get(PL_curcop)); + sv_setiv(sv, i); return 0; } } @@ -1998,6 +2075,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) STRLEN len; STRLEN ulen = 0; MAGIC* found; + const char *s; PERL_ARGS_ASSERT_MAGIC_SETPOS; PERL_UNUSED_ARG(mg); @@ -2020,12 +2098,12 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) found->mg_len = -1; return 0; } - len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); + s = SvPV_const(lsv, len); - pos = SvIV(sv) - CopARYBASE_get(PL_curcop); + pos = SvIV(sv); if (DO_UTF8(lsv)) { - ulen = sv_len_utf8(lsv); + ulen = sv_or_pv_len_utf8(lsv, s, len); if (ulen) len = ulen; } @@ -2039,9 +2117,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) pos = len; if (ulen) { - I32 p = pos; - sv_pos_u2b(lsv, &p, 0); - pos = p; + pos = sv_or_pv_pos_u2b(lsv, s, pos, 0); } found->mg_len = pos; @@ -2058,16 +2134,24 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) const char * const tmps = SvPV_const(lsv,len); STRLEN offs = LvTARGOFF(sv); STRLEN rem = LvTARGLEN(sv); + const bool negoff = LvFLAGS(sv) & 1; + const bool negrem = LvFLAGS(sv) & 2; PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; PERL_UNUSED_ARG(mg); + if (!translate_substr_offsets( + SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, + negoff ? -(IV)offs : (IV)offs, !negoff, + negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem + )) { + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); + sv_setsv_nomg(sv, &PL_sv_undef); + return 0; + } + if (SvUTF8(lsv)) - offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN); - if (offs > len) - offs = len; - if (rem > len - offs) - rem = len - offs; + offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); @@ -2078,34 +2162,52 @@ int Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) { dVAR; - STRLEN len; + STRLEN len, lsv_len, oldtarglen, newtarglen; const char * const tmps = SvPV_const(sv, len); SV * const lsv = LvTARG(sv); STRLEN lvoff = LvTARGOFF(sv); STRLEN lvlen = LvTARGLEN(sv); + const bool negoff = LvFLAGS(sv) & 1; + const bool neglen = LvFLAGS(sv) & 2; PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; PERL_UNUSED_ARG(mg); + SvGETMAGIC(lsv); + if (SvROK(lsv)) + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr" + ); + SvPV_force_nomg(lsv,lsv_len); + if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); + if (!translate_substr_offsets( + lsv_len, + negoff ? -(IV)lvoff : (IV)lvoff, !negoff, + neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen + )) + Perl_croak(aTHX_ "substr outside of string"); + oldtarglen = lvlen; if (DO_UTF8(sv)) { - sv_utf8_upgrade(lsv); + sv_utf8_upgrade_nomg(lsv); lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - sv_insert(lsv, lvoff, lvlen, tmps, len); - LvTARGLEN(sv) = sv_len_utf8(sv); + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = sv_or_pv_len_utf8(sv, tmps, len); SvUTF8_on(lsv); } - else if (lsv && SvUTF8(lsv)) { + else if (SvUTF8(lsv)) { const char *utf8; lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); - LvTARGLEN(sv) = len; + newtarglen = len; utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); - sv_insert(lsv, lvoff, lvlen, utf8, len); + sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0); Safefree(utf8); } else { - sv_insert(lsv, lvoff, lvlen, tmps, len); - LvTARGLEN(sv) = len; + sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); + newtarglen = len; } + if (!neglen) LvTARGLEN(sv) = newtarglen; + if (negoff) LvTARGOFF(sv) += newtarglen - oldtarglen; return 0; } @@ -2131,7 +2233,7 @@ Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(sv); /* update taint status */ - if (PL_tainted) + if (TAINT_get) mg->mg_len |= 1; else mg->mg_len &= ~1; @@ -2255,7 +2357,8 @@ int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; - return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); + Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); + return 0; } int @@ -2263,9 +2366,8 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_SETMGLOB; PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); mg->mg_len = -1; - if (!isGV_with_GP(sv)) - SvSCREAM_off(sv); return 0; } @@ -2294,7 +2396,6 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) SvVALID_off(sv); } else { assert(type == PERL_MAGIC_fm); - SvCOMPILED_off(sv); } return sv_unmagic(sv, type); } @@ -2337,12 +2438,13 @@ int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { dVAR; - register const char *s; - register I32 paren; - register const REGEXP * rx; + const char *s; + I32 paren; + const REGEXP * rx; const char * const remaining = mg->mg_ptr + 1; I32 i; STRLEN len; + MAGIC *tmg; PERL_ARGS_ASSERT_MAGIC_SET; @@ -2367,18 +2469,36 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) paren = atoi(mg->mg_ptr); setparen: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + setparen_got_rx: CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv); - break; } else { /* Croak with a READONLY error when a numbered match var is * set without a previous pattern match. Unless it's C */ + croakparen: if (!PL_localizing) { Perl_croak_no_modify(aTHX); } } + break; case '\001': /* ^A */ - sv_setsv(PL_bodytarget, sv); + if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); + else SvOK_off(PL_bodytarget); + FmLINES(PL_bodytarget) = 0; + if (SvPOK(PL_bodytarget)) { + char *s = SvPVX(PL_bodytarget); + while ( ((s = strchr(s, '\n'))) ) { + FmLINES(PL_bodytarget)++; + s++; + } + } + /* mg_set() has temporarily made sv non-magical */ + if (TAINTING_get) { + if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) + SvTAINTED_on(PL_bodytarget); + else + SvTAINTED_off(PL_bodytarget); + } break; case '\003': /* ^C */ PL_minus_c = cBOOL(SvIV(sv)); @@ -2431,6 +2551,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Safefree(PL_inplace); PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL; break; + case '\016': /* ^N */ + if (PL_curpm && (rx = PM_GETRE(PL_curpm)) + && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx; + goto croakparen; case '\017': /* ^O */ if (*(mg->mg_ptr+1) == '\0') { Safefree(PL_osname); @@ -2475,6 +2599,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ goto do_postmatch; } + break; case '\024': /* ^T */ #ifdef BIG_TIME PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv)); @@ -2497,9 +2622,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) { if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (!SvPOK(sv) && PL_localizing) { - sv_setpvn(sv, WARN_NONEstring, WARNsize); - PL_compiling.cop_warnings = pWARN_NONE; + if (!SvPOK(sv)) { + PL_compiling.cop_warnings = pWARN_STD; break; } { @@ -2549,33 +2673,25 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); break; case '^': - if (isGV_with_GP(PL_defoutgv)) { - Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - } + Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); + s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '~': - if (isGV_with_GP(PL_defoutgv)) { - Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - } + Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); + s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '=': - if (isGV_with_GP(PL_defoutgv)) - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '-': - if (isGV_with_GP(PL_defoutgv)) { - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; - } break; case '%': - if (isGV_with_GP(PL_defoutgv)) - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '|': { @@ -2600,7 +2716,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\\': SvREFCNT_dec(PL_ors_sv); - if (SvOK(sv) || SvGMAGICAL(sv)) { + if (SvOK(sv)) { PL_ors_sv = newSVsv(sv); } else { @@ -2608,7 +2724,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '[': - CopARYBASE_set(&PL_compiling, SvIV(sv)); + if (SvIV(sv) != 0) + Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible"); break; case '?': #ifdef COMPLEX_STATUS @@ -2638,89 +2755,94 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } break; case '<': - PL_uid = SvIV(sv); + { + const IV new_uid = SvIV(sv); + PL_delaymagic_uid = new_uid; if (PL_delaymagic) { PL_delaymagic |= DM_RUID; break; /* don't do magic till later */ } #ifdef HAS_SETRUID - (void)setruid((Uid_t)PL_uid); + (void)setruid((Uid_t)new_uid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)PL_uid, (Uid_t)-1); + (void)setreuid((Uid_t)new_uid, (Uid_t)-1); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1); + (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1); #else - if (PL_uid == PL_euid) { /* special case $< = $> */ + if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ #ifdef PERL_DARWIN /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */ - if (PL_uid != 0 && PerlProc_getuid() == 0) + if (new_uid != 0 && PerlProc_getuid() == 0) (void)PerlProc_setuid(0); #endif - (void)PerlProc_setuid(PL_uid); + (void)PerlProc_setuid(new_uid); } else { - PL_uid = PerlProc_getuid(); Perl_croak(aTHX_ "setruid() not implemented"); } #endif #endif #endif - PL_uid = PerlProc_getuid(); break; + } case '>': - PL_euid = SvIV(sv); + { + const UV new_euid = SvIV(sv); + PL_delaymagic_euid = new_euid; if (PL_delaymagic) { PL_delaymagic |= DM_EUID; break; /* don't do magic till later */ } #ifdef HAS_SETEUID - (void)seteuid((Uid_t)PL_euid); + (void)seteuid((Uid_t)new_euid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, (Uid_t)PL_euid); + (void)setreuid((Uid_t)-1, (Uid_t)new_euid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1); + (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1); #else - if (PL_euid == PL_uid) /* special case $> = $< */ - PerlProc_setuid(PL_euid); + if (new_euid == PerlProc_getuid()) /* special case $> = $< */ + PerlProc_setuid(new_euid); else { - PL_euid = PerlProc_geteuid(); Perl_croak(aTHX_ "seteuid() not implemented"); } #endif #endif #endif - PL_euid = PerlProc_geteuid(); break; + } case '(': - PL_gid = SvIV(sv); + { + const UV new_gid = SvIV(sv); + PL_delaymagic_gid = new_gid; if (PL_delaymagic) { PL_delaymagic |= DM_RGID; break; /* don't do magic till later */ } #ifdef HAS_SETRGID - (void)setrgid((Gid_t)PL_gid); + (void)setrgid((Gid_t)new_gid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)PL_gid, (Gid_t)-1); + (void)setregid((Gid_t)new_gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1); + (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1); #else - if (PL_gid == PL_egid) /* special case $( = $) */ - (void)PerlProc_setgid(PL_gid); + if (new_gid == PerlProc_getegid()) /* special case $( = $) */ + (void)PerlProc_setgid(new_gid); else { - PL_gid = PerlProc_getgid(); Perl_croak(aTHX_ "setrgid() not implemented"); } #endif #endif #endif - PL_gid = PerlProc_getgid(); break; + } case ')': + { + UV new_egid; #ifdef HAS_SETGROUPS { const char *p = SvPV_const(sv, len); @@ -2736,7 +2858,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - PL_egid = Atol(p); + new_egid = Atol(p); for (i = 0; i < maxgrp; ++i) { while (*p && !isSPACE(*p)) ++p; @@ -2755,35 +2877,46 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Safefree(gary); } #else /* HAS_SETGROUPS */ - PL_egid = SvIV(sv); + new_egid = SvIV(sv); #endif /* HAS_SETGROUPS */ + PL_delaymagic_egid = new_egid; if (PL_delaymagic) { PL_delaymagic |= DM_EGID; break; /* don't do magic till later */ } #ifdef HAS_SETEGID - (void)setegid((Gid_t)PL_egid); + (void)setegid((Gid_t)new_egid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)-1, (Gid_t)PL_egid); + (void)setregid((Gid_t)-1, (Gid_t)new_egid); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1); + (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1); #else - if (PL_egid == PL_gid) /* special case $) = $( */ - (void)PerlProc_setgid(PL_egid); + if (new_egid == PerlProc_getgid()) /* special case $) = $( */ + (void)PerlProc_setgid(new_egid); else { - PL_egid = PerlProc_getegid(); Perl_croak(aTHX_ "setegid() not implemented"); } #endif #endif #endif - PL_egid = PerlProc_getegid(); break; + } case ':': PL_chopset = SvPV_force(sv,len); break; + case '$': /* $$ */ + /* Store the pid in mg->mg_obj so we can tell when a fork has + occurred. mg->mg_obj points to *$ by default, so clear it. */ + if (isGV(mg->mg_obj)) { + if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = newSViv((IV)PerlProc_getpid()); + } + else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); + break; case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE @@ -2861,22 +2994,41 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } I32 -Perl_whichsig(pTHX_ const char *sig) +Perl_whichsig_sv(pTHX_ SV *sigsv) +{ + const char *sigpv; + STRLEN siglen; + PERL_ARGS_ASSERT_WHICHSIG_SV; + PERL_UNUSED_CONTEXT; + sigpv = SvPV_const(sigsv, siglen); + return whichsig_pvn(sigpv, siglen); +} + +I32 +Perl_whichsig_pv(pTHX_ const char *sig) +{ + PERL_ARGS_ASSERT_WHICHSIG_PV; + PERL_UNUSED_CONTEXT; + return whichsig_pvn(sig, strlen(sig)); +} + +I32 +Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) { - register char* const* sigv; + char* const* sigv; - PERL_ARGS_ASSERT_WHICHSIG; + PERL_ARGS_ASSERT_WHICHSIG_PVN; PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) - if (strEQ(sig,*sigv)) + if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD - if (strEQ(sig,"CHLD")) + if (memEQs(sig, len, "CHLD")) return SIGCLD; #endif #ifdef SIGCHLD - if (strEQ(sig,"CLD")) + if (memEQs(sig, len, "CLD")) return SIGCHLD; #endif return -1; @@ -2884,7 +3036,7 @@ Perl_whichsig(pTHX_ const char *sig) Signal_t #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -Perl_sighandler(int sig, siginfo_t *sip, void *uap PERL_UNUSED_DECL) +Perl_sighandler(int sig, siginfo_t *sip, void *uap) #else Perl_sighandler(int sig) #endif @@ -2902,13 +3054,9 @@ Perl_sighandler(int sig) OP *myop = PL_op; U32 flags = 0; XPV * const tXpv = PL_Xpv; + I32 old_ss_ix = PL_savestack_ix; + SV *errsv_save = NULL; - if (PL_savestack_ix + 15 <= PL_savestack_max) - flags |= 1; - if (PL_markstack_ptr < PL_markstack_max - 2) - flags |= 4; - if (PL_scopestack_ix < PL_scopestack_max - 3) - flags |= 16; if (!PL_psig_ptr[sig]) { PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n", @@ -2916,16 +3064,15 @@ Perl_sighandler(int sig) exit(sig); } - /* Max number of items pushed there is 3*n or 4. We cannot fix - infinity, so we fix 4 (in fact 5): */ - if (flags & 1) { - PL_savestack_ix += 5; /* Protect save in progress. */ - SAVEDESTRUCTOR_X(S_unwind_handler_stack, (void*)&flags); + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { + /* Max number of items pushed there is 3*n or 4. We cannot fix + infinity, so we fix 4 (in fact 5): */ + if (PL_savestack_ix + 15 <= PL_savestack_max) { + flags |= 1; + PL_savestack_ix += 5; /* Protect save in progress. */ + SAVEDESTRUCTOR_X(S_unwind_handler_stack, NULL); + } } - if (flags & 4) - PL_markstack_ptr++; /* Protect mark. */ - if (flags & 16) - PL_scopestack_ix += 1; /* sv_2cv is too complicated, try a simpler variant first: */ if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) || SvTYPE(cv) != SVt_PVCV) { @@ -2942,15 +3089,16 @@ Perl_sighandler(int sig) goto cleanup; } - if(PL_psig_name[sig]) { - sv = SvREFCNT_inc_NN(PL_psig_name[sig]); - flags |= 64; -#if !defined(PERL_IMPLICIT_CONTEXT) - PL_sig_sv = sv; -#endif - } else { - sv = sv_newmortal(); - sv_setpv(sv,PL_sig_name[sig]); + sv = PL_psig_name[sig] + ? SvREFCNT_inc_NN(PL_psig_name[sig]) + : newSVpv(PL_sig_name[sig],0); + flags |= 8; + SAVEFREESV(sv); + + if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) { + /* make sure our assumption about the size of the SAVEs are correct: + * 3 for SAVEDESTRUCTOR_X, 2 for SAVEFREESV */ + assert(old_ss_ix + 2 + ((flags & 1) ? 3+5 : 0) == PL_savestack_ix); } PUSHSTACKi(PERLSI_SIGNAL); @@ -2986,20 +3134,28 @@ Perl_sighandler(int sig) #endif PUTBACK; + errsv_save = newSVsv(ERRSV); + call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); POPSTACK; if (SvTRUE(ERRSV)) { + SvREFCNT_dec(errsv_save); #ifndef PERL_MICRO -#ifdef HAS_SIGPROCMASK /* Handler "died", for example to get out of a restart-able read(). * Before we re-do that on its behalf re-enable the signal which was * blocked by the system when we entered. */ - sigset_t set; - sigemptyset(&set); - sigaddset(&set,sig); - sigprocmask(SIG_UNBLOCK, &set, NULL); +#ifdef HAS_SIGPROCMASK +#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) + if (sip || uap) +#endif + { + sigset_t set; + sigemptyset(&set); + sigaddset(&set,sig); + sigprocmask(SIG_UNBLOCK, &set, NULL); + } #else /* Not clear if this will work */ (void)rsignal(sig, SIG_IGN); @@ -3008,14 +3164,15 @@ Perl_sighandler(int sig) #endif /* !PERL_MICRO */ die_sv(ERRSV); } + else { + sv_setsv(ERRSV, errsv_save); + SvREFCNT_dec(errsv_save); + } + cleanup: - if (flags & 1) - PL_savestack_ix -= 8; /* Unprotect save in progress. */ - if (flags & 4) - PL_markstack_ptr--; - if (flags & 16) - PL_scopestack_ix -= 1; - if (flags & 64) + /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ + PL_savestack_ix = old_ss_ix; + if (flags & 8) SvREFCNT_dec(sv); PL_op = myop; /* Apparently not needed... */ @@ -3031,37 +3188,28 @@ S_restore_magic(pTHX_ const void *p) dVAR; MGS* const mgs = SSPTR(PTR2IV(p), MGS*); SV* const sv = mgs->mgs_sv; + bool bumped; if (!sv) return; - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) - { + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */ #ifdef PERL_OLD_COPY_ON_WRITE /* While magic was saved (and off) sv_setsv may well have seen this SV as a prime candidate for COW. */ if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif - if (mgs->mgs_readonly) SvREADONLY_on(sv); if (mgs->mgs_magical) SvFLAGS(sv) |= mgs->mgs_magical; else mg_magical(sv); - if (SvGMAGICAL(sv)) { - /* downgrade public flags to private, - and discard any other private flags */ - - const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK); - if (pubflags) { - SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) ); - SvFLAGS(sv) |= ( pubflags << PRIVSHIFT ); - } - } } + bumped = mgs->mgs_bumped; mgs->mgs_sv = NULL; /* mark the MGS structure as restored */ /* If we're still on top of the stack, pop us off. (That condition @@ -3080,23 +3228,33 @@ S_restore_magic(pTHX_ const void *p) assert((popval & SAVE_MASK) == SAVEt_ALLOC); PL_savestack_ix -= popval >> SAVE_TIGHT_SHIFT; } - + if (bumped) { + if (SvREFCNT(sv) == 1) { + /* We hold the last reference to this SV, which implies that the + SV was deleted as a side effect of the routines we called. + So artificially keep it alive a bit longer. + We avoid turning on the TEMP flag, which can cause the SV's + buffer to get stolen (and maybe other stuff). */ + sv_2mortal(sv); + SvTEMP_off(sv); + } + else + SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */ + } } +/* clean up the mess created by Perl_sighandler(). + * Note that this is only called during an exit in a signal handler; + * a die is trapped by the call_sv() and the SAVEDESTRUCTOR_X manually + * skipped over. */ + static void S_unwind_handler_stack(pTHX_ const void *p) { dVAR; - const U32 flags = *(const U32*)p; - - PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK; + PERL_UNUSED_ARG(p); - if (flags & 1) - PL_savestack_ix -= 5; /* Unprotect save in progress. */ -#if !defined(PERL_IMPLICIT_CONTEXT) - if (flags & 64) - SvREFCNT_dec(PL_sig_sv); -#endif + PL_savestack_ix -= 5; /* Unprotect save in progress. */ } /* @@ -3127,8 +3285,8 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) Doing this here saves a lot of doing it manually in perl code (and forgetting to do it, and consequent subtle errors. */ PL_hints |= HINT_LOCALIZE_HH; - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, key, sv); + CopHINTHASH_set(&PL_compiling, + cophh_store_sv(CopHINTHASH_get(&PL_compiling), key, 0, sv, 0)); return 0; } @@ -3148,14 +3306,13 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARHINT; PERL_UNUSED_ARG(sv); - assert(mg->mg_len == HEf_SVKEY); - - PERL_UNUSED_ARG(sv); - PL_hints |= HINT_LOCALIZE_HH; - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder); + CopHINTHASH_set(&PL_compiling, + mg->mg_len == HEf_SVKEY + ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0) + : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling), + mg->mg_ptr, mg->mg_len, 0, 0)); return 0; } @@ -3172,19 +3329,37 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; - } + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, cophh_new_empty()); return 0; } +int +Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv, + const char *name, I32 namlen) +{ + MAGIC *nmg; + + PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER; + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(name); + PERL_UNUSED_ARG(namlen); + + sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0); + nmg = mg_find(nsv, mg->mg_type); + if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj); + nmg->mg_ptr = mg->mg_ptr; + nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj); + nmg->mg_flags |= MGf_REFCOUNTED; + return 1; +} + /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */