X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/150b625d31233719d0d078c7d9ebe5ac46a6c4da..010c8e19c2f0fd992a14779da9537d6867caf46f:/mg.c diff --git a/mg.c b/mg.c index e821415..5c2628b 100644 --- a/mg.c +++ b/mg.c @@ -164,42 +164,6 @@ Perl_mg_magical(pTHX_ SV *sv) } } - -/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */ - -STATIC bool -S_is_container_magic(const MAGIC *mg) -{ - assert(mg); - switch (mg->mg_type) { - case PERL_MAGIC_bm: - case PERL_MAGIC_fm: - case PERL_MAGIC_regex_global: - case PERL_MAGIC_nkeys: -#ifdef USE_LOCALE_COLLATE - case PERL_MAGIC_collxfrm: -#endif - case PERL_MAGIC_qr: - case PERL_MAGIC_taint: - case PERL_MAGIC_vec: - case PERL_MAGIC_vstring: - case PERL_MAGIC_utf8: - case PERL_MAGIC_substr: - case PERL_MAGIC_defelem: - case PERL_MAGIC_arylen: - case PERL_MAGIC_pos: - case PERL_MAGIC_backref: - case PERL_MAGIC_arylen_p: - case PERL_MAGIC_rhash: - case PERL_MAGIC_symtab: - case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */ - case PERL_MAGIC_checkcall: - return 0; - default: - return 1; - } -} - /* =for apidoc mg_get @@ -296,7 +260,8 @@ Perl_mg_set(pTHX_ SV *sv) mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */ (SSPTR(mgs_ix, MGS*))->mgs_magical = 0; } - if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV)) + if (PL_localizing == 2 + && (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type) || sv == DEFSV)) continue; if (vtbl && vtbl->svt_set) vtbl->svt_set(aTHX_ sv, mg); @@ -412,7 +377,7 @@ Perl_mg_clear(pTHX_ SV *sv) return 0; } -MAGIC* +static MAGIC* S_mg_findext_flags(pTHX_ const SV *sv, int type, const MGVTBL *vtbl, U32 flags) { PERL_UNUSED_CONTEXT; @@ -526,7 +491,7 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { const MGVTBL* const vtbl = mg->mg_virtual; - if (!S_is_container_magic(mg)) + if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type)) continue; if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local) @@ -536,7 +501,7 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic) mg->mg_ptr, mg->mg_len); /* container types should remain read-only across localization */ - SvFLAGS(nsv) |= SvREADONLY(sv); + if (!SvIsCOW(sv)) SvFLAGS(nsv) |= SvREADONLY(sv); } if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) { @@ -1067,9 +1032,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '^': - if (!isGV_with_GP(PL_defoutgv)) - s = ""; - else if (GvIOp(PL_defoutgv)) + if (GvIOp(PL_defoutgv)) s = IoTOP_NAME(GvIOp(PL_defoutgv)); if (s) sv_setpv(sv,s); @@ -1079,9 +1042,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '~': - if (!isGV_with_GP(PL_defoutgv)) - s = ""; - else if (GvIOp(PL_defoutgv)) + if (GvIOp(PL_defoutgv)) s = IoFMT_NAME(GvIOp(PL_defoutgv)); if (!s) s = GvENAME(PL_defoutgv); @@ -1104,7 +1065,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '/': break; case '[': - sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)); + sv_setiv(sv, 0); break; case '|': if (GvIO(PL_defoutgv)) @@ -1114,6 +1075,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); break; + case '$': /* $$ */ + { + IV const pid = (IV)PerlProc_getpid(); + if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) + /* never set manually, or at least not since last fork */ + sv_setiv(sv, pid); + /* else a value has been assigned manually, so do nothing */ + } + break; + case '!': { dSAVE_ERRNO; @@ -1331,7 +1302,9 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETSIG; if (!i) { - mg->mg_private = i = whichsig(MgPV_nolen_const(mg)); + STRLEN siglen; + const char * sig = MgPV_const(mg, siglen); + mg->mg_private = i = whichsig_pvn(sig, siglen); } if (i > 0) { @@ -1362,7 +1335,6 @@ int Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_CLEARSIG; - PERL_UNUSED_ARG(sv); magic_setsig(NULL, mg); return sv_unmagic(sv, mg->mg_type); @@ -1523,9 +1495,9 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETSIG; if (*s == '_') { - if (strEQ(s,"__DIE__")) + if (memEQs(s, len, "__DIE__")) svp = &PL_diehook; - else if (strEQ(s,"__WARN__") + else if (memEQs(s, len, "__WARN__") && (sv ? 1 : PL_warnhook != PERL_WARNHOOK_FATAL)) { /* Merge the existing behaviours, which are as follows: magic_setsig, we always set svp to &PL_warnhook @@ -1533,8 +1505,11 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) For magic_clearsig, we don't change the warnings handler if it's set to the &PL_warnhook. */ svp = &PL_warnhook; - } else if (sv) - Perl_croak(aTHX_ "No such hook: %s", s); + } else if (sv) { + SV *tmp = sv_newmortal(); + Perl_croak(aTHX_ "No such hook: %s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } i = 0; if (svp && *svp) { if (*svp != PERL_WARNHOOK_FATAL) @@ -1545,12 +1520,15 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) else { i = (I16)mg->mg_private; if (!i) { - i = whichsig(s); /* ...no, a brick */ + i = whichsig_pvn(s, len); /* ...no, a brick */ mg->mg_private = (U16)i; } if (i <= 0) { - if (sv) - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) { + SV *tmp = sv_newmortal(); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", + pv_pretty(tmp, s, len, 0, NULL, NULL, 0)); + } return 0; } #ifdef HAS_SIGPROCMASK @@ -1606,7 +1584,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) } else { sv = NULL; } - if (sv && strEQ(s,"IGNORE")) { + if (sv && memEQs(s, len,"IGNORE")) { if (i) { #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS PL_sig_ignoring[i] = 1; @@ -1616,7 +1594,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) #endif } } - else if (!sv || strEQ(s,"DEFAULT") || !len) { + else if (!sv || memEQs(s, len,"DEFAULT") || !len) { if (i) { #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS PL_sig_defaulting[i] = 1; @@ -1732,7 +1710,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg) if (hv) { (void) hv_iterinit(hv); if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) - i = HvKEYS(hv); + i = HvUSEDKEYS(hv); else { while (hv_iternext(hv)) i++; @@ -1759,13 +1737,20 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg) 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. +C and C are the tied thingy and the tie magic. + +C is the name of the method to call. + +C is the number of args (in addition to $self) to pass to the method. + +The C can be: + + G_DISCARD invoke method with G_DISCARD flag and don't + return a value + G_UNDEF_FILL fill the stack with argc pointers to + PL_sv_undef + +The arguments themselves are any values following the C argument. Returns the SV (if any) returned by the method, or NULL on failure. @@ -2037,7 +2022,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETARYLEN; if (obj) { - sv_setiv(sv, AvFILL(obj) + CopARYBASE_get(PL_curcop)); + sv_setiv(sv, AvFILL(obj)); } else { SvOK_off(sv); } @@ -2053,7 +2038,7 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETARYLEN; if (obj) { - av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop)); + av_fill(obj, SvIV(sv)); } else { Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Attempt to set length of freed array"); @@ -2101,7 +2086,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) I32 i = found->mg_len; if (DO_UTF8(lsv)) sv_pos_b2u(lsv, &i); - sv_setiv(sv, i + CopARYBASE_get(PL_curcop)); + sv_setiv(sv, i); return 0; } } @@ -2142,7 +2127,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) } len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv); - pos = SvIV(sv) - CopARYBASE_get(PL_curcop); + pos = SvIV(sv); if (DO_UTF8(lsv)) { ulen = sv_len_utf8(lsv); @@ -2384,9 +2369,8 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_SETMGLOB; PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); mg->mg_len = -1; - if (!isGV_with_GP(sv)) - SvSCREAM_off(sv); return 0; } @@ -2413,9 +2397,11 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) } else if (type == PERL_MAGIC_bm) { SvTAIL_off(sv); SvVALID_off(sv); + } else if (type == PERL_MAGIC_study) { + if (!isGV_with_GP(sv)) + SvSCREAM_off(sv); } else { assert(type == PERL_MAGIC_fm); - SvCOMPILED_off(sv); } return sv_unmagic(sv, type); } @@ -2501,6 +2487,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\001': /* ^A */ sv_setsv(PL_bodytarget, sv); + FmLINES(PL_bodytarget) = 0; + if (SvPOK(PL_bodytarget)) { + char *s = SvPVX(PL_bodytarget); + while ( ((s = strchr(s, '\n'))) ) { + FmLINES(PL_bodytarget)++; + s++; + } + } /* mg_set() has temporarily made sv non-magical */ if (PL_tainting) { if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) @@ -2679,33 +2673,25 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv); break; case '^': - if (isGV_with_GP(PL_defoutgv)) { - Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); - s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - } + Safefree(IoTOP_NAME(GvIOp(PL_defoutgv))); + s = IoTOP_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoTOP_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '~': - if (isGV_with_GP(PL_defoutgv)) { - Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); - s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); - IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); - } + Safefree(IoFMT_NAME(GvIOp(PL_defoutgv))); + s = IoFMT_NAME(GvIOp(PL_defoutgv)) = savesvpv(sv); + IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchsv(sv, GV_ADD, SVt_PVIO); break; case '=': - if (isGV_with_GP(PL_defoutgv)) - IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); + IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '-': - if (isGV_with_GP(PL_defoutgv)) { - IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); - if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) + IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIV(sv)); + if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L) IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L; - } break; case '%': - if (isGV_with_GP(PL_defoutgv)) - IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); + IoPAGE(GvIOp(PL_defoutgv)) = (SvIV(sv)); break; case '|': { @@ -2737,9 +2723,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_ors_sv = NULL; } break; - case '[': - CopARYBASE_set(&PL_compiling, SvIV(sv)); - break; case '?': #ifdef COMPLEX_STATUS if (PL_localizing == 2) { @@ -2837,7 +2820,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) (void)setregid((Gid_t)PL_gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1); + (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) -1); #else if (PL_gid == PL_egid) /* special case $( = $) */ (void)PerlProc_setgid(PL_gid); @@ -2914,6 +2897,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case ':': PL_chopset = SvPV_force(sv,len); break; + case '$': /* $$ */ + /* Store the pid in mg->mg_obj so we can tell when a fork has + occurred. mg->mg_obj points to *$ by default, so clear it. */ + if (isGV(mg->mg_obj)) { + if (mg->mg_flags & MGf_REFCOUNTED) /* probably never true */ + SvREFCNT_dec(mg->mg_obj); + mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = newSViv((IV)PerlProc_getpid()); + } + else sv_setiv(mg->mg_obj, (IV)PerlProc_getpid()); + break; case '0': LOCK_DOLLARZERO_MUTEX; #ifdef HAS_SETPROCTITLE @@ -2991,22 +2985,41 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } I32 -Perl_whichsig(pTHX_ const char *sig) +Perl_whichsig_sv(pTHX_ SV *sigsv) +{ + const char *sigpv; + STRLEN siglen; + PERL_ARGS_ASSERT_WHICHSIG_SV; + PERL_UNUSED_CONTEXT; + sigpv = SvPV_const(sigsv, siglen); + return whichsig_pvn(sigpv, siglen); +} + +I32 +Perl_whichsig_pv(pTHX_ const char *sig) +{ + PERL_ARGS_ASSERT_WHICHSIG_PV; + PERL_UNUSED_CONTEXT; + return whichsig_pvn(sig, strlen(sig)); +} + +I32 +Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) { register char* const* sigv; - PERL_ARGS_ASSERT_WHICHSIG; + PERL_ARGS_ASSERT_WHICHSIG_PVN; PERL_UNUSED_CONTEXT; for (sigv = (char* const*)PL_sig_name; *sigv; sigv++) - if (strEQ(sig,*sigv)) + if (strlen(*sigv) == len && memEQ(sig,*sigv, len)) return PL_sig_num[sigv - (char* const*)PL_sig_name]; #ifdef SIGCLD - if (strEQ(sig,"CHLD")) + if (memEQs(sig, len, "CHLD")) return SIGCLD; #endif #ifdef SIGCHLD - if (strEQ(sig,"CLD")) + if (memEQs(sig, len, "CLD")) return SIGCHLD; #endif return -1;