X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/84335ee93339f99a0959258e640fa57e9f0ba6ab..e2bcdfc01b8759d90d7dac9448eb6bd60378bcdc:/mg.c diff --git a/mg.c b/mg.c index 0bc7979..276e13d 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"] */ /* @@ -358,7 +360,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: @@ -461,15 +463,19 @@ 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; @@ -493,9 +499,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; + } } } @@ -524,7 +532,7 @@ Perl_mg_free(pTHX_ SV *sv) 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); @@ -532,6 +540,7 @@ Perl_mg_free(pTHX_ SV *sv) SvMAGIC_set(sv, moremagic); } SvMAGIC_set(sv, NULL); + SvMAGICAL_off(sv); return 0; } @@ -611,7 +620,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(aTHX_ "%s", PL_no_modify); NORETURN_FUNCTION_END; } @@ -763,14 +772,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 @@ -780,7 +782,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 */ @@ -803,15 +805,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); @@ -895,7 +897,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) @@ -918,7 +920,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] */ @@ -1017,8 +1019,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (GvIOp(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); @@ -1029,7 +1029,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpv(sv, errno ? Strerror(errno) : ""); #else { - const int saveerrno = errno; + dSAVE_ERRNO; sv_setnv(sv, (NV)errno); #ifdef OS2 if (errno == errno_isOS2 || errno == errno_isOS2_set) @@ -1037,7 +1037,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); - errno = saveerrno; + RESTORE_ERRNO; } #endif SvRTRIM(sv); @@ -1068,10 +1068,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; } @@ -1196,11 +1194,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 @@ -1329,35 +1327,6 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) 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); -} - Signal_t #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) Perl_csighandler(int sig, siginfo_t *sip PERL_UNUSED_DECL, void *uap PERL_UNUSED_DECL) @@ -1370,8 +1339,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; @@ -1384,9 +1351,7 @@ Perl_csighandler(int sig) exit(1); #endif #endif -#if defined(HAS_SIGACTION) && defined(SA_SIGINFO) -#endif - if ( + if ( #ifdef SIGILL sig == SIGILL || #endif @@ -1404,8 +1369,19 @@ Perl_csighandler(int sig) #else (*PL_sighandlerp)(sig); #endif - else - S_raise_signal(aTHX_ sig); + else { + /* 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 + /* 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); + } } #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS) @@ -1518,7 +1494,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PL_psig_name[i] = newSVpvn(s, len); SvREADONLY_on(PL_psig_name[i]); } - if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) { + if (isGV_with_GP(sv) || SvROK(sv)) { if (i) { (void)rsignal(i, PL_csighandlerp); #ifdef HAS_SIGPROCMASK @@ -1603,11 +1579,12 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) 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; } @@ -1623,16 +1600,17 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) /* Bail out if destruction is going on */ if(PL_dirty) return 0; - av_clear((AV*)sv); + av_clear(MUTABLE_AV(sv)); /* 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 + : (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; } @@ -1652,7 +1630,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; @@ -1660,7 +1638,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)) @@ -1678,7 +1656,7 @@ 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; } @@ -1700,7 +1678,7 @@ S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int if (mg->mg_len >= 0) mPUSHp(mg->mg_ptr, mg->mg_len); else if (mg->mg_len == HEf_SVKEY) - PUSHs((SV*)mg->mg_ptr); + PUSHs(MUTABLE_SV(mg->mg_ptr)); } else if (mg->mg_type == PERL_MAGIC_tiedelem) { mPUSHi(mg->mg_len); @@ -1852,8 +1830,8 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) { dVAR; dSP; 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; @@ -1864,7 +1842,7 @@ 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; } @@ -1914,7 +1892,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; @@ -1930,7 +1908,7 @@ 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; @@ -2178,12 +2156,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)]; } @@ -2230,14 +2208,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 { @@ -2259,7 +2237,7 @@ 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); + return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj)); } int @@ -2377,7 +2355,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) * set without a previous pattern match. Unless it's C */ if (!PL_localizing) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } } case '\001': /* ^A */ @@ -2398,21 +2376,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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 @@ -2463,7 +2437,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) 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)); + : newSVpvs_flags("", SVs_TEMP | SvUTF8(sv)); tmp_he = Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, @@ -2615,16 +2589,6 @@ 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; @@ -2797,7 +2761,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case ':': PL_chopset = SvPV_force(sv,len); break; -#ifndef MACOS_TRADITIONAL case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE @@ -2863,7 +2826,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif UNLOCK_DOLLARZERO_MUTEX; break; -#endif } return 0; } @@ -2935,7 +2897,7 @@ 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); @@ -2972,7 +2934,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)); @@ -2986,7 +2948,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)); } @@ -2995,7 +2957,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)) { @@ -3121,7 +3083,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; @@ -3163,7 +3125,7 @@ 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; }