X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/68f8932eb570af656553ed44c11a23f0a216a3ec..37ffbfcca347ea751c9514463873b90f8a496be0:/mg.c diff --git a/mg.c b/mg.c index f3e6ae9..54791cb 100644 --- a/mg.c +++ b/mg.c @@ -1,7 +1,7 @@ /* mg.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,8 +9,10 @@ */ /* - * "Sam sat on the ground and put his head in his hands. 'I wish I had never - * come here, and I don't want to see no more magic,' he said, and fell silent." + * Sam sat on the ground and put his head in his hands. 'I wish I had never + * come here, and I don't want to see no more magic,' he said, and fell silent. + * + * [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"] */ /* @@ -55,6 +57,10 @@ tie. # include #endif +#ifdef HAS_PRCTL_SET_NAME +# include +#endif + #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) Signal_t Perl_csighandler(int sig, siginfo_t *, void *); #else @@ -75,8 +81,10 @@ void setegid(uid_t id); struct magic_state { SV* mgs_sv; - U32 mgs_flags; I32 mgs_ss_ix; + U32 mgs_magical; + bool mgs_readonly; + bool mgs_bumped; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -85,9 +93,21 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { dVAR; MGS* mgs; + bool bumped = FALSE; PERL_ARGS_ASSERT_SAVE_MAGIC; + /* 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; + } + assert(SvMAGICAL(sv)); /* Turning READONLY off for a copy-on-write scalar (including shared hash keys) is a bad idea. */ @@ -98,8 +118,10 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; - mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv); + mgs->mgs_magical = SvMAGICAL(sv); + mgs->mgs_readonly = SvREADONLY(sv) != 0; mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ + mgs->mgs_bumped = bumped; SvMAGICAL_off(sv); SvREADONLY_off(sv); @@ -123,8 +145,9 @@ Perl_mg_magical(pTHX_ SV *sv) const MAGIC* mg; PERL_ARGS_ASSERT_MG_MAGICAL; PERL_UNUSED_CONTEXT; + + SvMAGICAL_off(sv); if ((mg = SvMAGIC(sv))) { - SvRMAGICAL_off(sv); do { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl) { @@ -169,6 +192,8 @@ S_is_container_magic(const MAGIC *mg) 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 */ + case PERL_MAGIC_checkcall: return 0; default: return 1; @@ -188,23 +213,11 @@ Perl_mg_get(pTHX_ SV *sv) { dVAR; const I32 mgs_ix = SSNEW(sizeof(MGS)); - const bool was_temp = (bool)SvTEMP(sv); - int have_new = 0; + 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); /* We must call svt_get(sv, mg) for each valid entry in the linked @@ -214,21 +227,24 @@ Perl_mg_get(pTHX_ SV *sv) newmg = cur = head = mg = SvMAGIC(sv); while (mg) { const MGVTBL * const vtbl = mg->mg_virtual; + 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); + vtbl->svt_get(aTHX_ sv, mg); /* guard against magic having been deleted - eg FETCH calling * untie */ - if (!SvMAGIC(sv)) + if (!SvMAGIC(sv)) { + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ break; + } - /* Don't restore the flags for this entry if it was deleted. */ + /* recalculate flags if this entry was deleted. */ if (mg->mg_flags & MGf_GSKIP) - (SSPTR(mgs_ix, MGS *))->mgs_flags = 0; + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; } - mg = mg->mg_moremagic; + mg = nextmg; if (have_new) { /* Have we finished with the new entries we saw? Start again @@ -245,16 +261,11 @@ Perl_mg_get(pTHX_ SV *sv) have_new = 1; cur = mg; mg = newmg; + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ } } 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; } @@ -283,12 +294,12 @@ Perl_mg_set(pTHX_ SV *sv) nextmg = mg->mg_moremagic; /* it may delete itself */ if (mg->mg_flags & MGf_GSKIP) { mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ - (SSPTR(mgs_ix, MGS*))->mgs_flags = 0; + (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; } - if (PL_localizing == 2 && !S_is_container_magic(mg)) + if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV)) 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)); @@ -318,7 +329,7 @@ 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; } @@ -350,7 +361,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; } @@ -358,7 +369,7 @@ Perl_mg_size(pTHX_ SV *sv) switch(SvTYPE(sv)) { case SVt_PVAV: - return AvFILLp((AV *) sv); /* Fallback to non-tied array */ + return AvFILLp((const AV *) sv); /* Fallback to non-tied array */ case SVt_PVHV: /* FIXME */ default: @@ -381,23 +392,46 @@ Perl_mg_clear(pTHX_ SV *sv) { const I32 mgs_ix = SSNEW(sizeof(MGS)); MAGIC* mg; + MAGIC *nextmg; PERL_ARGS_ASSERT_MG_CLEAR; save_magic(mgs_ix, sv); - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { + for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* const vtbl = mg->mg_virtual; /* omit GSKIP -- never set here */ + 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; } +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 @@ -409,15 +443,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); } /* @@ -439,7 +480,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; @@ -461,28 +502,35 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) /* =for apidoc mg_localize -Copy some of the magic from an existing SV to new localized version of -that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic -doesn't (eg taint, pos). +Copy some of the magic from an existing SV to new localized version of that +SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg +taint, pos). + +If setmagic is false then no set magic will be called on the new (empty) SV. +This typically means that assignment will soon follow (e.g. 'local $x = $y'), +and that will handle the magic. =cut */ void -Perl_mg_localize(pTHX_ SV *sv, SV *nsv) +Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) { dVAR; MAGIC *mg; 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)) 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); @@ -493,12 +541,32 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv) if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { SvFLAGS(nsv) |= SvMAGICAL(sv); - PL_localizing = 1; - SvSETMAGIC(nsv); - PL_localizing = 0; + if (setmagic) { + PL_localizing = 1; + SvSETMAGIC(nsv); + PL_localizing = 0; + } } } +#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 @@ -516,19 +584,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((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); @@ -536,6 +593,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 @@ -612,7 +702,7 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(aTHX); NORETURN_FUNCTION_END; } @@ -717,17 +807,13 @@ 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); } @@ -739,7 +825,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { dVAR; register I32 paren; - register char *s = NULL; + register const char *s = NULL; register REGEXP *rx; const char * const remaining = mg->mg_ptr + 1; const char nextchar = *remaining; @@ -749,6 +835,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ sv_setsv(sv, PL_bodytarget); + if (SvTAINTED(PL_bodytarget)) + SvTAINTED_on(sv); break; case '\003': /* ^C, ^CHILD_ERROR_NATIVE */ if (nextchar == '\0') { @@ -764,14 +852,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\005': /* ^E */ if (nextchar == '\0') { -#if defined(MACOS_TRADITIONAL) - { - char msg[256]; - - sv_setnv(sv,(double)gMacPerl_OSErr); - sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : ""); - } -#elif defined(VMS) +#if defined(VMS) { # include # include @@ -781,7 +862,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1) sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length); else - sv_setpvn(sv,"",0); + sv_setpvs(sv,""); } #elif defined(OS2) if (!(_emx_env & 0x200)) { /* Under DOS */ @@ -804,15 +885,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) PerlProc_GetOSError(sv, dwErr); } else - sv_setpvn(sv, "", 0); + sv_setpvs(sv, ""); SetLastError(dwErr); } #else { - const int saveerrno = errno; + dSAVE_ERRNO; sv_setnv(sv, (NV)errno); sv_setpv(sv, errno ? Strerror(errno) : ""); - errno = saveerrno; + RESTORE_ERRNO; } #endif SvRTRIM(sv); @@ -824,6 +905,12 @@ 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; @@ -839,7 +926,7 @@ 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 */ @@ -896,7 +983,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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", FALSE); + HV * const bits=get_hv("warnings::Bits", 0); if (bits) { SV ** const bits_all = hv_fetchs(bits, "all", FALSE); if (bits_all) @@ -919,7 +1006,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) 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((GV*)mg->mg_obj)); + * 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] */ @@ -973,14 +1060,17 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { sv_setiv(sv, (IV)STATUS_CURRENT); #ifdef COMPLEX_STATUS + SvUPGRADE(sv, SVt_PVLV); LvTARGOFF(sv) = PL_statusvalue; LvTARGLEN(sv) = PL_statusvalue_vms; #endif } break; case '^': - if (GvIOp(PL_defoutgv)) - s = IoTOP_NAME(GvIOp(PL_defoutgv)); + if (!isGV_with_GP(PL_defoutgv)) + s = ""; + else if (GvIOp(PL_defoutgv)) + s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); else { @@ -989,22 +1079,24 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - if (GvIOp(PL_defoutgv)) + if (!isGV_with_GP(PL_defoutgv)) + s = ""; + else if (GvIOp(PL_defoutgv)) s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); sv_setpv(sv,s); break; case '=': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(PL_defoutgv))); break; case '-': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(PL_defoutgv))); break; case '%': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)IoPAGE(GvIOp(PL_defoutgv))); break; case ':': @@ -1015,32 +1107,32 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)); break; case '|': - if (GvIOp(PL_defoutgv)) + if (GvIO(PL_defoutgv)) sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 ); break; - case ',': - break; case '\\': if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); break; case '!': + { + dSAVE_ERRNO; #ifdef VMS sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno)); - sv_setpv(sv, errno ? Strerror(errno) : ""); #else - { - const int saveerrno = errno; sv_setnv(sv, (NV)errno); +#endif #ifdef OS2 if (errno == errno_isOS2 || errno == errno_isOS2_set) sv_setpv(sv, os2error(Perl_rc)); else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); - errno = saveerrno; + if (SvPOKp(sv)) + SvPOK_on(sv); /* may have got removed during taint processing */ + RESTORE_ERRNO; } -#endif + SvRTRIM(sv); SvNOK_on(sv); /* what a wonderful hack! */ break; @@ -1069,10 +1161,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) (void)SvIOK_on(sv); /* what a wonderful hack! */ #endif break; -#ifndef MACOS_TRADITIONAL case '0': break; -#endif } return 0; } @@ -1118,7 +1208,6 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) #ifdef VMS if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt; - Stat_t sbuf; int i = 0, j = 0; my_strlcpy(eltbuf, s, sizeof(eltbuf)); @@ -1197,11 +1286,11 @@ Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) if (PL_localizing) { HE* entry; my_clearenv(); - hv_iterinit((HV*)sv); - while ((entry = hv_iternext((HV*)sv))) { + hv_iterinit(MUTABLE_HV(sv)); + while ((entry = hv_iternext(MUTABLE_HV(sv)))) { I32 keylen; my_setenv(hv_iterkey(entry, &keylen), - SvPV_nolen_const(hv_iterval((HV*)sv, entry))); + SvPV_nolen_const(hv_iterval(MUTABLE_HV(sv), entry))); } } #endif @@ -1237,10 +1326,14 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) { dVAR; /* Are we fetching a signal entry? */ - const I32 i = whichsig(MgPV_nolen_const(mg)); + int i = (I16)mg->mg_private; PERL_ARGS_ASSERT_MAGIC_GETSIG; + if (!i) { + mg->mg_private = i = whichsig(MgPV_nolen_const(mg)); + } + if (i > 0) { if(PL_psig_ptr[i]) sv_setsv(sv,PL_psig_ptr[i]); @@ -1268,66 +1361,11 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { - /* XXX Some of this code was copied from Perl_magic_setsig. A little - * refactoring might be in order. - */ - dVAR; - register const char * const s = MgPV_nolen_const(mg); PERL_ARGS_ASSERT_MAGIC_CLEARSIG; PERL_UNUSED_ARG(sv); - if (*s == '_') { - SV** svp = NULL; - if (strEQ(s,"__DIE__")) - svp = &PL_diehook; - else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL) - svp = &PL_warnhook; - if (svp && *svp) { - SV *const to_dec = *svp; - *svp = NULL; - SvREFCNT_dec(to_dec); - } - } - else { - /* Are we clearing a signal entry? */ - const I32 i = whichsig(s); - if (i > 0) { -#ifdef HAS_SIGPROCMASK - sigset_t set, save; - SV* save_sv; - /* Avoid having the signal arrive at a bad time, if possible. */ - sigemptyset(&set); - sigaddset(&set,i); - sigprocmask(SIG_BLOCK, &set, &save); - ENTER; - save_sv = newSVpvn((char *)(&save), sizeof(sigset_t)); - SAVEFREESV(save_sv); - SAVEDESTRUCTOR_X(restore_sigmask, save_sv); -#endif - PERL_ASYNC_CHECK(); -#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) - if (!PL_sig_handlers_initted) Perl_csighandler_init(); -#endif -#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - PL_sig_defaulting[i] = 1; - (void)rsignal(i, PL_csighandlerp); -#else - (void)rsignal(i, (Sighandler_t) SIG_DFL); -#endif - if(PL_psig_name[i]) { - SvREFCNT_dec(PL_psig_name[i]); - PL_psig_name[i]=0; - } - if(PL_psig_ptr[i]) { - SV * const to_dec=PL_psig_ptr[i]; - PL_psig_ptr[i]=0; - LEAVE; - SvREFCNT_dec(to_dec); - } - else - LEAVE; - } - } - return 0; + + magic_setsig(NULL, mg); + return sv_unmagic(sv, mg->mg_type); } Signal_t @@ -1366,13 +1404,14 @@ Perl_csighandler(int sig) #endif (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)) /* Call the perl level handler now-- - * with risk we may be in malloc() etc. */ + * with risk we may be in malloc() or being destructed etc. */ #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) (*PL_sighandlerp)(sig, NULL, NULL); #else (*PL_sighandlerp)(sig); #endif else { + if (!PL_psig_pend) return; /* Set a flag to say this signal is pending, that is awaiting delivery after * the current Perl opcode completes */ PL_psig_pend[sig]++; @@ -1380,7 +1419,7 @@ Perl_csighandler(int sig) #ifndef SIG_PENDING_DIE_COUNT # define SIG_PENDING_DIE_COUNT 120 #endif - /* And one to say _a_ signal is pending */ + /* Add one to say _a_ signal is pending */ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", (unsigned long)SIG_PENDING_DIE_COUNT); @@ -1408,6 +1447,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) { @@ -1416,19 +1463,45 @@ Perl_despatch_signals(pTHX) PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { - PERL_BLOCKSIG_ADD(set, sig); + dSAVE_ERRNO; +#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; } } } +/* sv of NULL signifies that we're acting as magic_clearsig. */ int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1452,22 +1525,32 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) if (*s == '_') { if (strEQ(s,"__DIE__")) svp = &PL_diehook; - else if (strEQ(s,"__WARN__")) + else if (strEQ(s,"__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 + (hence we always change the warnings handler) + For magic_clearsig, we don't change the warnings handler if it's + set to the &PL_warnhook. */ svp = &PL_warnhook; - else + } else if (sv) Perl_croak(aTHX_ "No such hook: %s", s); i = 0; - if (*svp) { + if (svp && *svp) { if (*svp != PERL_WARNHOOK_FATAL) to_dec = *svp; *svp = NULL; } } else { - i = whichsig(s); /* ...no, a brick */ + i = (I16)mg->mg_private; + if (!i) { + i = whichsig(s); /* ...no, a brick */ + mg->mg_private = (U16)i; + } if (i <= 0) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } #ifdef HAS_SIGPROCMASK @@ -1490,68 +1573,80 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 0; #endif - SvREFCNT_dec(PL_psig_name[i]); to_dec = PL_psig_ptr[i]; - PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); - SvTEMP_off(sv); /* Make sure it doesn't go away on us */ - PL_psig_name[i] = newSVpvn(s, len); - SvREADONLY_on(PL_psig_name[i]); + if (sv) { + PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); + SvTEMP_off(sv); /* Make sure it doesn't go away on us */ + + /* Signals don't change name during the program's execution, so once + they're cached in the appropriate slot of PL_psig_name, they can + stay there. + + Ideally we'd find some way of making SVs at (C) compile time, or + at least, doing most of the work. */ + if (!PL_psig_name[i]) { + PL_psig_name[i] = newSVpvn(s, len); + SvREADONLY_on(PL_psig_name[i]); + } + } else { + SvREFCNT_dec(PL_psig_name[i]); + PL_psig_name[i] = NULL; + PL_psig_ptr[i] = NULL; + } } - if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { + if (sv && (isGV_with_GP(sv) || SvROK(sv))) { if (i) { (void)rsignal(i, PL_csighandlerp); -#ifdef HAS_SIGPROCMASK - LEAVE; -#endif } else *svp = SvREFCNT_inc_simple_NN(sv); - if(to_dec) - SvREFCNT_dec(to_dec); - return 0; - } - s = SvOK(sv) ? SvPV_force(sv,len) : "DEFAULT"; - if (strEQ(s,"IGNORE")) { - if (i) { + } else { + if (sv && SvOK(sv)) { + s = SvPV_force(sv, len); + } else { + sv = NULL; + } + if (sv && strEQ(s,"IGNORE")) { + if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS - PL_sig_ignoring[i] = 1; - (void)rsignal(i, PL_csighandlerp); + PL_sig_ignoring[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_IGN); + (void)rsignal(i, (Sighandler_t) SIG_IGN); #endif + } } - } - else if (strEQ(s,"DEFAULT") || !*s) { - if (i) + else if (!sv || strEQ(s,"DEFAULT") || !len) { + if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS - { - PL_sig_defaulting[i] = 1; - (void)rsignal(i, PL_csighandlerp); - } + PL_sig_defaulting[i] = 1; + (void)rsignal(i, PL_csighandlerp); #else - (void)rsignal(i, (Sighandler_t) SIG_DFL); + (void)rsignal(i, (Sighandler_t) SIG_DFL); #endif + } + } + else { + /* + * We should warn if HINT_STRICT_REFS, but without + * access to a known hint bit in a known OP, we can't + * tell whether HINT_STRICT_REFS is in force or not. + */ + if (!strchr(s,':') && !strchr(s,'\'')) + Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), + SV_GMAGIC); + if (i) + (void)rsignal(i, PL_csighandlerp); + else + *svp = SvREFCNT_inc_simple_NN(sv); + } } - else { - /* - * We should warn if HINT_STRICT_REFS, but without - * access to a known hint bit in a known OP, we can't - * tell whether HINT_STRICT_REFS is in force or not. - */ - if (!strchr(s,':') && !strchr(s,'\'')) - Perl_sv_insert_flags(aTHX_ sv, 0, 0, STR_WITH_LEN("main::"), - SV_GMAGIC); - if (i) - (void)rsignal(i, PL_csighandlerp); - else - *svp = SvREFCNT_inc_simple_NN(sv); - } + #ifdef HAS_SIGPROCMASK if(i) LEAVE; #endif - if(to_dec) - SvREFCNT_dec(to_dec); + SvREFCNT_dec(to_dec); return 0; } #endif /* !PERL_MICRO */ @@ -1560,38 +1655,17 @@ int Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) { dVAR; - HV* stash; - PERL_ARGS_ASSERT_MAGIC_SETISA; PERL_UNUSED_ARG(sv); - /* Bail out if destruction is going on */ - if(PL_dirty) return 0; - /* Skip _isaelem because _isa will handle it shortly */ - if (PL_delaymagic & DM_ARRAY && mg->mg_type == PERL_MAGIC_isaelem) + if (PL_delaymagic & DM_ARRAY_ISA && mg->mg_type == PERL_MAGIC_isaelem) return 0; - /* 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 */ - - /* The first case occurs via setisa, - the second via setisa_elem, which - calls this same magic */ - stash = GvSTASH( - SvTYPE(mg->mg_obj) == SVt_PVGV - ? (GV*)mg->mg_obj - : (GV*)SvMAGIC(mg->mg_obj)->mg_obj - ); - - if (stash) - mro_isa_changed_in(stash); - - return 0; + return magic_clearisa(NULL, mg); } +/* sv of NULL signifies that we're acting as magic_setisa. */ int Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) { @@ -1601,18 +1675,34 @@ 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; - av_clear((AV*)sv); + if (sv) + av_clear(MUTABLE_AV(sv)); + + 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; + } - /* XXX see comments in magic_setisa */ stash = GvSTASH( - SvTYPE(mg->mg_obj) == SVt_PVGV - ? (GV*)mg->mg_obj - : (GV*)SvMAGIC(mg->mg_obj)->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; @@ -1633,7 +1723,7 @@ Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) { - HV * const hv = (HV*)LvTARG(sv); + HV * const hv = MUTABLE_HV(LvTARG(sv)); I32 i = 0; PERL_ARGS_ASSERT_MAGIC_GETNKEYS; @@ -1641,7 +1731,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); - if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) + if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) i = HvKEYS(hv); else { while (hv_iternext(hv)) @@ -1659,60 +1749,125 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETNKEYS; PERL_UNUSED_ARG(mg); if (LvTARG(sv)) { - hv_ksplit((HV*)LvTARG(sv), SvIV(sv)); + hv_ksplit(MUTABLE_HV(LvTARG(sv)), SvIV(sv)); } return 0; } -/* caller is responsible for stack switching/cleanup */ -STATIC int -S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val) +/* +=for apidoc magic_methcall + +Invoke a magic method (like FETCH). + +* sv and mg are the tied thingy 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. + +Returns the SV (if any) returned by the method, or NULL on failure. + + +=cut +*/ + +SV* +Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + U32 argc, ...) { dVAR; dSP; + SV* ret = NULL; 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); - EXTEND(SP, n); + + EXTEND(SP, argc+1); PUSHs(SvTIED_obj(sv, mg)); - if (n > 1) { - if (mg->mg_ptr) { - if (mg->mg_len >= 0) - mPUSHp(mg->mg_ptr, mg->mg_len); - else if (mg->mg_len == HEf_SVKEY) - PUSHs((SV*)mg->mg_ptr); + if (flags & G_UNDEF_FILL) { + while (argc--) { + PUSHs(&PL_sv_undef); } - else if (mg->mg_type == PERL_MAGIC_tiedelem) { - mPUSHi(mg->mg_len); - } - } - if (n > 2) { - PUSHs(val); + } else if (argc > 0) { + va_list args; + va_start(args, argc); + + do { + SV *const sv = va_arg(args, SV *); + PUSHs(sv); + } while (--argc); + + va_end(args); } PUTBACK; + if (flags & G_DISCARD) { + call_method(meth, G_SCALAR|G_DISCARD); + } + else { + if (call_method(meth, G_SCALAR)) + ret = *PL_stack_sp--; + } + POPSTACK; + if (flags & G_WRITING_TO_STDERR) + FREETMPS; + LEAVE; + return ret; +} + - return call_method(meth, flags); +/* wrapper for magic_methcall that creates the first arg */ + +STATIC SV* +S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, + int n, SV *val) +{ + dVAR; + SV* arg1 = NULL; + + PERL_ARGS_ASSERT_MAGIC_METHCALL1; + + if (mg->mg_ptr) { + if (mg->mg_len >= 0) { + arg1 = newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); + } + else if (mg->mg_len == HEf_SVKEY) + arg1 = MUTABLE_SV(mg->mg_ptr); + } + else if (mg->mg_type == PERL_MAGIC_tiedelem) { + arg1 = newSViv((IV)(mg->mg_len)); + sv_2mortal(arg1); + } + if (!arg1) { + return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n - 1, val); + } + return Perl_magic_methcall(aTHX_ sv, mg, meth, flags, n, arg1, val); } STATIC int S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) { - dVAR; dSP; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_METHPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - - if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { - sv_setsv(sv, *PL_stack_sp--); - } - - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); + if (ret) + sv_setsv(sv, ret); return 0; } @@ -1721,7 +1876,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_GETPACK; - if (mg->mg_ptr) + if (mg->mg_type == PERL_MAGIC_tiedelem) mg->mg_flags |= MGf_GSKIP; magic_methpack(sv,mg,"FETCH"); return 0; @@ -1730,15 +1885,32 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; + MAGIC *tmg; + SV *val; PERL_ARGS_ASSERT_MAGIC_SETPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); - POPSTACK; - LEAVE; + /* in the code C<$tied{foo} = $val>, the "thing" that gets passed to + * STORE() is not $val, but rather a PVLV (the sv in this call), whose + * public flags indicate its value based on copying from $val. Doing + * mg_set() on the PVLV temporarily does SvMAGICAL_off(), then calls us. + * So STORE()'s $_[2] arg is a temporarily disarmed PVLV. This goes + * wrong if $val happened to be tainted, as sv hasn't got magic + * enabled, even though taint magic is in the chain. In which case, + * 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)) + && (tmg->mg_len & 1)) + { + val = sv_mortalcopy(sv); + SvTAINTED_on(val); + } + else + val = sv; + + magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val); return 0; } @@ -1754,69 +1926,44 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) U32 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; I32 retval = 0; + SV* retsv; PERL_ARGS_ASSERT_MAGIC_SIZEPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { - sv = *PL_stack_sp--; - retval = SvIV(sv)-1; + retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL); + if (retsv) { + retval = SvIV(retsv)-1; if (retval < -1) Perl_croak(aTHX_ "FETCHSIZE returned a negative value"); } - POPSTACK; - FREETMPS; - LEAVE; return (U32) retval; } int Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; + dVAR; PERL_ARGS_ASSERT_MAGIC_WIPEPACK; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(sv, mg)); - PUTBACK; - call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK; - LEAVE; - + Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0); return 0; } int Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) { - dVAR; dSP; - const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY"; + dVAR; + SV* ret; PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(SvTIED_obj(sv, mg)); - if (SvOK(key)) - PUSHs(key); - PUTBACK; - - if (call_method(meth, G_SCALAR)) - sv_setsv(key, *PL_stack_sp--); - - POPSTACK; - FREETMPS; - LEAVE; + ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key) + : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0); + if (ret) + sv_setsv(key,ret); return 0; } @@ -1831,10 +1978,10 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) SV * Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { - dVAR; dSP; + dVAR; SV *retval; - SV * const tied = SvTIED_obj((SV*)hv, mg); - HV * const pkg = SvSTASH((SV*)SvRV(tied)); + SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg); + HV * const pkg = SvSTASH((const SV *)SvRV(tied)); PERL_ARGS_ASSERT_MAGIC_SCALARPACK; @@ -1845,25 +1992,15 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) return &PL_sv_yes; /* no xhv_eiter so now use FIRSTKEY */ key = sv_newmortal(); - magic_nextpack((SV*)hv, mg, key); + magic_nextpack(MUTABLE_SV(hv), mg, key); HvEITER_set(hv, NULL); /* need to reset iterator */ return SvOK(key) ? &PL_sv_yes : &PL_sv_no; } /* there is a SCALAR method that we can call */ - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 1); - PUSHs(tied); - PUTBACK; - - if (call_method("SCALAR", G_SCALAR)) - retval = *PL_stack_sp--; - else + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0); + if (!retval) retval = &PL_sv_undef; - POPSTACK; - LEAVE; return retval; } @@ -1895,7 +2032,7 @@ int Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) { dVAR; - const AV * const obj = (AV*)mg->mg_obj; + AV * const obj = MUTABLE_AV(mg->mg_obj); PERL_ARGS_ASSERT_MAGIC_GETARYLEN; @@ -1911,16 +2048,15 @@ int Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) { dVAR; - AV * const obj = (AV*)mg->mg_obj; + AV * const obj = MUTABLE_AV(mg->mg_obj); PERL_ARGS_ASSERT_MAGIC_SETARYLEN; if (obj) { av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop)); } else { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Attempt to set length of freed array"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); } return 0; } @@ -2040,19 +2176,19 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) STRLEN len; SV * const lsv = LvTARG(sv); const char * const tmps = SvPV_const(lsv,len); - I32 offs = LvTARGOFF(sv); - I32 rem = LvTARGLEN(sv); + STRLEN offs = LvTARGOFF(sv); + STRLEN rem = LvTARGLEN(sv); PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; PERL_UNUSED_ARG(mg); if (SvUTF8(lsv)) - sv_pos_u2b(lsv, &offs, &rem); - if (offs > (I32)len) + offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN); + if (offs > len) offs = len; - if (rem + offs > (I32)len) + if (rem > len - offs) rem = len - offs; - sv_setpvn(sv, tmps + offs, (STRLEN)rem); + sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); return 0; @@ -2065,22 +2201,22 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) STRLEN len; const char * const tmps = SvPV_const(sv, len); SV * const lsv = LvTARG(sv); - I32 lvoff = LvTARGOFF(sv); - I32 lvlen = LvTARGLEN(sv); + STRLEN lvoff = LvTARGOFF(sv); + STRLEN lvlen = LvTARGLEN(sv); PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; PERL_UNUSED_ARG(mg); if (DO_UTF8(sv)) { sv_utf8_upgrade(lsv); - sv_pos_u2b(lsv, &lvoff, &lvlen); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); sv_insert(lsv, lvoff, lvlen, tmps, len); LvTARGLEN(sv) = sv_len_utf8(sv); SvUTF8_on(lsv); } else if (lsv && SvUTF8(lsv)) { const char *utf8; - sv_pos_u2b(lsv, &lvoff, &lvlen); + lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); LvTARGLEN(sv) = len; utf8 = (char*)bytes_to_utf8((U8*)tmps, &len); sv_insert(lsv, lvoff, lvlen, utf8, len); @@ -2091,7 +2227,6 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) LvTARGLEN(sv) = len; } - return 0; } @@ -2159,12 +2294,12 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) if (LvTARGLEN(sv)) { if (mg->mg_obj) { SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, FALSE, 0); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, FALSE, 0); if (he) targ = HeVAL(he); } else { - AV* const av = (AV*)LvTARG(sv); + AV *const av = MUTABLE_AV(LvTARG(sv)); if ((I32)LvTARGOFF(sv) <= AvFILL(av)) targ = AvARRAY(av)[LvTARGOFF(sv)]; } @@ -2211,14 +2346,14 @@ Perl_vivify_defelem(pTHX_ SV *sv) return; if (mg->mg_obj) { SV * const ahv = LvTARG(sv); - HE * const he = hv_fetch_ent((HV*)ahv, mg->mg_obj, TRUE, 0); + HE * const he = hv_fetch_ent(MUTABLE_HV(ahv), mg->mg_obj, TRUE, 0); if (he) value = HeVAL(he); if (!value || value == &PL_sv_undef) Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); } else { - AV* const av = (AV*)LvTARG(sv); + AV *const av = MUTABLE_AV(LvTARG(sv)); if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) LvTARG(sv) = NULL; /* array can't be extended */ else { @@ -2240,7 +2375,8 @@ int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; - return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj); + Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); + return 0; } int @@ -2249,7 +2385,8 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETMGLOB; PERL_UNUSED_CONTEXT; mg->mg_len = -1; - SvSCREAM_off(sv); + if (!isGV_with_GP(sv)) + SvSCREAM_off(sv); return 0; } @@ -2278,7 +2415,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); } @@ -2327,6 +2463,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char * const remaining = mg->mg_ptr + 1; I32 i; STRLEN len; + MAGIC *tmg; PERL_ARGS_ASSERT_MAGIC_SET; @@ -2352,55 +2489,58 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) setparen: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { 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 */ if (!PL_localizing) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(aTHX); } } + break; case '\001': /* ^A */ sv_setsv(PL_bodytarget, sv); + /* mg_set() has temporarily made sv non-magical */ + if (PL_tainting) { + 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 = (bool)SvIV(sv); + PL_minus_c = cBOOL(SvIV(sv)); break; case '\004': /* ^D */ #ifdef DEBUGGING s = SvPV_nolen_const(sv); PL_debug = get_debug_opts(&s, 0) | DEBUG_TOP_FLAG; - DEBUG_x(dump_all()); + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); #else PL_debug = (SvIV(sv)) | DEBUG_TOP_FLAG; #endif break; case '\005': /* ^E */ if (*(mg->mg_ptr+1) == '\0') { -#ifdef MACOS_TRADITIONAL - gMacPerl_OSErr = SvIV(sv); -#else -# ifdef VMS +#ifdef VMS set_vaxc_errno(SvIV(sv)); -# else -# ifdef WIN32 +#else +# ifdef WIN32 SetLastError( SvIV(sv) ); -# else -# ifdef OS2 +# else +# ifdef OS2 os2_setsyserrno(SvIV(sv)); -# else +# else /* will anyone ever use this? */ SETERRNO(SvIV(sv), 4); -# endif # endif # endif #endif } else if (strEQ(mg->mg_ptr+1, "NCODING")) { - if (PL_encoding) - SvREFCNT_dec(PL_encoding); + SvREFCNT_dec(PL_encoding); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_encoding = newSVsv(sv); } @@ -2433,31 +2573,23 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) const char *const start = SvPV(sv, len); const char *out = (const char*)memchr(start, '\0', len); SV *tmp; - struct refcounted_he *tmp_he; PL_compiling.cop_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; - PL_hints - |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; + PL_hints |= HINT_LEXICAL_IO_IN | HINT_LEXICAL_IO_OUT; /* Opening for input is more common than opening for output, so ensure that hints for input are sooner on linked list. */ tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1, - SVs_TEMP | SvUTF8(sv)) - : newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv)); - - tmp_he - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - newSVpvs_flags("open>", SVs_TEMP), - tmp); - - /* The UTF-8 setting is carried over */ - sv_setpvn(tmp, start, out ? (STRLEN)(out - start) : len); + SvUTF8(sv)) + : newSVpvs_flags("", SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open>", tmp); + mg_set(tmp); - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ tmp_he, - newSVpvs_flags("open<", SVs_TEMP), - tmp); + tmp = newSVpvn_flags(start, out ? (STRLEN)(out - start) : len, + SvUTF8(sv)); + (void)hv_stores(GvHV(PL_hintgv), "open<", tmp); + mg_set(tmp); } break; case '\020': /* ^P */ @@ -2471,6 +2603,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)); @@ -2545,29 +2678,37 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); break; case '^': - 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); + 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); + } break; case '~': - 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); + 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); + } break; case '=': - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (isGV_with_GP(PL_defoutgv)) + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '-': - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) - IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; + 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)) = 0L; + } break; case '%': - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (isGV_with_GP(PL_defoutgv)) + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '|': { - IO * const io = GvIOp(PL_defoutgv); + IO * const io = GvIO(PL_defoutgv); if(!io) break; if ((SvIV(sv)) == 0) @@ -2587,8 +2728,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_rs = newSVsv(sv); break; case '\\': - if (PL_ors_sv) - SvREFCNT_dec(PL_ors_sv); + SvREFCNT_dec(PL_ors_sv); if (SvOK(sv) || SvGMAGICAL(sv)) { PL_ors_sv = newSVsv(sv); } @@ -2596,22 +2736,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_ors_sv = NULL; } break; - case ',': - if (PL_ofs_sv) - SvREFCNT_dec(PL_ofs_sv); - if (SvOK(sv) || SvGMAGICAL(sv)) { - PL_ofs_sv = newSVsv(sv); - } - else { - PL_ofs_sv = NULL; - } - break; case '[': CopARYBASE_set(&PL_compiling, SvIV(sv)); break; case '?': #ifdef COMPLEX_STATUS if (PL_localizing == 2) { + SvUPGRADE(sv, SVt_PVLV); PL_statusvalue = LvTARGOFF(sv); PL_statusvalue_vms = LvTARGLEN(sv); } @@ -2665,7 +2796,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_uid = PerlProc_getuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '>': PL_euid = SvIV(sv); @@ -2692,7 +2822,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_euid = PerlProc_geteuid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case '(': PL_gid = SvIV(sv); @@ -2719,18 +2848,25 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_gid = PerlProc_getgid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ')': #ifdef HAS_SETGROUPS { const char *p = SvPV_const(sv, len); Groups_t *gary = NULL; +#ifdef _SC_NGROUPS_MAX + int maxgrp = sysconf(_SC_NGROUPS_MAX); + + if (maxgrp < 0) + maxgrp = NGROUPS; +#else + int maxgrp = NGROUPS; +#endif while (isSPACE(*p)) ++p; PL_egid = Atol(p); - for (i = 0; i < NGROUPS; ++i) { + for (i = 0; i < maxgrp; ++i) { while (*p && !isSPACE(*p)) ++p; while (isSPACE(*p)) @@ -2773,12 +2909,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif #endif PL_egid = PerlProc_getegid(); - PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid)); break; case ':': PL_chopset = SvPV_force(sv,len); break; -#ifndef MACOS_TRADITIONAL case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE @@ -2840,11 +2974,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_origargv[0][PL_origalen-1] = 0; for (i = 1; i < PL_origargc; i++) PL_origargv[i] = 0; +#ifdef HAS_PRCTL_SET_NAME + /* Set the legacy process name in addition to the POSIX name on Linux */ + if (prctl(PR_SET_NAME, (unsigned long)s, 0, 0, 0) != 0) { + /* diag_listed_as: SKIPME */ + Perl_croak(aTHX_ "Can't set $0 with prctl(): %s", Strerror(errno)); + } +#endif } #endif UNLOCK_DOLLARZERO_MUTEX; break; -#endif } return 0; } @@ -2873,7 +3013,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 @@ -2891,13 +3031,8 @@ Perl_sighandler(int sig) OP *myop = PL_op; U32 flags = 0; XPV * const tXpv = PL_Xpv; + I32 old_ss_ix = PL_savestack_ix; - 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", @@ -2905,42 +3040,41 @@ 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 = (CV*)SvRV(PL_psig_ptr[sig])) + if (!SvROK(PL_psig_ptr[sig]) || !(cv = MUTABLE_CV(SvRV(PL_psig_ptr[sig]))) || SvTYPE(cv) != SVt_PVCV) { HV *st; cv = sv_2cv(PL_psig_ptr[sig], &st, &gv, GV_ADD); } if (!cv || !CvROOT(cv)) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", - PL_sig_name[sig], (gv ? GvENAME(gv) - : ((cv && CvGV(cv)) - ? GvENAME(CvGV(cv)) - : "__ANON__"))); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", + PL_sig_name[sig], (gv ? GvENAME(gv) + : ((cv && CvGV(cv)) + ? GvENAME(CvGV(cv)) + : "__ANON__"))); 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); @@ -2953,7 +3087,7 @@ Perl_sighandler(int sig) if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) { if (sip) { HV *sih = newHV(); - SV *rv = newRV_noinc((SV*)sih); + SV *rv = newRV_noinc(MUTABLE_SV(sih)); /* The siginfo fields signo, code, errno, pid, uid, * addr, status, and band are defined by POSIX/SUSv3. */ (void)hv_stores(sih, "signo", newSViv(sip->si_signo)); @@ -2967,7 +3101,7 @@ Perl_sighandler(int sig) hv_stores(sih, "band", newSViv(sip->si_band)); #endif EXTEND(SP, 2); - PUSHs((SV*)rv); + PUSHs(rv); mPUSHp((char *)sip, sizeof(*sip)); } @@ -2976,36 +3110,37 @@ Perl_sighandler(int sig) #endif PUTBACK; - call_sv((SV*)cv, G_DISCARD|G_EVAL); + call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); POPSTACK; if (SvTRUE(ERRSV)) { #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); (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ - Perl_die(aTHX_ NULL); + die_sv(ERRSV); } 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... */ @@ -3021,6 +3156,7 @@ 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; @@ -3034,8 +3170,10 @@ S_restore_magic(pTHX_ const void *p) sv_force_normal_flags(sv, 0); #endif - if (mgs->mgs_flags) - SvFLAGS(sv) |= mgs->mgs_flags; + if (mgs->mgs_readonly) + SvREADONLY_on(sv); + if (mgs->mgs_magical) + SvFLAGS(sv) |= mgs->mgs_magical; else mg_magical(sv); if (SvGMAGICAL(sv)) { @@ -3050,6 +3188,7 @@ S_restore_magic(pTHX_ const void *p) } } + 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 @@ -3061,31 +3200,44 @@ S_restore_magic(pTHX_ const void *p) */ if (PL_savestack_ix == mgs->mgs_ss_ix) { - I32 popval = SSPOPINT; + UV popval = SSPOPUV; assert(popval == SAVEt_DESTRUCTOR_X); PL_savestack_ix -= 2; - popval = SSPOPINT; - assert(popval == SAVEt_ALLOC); - popval = SSPOPINT; - PL_savestack_ix -= popval; + popval = SSPOPUV; + 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). */ + int was_temp = SvTEMP(sv); + sv_2mortal(sv); + if (!was_temp) { + SvTEMP_off(sv); + } + SvOK_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. */ } /* @@ -3102,7 +3254,7 @@ int Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) { dVAR; - SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr + SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr) : newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP); PERL_ARGS_ASSERT_MAGIC_SETHINT; @@ -3116,8 +3268,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; } @@ -3142,9 +3294,27 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(sv); PL_hints |= HINT_LOCALIZE_HH; - PL_compiling.cop_hints_hash - = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, - (SV *)mg->mg_ptr, &PL_sv_placeholder); + CopHINTHASH_set(&PL_compiling, + cophh_delete_sv(CopHINTHASH_get(&PL_compiling), + MUTABLE_SV(mg->mg_ptr), 0, 0)); + return 0; +} + +/* +=for apidoc magic_clearhints + +Triggered by clearing %^H, resets C. + +=cut +*/ +int +Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_ARGS_ASSERT_MAGIC_CLEARHINTS; + PERL_UNUSED_ARG(sv); + PERL_UNUSED_ARG(mg); + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, cophh_new_empty()); return 0; }