X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1b95d04f713d9c56e4957326f9f6b0481216a00c..cc02ebe5373ef9dc4ac786b90cb5db113958408e:/mg.c

diff --git a/mg.c b/mg.c
index cfa3197..7b13f61 100644
--- a/mg.c
+++ b/mg.c
@@ -76,6 +76,7 @@ void setegid(uid_t id);
 #endif
 
 /*
+ * Pre-magic setup and post-magic takedown.
  * Use the "DESTRUCTOR" scope cleanup to reinstate magic.
  */
 
@@ -97,6 +98,8 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 
     PERL_ARGS_ASSERT_SAVE_MAGIC;
 
+    assert(SvMAGICAL(sv));
+
     /* we shouldn't really be called here with RC==0, but it can sometimes
      * happen via mg_clear() (which also shouldn't be called when RC==0,
      * but it can happen). Handle this case gracefully(ish) by not RC++
@@ -108,7 +111,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 	bumped = TRUE;
     }
 
-    assert(SvMAGICAL(sv));
     /* Turning READONLY off for a copy-on-write scalar (including shared
        hash keys) is a bad idea.  */
     if (SvIsCOW(sv))
@@ -125,10 +127,6 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 
     SvMAGICAL_off(sv);
     SvREADONLY_off(sv);
-    if (!(SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK))) {
-	/* No public flags are set, so promote any private flags to public.  */
-	SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
-    }
 }
 
 /*
@@ -164,46 +162,10 @@ 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
 
-Do magic after a value is retrieved from the SV.  See C<sv_magic>.
+Do magic before a value is retrieved from the SV.  See C<sv_magic>.
 
 =cut
 */
@@ -213,12 +175,13 @@ Perl_mg_get(pTHX_ SV *sv)
 {
     dVAR;
     const I32 mgs_ix = SSNEW(sizeof(MGS));
+    bool saved = FALSE;
     bool have_new = 0;
     MAGIC *newmg, *head, *cur, *mg;
 
     PERL_ARGS_ASSERT_MG_GET;
 
-    save_magic(mgs_ix, sv);
+    if (PL_localizing == 1 && sv == DEFSV) return 0;
 
     /* We must call svt_get(sv, mg) for each valid entry in the linked
        list of magic. svt_get() may delete the current entry, add new
@@ -230,6 +193,13 @@ Perl_mg_get(pTHX_ SV *sv)
 	MAGIC * const nextmg = mg->mg_moremagic;	/* it may delete itself */
 
 	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;
+	    }
+
 	    vtbl->svt_get(aTHX_ sv, mg);
 
 	    /* guard against magic having been deleted - eg FETCH calling
@@ -243,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;
 
@@ -265,7 +239,9 @@ Perl_mg_get(pTHX_ SV *sv)
 	}
     }
 
-    restore_magic(INT2PTR(void *, (IV)mgs_ix));
+    if (saved)
+	restore_magic(INT2PTR(void *, (IV)mgs_ix));
+
     return 0;
 }
 
@@ -287,6 +263,8 @@ Perl_mg_set(pTHX_ SV *sv)
 
     PERL_ARGS_ASSERT_MG_SET;
 
+    if (PL_localizing == 2 && sv == DEFSV) return 0;
+
     save_magic(mgs_ix, sv);
 
     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
@@ -296,7 +274,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))
 	    continue;
 	if (vtbl && vtbl->svt_set)
 	    vtbl->svt_set(aTHX_ sv, mg);
@@ -309,7 +288,13 @@ Perl_mg_set(pTHX_ SV *sv)
 /*
 =for apidoc mg_length
 
-Report on the SV's length.  See C<sv_magic>.
+This function is deprecated.
+
+It 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
 */
@@ -335,15 +320,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;
 }
 
@@ -526,7 +503,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 +513,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)) {
@@ -637,7 +614,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 */
@@ -658,6 +635,8 @@ Perl_magic_regdata_cnt(pTHX_ SV *sv, MAGIC *mg)
     return (U32)-1;
 }
 
+/* @-, @+ */
+
 int
 Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -666,18 +645,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			/* @- */
@@ -686,7 +665,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);
@@ -696,6 +677,8 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+/* @-, @+ */
+
 int
 Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -710,9 +693,9 @@ U32
 Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
-    register I32 paren;
-    register I32 i;
-    register const REGEXP * rx;
+    I32 paren;
+    I32 i;
+    const REGEXP * rx;
     const char * const remaining = mg->mg_ptr + 1;
 
     PERL_ARGS_ASSERT_MAGIC_LEN;
@@ -820,13 +803,18 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
     }
 }
 
+#ifdef VMS
+#include <descrip.h>
+#include <starlet.h>
+#endif
+
 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;
 
@@ -834,7 +822,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;
@@ -854,8 +843,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	 if (nextchar == '\0') {
 #if defined(VMS)
 	     {
-#	          include <descrip.h>
-#	          include <starlet.h>
 		  char msg[255];
 		  $DESCRIPTOR(msgdsc,msg);
 		  sv_setnv(sv,(NV) vaxc$errno);
@@ -917,6 +904,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);
@@ -930,9 +931,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 */
@@ -974,83 +978,67 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	        sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 	    }
 	    else if (PL_compiling.cop_warnings == pWARN_STD) {
-		sv_setpvn(
-		    sv, 
-		    (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
-		    WARNsize
-		);
+		sv_setsv(sv, &PL_sv_undef);
+		break;
 	    }
             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", 0);
-		if (bits) {
-		    SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
-		    if (bits_all)
-			sv_setsv(sv, *bits_all);
-		}
-	        else {
-		    sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
-		}
+		HV * const bits = get_hv("warnings::Bits", 0);
+		SV ** const bits_all = bits ? hv_fetchs(bits, "all", FALSE) : NULL;
+		if (bits_all)
+		    sv_copypv(sv, *bits_all);
+	        else
+		    sv_setpvn(sv, WARN_ALLstring, WARNsize);
 	    }
             else {
 	        sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
 			  *PL_compiling.cop_warnings);
 	    }
-	    SvPOK_only(sv);
 	}
 	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)));
@@ -1067,9 +1055,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 +1065,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 +1088,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))
@@ -1113,7 +1097,22 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '\\':
 	if (PL_ors_sv)
 	    sv_copypv(sv, PL_ors_sv);
+	else
+	    sv_setsv(sv, &PL_sv_undef);
+	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);
+		/* never unsafe, even if reading in a tainted expression */
+		SvTAINTED_off(sv);
+	    }
+	    /* else a value has been assigned manually, so do nothing */
+	}
 	break;
+
     case '!':
 	{
 	dSAVE_ERRNO;
@@ -1128,8 +1127,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	else
 #endif
 	sv_setpv(sv, errno ? Strerror(errno) : "");
-	if (SvPOKp(sv))
-	    SvPOK_on(sv);    /* may have got removed during taint processing */
 	RESTORE_ERRNO;
 	}
 
@@ -1137,16 +1134,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	SvNOK_on(sv);	/* what a wonderful hack! */
 	break;
     case '<':
-	sv_setiv(sv, (IV)PL_uid);
+	sv_setiv(sv, (IV)PerlProc_getuid());
 	break;
     case '>':
-	sv_setiv(sv, (IV)PL_euid);
+	sv_setiv(sv, (IV)PerlProc_geteuid());
 	break;
     case '(':
-	sv_setiv(sv, (IV)PL_gid);
+	sv_setiv(sv, (IV)PerlProc_getgid());
 	goto add_groups;
     case ')':
-	sv_setiv(sv, (IV)PL_egid);
+	sv_setiv(sv, (IV)PerlProc_getegid());
       add_groups:
 #ifdef HAS_GETGROUPS
 	{
@@ -1184,17 +1181,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 = NULL;
 
     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) : "";
     }
@@ -1206,7 +1217,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
     if (PL_tainting) {
 	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;
 
@@ -1232,7 +1243,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) {
@@ -1331,7 +1342,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 +1375,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);
@@ -1518,14 +1530,14 @@ 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;
 
     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 +1545,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 +1560,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 +1624,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 +1634,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;
@@ -1709,18 +1727,6 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
-Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
-{
-    dVAR;
-    PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
-    PERL_UNUSED_ARG(sv);
-    PERL_UNUSED_ARG(mg);
-    PL_amagic_generation++;
-
-    return 0;
-}
-
-int
 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
 {
     HV * const hv = MUTABLE_HV(LvTARG(sv));
@@ -1759,13 +1765,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<sv> and C<mg> are the tied thingy and the tie magic.
+
+C<meth> is the name of the method to call.
+
+C<argc> is the number of args (in addition to $self) to pass to the method.
+
+The C<flags> 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<flags> argument.
 
 Returns the SV (if any) returned by the method, or NULL on failure.
 
@@ -1919,6 +1932,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");
 }
 
@@ -2018,11 +2032,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;
@@ -2037,7 +2057,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 +2073,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");
@@ -2062,6 +2082,25 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
+Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+
+    PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
+    PERL_UNUSED_ARG(sv);
+
+    /* Reset the iterator when the array is cleared */
+#if IVSIZE == I32SIZE
+    *((IV *) &(mg->mg_len)) = 0;
+#else
+    if (mg->mg_ptr)
+        *((IV *) mg->mg_ptr) = 0;
+#endif
+
+    return 0;
+}
+
+int
 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
@@ -2101,7 +2140,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;
 	}
     }
@@ -2118,6 +2157,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);
@@ -2140,12 +2180,12 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
 	found->mg_len = -1;
 	return 0;
     }
-    len = SvPOK(lsv) ? SvCUR(lsv) : sv_len(lsv);
+    s = SvPV_const(lsv, len);
 
-    pos = SvIV(sv) - CopARYBASE_get(PL_curcop);
+    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;
     }
@@ -2159,9 +2199,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;
@@ -2178,16 +2216,24 @@ 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;
 
     PERL_ARGS_ASSERT_MAGIC_GETSUBSTR;
     PERL_UNUSED_ARG(mg);
 
+    if (!translate_substr_offsets(
+	    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
+    )) {
+	Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
+	sv_setsv_nomg(sv, &PL_sv_undef);
+	return 0;
+    }
+
     if (SvUTF8(lsv))
-	offs = sv_pos_u2b_flags(lsv, offs, &rem, SV_CONST_RETURN);
-    if (offs > len)
-	offs = len;
-    if (rem > len - offs)
-	rem = len - offs;
+	offs = sv_or_pv_pos_u2b(lsv, tmps, offs, &rem);
     sv_setpvn(sv, tmps + offs, rem);
     if (SvUTF8(lsv))
         SvUTF8_on(sv);
@@ -2198,34 +2244,53 @@ int
 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
-    STRLEN len;
+    STRLEN len, lsv_len, oldtarglen, newtarglen;
     const char * const tmps = SvPV_const(sv, len);
+    const char *targs;
     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;
 
     PERL_ARGS_ASSERT_MAGIC_SETSUBSTR;
     PERL_UNUSED_ARG(mg);
 
+    SvGETMAGIC(lsv);
+    if (SvROK(lsv))
+	Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+			    "Attempt to use reference as lvalue in substr"
+	);
+    targs = SvPV_nomg(lsv,lsv_len);
+    if (SvUTF8(lsv)) lsv_len = sv_or_pv_len_utf8(lsv,targs,lsv_len);
+    if (!translate_substr_offsets(
+	    lsv_len,
+	    negoff ? -(IV)lvoff : (IV)lvoff, !negoff,
+	    neglen ? -(IV)lvlen : (IV)lvlen, !neglen, &lvoff, &lvlen
+    ))
+	Perl_croak(aTHX_ "substr outside of string");
+    oldtarglen = lvlen;
     if (DO_UTF8(sv)) {
 	sv_utf8_upgrade(lsv);
 	lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
-	sv_insert(lsv, lvoff, lvlen, tmps, len);
-	LvTARGLEN(sv) = sv_len_utf8(sv);
+	sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+	newtarglen = sv_len_utf8(sv);
 	SvUTF8_on(lsv);
     }
     else if (lsv && SvUTF8(lsv)) {
 	const char *utf8;
 	lvoff = sv_pos_u2b_flags(lsv, lvoff, &lvlen, SV_CONST_RETURN);
-	LvTARGLEN(sv) = len;
+	newtarglen = len;
 	utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
-	sv_insert(lsv, lvoff, lvlen, utf8, len);
+	sv_insert_flags(lsv, lvoff, lvlen, utf8, len, 0);
 	Safefree(utf8);
     }
     else {
-	sv_insert(lsv, lvoff, lvlen, tmps, len);
-	LvTARGLEN(sv) = len;
+	sv_insert_flags(lsv, lvoff, lvlen, tmps, len, 0);
+	newtarglen = len;
     }
+    if (!neglen) LvTARGLEN(sv) = newtarglen;
+    if (negoff)  LvTARGOFF(sv) += newtarglen - oldtarglen;
 
     return 0;
 }
@@ -2384,9 +2449,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;
 }
 
@@ -2457,9 +2521,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;
@@ -2488,18 +2552,29 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
       paren = atoi(mg->mg_ptr);
       setparen:
 	if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+      setparen_got_rx:
             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
 	} else {
             /* Croak with a READONLY error when a numbered match var is
              * set without a previous pattern match. Unless it's C<local $1>
              */
+      croakparen:
             if (!PL_localizing) {
                 Perl_croak_no_modify(aTHX);
             }
         }
         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);
+	    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)
@@ -2559,6 +2634,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	Safefree(PL_inplace);
 	PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
 	break;
+    case '\016':	/* ^N */
+	if (PL_curpm && (rx = PM_GETRE(PL_curpm))
+	 && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
+	goto croakparen;
     case '\017':	/* ^O */
 	if (*(mg->mg_ptr+1) == '\0') {
 	    Safefree(PL_osname);
@@ -2626,9 +2705,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
 	    if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
-		if (!SvPOK(sv) && PL_localizing) {
-	            sv_setpvn(sv, WARN_NONEstring, WARNsize);
-	            PL_compiling.cop_warnings = pWARN_NONE;
+		if (!SvPOK(sv)) {
+	            PL_compiling.cop_warnings = pWARN_STD;
 		    break;
 		}
 		{
@@ -2678,33 +2756,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 '|':
 	{
@@ -2729,7 +2799,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '\\':
 	SvREFCNT_dec(PL_ors_sv);
-	if (SvOK(sv) || SvGMAGICAL(sv)) {
+	if (SvOK(sv)) {
 	    PL_ors_sv = newSVsv(sv);
 	}
 	else {
@@ -2737,7 +2807,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	break;
     case '[':
-	CopARYBASE_set(&PL_compiling, SvIV(sv));
+	if (SvIV(sv) != 0)
+	    Perl_croak(aTHX_ "Assigning non-zero to $[ is no longer possible");
 	break;
     case '?':
 #ifdef COMPLEX_STATUS
@@ -2767,89 +2838,94 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	break;
     case '<':
-	PL_uid = SvIV(sv);
+	{
+	const IV new_uid = SvIV(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)PL_uid);
+	(void)setruid((Uid_t)new_uid);
 #else
 #ifdef HAS_SETREUID
-	(void)setreuid((Uid_t)PL_uid, (Uid_t)-1);
+	(void)setreuid((Uid_t)new_uid, (Uid_t)-1);
 #else
 #ifdef HAS_SETRESUID
-      (void)setresuid((Uid_t)PL_uid, (Uid_t)-1, (Uid_t)-1);
+      (void)setresuid((Uid_t)new_uid, (Uid_t)-1, (Uid_t)-1);
 #else
-	if (PL_uid == PL_euid) {		/* special case $< = $> */
+	if (new_uid == PerlProc_geteuid()) {		/* special case $< = $> */
 #ifdef PERL_DARWIN
 	    /* workaround for Darwin's setuid peculiarity, cf [perl #24122] */
-	    if (PL_uid != 0 && PerlProc_getuid() == 0)
+	    if (new_uid != 0 && PerlProc_getuid() == 0)
 		(void)PerlProc_setuid(0);
 #endif
-	    (void)PerlProc_setuid(PL_uid);
+	    (void)PerlProc_setuid(new_uid);
 	} else {
-	    PL_uid = PerlProc_getuid();
 	    Perl_croak(aTHX_ "setruid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_uid = PerlProc_getuid();
 	break;
+	}
     case '>':
-	PL_euid = SvIV(sv);
+	{
+	const UV new_euid = SvIV(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)PL_euid);
+	(void)seteuid((Uid_t)new_euid);
 #else
 #ifdef HAS_SETREUID
-	(void)setreuid((Uid_t)-1, (Uid_t)PL_euid);
+	(void)setreuid((Uid_t)-1, (Uid_t)new_euid);
 #else
 #ifdef HAS_SETRESUID
-	(void)setresuid((Uid_t)-1, (Uid_t)PL_euid, (Uid_t)-1);
+	(void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
 #else
-	if (PL_euid == PL_uid)		/* special case $> = $< */
-	    PerlProc_setuid(PL_euid);
+	if (new_euid == PerlProc_getuid())		/* special case $> = $< */
+	    PerlProc_setuid(new_euid);
 	else {
-	    PL_euid = PerlProc_geteuid();
 	    Perl_croak(aTHX_ "seteuid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_euid = PerlProc_geteuid();
 	break;
+	}
     case '(':
-	PL_gid = SvIV(sv);
+	{
+	const UV new_gid = SvIV(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)PL_gid);
+	(void)setrgid((Gid_t)new_gid);
 #else
 #ifdef HAS_SETREGID
-	(void)setregid((Gid_t)PL_gid, (Gid_t)-1);
+	(void)setregid((Gid_t)new_gid, (Gid_t)-1);
 #else
 #ifdef HAS_SETRESGID
-      (void)setresgid((Gid_t)PL_gid, (Gid_t)-1, (Gid_t) 1);
+      (void)setresgid((Gid_t)new_gid, (Gid_t)-1, (Gid_t) -1);
 #else
-	if (PL_gid == PL_egid)			/* special case $( = $) */
-	    (void)PerlProc_setgid(PL_gid);
+	if (new_gid == PerlProc_getegid())			/* special case $( = $) */
+	    (void)PerlProc_setgid(new_gid);
 	else {
-	    PL_gid = PerlProc_getgid();
 	    Perl_croak(aTHX_ "setrgid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_gid = PerlProc_getgid();
 	break;
+	}
     case ')':
+	{
+	UV new_egid;
 #ifdef HAS_SETGROUPS
 	{
 	    const char *p = SvPV_const(sv, len);
@@ -2865,7 +2941,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 
             while (isSPACE(*p))
                 ++p;
-            PL_egid = Atol(p);
+            new_egid = Atol(p);
             for (i = 0; i < maxgrp; ++i) {
                 while (*p && !isSPACE(*p))
                     ++p;
@@ -2884,35 +2960,46 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    Safefree(gary);
 	}
 #else  /* HAS_SETGROUPS */
-	PL_egid = SvIV(sv);
+	new_egid = SvIV(sv);
 #endif /* HAS_SETGROUPS */
+	PL_delaymagic_egid = new_egid;
 	if (PL_delaymagic) {
 	    PL_delaymagic |= DM_EGID;
 	    break;				/* don't do magic till later */
 	}
 #ifdef HAS_SETEGID
-	(void)setegid((Gid_t)PL_egid);
+	(void)setegid((Gid_t)new_egid);
 #else
 #ifdef HAS_SETREGID
-	(void)setregid((Gid_t)-1, (Gid_t)PL_egid);
+	(void)setregid((Gid_t)-1, (Gid_t)new_egid);
 #else
 #ifdef HAS_SETRESGID
-	(void)setresgid((Gid_t)-1, (Gid_t)PL_egid, (Gid_t)-1);
+	(void)setresgid((Gid_t)-1, (Gid_t)new_egid, (Gid_t)-1);
 #else
-	if (PL_egid == PL_gid)			/* special case $) = $( */
-	    (void)PerlProc_setgid(PL_egid);
+	if (new_egid == PerlProc_getgid())			/* special case $) = $( */
+	    (void)PerlProc_setgid(new_egid);
 	else {
-	    PL_egid = PerlProc_getegid();
 	    Perl_croak(aTHX_ "setegid() not implemented");
 	}
 #endif
 #endif
 #endif
-	PL_egid = PerlProc_getegid();
 	break;
+	}
     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
@@ -2990,22 +3077,41 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 }
 
 I32
-Perl_whichsig(pTHX_ const char *sig)
+Perl_whichsig_sv(pTHX_ SV *sigsv)
 {
-    register char* const* sigv;
+    const char *sigpv;
+    STRLEN siglen;
+    PERL_ARGS_ASSERT_WHICHSIG_SV;
+    PERL_UNUSED_CONTEXT;
+    sigpv = SvPV_const(sigsv, siglen);
+    return whichsig_pvn(sigpv, siglen);
+}
 
-    PERL_ARGS_ASSERT_WHICHSIG;
+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)
+{
+    char* const* sigv;
+
+    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;
@@ -3032,6 +3138,7 @@ Perl_sighandler(int sig)
     U32 flags = 0;
     XPV * const tXpv = PL_Xpv;
     I32 old_ss_ix = PL_savestack_ix;
+    SV *errsv_save = NULL;
 
 
     if (!PL_psig_ptr[sig]) {
@@ -3110,10 +3217,13 @@ Perl_sighandler(int sig)
 #endif
     PUTBACK;
 
+    errsv_save = newSVsv(ERRSV);
+
     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
 
     POPSTACK;
     if (SvTRUE(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
@@ -3137,6 +3247,11 @@ Perl_sighandler(int sig)
 #endif /* !PERL_MICRO */
 	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;
@@ -3161,31 +3276,20 @@ S_restore_magic(pTHX_ const void *p)
     if (!sv)
         return;
 
-    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
-    {
+    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+	SvTEMP_off(sv); /* if it's still magical, this value isn't temporary */
 #ifdef PERL_OLD_COPY_ON_WRITE
 	/* While magic was saved (and off) sv_setsv may well have seen
 	   this SV as a prime candidate for COW.  */
 	if (SvIsCOW(sv))
 	    sv_force_normal_flags(sv, 0);
 #endif
-
 	if (mgs->mgs_readonly)
 	    SvREADONLY_on(sv);
 	if (mgs->mgs_magical)
 	    SvFLAGS(sv) |= mgs->mgs_magical;
 	else
 	    mg_magical(sv);
-	if (SvGMAGICAL(sv)) {
-	    /* downgrade public flags to private,
-	       and discard any other private flags */
-
-	    const U32 pubflags = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
-	    if (pubflags) {
-		SvFLAGS(sv) &= ~( pubflags | (SVp_IOK|SVp_NOK|SVp_POK) );
-		SvFLAGS(sv) |= ( pubflags << PRIVSHIFT );
-	    }
-	}
     }
 
     bumped = mgs->mgs_bumped;
@@ -3214,12 +3318,8 @@ S_restore_magic(pTHX_ const void *p)
 	       So artificially keep it alive a bit longer.
 	       We avoid turning on the TEMP flag, which can cause the SV's
 	       buffer to get stolen (and maybe other stuff). */
-	    int was_temp = SvTEMP(sv);
 	    sv_2mortal(sv);
-	    if (!was_temp) {
-		SvTEMP_off(sv);
-	    }
-	    SvOK_off(sv);
+	    SvTEMP_off(sv);
 	}
 	else
 	    SvREFCNT_dec(sv); /* undo the inc in S_save_magic() */
@@ -3289,14 +3389,13 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
     PERL_UNUSED_ARG(sv);
 
-    assert(mg->mg_len == HEf_SVKEY);
-
-    PERL_UNUSED_ARG(sv);
-
     PL_hints |= HINT_LOCALIZE_HH;
     CopHINTHASH_set(&PL_compiling,
-	cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
-				 MUTABLE_SV(mg->mg_ptr), 0, 0));
+	mg->mg_len == HEf_SVKEY
+	 ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
+				 MUTABLE_SV(mg->mg_ptr), 0, 0)
+	 : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
+				 mg->mg_ptr, mg->mg_len, 0, 0));
     return 0;
 }
 
@@ -3318,12 +3417,32 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+int
+Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
+				 const char *name, I32 namlen)
+{
+    MAGIC *nmg;
+
+    PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(name);
+    PERL_UNUSED_ARG(namlen);
+
+    sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
+    nmg = mg_find(nsv, mg->mg_type);
+    if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
+    nmg->mg_ptr = mg->mg_ptr;
+    nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
+    nmg->mg_flags |= MGf_REFCOUNTED;
+    return 1;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */