X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ea726b52599b52cf534201a46ec3455418c9eb8e..e2bcdfc01b8759d90d7dac9448eb6bd60378bcdc:/mg.c

diff --git a/mg.c b/mg.c
index 18f9083..276e13d 100644
--- a/mg.c
+++ b/mg.c
@@ -9,8 +9,10 @@
  */
 
 /*
- * "Sam sat on the ground and put his head in his hands.  'I wish I had never
- * come here, and I don't want to see no more magic,' he said, and fell silent."
+ *  Sam sat on the ground and put his head in his hands.  'I wish I had never
+ *  come here, and I don't want to see no more magic,' he said, and fell silent.
+ *
+ *     [p.363 of _The Lord of the Rings_, II/vii: "The Mirror of Galadriel"]
  */
 
 /*
@@ -358,7 +360,7 @@ Perl_mg_size(pTHX_ SV *sv)
 
     switch(SvTYPE(sv)) {
 	case SVt_PVAV:
-	    return AvFILLp((AV *) sv); /* Fallback to non-tied array */
+	    return AvFILLp((const AV *) sv); /* Fallback to non-tied array */
 	case SVt_PVHV:
 	    /* FIXME */
 	default:
@@ -461,15 +463,19 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 /*
 =for apidoc mg_localize
 
-Copy some of the magic from an existing SV to new localized version of
-that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
-doesn't (eg taint, pos).
+Copy some of the magic from an existing SV to new localized version of that
+SV. Container magic (eg %ENV, $1, tie) gets copied, value magic doesn't (eg
+taint, pos).
+
+If setmagic is false then no set magic will be called on the new (empty) SV.
+This typically means that assignment will soon follow (e.g. 'local $x = $y'),
+and that will handle the magic.
 
 =cut
 */
 
 void
-Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
+Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
 {
     dVAR;
     MAGIC *mg;
@@ -493,9 +499,11 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
 
     if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
 	SvFLAGS(nsv) |= SvMAGICAL(sv);
-	PL_localizing = 1;
-	SvSETMAGIC(nsv);
-	PL_localizing = 0;
+	if (setmagic) {
+	    PL_localizing = 1;
+	    SvSETMAGIC(nsv);
+	    PL_localizing = 0;
+	}
     }	    
 }
 
@@ -524,7 +532,7 @@ Perl_mg_free(pTHX_ SV *sv)
 	    if (mg->mg_len > 0 || mg->mg_type == PERL_MAGIC_utf8)
 		Safefree(mg->mg_ptr);
 	    else if (mg->mg_len == HEf_SVKEY)
-		SvREFCNT_dec((SV*)mg->mg_ptr);
+		SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr));
 	}
 	if (mg->mg_flags & MGf_REFCOUNTED)
 	    SvREFCNT_dec(mg->mg_obj);
@@ -612,7 +620,7 @@ 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(aTHX_ PL_no_modify);
+    Perl_croak(aTHX_ "%s", PL_no_modify);
     NORETURN_FUNCTION_END;
 }
 
@@ -764,14 +772,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '\005':  /* ^E */
 	 if (nextchar == '\0') {
-#if defined(MACOS_TRADITIONAL)
-	     {
-		  char msg[256];
-
-		  sv_setnv(sv,(double)gMacPerl_OSErr);
-		  sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
-	     }
-#elif defined(VMS)
+#if defined(VMS)
 	     {
 #	          include <descrip.h>
 #	          include <starlet.h>
@@ -781,7 +782,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		  if (sys$getmsg(vaxc$errno,&msgdsc.dsc$w_length,&msgdsc,0,0) & 1)
 		       sv_setpvn(sv,msgdsc.dsc$a_pointer,msgdsc.dsc$w_length);
 		  else
-		       sv_setpvn(sv,"",0);
+		       sv_setpvs(sv,"");
 	     }
 #elif defined(OS2)
 	     if (!(_emx_env & 0x200)) {	/* Under DOS */
@@ -804,15 +805,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		       PerlProc_GetOSError(sv, dwErr);
 		  }
 		  else
-		       sv_setpvn(sv, "", 0);
+		       sv_setpvs(sv, "");
 		  SetLastError(dwErr);
 	     }
 #else
 	     {
-		 const int saveerrno = errno;
+		 dSAVE_ERRNO;
 		 sv_setnv(sv, (NV)errno);
 		 sv_setpv(sv, errno ? Strerror(errno) : "");
-		 errno = saveerrno;
+		 RESTORE_ERRNO;
 	     }
 #endif
 	     SvRTRIM(sv);
@@ -896,7 +897,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 		/* Get the bit mask for $warnings::Bits{all}, because
 		 * it could have been extended by warnings::register */
-		HV * const bits=get_hv("warnings::Bits", FALSE);
+		HV * const bits=get_hv("warnings::Bits", 0);
 		if (bits) {
 		    SV ** const bits_all = hv_fetchs(bits, "all", FALSE);
 		    if (bits_all)
@@ -919,7 +920,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     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((GV*)mg->mg_obj));
+		 * 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] */
@@ -1018,8 +1019,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	if (GvIOp(PL_defoutgv))
 	    sv_setiv(sv, (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0 );
 	break;
-    case ',':
-	break;
     case '\\':
 	if (PL_ors_sv)
 	    sv_copypv(sv, PL_ors_sv);
@@ -1030,7 +1029,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	sv_setpv(sv, errno ? Strerror(errno) : "");
 #else
 	{
-	const int saveerrno = errno;
+	dSAVE_ERRNO;
 	sv_setnv(sv, (NV)errno);
 #ifdef OS2
 	if (errno == errno_isOS2 || errno == errno_isOS2_set)
@@ -1038,7 +1037,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	else
 #endif
 	sv_setpv(sv, errno ? Strerror(errno) : "");
-	errno = saveerrno;
+	RESTORE_ERRNO;
 	}
 #endif
 	SvRTRIM(sv);
@@ -1069,10 +1068,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
 	break;
-#ifndef MACOS_TRADITIONAL
     case '0':
 	break;
-#endif
     }
     return 0;
 }
@@ -1582,8 +1579,8 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg)
        calls this same magic */
     stash = GvSTASH(
         SvTYPE(mg->mg_obj) == SVt_PVGV
-            ? (GV*)mg->mg_obj
-            : (GV*)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
+            ? (const GV *)mg->mg_obj
+            : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
     );
 
     if (stash)
@@ -1603,13 +1600,13 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
     /* Bail out if destruction is going on */
     if(PL_dirty) return 0;
 
-    av_clear((AV*)sv);
+    av_clear(MUTABLE_AV(sv));
 
     /* XXX see comments in magic_setisa */
     stash = GvSTASH(
         SvTYPE(mg->mg_obj) == SVt_PVGV
-            ? (GV*)mg->mg_obj
-            : (GV*)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
+            ? (const GV *)mg->mg_obj
+            : (const GV *)mg_find(mg->mg_obj, PERL_MAGIC_isa)->mg_obj
     );
 
     if (stash)
@@ -1641,7 +1638,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
 
     if (hv) {
          (void) hv_iterinit(hv);
-         if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
+         if (! SvTIED_mg((const SV *)hv, PERL_MAGIC_tied))
 	     i = HvKEYS(hv);
          else {
 	     while (hv_iternext(hv))
@@ -1681,7 +1678,7 @@ S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int
 	    if (mg->mg_len >= 0)
 		mPUSHp(mg->mg_ptr, mg->mg_len);
 	    else if (mg->mg_len == HEf_SVKEY)
-		PUSHs((SV*)mg->mg_ptr);
+		PUSHs(MUTABLE_SV(mg->mg_ptr));
 	}
 	else if (mg->mg_type == PERL_MAGIC_tiedelem) {
 	    mPUSHi(mg->mg_len);
@@ -1833,8 +1830,8 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
 {
     dVAR; dSP;
     SV *retval;
-    SV * const tied = SvTIED_obj((SV*)hv, mg);
-    HV * const pkg = SvSTASH((SV*)SvRV(tied));
+    SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
+    HV * const pkg = SvSTASH((const SV *)SvRV(tied));
    
     PERL_ARGS_ASSERT_MAGIC_SCALARPACK;
 
@@ -1845,7 +1842,7 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
             return &PL_sv_yes;
         /* no xhv_eiter so now use FIRSTKEY */
         key = sv_newmortal();
-        magic_nextpack((SV*)hv, mg, key);
+        magic_nextpack(MUTABLE_SV(hv), mg, key);
         HvEITER_set(hv, NULL);     /* need to reset iterator */
         return SvOK(key) ? &PL_sv_yes : &PL_sv_no;
     }
@@ -1895,7 +1892,7 @@ int
 Perl_magic_getarylen(pTHX_ SV *sv, const MAGIC *mg)
 {
     dVAR;
-    AV * const obj = (AV*)mg->mg_obj;
+    AV * const obj = MUTABLE_AV(mg->mg_obj);
 
     PERL_ARGS_ASSERT_MAGIC_GETARYLEN;
 
@@ -1911,7 +1908,7 @@ int
 Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
-    AV * const obj = (AV*)mg->mg_obj;
+    AV * const obj = MUTABLE_AV(mg->mg_obj);
 
     PERL_ARGS_ASSERT_MAGIC_SETARYLEN;
 
@@ -2164,7 +2161,7 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
                 targ = HeVAL(he);
 	}
 	else {
-	    AV* const av = (AV*)LvTARG(sv);
+	    AV *const av = MUTABLE_AV(LvTARG(sv));
 	    if ((I32)LvTARGOFF(sv) <= AvFILL(av))
 		targ = AvARRAY(av)[LvTARGOFF(sv)];
 	}
@@ -2218,7 +2215,7 @@ Perl_vivify_defelem(pTHX_ SV *sv)
 	    Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj));
     }
     else {
-	AV* const av = (AV*)LvTARG(sv);
+	AV *const av = MUTABLE_AV(LvTARG(sv));
 	if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
 	    LvTARG(sv) = NULL;	/* array can't be extended */
 	else {
@@ -2240,7 +2237,7 @@ int
 Perl_magic_killbackrefs(pTHX_ SV *sv, MAGIC *mg)
 {
     PERL_ARGS_ASSERT_MAGIC_KILLBACKREFS;
-    return Perl_sv_kill_backrefs(aTHX_ sv, (AV*)mg->mg_obj);
+    return Perl_sv_kill_backrefs(aTHX_ sv, MUTABLE_AV(mg->mg_obj));
 }
 
 int
@@ -2358,7 +2355,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
              * set without a previous pattern match. Unless it's C<local $1>
              */
             if (!PL_localizing) {
-                Perl_croak(aTHX_ PL_no_modify);
+                Perl_croak(aTHX_ "%s", PL_no_modify);
             }
         }
     case '\001':	/* ^A */
@@ -2379,21 +2376,17 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
     case '\005':  /* ^E */
 	if (*(mg->mg_ptr+1) == '\0') {
-#ifdef MACOS_TRADITIONAL
-	    gMacPerl_OSErr = SvIV(sv);
-#else
-#  ifdef VMS
+#ifdef VMS
 	    set_vaxc_errno(SvIV(sv));
-#  else
-#    ifdef WIN32
+#else
+#  ifdef WIN32
 	    SetLastError( SvIV(sv) );
-#    else
-#      ifdef OS2
+#  else
+#    ifdef OS2
 	    os2_setsyserrno(SvIV(sv));
-#      else
+#    else
 	    /* will anyone ever use this? */
 	    SETERRNO(SvIV(sv), 4);
-#      endif
 #    endif
 #  endif
 #endif
@@ -2444,7 +2437,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	       ensure that hints for input are sooner on linked list.  */
 	    tmp = out ? newSVpvn_flags(out + 1, start + len - out - 1,
 				       SVs_TEMP | SvUTF8(sv))
-		: newSVpvn_flags("", 0, SVs_TEMP | SvUTF8(sv));
+		: newSVpvs_flags("", SVs_TEMP | SvUTF8(sv));
 
 	    tmp_he
 		= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash, 
@@ -2596,16 +2589,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    PL_ors_sv = NULL;
 	}
 	break;
-    case ',':
-	if (PL_ofs_sv)
-	    SvREFCNT_dec(PL_ofs_sv);
-	if (SvOK(sv) || SvGMAGICAL(sv)) {
-	    PL_ofs_sv = newSVsv(sv);
-	}
-	else {
-	    PL_ofs_sv = NULL;
-	}
-	break;
     case '[':
 	CopARYBASE_set(&PL_compiling, SvIV(sv));
 	break;
@@ -2778,7 +2761,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
     case ':':
 	PL_chopset = SvPV_force(sv,len);
 	break;
-#ifndef MACOS_TRADITIONAL
     case '0':
 	LOCK_DOLLARZERO_MUTEX;
 #ifdef HAS_SETPROCTITLE
@@ -2844,7 +2826,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 #endif
 	UNLOCK_DOLLARZERO_MUTEX;
 	break;
-#endif
     }
     return 0;
 }
@@ -2953,7 +2934,7 @@ Perl_sighandler(int sig)
 	 if (sigaction(sig, 0, &oact) == 0 && oact.sa_flags & SA_SIGINFO) {
 	      if (sip) {
 		   HV *sih = newHV();
-		   SV *rv  = newRV_noinc((SV*)sih);
+		   SV *rv  = newRV_noinc(MUTABLE_SV(sih));
 		   /* The siginfo fields signo, code, errno, pid, uid,
 		    * addr, status, and band are defined by POSIX/SUSv3. */
 		   (void)hv_stores(sih, "signo", newSViv(sip->si_signo));
@@ -2967,7 +2948,7 @@ Perl_sighandler(int sig)
 		   hv_stores(sih, "band",       newSViv(sip->si_band));
 #endif
 		   EXTEND(SP, 2);
-		   PUSHs((SV*)rv);
+		   PUSHs(rv);
 		   mPUSHp((char *)sip, sizeof(*sip));
 	      }
 
@@ -2976,7 +2957,7 @@ Perl_sighandler(int sig)
 #endif
     PUTBACK;
 
-    call_sv((SV*)cv, G_DISCARD|G_EVAL);
+    call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
 
     POPSTACK;
     if (SvTRUE(ERRSV)) {
@@ -3102,7 +3083,7 @@ int
 Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
-    SV *key = (mg->mg_len == HEf_SVKEY) ? (SV *)mg->mg_ptr
+    SV *key = (mg->mg_len == HEf_SVKEY) ? MUTABLE_SV(mg->mg_ptr)
 	: newSVpvn_flags(mg->mg_ptr, mg->mg_len, SVs_TEMP);
 
     PERL_ARGS_ASSERT_MAGIC_SETHINT;
@@ -3144,7 +3125,7 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
     PL_hints |= HINT_LOCALIZE_HH;
     PL_compiling.cop_hints_hash
 	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
-				 (SV *)mg->mg_ptr, &PL_sv_placeholder);
+				 MUTABLE_SV(mg->mg_ptr), &PL_sv_placeholder);
     return 0;
 }