X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=7230b0151dfb0e85f7558d3b733b9ff55483e4cd;hb=8514a89ddb9f1e33f9830c00e00db83cbd8945f9;hp=0ac07420f4b97024ff70a2dc449f42e68955bd38;hpb=7ea3cd407b6ec2a3e424bdfbc486b6e01d6d28bd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index 0ac0742..7230b01 100644
--- a/mg.c
+++ b/mg.c
@@ -1,6 +1,6 @@
 /*    mg.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, 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.
@@ -20,6 +20,9 @@
 #  ifndef NGROUPS
 #    define NGROUPS 32
 #  endif
+#  ifdef I_GRP
+#    include <grp.h>
+#  endif
 #endif
 
 static void restore_magic(pTHXo_ void *p);
@@ -37,12 +40,12 @@ 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(pTHX_ IV mgs_ix, SV *sv)
 {
     MGS* mgs;
     assert(SvMAGICAL(sv));
 
-    SAVEDESTRUCTOR_X(restore_magic, (void*)mgs_ix);
+    SAVEDESTRUCTOR_X(restore_magic, INT2PTR(void*,mgs_ix));
 
     mgs = SSPTR(mgs_ix, MGS*);
     mgs->mgs_sv = sv;
@@ -51,7 +54,7 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
 
     SvMAGICAL_off(sv);
     SvREADONLY_off(sv);
-    SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+    SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
 }
 
 /*
@@ -90,7 +93,7 @@ Do magic after a value is retrieved from the SV.  See C<sv_magic>.
 int
 Perl_mg_get(pTHX_ SV *sv)
 {
-    I32 mgs_ix;
+    IV mgs_ix;
     MAGIC* mg;
     MAGIC** mgp;
     int mgp_valid = 0;
@@ -117,7 +120,7 @@ Perl_mg_get(pTHX_ SV *sv)
 	    mgp = &SvMAGIC(sv);	/* Re-establish pointer after sv_upgrade */
     }
 
-    restore_magic(aTHXo_ (void*)mgs_ix);
+    restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
     return 0;
 }
 
@@ -132,7 +135,7 @@ Do magic after a value is assigned to the SV.  See C<sv_magic>.
 int
 Perl_mg_set(pTHX_ SV *sv)
 {
-    I32 mgs_ix;
+    IV mgs_ix;
     MAGIC* mg;
     MAGIC* nextmg;
 
@@ -150,7 +153,7 @@ Perl_mg_set(pTHX_ SV *sv)
 	    CALL_FPTR(vtbl->svt_set)(aTHX_ sv, mg);
     }
 
-    restore_magic(aTHXo_ (void*)mgs_ix);
+    restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
     return 0;
 }
 
@@ -172,13 +175,13 @@ Perl_mg_length(pTHX_ SV *sv)
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 	MGVTBL* vtbl = mg->mg_virtual;
 	if (vtbl && vtbl->svt_len) {
-            I32 mgs_ix;
+            IV mgs_ix;
 
 	    mgs_ix = SSNEW(sizeof(MGS));
 	    save_magic(mgs_ix, sv);
 	    /* omit MGf_GSKIP -- not changed here */
 	    len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
-	    restore_magic(aTHXo_ (void*)mgs_ix);
+	    restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
 	    return len;
 	}
     }
@@ -187,7 +190,7 @@ Perl_mg_length(pTHX_ SV *sv)
     return len;
 }
 
-I32
+IV
 Perl_mg_size(pTHX_ SV *sv)
 {
     MAGIC* mg;
@@ -196,13 +199,13 @@ Perl_mg_size(pTHX_ SV *sv)
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 	MGVTBL* vtbl = mg->mg_virtual;
 	if (vtbl && vtbl->svt_len) {
-            I32 mgs_ix;
+            IV mgs_ix;
 
 	    mgs_ix = SSNEW(sizeof(MGS));
 	    save_magic(mgs_ix, sv);
 	    /* omit MGf_GSKIP -- not changed here */
 	    len = CALL_FPTR(vtbl->svt_len)(aTHX_ sv, mg);
-	    restore_magic(aTHXo_ (void*)mgs_ix);
+	    restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
 	    return len;
 	}
     }
@@ -231,7 +234,7 @@ Clear something magical that the SV represents.  See C<sv_magic>.
 int
 Perl_mg_clear(pTHX_ SV *sv)
 {
-    I32 mgs_ix;
+    IV mgs_ix;
     MAGIC* mg;
 
     mgs_ix = SSNEW(sizeof(MGS));
@@ -245,7 +248,7 @@ Perl_mg_clear(pTHX_ SV *sv)
 	    CALL_FPTR(vtbl->svt_clear)(aTHX_ sv, mg);
     }
 
-    restore_magic(aTHXo_ (void*)mgs_ix);
+    restore_magic(aTHXo_ INT2PTR(void*,mgs_ix));
     return 0;
 }
 
@@ -261,6 +264,8 @@ MAGIC*
 Perl_mg_find(pTHX_ SV *sv, int type)
 {
     MAGIC* mg;
+    if (!sv)
+        return 0;
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 	if (mg->mg_type == type)
 	    return mg;
@@ -284,8 +289,9 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
     for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
 	if (isUPPER(mg->mg_type)) {
 	    sv_magic(nsv,
-		     mg->mg_type == 'P' ? SvTIED_obj(sv, mg) :
-		     (mg->mg_type == 'D' && mg->mg_obj) ? sv : mg->mg_obj,
+		     mg->mg_type == PERL_MAGIC_tied ? SvTIED_obj(sv, mg) :
+		     (mg->mg_type == PERL_MAGIC_regdata && mg->mg_obj)
+							? sv : mg->mg_obj,
 		     toLOWER(mg->mg_type), key, klen);
 	    count++;
 	}
@@ -311,11 +317,12 @@ Perl_mg_free(pTHX_ SV *sv)
 	moremagic = mg->mg_moremagic;
 	if (vtbl && vtbl->svt_free)
 	    CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
-	if (mg->mg_ptr && mg->mg_type != 'g')
+	if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
 	    if (mg->mg_len >= 0)
 		Safefree(mg->mg_ptr);
 	    else if (mg->mg_len == HEf_SVKEY)
 		SvREFCNT_dec((SV*)mg->mg_ptr);
+	}
 	if (mg->mg_flags & MGf_REFCOUNTED)
 	    SvREFCNT_dec(mg->mg_obj);
 	Safefree(mg);
@@ -324,6 +331,7 @@ Perl_mg_free(pTHX_ SV *sv)
     return 0;
 }
 
+
 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 #include <signal.h>
 #endif
@@ -364,7 +372,14 @@ Perl_magic_regdatum_get(pTHX_ SV *sv, MAGIC *mg)
 		    i = t;
 		else			/* @- */
 		    i = s;
-		sv_setiv(sv,i);
+		
+		if (i > 0 && DO_UTF8(PL_reg_sv)) {
+		    char *b = rx->subbeg;
+		    if (b)
+		        i = Perl_utf8_length(aTHX_ (U8*)b, (U8*)(b+i));
+		}
+
+		sv_setiv(sv, i);
 	    }
     }
     return 0;
@@ -403,10 +418,12 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
 		    char *s    = rx->subbeg + s1;
 		    char *send = rx->subbeg + t1;
 
-		    i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
+		    i = t1 - s1;
+		    if (is_utf8_string((U8*)s, i))
+			i = Perl_utf8_length(aTHX_ (U8*)s, (U8*)send);
 		}
 		if (i < 0)
-		    Perl_croak(aTHX_ "panic: magic_len: %d", i);
+		    Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
 		return i;
 	    }
 	}
@@ -470,9 +487,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	break;
 
     case '\004':		/* ^D */
-	sv_setiv(sv, (IV)(PL_debug & 32767));
+	sv_setiv(sv, (IV)(PL_debug & DEBUG_MASK));
 #if defined(YYDEBUG) && defined(DEBUGGING)
-	PL_yydebug = (PL_debug & 1);
+	PL_yydebug = DEBUG_p_TEST;
 #endif
 	break;
     case '\005':  /* ^E */
@@ -564,6 +581,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 		(void)SvOK_off(sv);
 	    else if (PL_in_eval)
  		sv_setiv(sv, PL_in_eval & ~(EVAL_INREQUIRE));
+	    else
+		sv_setiv(sv, 0);
 	}
 	break;
     case '\024':		/* ^T */
@@ -615,13 +634,13 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 
 	      getrx:
 		if (i >= 0) {
-		    bool was_tainted;
+		    bool was_tainted = FALSE;
 		    if (PL_tainting) {
 			was_tainted = PL_tainted;
 			PL_tainted = FALSE;
 		    }
 		    sv_setpvn(sv, s, i);
-		    if (DO_UTF8(PL_reg_sv))
+                   if (PL_reg_sv && DO_UTF8(PL_reg_sv) && is_utf8_string((U8*)s, i))
 			SvUTF8_on(sv);
 		    else
 			SvUTF8_off(sv);
@@ -663,7 +682,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '.':
 #ifndef lint
 	if (GvIO(PL_last_in_gv)) {
-	    sv_setiv(sv, (IV)IoLINES(GvIO(PL_last_in_gv)));
+	    sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv)));
 	}
 #endif
 	break;
@@ -787,7 +806,7 @@ Perl_magic_getuvar(pTHX_ SV *sv, MAGIC *mg)
     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 
     if (uf && uf->uf_val)
-	(*uf->uf_val)(uf->uf_index, sv);
+	(*uf->uf_val)(aTHX_ uf->uf_index, sv);
     return 0;
 }
 
@@ -922,6 +941,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
     }
     FreeEnvironmentStrings(envv);
 #	else
+#ifdef USE_ENVIRON_ARRAY
 #	    ifndef PERL_USE_SAFE_PUTENV
     I32 i;
 
@@ -934,6 +954,7 @@ Perl_magic_clear_all_env(pTHX_ SV *sv, MAGIC *mg)
 
     environ[0] = Nullch;
 
+#endif /* USE_ENVIRON_ARRAY */
 #	endif /* WIN32 */
 #   endif /* PERL_IMPLICIT_SYS */
 #endif /* VMS */
@@ -985,12 +1006,46 @@ Perl_magic_clearsig(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+void
+Perl_raise_signal(pTHX_ int sig)
+{
+    /* Set a flag to say this signal is pending */
+    PL_psig_pend[sig]++;
+    /* And one to say _a_ signal is pending */
+    PL_sig_pending = 1;
+}
+
+Signal_t
+Perl_csighandler(int sig)
+{
+#ifdef PERL_OLD_SIGNALS
+    /* Call the perl level handler now with risk we may be in malloc() etc. */
+    (*PL_sighandlerp)(sig);
+#else
+    dTHX;
+    Perl_raise_signal(aTHX_ sig);
+#endif
+}
+
+void
+Perl_despatch_signals(pTHX)
+{
+    int sig;
+    PL_sig_pending = 0;
+    for (sig = 1; sig < SIG_SIZE; sig++) {
+	if (PL_psig_pend[sig]) {
+	    PL_psig_pend[sig] = 0;
+	    (*PL_sighandlerp)(sig);
+	}
+    }
+}
+
 int
 Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 {
     register char *s;
     I32 i;
-    SV** svp;
+    SV** svp = 0;
     STRLEN len;
 
     s = MgPV(mg,len);
@@ -1023,7 +1078,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
     }
     if (SvTYPE(sv) == SVt_PVGV || SvROK(sv)) {
 	if (i)
-	    (void)rsignal(i, PL_sighandlerp);
+	    (void)rsignal(i, &Perl_csighandler);
 	else
 	    *svp = SvREFCNT_inc(sv);
 	return 0;
@@ -1050,7 +1105,7 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg)
 	if (!strchr(s,':') && !strchr(s,'\''))
 	    sv_insert(sv, 0, 0, "main::", 6);
 	if (i)
-	    (void)rsignal(i, PL_sighandlerp);
+	    (void)rsignal(i, &Perl_csighandler);
 	else
 	    *svp = SvREFCNT_inc(sv);
     }
@@ -1083,7 +1138,7 @@ Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
 
     if (hv) {
 	(void) hv_iterinit(hv);
-	if (! SvTIED_mg((SV*)hv, 'P'))
+	if (! SvTIED_mg((SV*)hv, PERL_MAGIC_tied))
 	    i = HvKEYS(hv);
 	else {
 	    /*SUPPRESS 560*/
@@ -1122,7 +1177,7 @@ S_magic_methcall(pTHX_ SV *sv, MAGIC *mg, char *meth, I32 flags, int n, SV *val)
 	    else if (mg->mg_len == HEf_SVKEY)
 		PUSHs((SV*)mg->mg_ptr);
 	}
-	else if (mg->mg_type == 'p') {
+	else if (mg->mg_type == PERL_MAGIC_tiedelem) {
 	    PUSHs(sv_2mortal(newSViv(mg->mg_len)));
 	}
     }
@@ -1285,7 +1340,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
     SV* lsv = LvTARG(sv);
 
     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
-	mg = mg_find(lsv, 'g');
+	mg = mg_find(lsv, PERL_MAGIC_regex_global);
 	if (mg && mg->mg_len >= 0) {
 	    I32 i = mg->mg_len;
 	    if (DO_UTF8(lsv))
@@ -1309,12 +1364,12 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
     mg = 0;
 
     if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
-	mg = mg_find(lsv, 'g');
+	mg = mg_find(lsv, PERL_MAGIC_regex_global);
     if (!mg) {
 	if (!SvOK(sv))
 	    return 0;
-	sv_magic(lsv, (SV*)0, 'g', Nullch, 0);
-	mg = mg_find(lsv, 'g');
+	sv_magic(lsv, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
+	mg = mg_find(lsv, PERL_MAGIC_regex_global);
     }
     else if (!SvOK(sv)) {
 	mg->mg_len = -1;
@@ -1393,12 +1448,14 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
     I32 offs = LvTARGOFF(sv);
     I32 rem = LvTARGLEN(sv);
 
+    if (SvUTF8(lsv))
+	sv_pos_u2b(lsv, &offs, &rem);
     if (offs > len)
 	offs = len;
     if (rem + offs > len)
 	rem = len - offs;
     sv_setpvn(sv, tmps + offs, (STRLEN)rem);
-    if (DO_UTF8(lsv))
+    if (SvUTF8(lsv))
         SvUTF8_on(sv);
     return 0;
 }
@@ -1407,8 +1464,26 @@ int
 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 {
     STRLEN len;
-    char *tmps = SvPV(sv,len);
-    sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+    char *tmps = SvPV(sv, len);
+    SV *lsv = LvTARG(sv);
+    I32 lvoff = LvTARGOFF(sv);
+    I32 lvlen = LvTARGLEN(sv);
+
+    if (DO_UTF8(sv)) {
+	sv_utf8_upgrade(lsv);
+ 	sv_pos_u2b(lsv, &lvoff, &lvlen);
+	sv_insert(lsv, lvoff, lvlen, tmps, len);
+	SvUTF8_on(lsv);
+    }
+    else if (SvUTF8(lsv)) {
+	sv_pos_u2b(lsv, &lvoff, &lvlen);
+	tmps = (char*)bytes_to_utf8((U8*)tmps, &len);
+	sv_insert(lsv, lvoff, lvlen, tmps, len);
+	Safefree(tmps);
+    }
+    else
+        sv_insert(lsv, lvoff, lvlen, tmps, len);
+
     return 0;
 }
 
@@ -1514,7 +1589,7 @@ Perl_vivify_defelem(pTHX_ SV *sv)
     MAGIC *mg;
     SV *value = Nullsv;
 
-    if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
+    if (!LvTARGLEN(sv) || !(mg = mg_find(sv, PERL_MAGIC_defelem)))
 	return;
     if (mg->mg_obj) {
 	SV *ahv = LvTARG(sv);
@@ -1583,7 +1658,7 @@ Perl_magic_setmglob(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
 {
-    sv_unmagic(sv, 'B');
+    sv_unmagic(sv, PERL_MAGIC_bm);
     SvVALID_off(sv);
     return 0;
 }
@@ -1591,7 +1666,7 @@ Perl_magic_setbm(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setfm(pTHX_ SV *sv, MAGIC *mg)
 {
-    sv_unmagic(sv, 'f');
+    sv_unmagic(sv, PERL_MAGIC_fm);
     SvCOMPILED_off(sv);
     return 0;
 }
@@ -1602,7 +1677,7 @@ Perl_magic_setuvar(pTHX_ SV *sv, MAGIC *mg)
     struct ufuncs *uf = (struct ufuncs *)mg->mg_ptr;
 
     if (uf && uf->uf_set)
-	(*uf->uf_set)(uf->uf_index, sv);
+	(*uf->uf_set)(aTHX_ uf->uf_index, sv);
     return 0;
 }
 
@@ -1646,7 +1721,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	break;
 
     case '\004':	/* ^D */
-	PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
+	PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | DEBUG_TOP_FLAG;
 	DEBUG_x(dump_all());
 	break;
     case '\005':  /* ^E */
@@ -2127,7 +2202,7 @@ Perl_sighandler(int sig)
     dSP;
     GV *gv = Nullgv;
     HV *st;
-    SV *sv, *tSv = PL_Sv;
+    SV *sv = Nullsv, *tSv = PL_Sv;
     CV *cv = Nullcv;
     OP *myop = PL_op;
     U32 flags = 0;
@@ -2195,9 +2270,28 @@ Perl_sighandler(int sig)
     PUSHs(sv);
     PUTBACK;
 
-    call_sv((SV*)cv, G_DISCARD);
+    call_sv((SV*)cv, G_DISCARD|G_EVAL);
 
     POPSTACK;
+    if (SvTRUE(ERRSV)) {
+#ifndef PERL_MICRO
+#ifdef HAS_SIGPROCMASK
+	/* 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
+	 * blocked by the system when we entered.
+	 */
+	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, &Perl_csighandler);
+#endif
+#endif /* !PERL_MICRO */
+	Perl_die(aTHX_ Nullch);
+    }
 cleanup:
     if (flags & 1)
 	PL_savestack_ix -= 8; /* Unprotect save in progress. */