X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/27deb0cf05ad74bec9ea0da3d1b6405346a66401..a8cb1947aad7d9fcd7bb6fdc7fe8bf92f699d59d:/mg.c?ds=sidebyside diff --git a/mg.c b/mg.c index a0ee39d..3b341d5 100644 --- a/mg.c +++ b/mg.c @@ -171,6 +171,7 @@ Perl_mg_get(pTHX_ SV *sv) const I32 mgs_ix = SSNEW(sizeof(MGS)); bool saved = FALSE; bool have_new = 0; + bool taint_only = TRUE; /* the only get method seen is taint */ MAGIC *newmg, *head, *cur, *mg; PERL_ARGS_ASSERT_MG_GET; @@ -189,10 +190,13 @@ Perl_mg_get(pTHX_ SV *sv) if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) { /* taint's mg get is so dumb it doesn't need flag saving */ - if (!saved && mg->mg_type != PERL_MAGIC_taint) { - save_magic(mgs_ix, sv); - saved = TRUE; - } + if (mg->mg_type != PERL_MAGIC_taint) { + taint_only = FALSE; + if (!saved) { + save_magic(mgs_ix, sv); + saved = TRUE; + } + } vtbl->svt_get(aTHX_ sv, mg); @@ -210,8 +214,23 @@ Perl_mg_get(pTHX_ SV *sv) ~(SVs_GMG|SVs_SMG|SVs_RMG); } else if (vtbl == &PL_vtbl_utf8) { - /* get-magic can reallocate the PV */ - magic_setutf8(sv, mg); + /* get-magic can reallocate the PV, unless there's only taint + * magic */ + if (taint_only) { + MAGIC *mg2; + for (mg2 = nextmg; mg2; mg2 = mg2->mg_moremagic) { + if ( mg2->mg_type != PERL_MAGIC_taint + && !(mg2->mg_flags & MGf_GSKIP) + && mg2->mg_virtual + && mg2->mg_virtual->svt_get + ) { + taint_only = FALSE; + break; + } + } + } + if (!taint_only) + magic_setutf8(sv, mg); } mg = nextmg; @@ -588,9 +607,9 @@ Perl_mg_free_type(pTHX_ SV *sv, int how) MAGIC *mg, *prevmg, *moremg; PERL_ARGS_ASSERT_MG_FREE_TYPE; for (prevmg = NULL, mg = SvMAGIC(sv); mg; prevmg = mg, mg = moremg) { - MAGIC *newhead; moremg = mg->mg_moremagic; if (mg->mg_type == how) { + MAGIC *newhead; /* temporarily move to the head of the magic chain, in case custom free code relies on this historical aspect of mg_free */ if (prevmg) { @@ -619,8 +638,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - UV uv= (UV)mg->mg_obj; - if (uv == '+') { /* @+ */ + const SSize_t n = (SSize_t)mg->mg_obj; + if (n == '+') { /* @+ */ /* return the number possible */ return RX_NPARENS(rx); } else { /* @- @^CAPTURE @{^CAPTURE} */ @@ -631,7 +650,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) && (RX_OFFS(rx)[paren].start == -1 || RX_OFFS(rx)[paren].end == -1) ) paren--; - if (uv == '-') { + if (n == '-') { /* @- */ return (U32)paren; } else { @@ -655,10 +674,10 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm) { REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - const UV uv= (UV)mg->mg_obj; + const SSize_t n = (SSize_t)mg->mg_obj; /* @{^CAPTURE} does not contain $&, so we need to increment by 1 */ const I32 paren = mg->mg_len - + (uv == '\003' ? 1 : 0); + + (n == '\003' ? 1 : 0); SSize_t s; SSize_t t; if (paren < 0) @@ -669,9 +688,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { SSize_t i; - if (uv == '+') /* @+ */ + if (n == '+') /* @+ */ i = t; - else if (uv == '-') /* @- */ + else if (n == '-') /* @- */ i = s; else { /* @^CAPTURE @{^CAPTURE} */ CALLREG_NUMBUF_FETCH(rx,paren,sv); @@ -691,7 +710,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) } } } - sv_setsv(sv, NULL); + sv_set_undef(sv); return 0; } @@ -725,7 +744,7 @@ 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); + sv_set_undef(sv); else { SvPVCLEAR(sv); SvUTF8_off(sv); @@ -800,9 +819,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { do_numbuf_fetch: CALLREG_NUMBUF_FETCH(rx,paren,sv); - } else { - sv_setsv(sv,&PL_sv_undef); } + else + goto set_undef; return 0; } @@ -810,7 +829,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); - else sv_setsv(sv, &PL_sv_undef); + else + sv_set_undef(sv); if (SvTAINTED(PL_bodytarget)) SvTAINTED_on(sv); break; @@ -829,7 +849,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\005': /* ^E */ if (nextchar != '\0') { if (strEQ(remaining, "NCODING")) - sv_setsv(sv, NULL); + sv_set_undef(sv); break; } @@ -924,7 +944,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '\010': /* ^H */ - sv_setiv(sv, (IV)PL_hints); + sv_setuv(sv, PL_hints); break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ @@ -940,7 +960,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvROK_on(sv); sv_rvweaken(sv); } - else sv_setsv_nomg(sv, NULL); + else + sv_set_undef(sv); } break; case '\017': /* ^O & ^OPEN */ @@ -988,14 +1009,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\027': /* ^W & $^WARNING_BITS */ if (nextchar == '\0') - sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); + sv_setiv(sv, (IV)cBOOL(PL_dowarn & G_WARN_ON)); else if (strEQ(remaining, "ARNING_BITS")) { if (PL_compiling.cop_warnings == pWARN_NONE) { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_STD) { - sv_setsv(sv, &PL_sv_undef); - break; + goto set_undef; } else if (PL_compiling.cop_warnings == pWARN_ALL) { /* Get the bit mask for $warnings::Bits{all}, because @@ -1024,16 +1044,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = RX_LASTCLOSEPAREN(rx); if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -1092,7 +1110,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); else - sv_setsv(sv, &PL_sv_undef); + goto set_undef; break; case '$': /* $$ */ { @@ -1121,13 +1139,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #ifdef HAS_GETGROUPS { Groups_t *gary = NULL; - I32 i; I32 num_groups = getgroups(0, gary); if (num_groups > 0) { + I32 i; Newx(gary, num_groups, Groups_t); num_groups = getgroups(num_groups, gary); for (i = 0; i < num_groups; i++) - Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]); + Perl_sv_catpvf(aTHX_ sv, " %" IVdf, (IV)gary[i]); Safefree(gary); } } @@ -1138,6 +1156,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; } return 0; + + set_undef: + sv_set_undef(sv); + return 0; } int @@ -1341,7 +1363,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) if(sigstate == (Sighandler_t) SIG_IGN) sv_setpvs(sv,"IGNORE"); else - sv_setsv(sv,&PL_sv_undef); + sv_set_undef(sv); PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); SvTEMP_off(sv); } @@ -2002,7 +2024,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) /* The magic ptr/len for the debugger's hash should always be an SV. */ if (UNLIKELY(mg->mg_len != HEf_SVKEY)) { - Perl_croak(aTHX_ "panic: magic_setdbline len=%"IVdf", ptr='%s'", + Perl_croak(aTHX_ "panic: magic_setdbline len=%" IVdf ", ptr='%s'", (IV)mg->mg_len, mg->mg_ptr); } @@ -2040,7 +2062,7 @@ Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg) if (obj) { sv_setiv(sv, AvFILL(obj)); } else { - sv_setsv(sv, NULL); + sv_set_undef(sv); } return 0; } @@ -2118,7 +2140,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg) sv_setuv(sv, i); return 0; } - sv_setsv(sv,NULL); + sv_set_undef(sv); return 0; } @@ -2128,7 +2150,6 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) SV* const lsv = LvTARG(sv); SSize_t pos; STRLEN len; - STRLEN ulen = 0; MAGIC* found; const char *s; @@ -2150,7 +2171,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) pos = SvIV(sv); if (DO_UTF8(lsv)) { - ulen = sv_or_pv_len_utf8(lsv, s, len); + const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len); if (ulen) len = ulen; } @@ -2177,8 +2198,8 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) const char * const tmps = SvPV_const(lsv,len); STRLEN offs = LvTARGOFF(sv); STRLEN rem = LvTARGLEN(sv); - const bool negoff = LvFLAGS(sv) & 1; - const bool negrem = LvFLAGS(sv) & 2; + const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; + const bool negrem = LvFLAGS(sv) & LVf_NEG_LEN; PERL_ARGS_ASSERT_MAGIC_GETSUBSTR; PERL_UNUSED_ARG(mg); @@ -2189,7 +2210,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); - sv_setsv_nomg(sv, &PL_sv_undef); + sv_set_undef(sv); return 0; } @@ -2209,8 +2230,8 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) SV * const lsv = LvTARG(sv); STRLEN lvoff = LvTARGOFF(sv); STRLEN lvlen = LvTARGLEN(sv); - const bool negoff = LvFLAGS(sv) & 1; - const bool neglen = LvFLAGS(sv) & 2; + const bool negoff = LvFLAGS(sv) & LVf_NEG_OFF; + const bool neglen = LvFLAGS(sv) & LVf_NEG_LEN; PERL_ARGS_ASSERT_MAGIC_SETSUBSTR; PERL_UNUSED_ARG(mg); @@ -2285,11 +2306,14 @@ int Perl_magic_getvec(pTHX_ SV *sv, MAGIC *mg) { SV * const lsv = LvTARG(sv); + char errflags = LvFLAGS(sv); PERL_ARGS_ASSERT_MAGIC_GETVEC; PERL_UNUSED_ARG(mg); - sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); + /* non-zero errflags implies deferred out-of-range condition */ + assert(!(errflags & ~(LVf_NEG_OFF|LVf_OUT_OF_RANGE))); + sv_setuv(sv, errflags ? 0 : do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv))); return 0; } @@ -2443,13 +2467,9 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SETREGEXP; - if (type == PERL_MAGIC_qr) { - } else if (type == PERL_MAGIC_bm) { - SvTAIL_off(sv); - SvVALID_off(sv); - } else { - assert(type == PERL_MAGIC_fm); - } + assert( type == PERL_MAGIC_fm + || type == PERL_MAGIC_qr + || type == PERL_MAGIC_bm); return sv_unmagic(sv, type); } @@ -2559,7 +2579,7 @@ S_set_dollarzero(pTHX_ SV *sv) * the setproctitle() routine to manipulate that. */ if (PL_origalen != 1) { s = SvPV_const(sv, len); -# if __FreeBSD_version > 410001 +# if __FreeBSD_version > 410001 || defined(__DragonFly__) /* The leading "-" removes the "perl: " prefix, * but not the "(perl) suffix from the ps(1) * output, because that's what ps(1) shows if the @@ -2708,19 +2728,22 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) # endif #endif } - else { - if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) - if (PL_localizing != 2) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "${^ENCODING} is no longer supported"); - } - } + else if (strEQ(mg->mg_ptr + 1, "NCODING") && SvOK(sv)) + Perl_croak(aTHX_ "${^ENCODING} is no longer supported"); break; case '\006': /* ^F */ PL_maxsysfd = SvIV(sv); break; case '\010': /* ^H */ - PL_hints = SvIV(sv); + { + U32 save_hints = PL_hints; + PL_hints = SvUV(sv); + + /* If wasn't UTF-8, and now is, notify the parser */ + if ((PL_hints & HINT_UTF8) && ! (save_hints & HINT_UTF8)) { + notify_parser_that_changed_to_utf8(); + } + } break; case '\011': /* ^I */ /* NOT \t in EBCDIC */ Safefree(PL_inplace); @@ -2888,33 +2911,32 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '/': { - SV *tmpsv= sv; if (SvROK(sv)) { - SV *referent= SvRV(sv); - const char *reftype= sv_reftype(referent, 0); - /* XXX: dodgy type check: This leaves me feeling dirty, but the alternative - * is to copy pretty much the entire sv_reftype() into this routine, or to do - * a full string comparison on the return of sv_reftype() both of which - * make me feel worse! NOTE, do not modify this comment without reviewing the - * corresponding comment in sv_reftype(). - Yves */ + SV *referent = SvRV(sv); + const char *reftype = sv_reftype(referent, 0); + /* XXX: dodgy type check: This leaves me feeling dirty, but + * the alternative is to copy pretty much the entire + * sv_reftype() into this routine, or to do a full string + * comparison on the return of sv_reftype() both of which + * make me feel worse! NOTE, do not modify this comment + * without reviewing the corresponding comment in + * sv_reftype(). - Yves */ if (reftype[0] == 'S' || reftype[0] == 'L') { - IV val= SvIV(referent); + IV val = SvIV(referent); if (val <= 0) { - tmpsv= &PL_sv_undef; - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), - "Setting $/ to a reference to %s as a form of slurp is deprecated, treating as undef", - SvIV(SvRV(sv)) < 0 ? "a negative integer" : "zero" - ); + sv_setsv(sv, PL_rs); + Perl_croak(aTHX_ "Setting $/ to a reference to %s is forbidden", + val < 0 ? "a negative integer" : "zero"); } } else { sv_setsv(sv, PL_rs); - /* diag_listed_as: Setting $/ to %s reference is forbidden */ + /* diag_listed_as: Setting $/ to %s reference is forbidden */ Perl_croak(aTHX_ "Setting $/ to a%s %s reference is forbidden", *reftype == 'A' ? "n" : "", reftype); } } SvREFCNT_dec(PL_rs); - PL_rs = newSVsv(tmpsv); + PL_rs = newSVsv(sv); } break; case '\\': @@ -3250,7 +3272,7 @@ Perl_sighandler(int sig) : cv && CvGV(cv) ? GvENAME_HEK(CvGV(cv)) : NULL; if (hek) Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "SIG%s handler \"%"HEKf"\" not defined.\n", + "SIG%s handler \"%" HEKf "\" not defined.\n", PL_sig_name[sig], HEKfARG(hek)); /* diag_listed_as: SIG%s handler "%s" not defined */ else Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL),