X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=2e3bf46be5b9c7143ce22f69fb7be706f07e9449;hb=27565cb6b0d14f9ecd5ee3593c2cb2a263020809;hp=c0ebd1b6a5db3d3d17e4f750660f461f24324b15;hpb=3881461aa7ea7d04f800c042497ae7c44c5a670d;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index c0ebd1b..2e3bf46 100644
--- a/mg.c
+++ b/mg.c
@@ -152,7 +152,7 @@ Perl_mg_get(pTHX_ SV *sv)
        cause the SV's buffer to get stolen (and maybe other stuff).
        So restore it.
     */
-    sv_2mortal(SvREFCNT_inc_simple(sv));
+    sv_2mortal(SvREFCNT_inc_simple_NN(sv));
     if (!was_temp) {
 	SvTEMP_off(sv);
     }
@@ -272,7 +272,7 @@ Perl_mg_length(pTHX_ SV *sv)
 
     if (DO_UTF8(sv)) {
         const U8 *s = (U8*)SvPV_const(sv, len);
-        len = Perl_utf8_length(aTHX_ s, s + len);
+	len = utf8_length(s, s + len);
     }
     else
         (void)SvPV_const(sv, len);
@@ -379,7 +379,7 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 	}
 	else {
 	    const char type = mg->mg_type;
-	    if (isUPPER(type)) {
+	    if (isUPPER(type) && type != PERL_MAGIC_uvar) {
 		sv_magic(nsv,
 		     (type == PERL_MAGIC_tied)
 			? SvTIED_obj(sv, mg)
@@ -531,7 +531,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 		    if (i > 0 && RX_MATCH_UTF8(rx)) {
 			const char * const b = rx->subbeg;
 			if (b)
-			    i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+			    i = utf8_length((U8*)b, (U8*)(b+i));
 		    }
 
 		    sv_setiv(sv, i);
@@ -758,10 +758,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	    SvTAINTED_off(sv);
 	}
 	else if (strEQ(remaining, "PEN")) {
-	    if (!PL_compiling.cop_io)
+	    if (!(CopHINTS_get(&PL_compiling) & HINT_LEXICAL_IO))
 		sv_setsv(sv, &PL_sv_undef);
             else {
-	        sv_setsv(sv, PL_compiling.cop_io);
+	        sv_setsv(sv,
+			 Perl_refcounted_he_fetch(aTHX_
+						  PL_compiling.cop_hints_hash,
+						  0, "open", 4, 0, 0));
 	    }
 	}
 	break;
@@ -816,17 +819,19 @@ 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 */
-		SV **bits_all;
 		HV * const bits=get_hv("warnings::Bits", FALSE);
-		if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
-		    sv_setsv(sv, *bits_all);
+		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) ;
 		}
 	    }
             else {
-	        sv_setsv(sv, PL_compiling.cop_warnings);
+	        sv_setpvn(sv, (char *) (PL_compiling.cop_warnings + 1),
+			  *PL_compiling.cop_warnings);
 	    }
 	    SvPOK_only(sv);
 	}
@@ -963,7 +968,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '/':
 	break;
     case '[':
-	WITH_THR(sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop)));
+	sv_setiv(sv, (IV)CopARYBASE_get(PL_curcop));
 	break;
     case '|':
 	if (GvIOp(PL_defoutgv))
@@ -1068,8 +1073,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 	    Stat_t sbuf;
 	    int i = 0, j = 0;
 
-	    strncpy(eltbuf, s, 255);
-	    eltbuf[255] = 0;
+	    my_strlcpy(eltbuf, s, sizeof(eltbuf));
 	    elt = eltbuf;
 	    do {          /* DCL$PATH may be a search list */
 		while (1) {   /* as may dev portion of any element */
@@ -1098,11 +1102,20 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 		char tmpbuf[256];
 		Stat_t st;
 		I32 i;
+#ifdef VMS  /* Hmm.  How do we get $Config{path_sep} from C? */
+		const char path_sep = '|';
+#else
+		const char path_sep = ':';
+#endif
 		s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
-			     s, strend, ':', &i);
+			     s, strend, path_sep, &i);
 		s++;
-		if (i >= sizeof tmpbuf   /* too long -- assume the worst */
-		      || *tmpbuf != '/'
+		if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
+#ifdef VMS
+		      || !strchr(tmpbuf, ':') /* no colon thus no device name -- assume relative path */
+#else
+		      || *tmpbuf != '/'       /* no starting slash -- assume relative path */
+#endif
 		      || (PerlLIO_stat(tmpbuf, &st) == 0 && (st.st_mode & 2)) ) {
 		    MgTAINTEDDIR_on(mg);
 		    return 0;
@@ -1165,7 +1178,7 @@ static void
 restore_sigmask(pTHX_ SV *save_sv)
 {
     const sigset_t * const ossetp = (const sigset_t *) SvPV_nolen_const( save_sv );
-    (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
+    (void)sigprocmask(SIG_SETMASK, ossetp, NULL);
 }
 #endif
 int
@@ -1178,20 +1191,21 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg)
     	if(PL_psig_ptr[i])
     	    sv_setsv(sv,PL_psig_ptr[i]);
     	else {
-    	    Sighandler_t sigstate;
-    	    sigstate = rsignal_state(i);
+	    Sighandler_t sigstate = rsignal_state(i);
 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
-    	    if (PL_sig_handlers_initted && PL_sig_ignoring[i]) sigstate = SIG_IGN;
+	    if (PL_sig_handlers_initted && PL_sig_ignoring[i])
+		sigstate = SIG_IGN;
 #endif
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
-    	    if (PL_sig_handlers_initted && PL_sig_defaulting[i]) sigstate = SIG_DFL;
+	    if (PL_sig_handlers_initted && PL_sig_defaulting[i])
+		sigstate = SIG_DFL;
 #endif
     	    /* cache state so we don't fetch it again */
     	    if(sigstate == (Sighandler_t) SIG_IGN)
     	    	sv_setpv(sv,"IGNORE");
     	    else
     	    	sv_setsv(sv,&PL_sv_undef);
-	    PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
+	    PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
     	    SvTEMP_off(sv);
     	}
     }
@@ -1210,14 +1224,12 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
 	SV** svp = NULL;
 	if (strEQ(s,"__DIE__"))
 	    svp = &PL_diehook;
-	else if (strEQ(s,"__WARN__"))
+	else if (strEQ(s,"__WARN__") && PL_warnhook != PERL_WARNHOOK_FATAL)
 	    svp = &PL_warnhook;
-	else
-	    Perl_croak(aTHX_ "No such hook: %s", s);
 	if (svp && *svp) {
-            SV * const to_dec = *svp;
+	    SV *const to_dec = *svp;
 	    *svp = NULL;
-    	    SvREFCNT_dec(to_dec);
+	    SvREFCNT_dec(to_dec);
 	}
     }
     else {
@@ -1370,7 +1382,8 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	    Perl_croak(aTHX_ "No such hook: %s", s);
 	i = 0;
 	if (*svp) {
-	    to_dec = *svp;
+	    if (*svp != PERL_WARNHOOK_FATAL)
+		to_dec = *svp;
 	    *svp = NULL;
 	}
     }
@@ -1403,7 +1416,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 #endif
 	SvREFCNT_dec(PL_psig_name[i]);
 	to_dec = PL_psig_ptr[i];
-	PL_psig_ptr[i] = SvREFCNT_inc_simple(sv);
+	PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv);
 	SvTEMP_off(sv); /* Make sure it doesn't go away on us */
 	PL_psig_name[i] = newSVpvn(s, len);
 	SvREADONLY_on(PL_psig_name[i]);
@@ -1454,7 +1467,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	if (i)
 	    (void)rsignal(i, PL_csighandlerp);
 	else
-	    *svp = SvREFCNT_inc_simple(sv);
+	    *svp = SvREFCNT_inc_simple_NN(sv);
     }
 #ifdef HAS_SIGPROCMASK
     if(i)
@@ -1657,7 +1670,7 @@ Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
 }
 
 int
-Perl_magic_existspack(pTHX_ SV *sv, MAGIC *mg)
+Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
 {
     return magic_methpack(sv,mg,"EXISTS");
 }
@@ -1666,7 +1679,7 @@ SV *
 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
 {
     dVAR; dSP;
-    SV *retval = &PL_sv_undef;
+    SV *retval;
     SV * const tied = SvTIED_obj((SV*)hv, mg);
     HV * const pkg = SvSTASH((SV*)SvRV(tied));
    
@@ -1692,6 +1705,8 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
 
     if (call_method("SCALAR", G_SCALAR))
         retval = *PL_stack_sp--; 
+    else
+	retval = &PL_sv_undef;
     POPSTACK;
     LEAVE;
     return retval;
@@ -1899,7 +1914,7 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
     STRLEN len;
-    const char *tmps = SvPV_const(sv, len);
+    const char * const tmps = SvPV_const(sv, len);
     SV * const lsv = LvTARG(sv);
     I32 lvoff = LvTARGOFF(sv);
     I32 lvlen = LvTARGLEN(sv);
@@ -1913,11 +1928,12 @@ Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 	SvUTF8_on(lsv);
     }
     else if (lsv && SvUTF8(lsv)) {
+	const char *utf8;
 	sv_pos_u2b(lsv, &lvoff, &lvlen);
 	LvTARGLEN(sv) = len;
-	tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
-	sv_insert(lsv, lvoff, lvlen, tmps, len);
-	Safefree(tmps);
+	utf8 = (char*)bytes_to_utf8((U8*)tmps, &len);
+	sv_insert(lsv, lvoff, lvlen, utf8, len);
+	Safefree(utf8);
     }
     else {
 	sv_insert(lsv, lvoff, lvlen, tmps, len);
@@ -1991,7 +2007,7 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
 	    if ((I32)LvTARGOFF(sv) <= AvFILL(av))
 		targ = AvARRAY(av)[LvTARGOFF(sv)];
 	}
-	if (targ && targ != &PL_sv_undef) {
+	if (targ && (targ != &PL_sv_undef)) {
 	    /* somebody else defined it for us */
 	    SvREFCNT_dec(LvTARG(sv));
 	    LvTARG(sv) = SvREFCNT_inc_simple_NN(targ);
@@ -2225,10 +2241,11 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    }
 	}
 	else if (strEQ(mg->mg_ptr, "\017PEN")) {
-	    if (!PL_compiling.cop_io)
-		PL_compiling.cop_io = newSVsv(sv);
-	    else
-		sv_setsv(PL_compiling.cop_io,sv);
+	    PL_compiling.cop_hints |= HINT_LEXICAL_IO;
+	    PL_hints |= HINT_LOCALIZE_HH | HINT_LEXICAL_IO;
+	    PL_compiling.cop_hints_hash
+		= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+					 sv_2mortal(newSVpvs("open")), sv);
 	}
 	break;
     case '\020':	/* ^P */
@@ -2274,15 +2291,20 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		    }
 		    if (!accumulate)
 	                PL_compiling.cop_warnings = pWARN_NONE;
-		    else if (isWARN_on(sv, WARN_ALL) && !any_fatals) {
+		    /* Yuck. I can't see how to abstract this:  */
+		    else if (isWARN_on(((STRLEN *)SvPV_nolen_const(sv)) - 1,
+				       WARN_ALL) && !any_fatals) {
 	                PL_compiling.cop_warnings = pWARN_ALL;
 	                PL_dowarn |= G_WARN_ONCE ;
 	            }
                     else {
-	                if (specialWARN(PL_compiling.cop_warnings))
-		            PL_compiling.cop_warnings = newSVsv(sv) ;
-	                else
-	                    sv_setsv(PL_compiling.cop_warnings, sv);
+			STRLEN len;
+			const char *const p = SvPV_const(sv, len);
+
+			PL_compiling.cop_warnings
+			    = Perl_new_warnings_bitfield(aTHX_ PL_compiling.cop_warnings,
+							 p, len);
+
 	                if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE))
 	                    PL_dowarn |= G_WARN_ONCE ;
 	            }
@@ -2500,8 +2522,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
             }
             if (i)
                 (void)setgroups(i, gary);
-            if (gary)
-                Safefree(gary);
+	    Safefree(gary);
 	}
 #else  /* HAS_SETGROUPS */
 	PL_egid = SvIV(sv);
@@ -2722,7 +2743,7 @@ Perl_sighandler(int sig)
 #endif
 		   EXTEND(SP, 2);
 		   PUSHs((SV*)rv);
-		   PUSHs(newSVpv((void*)sip, sizeof(*sip)));
+		   PUSHs(newSVpv((char *)sip, sizeof(*sip)));
 	      }
 
               va_end(args);
@@ -2797,10 +2818,10 @@ S_restore_magic(pTHX_ const void *p)
 	    /* downgrade public flags to private,
 	       and discard any other private flags */
 
-	    U32 public = SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK);
-	    if (public) {
-		SvFLAGS(sv) &= ~( public | SVp_IOK|SVp_NOK|SVp_POK );
-		SvFLAGS(sv) |= ( public << PRIVSHIFT );
+	    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 );
 	    }
 	}
     }
@@ -2845,8 +2866,9 @@ S_unwind_handler_stack(pTHX_ const void *p)
 =for apidoc magic_sethint
 
 Triggered by a store to %^H, records the key/value pair to
-C<PL_compiling.cop_hints>.  It is assumed that hints aren't storing anything
-that would need a deep copy.  Maybe we should warn if we find a reference.
+C<PL_compiling.cop_hints_hash>.  It is assumed that hints aren't storing
+anything that would need a deep copy.  Maybe we should warn if we find a
+reference.
 
 =cut
 */
@@ -2865,16 +2887,17 @@ Perl_magic_sethint(pTHX_ SV *sv, MAGIC *mg)
        Doing this here saves a lot of doing it manually in perl code (and
        forgetting to do it, and consequent subtle errors.  */
     PL_hints |= HINT_LOCALIZE_HH;
-    PL_compiling.cop_hints
-	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
-				 (SV *)mg->mg_ptr, newSVsv(sv));
+    PL_compiling.cop_hints_hash
+	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
+				 (SV *)mg->mg_ptr, sv);
     return 0;
 }
 
 /*
 =for apidoc magic_sethint
 
-Triggered by a delete from %^H, records the key to C<PL_compiling.cop_hints>.
+Triggered by a delete from %^H, records the key to
+C<PL_compiling.cop_hints_hash>.
 
 =cut
 */
@@ -2882,11 +2905,15 @@ int
 Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
+    PERL_UNUSED_ARG(sv);
+
     assert(mg->mg_len == HEf_SVKEY);
 
+    PERL_UNUSED_ARG(sv);
+
     PL_hints |= HINT_LOCALIZE_HH;
-    PL_compiling.cop_hints
-	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints,
+    PL_compiling.cop_hints_hash
+	= Perl_refcounted_he_new(aTHX_ PL_compiling.cop_hints_hash,
 				 (SV *)mg->mg_ptr, &PL_sv_placeholder);
     return 0;
 }