X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a9844598bfc0b23a08d80e539ba4e03fbe392971..ff44333e5a9d9dca5272bb166df463607ebd3020:/mg.c diff --git a/mg.c b/mg.c index a182aad..e56f53d 100644 --- a/mg.c +++ b/mg.c @@ -90,13 +90,13 @@ struct magic_state { /* MGS is typedef'ed to struct magic_state in perl.h */ STATIC void -S_save_magic(pTHX_ I32 mgs_ix, SV *sv) +S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags) { dVAR; MGS* mgs; bool bumped = FALSE; - PERL_ARGS_ASSERT_SAVE_MAGIC; + PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS; assert(SvMAGICAL(sv)); @@ -111,24 +111,23 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv) bumped = TRUE; } - /* Turning READONLY off for a copy-on-write scalar (including shared - hash keys) is a bad idea. */ - if (SvIsCOW(sv)) - sv_force_normal_flags(sv, 0); - SAVEDESTRUCTOR_X(S_restore_magic, INT2PTR(void*, (IV)mgs_ix)); mgs = SSPTR(mgs_ix, MGS*); mgs->mgs_sv = sv; mgs->mgs_magical = SvMAGICAL(sv); - mgs->mgs_readonly = SvREADONLY(sv) != 0; + mgs->mgs_readonly = SvREADONLY(sv) && !SvIsCOW(sv); mgs->mgs_ss_ix = PL_savestack_ix; /* points after the saved destructor */ mgs->mgs_bumped = bumped; - SvMAGICAL_off(sv); - SvREADONLY_off(sv); + SvFLAGS(sv) &= ~flags; + /* Turning READONLY off for a copy-on-write scalar (including shared + hash keys) is a bad idea. */ + if (!SvIsCOW(sv)) SvREADONLY_off(sv); } +#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG) + /* =for apidoc mg_magical @@ -165,7 +164,8 @@ Perl_mg_magical(pTHX_ SV *sv) /* =for apidoc mg_get -Do magic after a value is retrieved from the SV. See C. +Do magic before a value is retrieved from the SV. The type of SV must +be >= SVt_PVMG. See C. =cut */ @@ -213,6 +213,10 @@ Perl_mg_get(pTHX_ SV *sv) if (mg->mg_flags & MGf_GSKIP) (SSPTR(mgs_ix, MGS *))->mgs_magical = 0; } + else if (vtbl == &PL_vtbl_utf8) { + /* get-magic can reallocate the PV */ + magic_setutf8(sv, mg); + } mg = nextmg; @@ -261,7 +265,7 @@ Perl_mg_set(pTHX_ SV *sv) if (PL_localizing == 2 && sv == DEFSV) return 0; - save_magic(mgs_ix, sv); + save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */ for (mg = SvMAGIC(sv); mg; mg = nextmg) { const MGVTBL* vtbl = mg->mg_virtual; @@ -284,7 +288,11 @@ Perl_mg_set(pTHX_ SV *sv) /* =for apidoc mg_length -Report on the SV's length. See C. +Reports on the SV's length in bytes, calling length magic if available, +but does not set the UTF8 flag on the sv. It will fall back to 'get' +magic if there is no 'length' magic, but with no indication as to +whether it called 'get' magic. It assumes the sv is a PVMG or +higher. Use sv_len() instead. =cut */ @@ -310,15 +318,7 @@ Perl_mg_length(pTHX_ SV *sv) } } - { - /* You can't know whether it's UTF-8 until you get the string again... - */ - const U8 *s = (U8*)SvPV_const(sv, len); - - if (DO_UTF8(sv)) { - len = utf8_length(s, s + len); - } - } + (void)SvPV_const(sv, len); return len; } @@ -612,7 +612,7 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATA_CNT; if (PL_curpm) { - register const REGEXP * const rx = PM_GETRE(PL_curpm); + const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { if (mg->mg_obj) { /* @+ */ /* return the number possible */ @@ -633,6 +633,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg) return (U32)-1; } +/* @-, @+ */ + int Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) { @@ -641,18 +643,18 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_REGDATUM_GET; if (PL_curpm) { - register const REGEXP * const rx = PM_GETRE(PL_curpm); + const REGEXP * const rx = PM_GETRE(PL_curpm); if (rx) { - register const I32 paren = mg->mg_len; - register I32 s; - register I32 t; + const I32 paren = mg->mg_len; + I32 s; + I32 t; if (paren < 0) return 0; if (paren <= (I32)RX_NPARENS(rx) && (s = RX_OFFS(rx)[paren].start) != -1 && (t = RX_OFFS(rx)[paren].end) != -1) { - register I32 i; + I32 i; if (mg->mg_obj) /* @+ */ i = t; else /* @- */ @@ -661,7 +663,9 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) if (i > 0 && RX_MATCH_UTF8(rx)) { const char * const b = RX_SUBBEG(rx); if (b) - i = utf8_length((U8*)b, (U8*)(b+i)); + i = RX_SUBCOFFSET(rx) + + utf8_length((U8*)b, + (U8*)(b-RX_SUBOFFSET(rx)+i)); } sv_setiv(sv, i); @@ -671,95 +675,18 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg) return 0; } +/* @-, @+ */ + 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_no_modify(aTHX); + Perl_croak_no_modify(); NORETURN_FUNCTION_END; } -U32 -Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) -{ - dVAR; - register I32 paren; - register I32 i; - 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 */ - break; - } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - goto do_prematch; - } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - goto do_postmatch; - } - break; - case '\015': /* $^MATCH */ - if (strEQ(remaining, "ATCH")) { - goto do_match; - } else { - break; - } - case '`': - do_prematch: - paren = RX_BUFF_IDX_PREMATCH; - goto maybegetparen; - case '\'': - do_postmatch: - paren = RX_BUFF_IDX_POSTMATCH; - goto maybegetparen; - case '&': - do_match: - paren = RX_BUFF_IDX_FULLMATCH; - goto maybegetparen; - case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - paren = atoi(mg->mg_ptr); - maybegetparen: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - getparen: - i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren); - - if (i < 0) - Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i); - return i; - } else { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } - case '+': - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTPAREN(rx); - if (paren) - goto getparen; - } - return 0; - case '\016': /* ^N */ - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - paren = RX_LASTCLOSEPAREN(rx); - if (paren) - goto getparen; - } - return 0; - } - magic_get(sv,mg); - if (!SvPOK(sv) && SvNIOK(sv)) { - sv_2pv(sv, 0); - } - if (SvPOK(sv)) - return SvCUR(sv); - return 0; -} - #define SvRTRIM(sv) STMT_START { \ if (SvPOK(sv)) { \ STRLEN len = SvCUR(sv); \ @@ -804,9 +731,9 @@ int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { dVAR; - register I32 paren; - register const char *s = NULL; - register REGEXP *rx; + I32 paren; + const char *s = NULL; + REGEXP *rx; const char * const remaining = mg->mg_ptr + 1; const char nextchar = *remaining; @@ -814,7 +741,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ - sv_setsv(sv, PL_bodytarget); + if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); + else sv_setsv(sv, &PL_sv_undef); if (SvTAINTED(PL_bodytarget)) SvTAINTED_on(sv); break; @@ -895,6 +823,20 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\011': /* ^I */ /* NOT \t in EBCDIC */ sv_setpv(sv, PL_inplace); /* Will undefine sv if PL_inplace is NULL */ break; + case '\014': /* ^LAST_FH */ + if (strEQ(remaining, "AST_FH")) { + if (PL_last_in_gv) { + assert(isGV_with_GP(PL_last_in_gv)); + SV_CHECK_THINKFIRST_COW_DROP(sv); + prepare_SV_for_RV(sv); + SvOK_off(sv); + SvRV_set(sv, SvREFCNT_inc_simple_NN(PL_last_in_gv)); + SvROK_on(sv); + sv_rvweaken(sv); + } + else sv_setsv_nomg(sv, NULL); + } + break; case '\017': /* ^O & ^OPEN */ if (nextchar == '\0') { sv_setpv(sv, PL_osname); @@ -908,9 +850,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (nextchar == '\0') { /* ^P */ sv_setiv(sv, (IV)PL_perldb); } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ - goto do_prematch_fetch; + + paren = RX_BUFF_IDX_CARET_PREMATCH; + goto do_numbuf_fetch; } else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */ - goto do_postmatch_fetch; + paren = RX_BUFF_IDX_CARET_POSTMATCH; + goto do_numbuf_fetch; } break; case '\023': /* ^S */ @@ -932,8 +877,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(remaining, "AINT")) - sv_setiv(sv, PL_tainting - ? (PL_taint_warn || PL_unsafe ? -1 : 1) + sv_setiv(sv, TAINTING_get + ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) : 0); break; case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ @@ -973,55 +918,46 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; case '\015': /* $^MATCH */ if (strEQ(remaining, "ATCH")) { + paren = RX_BUFF_IDX_CARET_FULLMATCH; + goto do_numbuf_fetch; + } + case '1': case '2': case '3': case '4': 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((const GV *)mg->mg_obj)); - * XXX Does the new way break anything? - */ - paren = atoi(mg->mg_ptr); /* $& is in [0] */ - CALLREG_NUMBUF_FETCH(rx,paren,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - } + /* + * 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] */ + do_numbuf_fetch: + if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { + CALLREG_NUMBUF_FETCH(rx,paren,sv); + break; + } + sv_setsv(sv,&PL_sv_undef); break; case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (RX_LASTPAREN(rx)) { - CALLREG_NUMBUF_FETCH(rx,RX_LASTPAREN(rx),sv); - break; - } + paren = RX_LASTPAREN(rx); + if (paren) + goto do_numbuf_fetch; } sv_setsv(sv,&PL_sv_undef); break; case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - if (RX_LASTCLOSEPAREN(rx)) { - CALLREG_NUMBUF_FETCH(rx,RX_LASTCLOSEPAREN(rx),sv); - break; - } - + paren = RX_LASTCLOSEPAREN(rx); + if (paren) + goto do_numbuf_fetch; } sv_setsv(sv,&PL_sv_undef); break; case '`': - do_prematch_fetch: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF_FETCH(rx,-2,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - break; + paren = RX_BUFF_IDX_PREMATCH; + goto do_numbuf_fetch; case '\'': - do_postmatch_fetch: - if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - CALLREG_NUMBUF_FETCH(rx,-1,sv); - break; - } - sv_setsv(sv,&PL_sv_undef); - break; + paren = RX_BUFF_IDX_POSTMATCH; + goto do_numbuf_fetch; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -1109,7 +1045,35 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpv(sv, os2error(Perl_rc)); else #endif - sv_setpv(sv, errno ? Strerror(errno) : ""); + if (! errno) { + sv_setpvs(sv, ""); + } + else { + + /* Strerror can return NULL on some platforms, which will result in + * 'sv' not being considered SvOK. The SvNOK_on() below will cause + * just the number part to be valid */ + sv_setpv(sv, Strerror(errno)); + + /* In some locales the error string may come back as UTF-8, in + * which case we should turn on that flag. This didn't use to + * happen, and to avoid any possible backward compatibility issues, + * we don't turn on the flag unless we have to. So the flag stays + * off for an entirely ASCII string. We assume that if the string + * looks like UTF-8, it really is UTF-8: "text in any other + * encoding that uses bytes with the high bit set is extremely + * unlikely to pass a UTF-8 validity test" + * (http://en.wikipedia.org/wiki/Charset_detection). There is a + * potential that we will get it wrong however, especially on short + * error message text. (If it turns out to be necessary, we could + * also keep track if the current LC_MESSAGES locale is UTF-8) */ + if (SvOK(sv) /* It could be that Strerror returned invalid */ + && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv)) + && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv))) + { + SvUTF8_on(sv); + } + } RESTORE_ERRNO; } @@ -1117,16 +1081,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) SvNOK_on(sv); /* what a wonderful hack! */ break; case '<': - sv_setiv(sv, (IV)PerlProc_getuid()); + sv_setuid(sv, PerlProc_getuid()); break; case '>': - sv_setiv(sv, (IV)PerlProc_geteuid()); + sv_setuid(sv, PerlProc_geteuid()); break; case '(': - sv_setiv(sv, (IV)PerlProc_getgid()); + sv_setgid(sv, PerlProc_getgid()); goto add_groups; case ')': - sv_setiv(sv, (IV)PerlProc_getegid()); + sv_setgid(sv, PerlProc_getegid()); add_groups: #ifdef HAS_GETGROUPS { @@ -1164,17 +1128,31 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) { dVAR; STRLEN len = 0, klen; - const char *s = SvOK(sv) ? SvPV_const(sv,len) : ""; - const char * const ptr = MgPV_const(mg,klen); - my_setenv(ptr, s); + const char * const key = MgPV_const(mg,klen); + const char *s = ""; PERL_ARGS_ASSERT_MAGIC_SETENV; + SvGETMAGIC(sv); + if (SvOK(sv)) { + /* defined environment variables are byte strings; unfortunately + there is no SvPVbyte_force_nomg(), so we must do this piecewise */ + (void)SvPV_force_nomg_nolen(sv); + sv_utf8_downgrade(sv, /* fail_ok */ TRUE); + if (SvUTF8(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), "Wide character in %s", "setenv"); + SvUTF8_off(sv); + } + s = SvPVX(sv); + len = SvCUR(sv); + } + my_setenv(key, s); /* does the deed */ + #ifdef DYNAMIC_ENV_FETCH /* We just undefd an environment var. Is a replacement */ /* waiting in the wings? */ if (!len) { - SV ** const valp = hv_fetch(GvHVn(PL_envgv), ptr, klen, FALSE); + SV ** const valp = hv_fetch(GvHVn(PL_envgv), key, klen, FALSE); if (valp) s = SvOK(*valp) ? SvPV_const(*valp, len) : ""; } @@ -1183,10 +1161,10 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ - if (PL_tainting) { + if (TAINTING_get) { MgTAINTEDDIR_off(mg); #ifdef VMS - if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) { + if (s && klen == 8 && strEQ(key, "DCL$PATH")) { char pathbuf[256], eltbuf[256], *cp, *elt; int i = 0, j = 0; @@ -1212,7 +1190,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf)); } #endif /* VMS */ - if (s && klen == 4 && strEQ(ptr,"PATH")) { + if (s && klen == 4 && strEQ(key,"PATH")) { const char * const strend = s + len; while (s < strend) { @@ -1499,7 +1477,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) sigset_t set, save; SV* save_sv; #endif - register const char *s = MgPV_const(mg,len); + const char *s = MgPV_const(mg,len); PERL_ARGS_ASSERT_MAGIC_SETSIG; @@ -1756,7 +1734,7 @@ Returns the SV (if any) returned by the method, or NULL on failure. */ SV* -Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, +Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, U32 argc, ...) { dVAR; @@ -1797,10 +1775,10 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, } PUTBACK; if (flags & G_DISCARD) { - call_method(meth, G_SCALAR|G_DISCARD); + call_sv(meth, G_SCALAR|G_DISCARD|G_METHOD_NAMED); } else { - if (call_method(meth, G_SCALAR)) + if (call_sv(meth, G_SCALAR|G_METHOD_NAMED)) ret = *PL_stack_sp--; } POPSTACK; @@ -1810,11 +1788,10 @@ Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, 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, +S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, SV *meth, U32 flags, int n, SV *val) { dVAR; @@ -1840,7 +1817,7 @@ S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, U32 flags, } STATIC int -S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth) +S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth) { dVAR; SV* ret; @@ -1860,7 +1837,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg) if (mg->mg_type == PERL_MAGIC_tiedelem) mg->mg_flags |= MGf_GSKIP; - magic_methpack(sv,mg,"FETCH"); + magic_methpack(sv,mg,SV_CONST(FETCH)); return 0; } @@ -1883,7 +1860,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) * 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)) + if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) && (tmg->mg_len & 1)) { val = sv_mortalcopy(sv); @@ -1892,7 +1869,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) else val = sv; - magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val); + magic_methcall1(sv, mg, SV_CONST(STORE), G_DISCARD, 2, val); return 0; } @@ -1902,7 +1879,7 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_CLEARPACK; if (mg->mg_type == PERL_MAGIC_tiedscalar) return 0; - return magic_methpack(sv,mg,"DELETE"); + return magic_methpack(sv,mg,SV_CONST(DELETE)); } @@ -1915,7 +1892,7 @@ Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_SIZEPACK; - retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL); + retsv = magic_methcall1(sv, mg, SV_CONST(FETCHSIZE), 0, 1, NULL); if (retsv) { retval = SvIV(retsv)-1; if (retval < -1) @@ -1931,7 +1908,7 @@ Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_WIPEPACK; - Perl_magic_methcall(aTHX_ sv, mg, "CLEAR", G_DISCARD, 0); + Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(CLEAR), G_DISCARD, 0); return 0; } @@ -1943,8 +1920,8 @@ Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key) PERL_ARGS_ASSERT_MAGIC_NEXTPACK; - ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, "NEXTKEY", 0, 1, key) - : Perl_magic_methcall(aTHX_ sv, mg, "FIRSTKEY", 0, 0); + ret = SvOK(key) ? Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(NEXTKEY), 0, 1, key) + : Perl_magic_methcall(aTHX_ sv, mg, SV_CONST(FIRSTKEY), 0, 0); if (ret) sv_setsv(key,ret); return 0; @@ -1955,7 +1932,7 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg) { PERL_ARGS_ASSERT_MAGIC_EXISTSPACK; - return magic_methpack(sv,mg,"EXISTS"); + return magic_methpack(sv,mg,SV_CONST(EXISTS)); } SV * @@ -1981,7 +1958,7 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg) } /* there is a SCALAR method that we can call */ - retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, "SCALAR", 0, 0); + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(hv), mg, SV_CONST(SCALAR), 0, 0); if (!retval) retval = &PL_sv_undef; return retval; @@ -2001,11 +1978,17 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) if (svp && SvIOKp(*svp)) { OP * const o = INT2PTR(OP*,SvIVX(*svp)); if (o) { +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_rw(OpSLAB(o)); +#endif /* set or clear breakpoint in the relevant control op */ if (i) o->op_flags |= OPf_SPECIAL; else o->op_flags &= ~OPf_SPECIAL; +#ifdef PERL_DEBUG_READONLY_OPS + Slab_to_ro(OpSLAB(o)); +#endif } } return 0; @@ -2120,6 +2103,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) STRLEN len; STRLEN ulen = 0; MAGIC* found; + const char *s; PERL_ARGS_ASSERT_MAGIC_SETPOS; PERL_UNUSED_ARG(mg); @@ -2142,12 +2126,12 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) found->mg_len = -1; return 0; } - len = SvPOK_nog(lsv) ? SvCUR(lsv) : sv_len(lsv); + s = SvPV_const(lsv, len); pos = SvIV(sv); if (DO_UTF8(lsv)) { - ulen = sv_len_utf8(lsv); + ulen = sv_or_pv_len_utf8(lsv, s, len); if (ulen) len = ulen; } @@ -2161,9 +2145,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg) pos = len; if (ulen) { - I32 p = pos; - sv_pos_u2b(lsv, &p, 0); - pos = p; + pos = sv_or_pv_pos_u2b(lsv, s, pos, 0); } found->mg_len = pos; @@ -2187,7 +2169,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(mg); if (!translate_substr_offsets( - SvUTF8(lsv) ? sv_len_utf8(lsv) : len, + SvUTF8(lsv) ? sv_or_pv_len_utf8(lsv, tmps, len) : len, negoff ? -(IV)offs : (IV)offs, !negoff, negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { @@ -2197,7 +2179,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) } if (SvUTF8(lsv)) - offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN); + offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem); sv_setpvn(sv, tmps + offs, rem); if (SvUTF8(lsv)) SvUTF8_on(sv); @@ -2224,8 +2206,8 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "Attempt to use reference as lvalue in substr" ); - if (SvUTF8(lsv)) lsv_len = sv_len_utf8(lsv); - else (void)SvPV_nomg(lsv,lsv_len); + SvPV_force_nomg(lsv,lsv_len); + if (SvUTF8(lsv)) lsv_len = sv_len_utf8_nomg(lsv); if (!translate_substr_offsets( lsv_len, negoff ? -(IV)lvoff : (IV)lvoff, !negoff, @@ -2234,13 +2216,13 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg) Perl_croak(aTHX_ "substr outside of string"); oldtarglen = lvlen; if (DO_UTF8(sv)) { - sv_utf8_upgrade(lsv); + sv_utf8_upgrade_nomg(lsv); lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0); - newtarglen = sv_len_utf8(sv); + newtarglen = sv_or_pv_len_utf8(sv, tmps, len); SvUTF8_on(lsv); } - else if (lsv && SvUTF8(lsv)) { + else if (SvUTF8(lsv)) { const char *utf8; lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN); newtarglen = len; @@ -2265,6 +2247,9 @@ Perl_magic_gettaint(pTHX_ SV *sv, MAGIC *mg) PERL_ARGS_ASSERT_MAGIC_GETTAINT; PERL_UNUSED_ARG(sv); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_ARG(mg); +#endif TAINT_IF((PL_localizing != 1) && (mg->mg_len & 1)); return 0; @@ -2279,7 +2264,7 @@ Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(sv); /* update taint status */ - if (PL_tainted) + if (TAINT_get) mg->mg_len |= 1; else mg->mg_len &= ~1; @@ -2312,19 +2297,6 @@ Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg) } int -Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg) -{ - PERL_ARGS_ASSERT_MAGIC_SETVSTRING; - - if (SvPOKp(sv)) { - SV * const vecsv = sv_newmortal(); - scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv); - if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0; - } - return sv_unmagic(sv, mg->mg_type); -} - -int Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg) { dVAR; @@ -2497,9 +2469,9 @@ int Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) { dVAR; - register const char *s; - register I32 paren; - register const REGEXP * rx; + const char *s; + I32 paren; + const REGEXP * rx; const char * const remaining = mg->mg_ptr + 1; I32 i; STRLEN len; @@ -2536,12 +2508,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) */ croakparen: if (!PL_localizing) { - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); } } break; case '\001': /* ^A */ - sv_setsv(PL_bodytarget, sv); + if (SvOK(sv)) sv_copypv(PL_bodytarget, sv); + else SvOK_off(PL_bodytarget); FmLINES(PL_bodytarget) = 0; if (SvPOK(PL_bodytarget)) { char *s = SvPVX(PL_bodytarget); @@ -2551,7 +2524,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } /* mg_set() has temporarily made sv non-magical */ - if (PL_tainting) { + if (TAINTING_get) { if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) SvTAINTED_on(PL_bodytarget); else @@ -2699,8 +2672,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_compiling.cop_warnings = pWARN_NONE; } /* Yuck. I can't see how to abstract this: */ - else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1, - WARN_ALL) && !any_fatals) { + else if (isWARN_on( + ((STRLEN *)SvPV_nolen_const(sv)) - 1, + WARN_ALL) + && !any_fatals) + { if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = pWARN_ALL; @@ -2814,20 +2790,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '<': { - const IV new_uid = SvIV(sv); + const Uid_t new_uid = SvUID(sv); PL_delaymagic_uid = new_uid; if (PL_delaymagic) { PL_delaymagic |= DM_RUID; break; /* don't do magic till later */ } #ifdef HAS_SETRUID - (void)setruid((Uid_t)new_uid); + (void)setruid(new_uid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)new_uid, (Uid_t)-1); + (void)setreuid(new_uid, (Uid_t)-1); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1); + (void)setresuid(new_uid, (Uid_t)-1, (Uid_t)-1); #else if (new_uid == PerlProc_geteuid()) { /* special case $< = $> */ #ifdef PERL_DARWIN @@ -2846,20 +2822,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } case '>': { - const UV new_euid = SvIV(sv); + const Uid_t new_euid = SvUID(sv); PL_delaymagic_euid = new_euid; if (PL_delaymagic) { PL_delaymagic |= DM_EUID; break; /* don't do magic till later */ } #ifdef HAS_SETEUID - (void)seteuid((Uid_t)new_euid); + (void)seteuid(new_euid); #else #ifdef HAS_SETREUID - (void)setreuid((Uid_t)-1, (Uid_t)new_euid); + (void)setreuid((Uid_t)-1, new_euid); #else #ifdef HAS_SETRESUID - (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1); + (void)setresuid((Uid_t)-1, new_euid, (Uid_t)-1); #else if (new_euid == PerlProc_getuid()) /* special case $> = $< */ PerlProc_setuid(new_euid); @@ -2873,20 +2849,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } case '(': { - const UV new_gid = SvIV(sv); + const Gid_t new_gid = SvGID(sv); PL_delaymagic_gid = new_gid; if (PL_delaymagic) { PL_delaymagic |= DM_RGID; break; /* don't do magic till later */ } #ifdef HAS_SETRGID - (void)setrgid((Gid_t)new_gid); + (void)setrgid(new_gid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)new_gid, (Gid_t)-1); + (void)setregid(new_gid, (Gid_t)-1); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1); + (void)setresgid(new_gid, (Gid_t)-1, (Gid_t) -1); #else if (new_gid == PerlProc_getegid()) /* special case $( = $) */ (void)PerlProc_setgid(new_gid); @@ -2900,7 +2876,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } case ')': { - UV new_egid; + Gid_t new_egid; #ifdef HAS_SETGROUPS { const char *p = SvPV_const(sv, len); @@ -2916,7 +2892,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) while (isSPACE(*p)) ++p; - new_egid = Atol(p); + new_egid = (Gid_t)Atol(p); for (i = 0; i < maxgrp; ++i) { while (*p && !isSPACE(*p)) ++p; @@ -2928,14 +2904,14 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) Newx(gary, i + 1, Groups_t); else Renew(gary, i + 1, Groups_t); - gary[i] = Atol(p); + gary[i] = (Groups_t)Atol(p); } if (i) (void)setgroups(i, gary); Safefree(gary); } #else /* HAS_SETGROUPS */ - new_egid = SvIV(sv); + new_egid = SvGID(sv); #endif /* HAS_SETGROUPS */ PL_delaymagic_egid = new_egid; if (PL_delaymagic) { @@ -2943,13 +2919,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; /* don't do magic till later */ } #ifdef HAS_SETEGID - (void)setegid((Gid_t)new_egid); + (void)setegid(new_egid); #else #ifdef HAS_SETREGID - (void)setregid((Gid_t)-1, (Gid_t)new_egid); + (void)setregid((Gid_t)-1, new_egid); #else #ifdef HAS_SETRESGID - (void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1); + (void)setresgid((Gid_t)-1, new_egid, (Gid_t)-1); #else if (new_egid == PerlProc_getgid()) /* special case $) = $( */ (void)PerlProc_setgid(new_egid); @@ -3073,7 +3049,7 @@ Perl_whichsig_pv(pTHX_ const char *sig) I32 Perl_whichsig_pvn(pTHX_ const char *sig, STRLEN len) { - register char* const* sigv; + char* const* sigv; PERL_ARGS_ASSERT_WHICHSIG_PVN; PERL_UNUSED_CONTEXT; @@ -3197,8 +3173,10 @@ Perl_sighandler(int sig) call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL); POPSTACK; - if (SvTRUE(ERRSV)) { - SvREFCNT_dec(errsv_save); + { + SV * const errsv = ERRSV; + if (SvTRUE_NN(errsv)) { + SvREFCNT_dec(errsv_save); #ifndef PERL_MICRO /* Handler "died", for example to get out of a restart-able read(). * Before we re-do that on its behalf re-enable the signal which was @@ -3206,32 +3184,33 @@ Perl_sighandler(int sig) */ #ifdef HAS_SIGPROCMASK #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) - if (sip || uap) + if (sip || uap) #endif - { - sigset_t set; - sigemptyset(&set); - sigaddset(&set,sig); - sigprocmask(SIG_UNBLOCK, &set, NULL); - } + { + sigset_t set; + sigemptyset(&set); + sigaddset(&set,sig); + sigprocmask(SIG_UNBLOCK, &set, NULL); + } #else - /* Not clear if this will work */ - (void)rsignal(sig, SIG_IGN); - (void)rsignal(sig, PL_csighandlerp); + /* Not clear if this will work */ + (void)rsignal(sig, SIG_IGN); + (void)rsignal(sig, PL_csighandlerp); #endif #endif /* !PERL_MICRO */ - die_sv(ERRSV); - } - else { - sv_setsv(ERRSV, errsv_save); - SvREFCNT_dec(errsv_save); + die_sv(errsv); + } + else { + sv_setsv(errsv, errsv_save); + SvREFCNT_dec(errsv_save); + } } cleanup: /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */ PL_savestack_ix = old_ss_ix; if (flags & 8) - SvREFCNT_dec(sv); + SvREFCNT_dec_NN(sv); PL_op = myop; /* Apparently not needed... */ PL_Sv = tSv; /* Restore global temporaries. */ @@ -3297,7 +3276,7 @@ S_restore_magic(pTHX_ const void *p) SvTEMP_off(sv); } else - SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */ + SvREFCNT_dec_NN(sv); /* undo the inc in S_save_magic() */ } }