X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=5cfa8cb9204aa30a35d9ef757e40907b78b60498;hb=210de33e131d7fdc9337689b20de77974cb93d7a;hp=22f8c9990de4cf4013c2408dc7da5e743c23f1f0;hpb=9711599ee3b2375539002b6ddc0873ec478916bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/mg.c b/mg.c index 22f8c99..5cfa8cb 100644 --- a/mg.c +++ b/mg.c @@ -383,15 +383,18 @@ 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); } @@ -467,7 +470,7 @@ 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 empty is false then no set magic will be called on the new (empty) SV. +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. @@ -475,7 +478,7 @@ and that will handle the magic. */ void -Perl_mg_localize(pTHX_ SV *sv, SV *nsv, I32 empty) +Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) { dVAR; MAGIC *mg; @@ -499,7 +502,7 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, I32 empty) if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { SvFLAGS(nsv) |= SvMAGICAL(sv); - if (empty) { + if (setmagic) { PL_localizing = 1; SvSETMAGIC(nsv); PL_localizing = 0; @@ -772,14 +775,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 @@ -817,10 +813,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } #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); @@ -904,7 +900,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) @@ -981,6 +977,7 @@ 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 @@ -1026,8 +1023,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); @@ -1038,7 +1033,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) @@ -1046,7 +1041,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) else #endif sv_setpv(sv, errno ? Strerror(errno) : ""); - errno = saveerrno; + RESTORE_ERRNO; } #endif SvRTRIM(sv); @@ -1077,10 +1072,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; } @@ -1245,10 +1238,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]); @@ -1276,66 +1273,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 @@ -1374,13 +1316,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]++; @@ -1388,7 +1331,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); @@ -1437,6 +1380,7 @@ Perl_despatch_signals(pTHX) } } +/* sv of NULL signifies that we're acting as magic_clearsig. */ int Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) { @@ -1460,21 +1404,31 @@ 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)) + if (sv && ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } @@ -1498,62 +1452,75 @@ 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 (isGV_with_GP(sv) || 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; @@ -1568,38 +1535,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) 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 - ? (const GV *)mg->mg_obj - : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->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) { @@ -1611,9 +1557,17 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg) /* Bail out if destruction is going on */ if(PL_dirty) return 0; - av_clear(MUTABLE_AV(sv)); + if (sv) + av_clear(MUTABLE_AV(sv)); + + /* XXX Once it's possible, we need to + detect that our @ISA is aliased in + other stashes, and act on the stashes + of all of the aliases */ - /* XXX see comments in magic_setisa */ + /* The first case occurs via setisa, + the second via setisa_elem, which + calls this same magic */ stash = GvSTASH( SvTYPE(mg->mg_obj) == SVt_PVGV ? (const GV *)mg->mg_obj @@ -2387,21 +2341,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 @@ -2604,22 +2554,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); } @@ -2786,7 +2727,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 @@ -2852,7 +2792,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) #endif UNLOCK_DOLLARZERO_MUTEX; break; -#endif } return 0; }