X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d06445298904613950b0410a2f3b1125ab58c7b5..ebcfa0534aa7072c0353af79a1e3d7e87678e73e:/mg.c diff --git a/mg.c b/mg.c index b64a778..8b283d9 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,9 @@ void setegid(uid_t id); struct magic_state { SV* mgs_sv; - U32 mgs_flags; I32 mgs_ss_ix; + U32 mgs_magical; + bool mgs_readonly; }; /* MGS is typedef'ed to struct magic_state in perl.h */ @@ -85,6 +92,9 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) { dVAR; MGS* mgs; + + 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. */ @@ -95,7 +105,8 @@ 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 */ SvMAGICAL_off(sv); @@ -118,17 +129,24 @@ void Perl_mg_magical(pTHX_ SV *sv) { const MAGIC* mg; + PERL_ARGS_ASSERT_MG_MAGICAL; PERL_UNUSED_CONTEXT; - for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { - const MGVTBL* const vtbl = mg->mg_virtual; - if (vtbl) { - if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) - SvGMAGICAL_on(sv); - if (vtbl->svt_set) - SvSMAGICAL_on(sv); - if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear) - SvRMAGICAL_on(sv); - } + + SvMAGICAL_off(sv); + if ((mg = SvMAGIC(sv))) { + do { + const MGVTBL* const vtbl = mg->mg_virtual; + if (vtbl) { + if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP)) + SvGMAGICAL_on(sv); + if (vtbl->svt_set) + SvSMAGICAL_on(sv); + if (vtbl->svt_clear) + SvRMAGICAL_on(sv); + } + } while ((mg = mg->mg_moremagic)); + if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG))) + SvRMAGICAL_on(sv); } } @@ -138,6 +156,7 @@ Perl_mg_magical(pTHX_ SV *sv) STATIC bool S_is_container_magic(const MAGIC *mg) { + assert(mg); switch (mg->mg_type) { case PERL_MAGIC_bm: case PERL_MAGIC_fm: @@ -159,6 +178,7 @@ 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 */ return 0; default: return 1; @@ -178,12 +198,14 @@ 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; + const bool was_temp = cBOOL(SvTEMP(sv)); + 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. @@ -202,21 +224,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 @@ -233,6 +258,7 @@ Perl_mg_get(pTHX_ SV *sv) have_new = 1; cur = mg; mg = newmg; + (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; /* recalculate flags */ } } @@ -262,6 +288,8 @@ Perl_mg_set(pTHX_ SV *sv) MAGIC* mg; MAGIC* nextmg; + PERL_ARGS_ASSERT_MG_SET; + save_magic(mgs_ix, sv); for (mg = SvMAGIC(sv); mg; mg = nextmg) { @@ -269,12 +297,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)) 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)); @@ -296,13 +324,15 @@ Perl_mg_length(pTHX_ SV *sv) MAGIC* mg; STRLEN len; + PERL_ARGS_ASSERT_MG_LENGTH; + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL * const vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { 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; } @@ -325,6 +355,8 @@ Perl_mg_size(pTHX_ SV *sv) { MAGIC* mg; + PERL_ARGS_ASSERT_MG_SIZE; + for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; if (vtbl && vtbl->svt_len) { @@ -332,7 +364,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; } @@ -340,7 +372,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: @@ -363,15 +395,20 @@ 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)); @@ -413,10 +450,13 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen) { int count = 0; MAGIC* mg; + + PERL_ARGS_ASSERT_MG_COPY; + 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; @@ -438,25 +478,32 @@ 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; + 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); @@ -467,9 +514,11 @@ 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; + } } } @@ -486,16 +535,19 @@ Perl_mg_free(pTHX_ SV *sv) { MAGIC* mg; MAGIC* moremagic; + + 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); + 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); + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); @@ -503,6 +555,7 @@ Perl_mg_free(pTHX_ SV *sv) SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); + SvMAGICAL_off(sv); return 0; } @@ -514,6 +567,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) dVAR; PERL_UNUSED_ARG(sv); + PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; + if (PL_curpm) { register const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { @@ -540,6 +595,9 @@ int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { dVAR; + + PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; + if (PL_curpm) { register const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { @@ -574,9 +632,10 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) int 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; } @@ -589,6 +648,8 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) 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 */ @@ -671,6 +732,8 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) void Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) { + PERL_ARGS_ASSERT_EMULATE_COP_IO; + if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) sv_setsv(sv, &PL_sv_undef); else { @@ -699,11 +762,13 @@ 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; + PERL_ARGS_ASSERT_MAGIC_GET; + switch (*mg->mg_ptr) { case '\001': /* ^A */ sv_setsv(sv, PL_bodytarget); @@ -722,14 +787,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 @@ -739,7 +797,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 */ @@ -762,15 +820,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); @@ -854,7 +912,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) @@ -877,7 +935,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] */ @@ -931,14 +989,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 { @@ -947,22 +1008,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 ':': @@ -973,32 +1036,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; @@ -1027,10 +1090,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; } @@ -1040,6 +1101,8 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg) { struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; + PERL_ARGS_ASSERT_MAGIC_GETUVAR; + if (uf && uf->uf_val) (*uf->uf_val)(aTHX_ uf->uf_index, sv); return 0; @@ -1054,6 +1117,8 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) const char * const ptr = MgPV_const(mg,klen); my_setenv(ptr, s); + PERL_ARGS_ASSERT_MAGIC_SETENV; + #ifdef DYNAMIC_ENV_FETCH /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ @@ -1133,6 +1198,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_clearenv(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_CLEARENV; PERL_UNUSED_ARG(sv); my_setenv(MgPV_nolen_const(mg),NULL); return 0; @@ -1142,6 +1208,7 @@ int Perl_magic_set_all_env(pTHX_ SV *sv, MAGIC *mg) { dVAR; + PERL_ARGS_ASSERT_MAGIC_SET_ALL_ENV; PERL_UNUSED_ARG(mg); #if defined(VMS) Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system"); @@ -1149,11 +1216,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 @@ -1164,6 +1231,7 @@ int Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg) { dVAR; + PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV; PERL_UNUSED_ARG(sv); PERL_UNUSED_ARG(mg); #if defined(VMS) @@ -1188,7 +1256,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]); @@ -1216,94 +1291,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; -} -/* - * The signal handling nomenclature has gotten a bit confusing since the advent of - * safe signals. S_raise_signal only raises signals by analogy with what the - * underlying system's signal mechanism does. It might be more proper to say that - * it defers signals that have already been raised and caught. - * - * PL_sig_pending and PL_psig_pend likewise do not track signals that are pending - * in the sense of being on the system's signal queue in between raising and delivery. - * They are only pending on Perl's deferral list, i.e., they track deferred signals - * awaiting delivery after the current Perl opcode completes and say nothing about - * signals raised but not yet caught in the underlying signal implementation. - */ - -#ifndef SIG_PENDING_DIE_COUNT -# define SIG_PENDING_DIE_COUNT 120 -#endif - -static void -S_raise_signal(pTHX_ int sig) -{ - dVAR; - /* Set a flag to say this signal is pending */ - PL_psig_pend[sig]++; - /* And 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); + magic_setsig(NULL, mg); + return sv_unmagic(sv, mg->mg_type); } Signal_t @@ -1318,8 +1310,6 @@ Perl_csighandler(int sig) #else dTHX; #endif -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -#endif #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS (void) rsignal(sig, PL_csighandlerp); if (PL_sig_ignoring[sig]) return; @@ -1332,9 +1322,7 @@ Perl_csighandler(int sig) exit(1); #endif #endif -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -#endif - if ( + if ( #ifdef SIGILL sig == SIGILL || #endif @@ -1346,14 +1334,26 @@ 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 - S_raise_signal(aTHX_ sig); + 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]++; + +#ifndef SIG_PENDING_DIE_COUNT +# define SIG_PENDING_DIE_COUNT 120 +#endif + /* 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); + } } #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) @@ -1385,6 +1385,7 @@ Perl_despatch_signals(pTHX) PL_sig_pending = 0; for (sig = 1; sig < SIG_SIZE; sig++) { if (PL_psig_pend[sig]) { + dSAVE_ERRNO; PERL_BLOCKSIG_ADD(set, sig); PL_psig_pend[sig] = 0; PERL_BLOCKSIG_BLOCK(set); @@ -1394,10 +1395,12 @@ Perl_despatch_signals(pTHX) (*PL_sighandlerp)(sig); #endif PERL_BLOCKSIG_UNBLOCK(set); + RESTORE_ERRNO; } } } +/* sv of NULL signifies that we're acting as magic_clearsig. */ int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1414,27 +1417,39 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) sigset_t set, save; SV* save_sv; #endif - register const char *s = MgPV_const(mg,len); + + PERL_ARGS_ASSERT_MAGIC_SETSIG; + 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 @@ -1457,67 +1472,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(aTHX_ sv, 0, 0, STR_WITH_LEN("main::")); - 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 */ @@ -1526,54 +1554,47 @@ 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 - ); - - 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) { dVAR; HV* stash; + PERL_ARGS_ASSERT_MAGIC_CLEARISA; + /* Bail out if destruction is going on */ if(PL_dirty) return 0; - av_clear((AV*)sv); + if (sv) + av_clear(MUTABLE_AV(sv)); - /* XXX see comments in magic_setisa */ + /* 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 + ? (const GV *)mg->mg_obj + : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj ); - mro_isa_changed_in(stash); + if (stash) + mro_isa_changed_in(stash); return 0; } @@ -1582,6 +1603,7 @@ 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++; @@ -1592,13 +1614,15 @@ 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; PERL_UNUSED_ARG(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)) @@ -1613,65 +1637,126 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) int 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 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. + +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; + 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); - } - else if (mg->mg_type == PERL_MAGIC_tiedelem) { - mPUSHi(mg->mg_len); + if (flags & G_UNDEF_FILL) { + while (argc--) { + PUSHs(&PL_sv_undef); } - } - 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; + LEAVE; + return ret; +} + + +/* 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; - return call_method(meth, flags); + 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; - - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); + dVAR; + SV* ret; - if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) { - sv_setsv(sv, *PL_stack_sp--); - } + PERL_ARGS_ASSERT_MAGIC_METHPACK; - POPSTACK; - FREETMPS; - LEAVE; + ret = magic_methcall1(sv, mg, meth, 0, 1, NULL); + if (ret) + sv_setsv(sv, ret); return 0; } int Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) { - if (mg->mg_ptr) + PERL_ARGS_ASSERT_MAGIC_GETPACK; + + if (mg->mg_type == PERL_MAGIC_tiedelem) mg->mg_flags |= MGf_GSKIP; magic_methpack(sv,mg,"FETCH"); return 0; @@ -1680,18 +1765,40 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) { - dVAR; dSP; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, sv); - POPSTACK; - LEAVE; + dVAR; + MAGIC *tmg; + SV *val; + + PERL_ARGS_ASSERT_MAGIC_SETPACK; + + /* 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; } int Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_CLEARPACK; + return magic_methpack(sv,mg,"DELETE"); } @@ -1699,80 +1806,65 @@ 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; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) { - sv = *PL_stack_sp--; - retval = SvIV(sv)-1; + PERL_ARGS_ASSERT_MAGIC_SIZEPACK; + + 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; - ENTER; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(sv, mg)); - PUTBACK; - call_method("CLEAR", G_SCALAR|G_DISCARD); - POPSTACK; - LEAVE; + PERL_ARGS_ASSERT_MAGIC_WIPEPACK; + 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"; - - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP, 2); - PUSHs(SvTIED_obj(sv, mg)); - if (SvOK(key)) - PUSHs(key); - PUTBACK; + dVAR; + SV* ret; - if (call_method(meth, G_SCALAR)) - sv_setsv(key, *PL_stack_sp--); + PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - 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; } int Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; + return magic_methpack(sv,mg,"EXISTS"); } 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; + if (!gv_fetchmethod_autoload(pkg, "SCALAR", FALSE)) { SV *key; if (HvEITER_get(hv)) @@ -1780,25 +1872,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; } @@ -1810,6 +1892,9 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) const I32 i = SvTRUE(sv); SV ** const svp = av_fetch(GvAV(gv), atoi(MgPV_nolen_const(mg)), FALSE); + + PERL_ARGS_ASSERT_MAGIC_SETDBLINE; + if (svp && SvIOKp(*svp)) { OP * const o = INT2PTR(OP*,SvIVX(*svp)); if (o) { @@ -1827,7 +1912,10 @@ 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; + if (obj) { sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop)); } else { @@ -1840,13 +1928,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; } @@ -1855,7 +1945,10 @@ int Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg) { dVAR; + + PERL_ARGS_ASSERT_MAGIC_FREEARYLEN_P; PERL_UNUSED_ARG(sv); + /* during global destruction, mg_obj may already have been freed */ if (PL_in_clean_all) return 0; @@ -1878,6 +1971,8 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) { dVAR; SV* const lsv = LvTARG(sv); + + PERL_ARGS_ASSERT_MAGIC_GETPOS; PERL_UNUSED_ARG(mg); if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) { @@ -1904,6 +1999,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) STRLEN ulen = 0; MAGIC* found; + PERL_ARGS_ASSERT_MAGIC_SETPOS; PERL_UNUSED_ARG(mg); if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) @@ -1960,17 +2056,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; @@ -1983,20 +2081,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); @@ -2007,7 +2107,6 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) LvTARGLEN(sv) = len; } - return 0; } @@ -2015,7 +2114,10 @@ int Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) { dVAR; + + PERL_ARGS_ASSERT_MAGIC_GETTAINT; PERL_UNUSED_ARG(sv); + TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1)); return 0; } @@ -2024,7 +2126,10 @@ int Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) { dVAR; + + PERL_ARGS_ASSERT_MAGIC_SETTAINT; PERL_UNUSED_ARG(sv); + /* update taint status */ if (PL_tainted) mg->mg_len |= 1; @@ -2037,6 +2142,8 @@ int Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) { SV * const lsv = LvTARG(sv); + + PERL_ARGS_ASSERT_MAGIC_GETVEC; PERL_UNUSED_ARG(mg); if (lsv) @@ -2050,6 +2157,7 @@ Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_SETVEC; PERL_UNUSED_ARG(mg); do_vecset(sv); /* XXX slurp this routine */ return 0; @@ -2060,15 +2168,18 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) { dVAR; SV *targ = NULL; + + PERL_ARGS_ASSERT_MAGIC_GETDEFELEM; + 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)]; } @@ -2091,6 +2202,7 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setdefelem(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_SETDEFELEM; PERL_UNUSED_ARG(mg); if (LvTARGLEN(sv)) vivify_defelem(sv); @@ -2108,18 +2220,20 @@ Perl_vivify_defelem(pTHX_ SV *sv) MAGIC *mg; SV *value = NULL; + PERL_ARGS_ASSERT_VIVIFY_DEFELEM; + if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem))) 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 { @@ -2140,15 +2254,19 @@ Perl_vivify_defelem(pTHX_ SV *sv) int Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg) { - return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj); + PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS; + Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); + return 0; } int 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; } @@ -2157,6 +2275,8 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg) { const struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr; + PERL_ARGS_ASSERT_MAGIC_SETUVAR; + if (uf && uf->uf_set) (*uf->uf_set)(aTHX_ uf->uf_index, sv); return 0; @@ -2166,6 +2286,9 @@ int Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) { const char type = mg->mg_type; + + PERL_ARGS_ASSERT_MAGIC_SETREGEXP; + if (type == PERL_MAGIC_qr) { } else if (type == PERL_MAGIC_bm) { SvTAIL_off(sv); @@ -2181,6 +2304,8 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_SETCOLLXFRM; + /* * RenE Descartes said "I think not." * and vanished with a faint plop. @@ -2200,6 +2325,7 @@ Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg) int Perl_magic_setutf8(pTHX_ SV *sv, MAGIC *mg) { + PERL_ARGS_ASSERT_MAGIC_SETUTF8; PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); Safefree(mg->mg_ptr); /* The mg_ptr holds the pos cache. */ @@ -2219,6 +2345,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) I32 i; STRLEN len; + PERL_ARGS_ASSERT_MAGIC_SET; + switch (*mg->mg_ptr) { case '\015': /* $^MATCH */ if (strEQ(remaining, "ATCH")) @@ -2241,55 +2369,51 @@ 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); 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); } @@ -2322,31 +2446,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 */ @@ -2360,6 +2476,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)); @@ -2434,29 +2551,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) @@ -2476,8 +2601,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); } @@ -2485,22 +2609,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); } @@ -2554,7 +2669,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); @@ -2581,7 +2695,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); @@ -2608,18 +2721,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)) @@ -2662,12 +2782,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 @@ -2729,11 +2847,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; } @@ -2742,6 +2866,8 @@ I32 Perl_whichsig(pTHX_ const char *sig) { register char* const* sigv; + + PERL_ARGS_ASSERT_WHICHSIG; PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) @@ -2803,19 +2929,18 @@ Perl_sighandler(int sig) 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; } @@ -2840,7 +2965,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)); @@ -2854,7 +2979,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)); } @@ -2863,7 +2988,7 @@ 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)) { @@ -2883,7 +3008,7 @@ Perl_sighandler(int sig) (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ - Perl_die(aTHX_ NULL); + die_sv(ERRSV); } cleanup: if (flags & 1) @@ -2921,8 +3046,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)) { @@ -2948,13 +3075,12 @@ 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; } } @@ -2965,6 +3091,8 @@ S_unwind_handler_stack(pTHX_ const void *p) dVAR; const U32 flags = *(const U32*)p; + PERL_ARGS_ASSERT_UNWIND_HANDLER_STACK; + if (flags & 1) PL_savestack_ix -= 5; /* Unprotect save in progress. */ #if !defined(PERL_IMPLICIT_CONTEXT) @@ -2987,9 +3115,11 @@ 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; + /* mg->mg_obj isn't being used. If needed, it would be possible to store an alternative leaf in there, with PL_compiling.cop_hints being used if it's NULL. If needed for threads, the alternative could lock a mutex, @@ -3005,7 +3135,7 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg) } /* -=for apidoc magic_sethint +=for apidoc magic_clearhint Triggered by a delete from %^H, records the key to C. @@ -3016,6 +3146,8 @@ int Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) { dVAR; + + PERL_ARGS_ASSERT_MAGIC_CLEARHINT; PERL_UNUSED_ARG(sv); assert(mg->mg_len == HEf_SVKEY); @@ -3025,7 +3157,27 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg) 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); + MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder); + 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); + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; + } return 0; }