X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=63de61249fe0e9438a48bd51e0b6d448c1a0c27a;hb=39f1703b298e7cfad95b26600223fa7595098e73;hp=2a807607225f7ef3f3582cd9a2a59e6e615bd94b;hpb=2e34cc90b22e8d09149d579a4d5db71a1836c9ca;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index 2a80760..63de612 100644
--- a/mg.c
+++ b/mg.c
@@ -1,6 +1,6 @@
 /*    mg.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -12,6 +12,10 @@
  * come here, and I don't want to see no more magic,' he said, and fell silent."
  */
 
+/*
+=head1 Magical Functions
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_MG_C
 #include "perl.h"
@@ -30,7 +34,7 @@
 #  define  FAKE_PERSISTENT_SIGNAL_HANDLERS
 #endif
 /* if we're doing kill() with sys$sigprc on VMS, FAKE_DEFAULT_SIGNAL_HANDLERS */
-#if defined(KILL_BY_SIGPRC) 
+#if defined(KILL_BY_SIGPRC)
 #  define  FAKE_DEFAULT_SIGNAL_HANDLERS
 #endif
 
@@ -208,7 +212,7 @@ Perl_mg_length(pTHX_ SV *sv)
 	}
     }
 
-    if (DO_UTF8(sv)) 
+    if (DO_UTF8(sv))
     {
         U8 *s = (U8*)SvPV(sv, len);
         len = Perl_utf8_length(aTHX_ s, s + len);
@@ -271,7 +275,7 @@ Perl_mg_clear(pTHX_ SV *sv)
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 	MGVTBL* vtbl = mg->mg_virtual;
 	/* omit GSKIP -- never set here */
-	
+
 	if (vtbl && vtbl->svt_clear)
 	    CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
     }
@@ -315,7 +319,11 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
     int count = 0;
     MAGIC* mg;
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-	if (isUPPER(mg->mg_type)) {
+	MGVTBL* vtbl = mg->mg_virtual;
+	if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy){
+	    count += CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv, key, klen);
+	}
+	else if (isUPPER(mg->mg_type)) {
 	    sv_magic(nsv,
 		     mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
 		     (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
@@ -346,7 +354,7 @@ Perl_mg_free(pTHX_ SV *sv)
 	if (vtbl && vtbl->svt_free)
 	    CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
 	if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-	    if (mg->mg_len >= 0)
+	    if (mg->mg_len > 0)
 		Safefree(mg->mg_ptr);
 	    else if (mg->mg_len == HEf_SVKEY)
 		SvREFCNT_dec((SV*)mg->mg_ptr);
@@ -392,7 +400,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 	paren = mg->mg_len;
 	if (paren < 0)
 	    return 0;
-	if (paren <= rx->nparens &&
+	if (paren <= (I32)rx->nparens &&
 	    (s = rx->startp[paren]) != -1 &&
 	    (t = rx->endp[paren]) != -1)
 	    {
@@ -400,7 +408,7 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 		    i = t;
 		else			/* @- */
 		    i = s;
-		
+
 		if (i > 0 && PL_reg_match_utf8) {
 		    char *b = rx->subbeg;
 		    if (b)
@@ -436,7 +444,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 
 	    paren = atoi(mg->mg_ptr); /* $& is in [0] */
 	  getparen:
-	    if (paren <= rx->nparens &&
+	    if (paren <= (I32)rx->nparens &&
 		(s1 = rx->startp[paren]) != -1 &&
 		(t1 = rx->endp[paren]) != -1)
 	    {
@@ -446,7 +454,7 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 		    char *s    = rx->subbeg + s1;
 		    char *send = rx->subbeg + t1;
 
-		    i = t1 - s1;
+                    i = t1 - s1;
 		    if (is_utf8_string((U8*)s, i))
 			i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
 		}
@@ -454,6 +462,14 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 		    Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 		return i;
 	    }
+	    else {
+		if (ckWARN(WARN_UNINITIALIZED))
+		    report_uninit();
+	    }
+	}
+	else {
+	    if (ckWARN(WARN_UNINITIALIZED))
+		report_uninit();
 	}
 	return 0;
     case '+':
@@ -532,11 +548,11 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef MACOS_TRADITIONAL
 	     {
 		  char msg[256];
-	
+
 		  sv_setnv(sv,(double)gMacPerl_OSErr);
-		  sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");	
+		  sv_setpv(sv, gMacPerl_OSErr ? GetSysErrText(gMacPerl_OSErr, msg) : "");
 	     }
-#else	
+#else
 #ifdef VMS
 	     {
 #	          include <descrip.h>
@@ -666,7 +682,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	     */
 	    paren = atoi(mg->mg_ptr); /* $& is in [0] */
 	  getparen:
-	    if (paren <= rx->nparens &&
+	    if (paren <= (I32)rx->nparens &&
 		(s1 = rx->startp[paren]) != -1 &&
 		(t1 = rx->endp[paren]) != -1)
 	    {
@@ -869,7 +885,6 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
     register char *s;
     char *ptr;
     STRLEN len, klen;
-    I32 i;
 
     s = SvPV(sv,len);
     ptr = MgPV(mg,klen);
@@ -893,7 +908,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 #ifdef VMS
 	if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
 	    char pathbuf[256], eltbuf[256], *cp, *elt = s;
-	    struct stat sbuf;
+	    Stat_t sbuf;
 	    int i = 0, j = 0;
 
 	    do {          /* DCL$PATH may be a search list */
@@ -921,7 +936,8 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 
 	    while (s < strend) {
 		char tmpbuf[256];
-		struct stat st;
+		Stat_t st;
+		I32 i;
 		s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
 			     s, strend, ':', &i);
 		s++;
@@ -974,11 +990,16 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
 #if defined(VMS) || defined(EPOC)
     Perl_die(aTHX_ "Can't make list assignment to %%ENV on this system");
 #else
-#   if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
+#  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
     PerlEnv_clearenv();
-#   else
-#       ifdef USE_ENVIRON_ARRAY
-#	    ifndef PERL_USE_SAFE_PUTENV
+#  else
+#    ifdef USE_ENVIRON_ARRAY
+#      if defined(USE_ITHREADS)
+    /* only the parent thread can clobber the process environment */
+    if (PL_curinterp == aTHX)
+#      endif
+    {
+#      ifndef PERL_USE_SAFE_PUTENV
     I32 i;
 
     if (environ == PL_origenviron)
@@ -986,11 +1007,11 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     else
 	for (i = 0; environ[i]; i++)
 	    safesysfree(environ[i]);
-#	    endif /* PERL_USE_SAFE_PUTENV */
+#      endif /* PERL_USE_SAFE_PUTENV */
 
     environ[0] = Nullch;
-
-#       endif /* USE_ENVIRON_ARRAY */
+    }
+#    endif /* USE_ENVIRON_ARRAY */
 #   endif /* PERL_IMPLICIT_SYS || WIN32 */
 #endif /* VMS || EPC */
     return 0;
@@ -999,7 +1020,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS)||defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
 static int sig_handlers_initted = 0;
 #endif
-#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS   
+#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
 static int sig_ignoring[SIG_SIZE];      /* which signals we are ignoring */
 #endif
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
@@ -1069,7 +1090,9 @@ Perl_raise_signal(pTHX_ int sig)
 Signal_t
 Perl_csighandler(int sig)
 {
-#ifndef PERL_OLD_SIGNALS
+#ifdef PERL_GET_SIG_CONTEXT
+    dTHXa(PERL_GET_SIG_CONTEXT);
+#else
     dTHX;
 #endif
 #ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
@@ -1077,7 +1100,7 @@ Perl_csighandler(int sig)
     if (sig_ignoring[sig]) return;
 #endif
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
-    if (sig_defaulting[sig]) 
+    if (sig_defaulting[sig])
 #ifdef KILL_BY_SIGPRC
             exit((Perl_sig_to_vmscondition(sig)&STS$M_COND_ID)|STS$K_SEVERE|STS$M_INHIB_MSG);
 #else
@@ -1102,6 +1125,7 @@ Perl_csighandler_init(void)
 
     for (sig = 1; sig < SIG_SIZE; sig++) {
 #ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
+        dTHX;
         sig_defaulting[sig] = 1;
         (void) rsignal(sig, &Perl_csighandler);
 #endif
@@ -1152,7 +1176,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	i = whichsig(s);	/* ...no, a brick */
 	if (!i) {
 	    if (ckWARN(WARN_SIGNAL))
-		Perl_warner(aTHX_ WARN_SIGNAL, "No such signal: SIG%s", s);
+		Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s);
 	    return 0;
 	}
 #if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
@@ -1241,7 +1265,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
 {
     HV *hv = (HV*)LvTARG(sv);
     I32 i = 0;
-     
+
     if (hv) {
          (void) hv_iterinit(hv);
          if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
@@ -1420,7 +1444,7 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg)
     svp = av_fetch(GvAV(gv),
 		     atoi(MgPV(mg,n_a)), FALSE);
     if (svp && SvIOKp(*svp) && (o = INT2PTR(OP*,SvIVX(*svp))))
-	o->op_private = i;
+	o->op_private = (U8)i;
     return 0;
 }
 
@@ -1494,7 +1518,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
 	if (pos < 0)
 	    pos = 0;
     }
-    else if (pos > len)
+    else if (pos > (SSize_t)len)
 	pos = len;
 
     if (ulen) {
@@ -1502,7 +1526,7 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
 	sv_pos_u2b(lsv, &p, 0);
 	pos = p;
     }
-	
+
     mg->mg_len = pos;
     mg->mg_flags &= ~MGf_MINMATCH;
 
@@ -1554,9 +1578,9 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
 
     if (SvUTF8(lsv))
 	sv_pos_u2b(lsv, &offs, &rem);
-    if (offs > len)
+    if (offs > (I32)len)
 	offs = len;
-    if (rem + offs > len)
+    if (rem + offs > (I32)len)
 	rem = len - offs;
     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
     if (SvUTF8(lsv))
@@ -1821,7 +1845,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	sv_setsv(PL_bodytarget, sv);
 	break;
     case '\003':	/* ^C */
-	PL_minus_c = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+	PL_minus_c = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	break;
 
     case '\004':	/* ^D */
@@ -1926,7 +1950,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		    else if (isWARN_on(sv, 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) ;
@@ -1940,7 +1964,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    }
 	}
 	else if (strEQ(mg->mg_ptr+1, "IDE_SYSTEM_CALLS"))
-	    PL_widesyscalls = SvTRUE(sv);
+	    PL_widesyscalls = (bool)SvTRUE(sv);
 	break;
     case '.':
 	if (PL_localizing) {
@@ -1948,7 +1972,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		SAVESPTR(PL_last_in_gv);
 	}
 	else if (SvOK(sv) && GvIO(PL_last_in_gv))
-	    IoLINES(GvIOp(PL_last_in_gv)) = (long)SvIV(sv);
+	    IoLINES(GvIOp(PL_last_in_gv)) = SvIV(sv);
 	break;
     case '^':
 	Safefree(IoTOP_NAME(GvIOp(PL_defoutgv)));
@@ -1961,15 +1985,15 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	IoFMT_GV(GvIOp(PL_defoutgv)) = gv_fetchpv(s,TRUE, SVt_PVIO);
 	break;
     case '=':
-	IoPAGE_LEN(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+	IoPAGE_LEN(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	break;
     case '-':
-	IoLINES_LEFT(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+	IoLINES_LEFT(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	if (IoLINES_LEFT(GvIOp(PL_defoutgv)) < 0L)
 	    IoLINES_LEFT(GvIOp(PL_defoutgv)) = 0L;
 	break;
     case '%':
-	IoPAGE(GvIOp(PL_defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+	IoPAGE(GvIOp(PL_defoutgv)) = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	break;
     case '|':
 	{
@@ -2220,7 +2244,12 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 		    break;
 	    }
 	    /* can grab env area too? */
-	    if (PL_origenviron && (PL_origenviron[0] == s + 1)) {
+	    if (PL_origenviron
+#ifdef USE_ITHREADS
+		&& PL_curinterp == aTHX
+#endif
+		&& (PL_origenviron[0] == s + 1))
+	    {
 		my_setenv("NoNe  SuCh", Nullch);
 					    /* force copy of environment */
 		for (i = 0; PL_origenviron[i]; i++)
@@ -2235,7 +2264,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	s = SvPV_force(sv,len);
 	i = len;
-	if (i >= PL_origalen) {
+	if (i >= (I32)PL_origalen) {
 	    i = PL_origalen;
 	    /* don't allow system to limit $0 seen by script */
 	    /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
@@ -2247,9 +2276,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	    Copy(s, PL_origargv[0], i, char);
 	    s = PL_origargv[0]+i;
 	    *s++ = '\0';
-	    while (++i < PL_origalen)
-		*s++ = ' ';
-	    s = PL_origargv[0]+i;
+	    while (++i < (I32)PL_origalen)
+		*s++ = '\0';
 	    for (i = 1; i < PL_origargc; i++)
 		PL_origargv[i] = Nullch;
 	}
@@ -2305,8 +2333,8 @@ static SV* sig_sv;
 Signal_t
 Perl_sighandler(int sig)
 {
-#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
-    dTHXa(PL_curinterp);	/* fake TLS, because signals don't do TLS */
+#ifdef PERL_GET_SIG_CONTEXT
+    dTHXa(PERL_GET_SIG_CONTEXT);
 #else
     dTHX;
 #endif
@@ -2319,10 +2347,6 @@ Perl_sighandler(int sig)
     U32 flags = 0;
     XPV *tXpv = PL_Xpv;
 
-#if defined(WIN32) && defined(PERL_IMPLICIT_CONTEXT)
-    PERL_SET_THX(aTHX);	/* fake TLS, see above */
-#endif
-
     if (PL_savestack_ix + 15 <= PL_savestack_max)
 	flags |= 1;
     if (PL_markstack_ptr < PL_markstack_max - 2)
@@ -2332,9 +2356,11 @@ Perl_sighandler(int sig)
     if (PL_scopestack_ix < PL_scopestack_max - 3)
 	flags |= 16;
 
-    if (!PL_psig_ptr[sig])
-	Perl_die(aTHX_ "Signal SIG%s received, but no signal handler set.\n",
-	    PL_sig_name[sig]);
+    if (!PL_psig_ptr[sig]) {
+		PerlIO_printf(Perl_error_log, "Signal SIG%s received, but no signal handler set.\n",
+				 PL_sig_name[sig]);
+		exit(sig);
+	}
 
     /* Max number of items pushed there is 3*n or 4. We cannot fix
        infinity, so we fix 4 (in fact 5): */
@@ -2357,7 +2383,7 @@ Perl_sighandler(int sig)
 
     if (!cv || !CvROOT(cv)) {
 	if (ckWARN(WARN_SIGNAL))
-	    Perl_warner(aTHX_ WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
+	    Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n",
 		PL_sig_name[sig], (gv ? GvENAME(gv)
 				: ((cv && CvGV(cv))
 				   ? GvENAME(CvGV(cv))
@@ -2476,3 +2502,5 @@ unwind_handler_stack(pTHX_ void *p)
 	SvREFCNT_dec(sig_sv);
 #endif
 }
+
+