X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=mg.c;h=eb5888605f8243e1fdf2a91ff87116c60a5bc6d9;hb=64f14228217abb04a437553319642d6e7a82a3e8;hp=f42a4ad33975502d8b8b39513a422efd1ffbff2e;hpb=ff0cee690d2ef6ba882e59dd4baaa0c944adb7a2;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/mg.c b/mg.c
index f42a4ad..eb58886 100644
--- a/mg.c
+++ b/mg.c
@@ -1,6 +1,6 @@
 /*    mg.c
  *
- *    Copyright (c) 1991-1994, Larry Wall
+ *    Copyright (c) 1991-1997, 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,7 +20,7 @@
 # include <unistd.h>
 #endif
 
-#ifdef HAS_GETGROUPS
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
 #  ifndef NGROUPS
 #    define NGROUPS 32
 #  endif
@@ -286,7 +286,6 @@ MAGIC *mg;
 	    }
 	}
 	return 0;
-	break;
     case '+':
 	if (curpm && (rx = curpm->op_pmregexp)) {
 	    paren = rx->lastparen;
@@ -294,7 +293,6 @@ MAGIC *mg;
 		goto getparen;
 	}
 	return 0;
-	break;
     case '`':
 	if (curpm && (rx = curpm->op_pmregexp)) {
 	    if ((s = rx->subbeg) && rx->startp[0]) {
@@ -309,7 +307,7 @@ MAGIC *mg;
 	    if (rx->subend && (s = rx->endp[0])) {
 		i = rx->subend - s;
 		if (i >= 0)
-		    return 0;
+		    return i;
 	    }
 	}
 	return 0;
@@ -533,27 +531,20 @@ MAGIC *mg;
 	break;
     case '(':
 	sv_setiv(sv, (IV)gid);
-	s = buf;
-	(void)sprintf(s,"%d",(int)gid);
+	sv_setpvf(sv, "%Vd", (IV)gid);
 	goto add_groups;
     case ')':
 	sv_setiv(sv, (IV)egid);
-	s = buf;
-	(void)sprintf(s,"%d",(int)egid);
+	sv_setpvf(sv, "%Vd", (IV)egid);
       add_groups:
-	while (*s) s++;
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t gary[NGROUPS];
-
 	    i = getgroups(NGROUPS,gary);
-	    while (--i >= 0) {
-		(void)sprintf(s," %d", (int)gary[i]);
-		while (*s) s++;
-	    }
+	    while (--i >= 0)
+		sv_catpvf(sv, " %Vd", (IV)gary[i]);
 	}
 #endif
-	sv_setpv(sv,buf);
 	SvIOK_on(sv);	/* what a wonderful hack! */
 	break;
     case '*':
@@ -583,39 +574,73 @@ MAGIC* mg;
 {
     register char *s;
     char *ptr;
-    STRLEN len;
+    STRLEN len, klen;
     I32 i;
+
     s = SvPV(sv,len);
-    ptr = MgPV(mg);
+    ptr = MgPV(mg,klen);
     my_setenv(ptr, s);
+
 #ifdef DYNAMIC_ENV_FETCH
      /* We just undefd an environment var.  Is a replacement */
      /* waiting in the wings? */
     if (!len) {
-	HE *envhe;
-	SV *keysv;
-	if (mg->mg_len == HEf_SVKEY) keysv = (SV *)mg->mg_ptr;
-	else keysv = newSVpv(mg->mg_ptr,mg->mg_len);
-	if (envhe = hv_fetch_ent(GvHVn(envgv),keysv,FALSE,0))
-	    s = SvPV(HeVAL(envhe),len);
-	if (mg->mg_len != HEf_SVKEY) SvREFCNT_dec(keysv);
+	SV **valp;
+	if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
+	    s = SvPV(*valp, len);
     }
 #endif
+
+#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32)
 			    /* And you'll never guess what the dog had */
 			    /*   in its mouth... */
     if (tainting) {
-	if (s && strEQ(ptr,"PATH")) {
+	MgTAINTEDDIR_off(mg);
+#ifdef VMS
+	if (s && klen == 8 && strEQ(ptr, "DCL$PATH")) {
+	    char pathbuf[256], eltbuf[256], *cp, *elt = s;
+	    struct stat sbuf;
+	    int i = 0, j = 0;
+
+	    do {          /* DCL$PATH may be a search list */
+		while (1) {   /* as may dev portion of any element */
+		    if ( ((cp = strchr(elt,'[')) || (cp = strchr(elt,'<'))) ) {
+			if ( *(cp+1) == '.' || *(cp+1) == '-' ||
+			     cando_by_name(S_IWUSR,0,elt) ) {
+			    MgTAINTEDDIR_on(mg);
+			    return 0;
+			}
+		    }
+		    if ((cp = strchr(elt, ':')) != Nullch)
+			*cp = '\0';
+		    if (my_trnlnm(elt, eltbuf, j++))
+			elt = eltbuf;
+		    else
+			break;
+		}
+		j = 0;
+	    } while (my_trnlnm(s, pathbuf, i++) && (elt = pathbuf));
+	}
+#endif /* VMS */
+	if (s && klen == 4 && strEQ(ptr,"PATH")) {
 	    char *strend = s + len;
 
 	    while (s < strend) {
-		s = cpytill(tokenbuf,s,strend,':',&i);
+		struct stat st;
+		s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
+			     s, strend, ':', &i);
 		s++;
-		if (*tokenbuf != '/'
-		  || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+		if (i >= sizeof tokenbuf   /* too long -- assume the worst */
+		      || *tokenbuf != '/'
+		      || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
 		    MgTAINTEDDIR_on(mg);
+		    return 0;
+		}
 	    }
 	}
     }
+#endif /* neither OS2 nor AMIGAOS nor WIN32 */
+
     return 0;
 }
 
@@ -624,7 +649,46 @@ magic_clearenv(sv,mg)
 SV* sv;
 MAGIC* mg;
 {
-    my_setenv(MgPV(mg),Nullch);
+    my_setenv(MgPV(mg,na),Nullch);
+    return 0;
+}
+
+int
+magic_clear_all_env(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+#if defined(VMS)
+    die("Can't make list assignment to %%ENV on this system");
+#else
+#ifdef WIN32
+    char *envv = GetEnvironmentStrings();
+    char *cur = envv;
+    STRLEN len;
+    while (*cur) {
+	char *end = strchr(cur,'=');
+	if (end && end != cur) {
+	    *end = '\0';
+	    my_setenv(cur,Nullch);
+	    *end = '=';
+	    cur += strlen(end+1)+1;
+	}
+	else if ((len = strlen(cur)))
+	    cur += len+1;
+    }
+    FreeEnvironmentStrings(envv);
+#else
+    I32 i;
+
+    if (environ == origenviron)
+	New(901, environ, 1, char*);
+    else
+	for (i = 0; environ[i]; i++)
+	    Safefree(environ[i]);
+    environ[0] = Nullch;
+
+#endif
+#endif
     return 0;
 }
 
@@ -635,7 +699,7 @@ MAGIC* mg;
 {
     I32 i;
     /* Are we fetching a signal entry? */
-    i = whichsig(MgPV(mg));
+    i = whichsig(MgPV(mg,na));
     if (i) {
     	if(psig_ptr[i])
     	    sv_setsv(sv,psig_ptr[i]);
@@ -660,7 +724,7 @@ MAGIC* mg;
 {
     I32 i;
     /* Are we clearing a signal entry? */
-    i = whichsig(MgPV(mg));
+    i = whichsig(MgPV(mg,na));
     if (i) {
     	if(psig_ptr[i]) {
     	    SvREFCNT_dec(psig_ptr[i]);
@@ -683,7 +747,7 @@ MAGIC* mg;
     I32 i;
     SV** svp;
 
-    s = MgPV(mg);
+    s = MgPV(mg,na);
     if (*s == '_') {
 	if (strEQ(s,"__DIE__"))
 	    svp = &diehook;
@@ -734,12 +798,13 @@ MAGIC* mg;
 	    *svp = 0;
     }
     else {
-    	if(hints & HINT_STRICT_REFS)
-    		die(no_symref,s,"a subroutine");
-	if (!strchr(s,':') && !strchr(s,'\'')) {
-	    sprintf(tokenbuf, "main::%s",s);
-	    sv_setpv(sv,tokenbuf);
-	}
+	/*
+	 * We should warn if HINT_STRICT_REFS, but without
+	 * access to a known hint bit in a known OP, we can't
+	 * tell whether HINT_STRICT_REFS is in force or not.
+	 */
+	if (!strchr(s,':') && !strchr(s,'\''))
+	    sv_setpv(sv, form("main::%s", s));
 	if (i)
 	    (void)rsignal(i, sighandler);
 	else
@@ -921,7 +986,7 @@ MAGIC* mg;
     gv = DBline;
     i = SvTRUE(sv);
     svp = av_fetch(GvAV(gv),
-		     atoi(MgPV(mg)), FALSE);
+		     atoi(MgPV(mg,na)), FALSE);
     if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
 	o->op_private = i;
     else
@@ -1090,15 +1155,32 @@ MAGIC* mg;
 }
 
 int
-magic_getitervar(sv,mg)
+magic_getdefelem(sv,mg)
 SV* sv;
 MAGIC* mg;
 {
     SV *targ = Nullsv;
     if (LvTARGLEN(sv)) {
-	AV* av = (AV*)LvTARG(sv);
-	if (LvTARGOFF(sv) <= AvFILL(av))
-	    targ = AvARRAY(av)[LvTARGOFF(sv)];
+	if (mg->mg_obj) {
+	    HV* hv = (HV*)LvTARG(sv);
+	    HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
+	    if (he)
+		targ = HeVAL(he);
+	}
+	else {
+	    AV* av = (AV*)LvTARG(sv);
+	    if ((I32)LvTARGOFF(sv) <= AvFILL(av))
+		targ = AvARRAY(av)[LvTARGOFF(sv)];
+	}
+	if (targ && targ != &sv_undef) {
+	    /* somebody else defined it for us */
+	    SvREFCNT_dec(LvTARG(sv));
+	    LvTARG(sv) = SvREFCNT_inc(targ);
+	    LvTARGLEN(sv) = 0;
+	    SvREFCNT_dec(mg->mg_obj);
+	    mg->mg_obj = Nullsv;
+	    mg->mg_flags &= ~MGf_REFCOUNTED;
+	}
     }
     else
 	targ = LvTARG(sv);
@@ -1107,19 +1189,21 @@ MAGIC* mg;
 }
 
 int
-magic_setitervar(sv,mg)
+magic_setdefelem(sv,mg)
 SV* sv;
 MAGIC* mg;
 {
     if (LvTARGLEN(sv))
-	vivify_itervar(sv);
-    if (LvTARG(sv))
+	vivify_defelem(sv);
+    if (LvTARG(sv)) {
 	sv_setsv(LvTARG(sv), sv);
+	SvSETMAGIC(LvTARG(sv));
+    }
     return 0;
 }
 
 int
-magic_freeitervar(sv,mg)
+magic_freedefelem(sv,mg)
 SV* sv;
 MAGIC* mg;
 {
@@ -1128,24 +1212,37 @@ MAGIC* mg;
 }
 
 void
-vivify_itervar(sv)
+vivify_defelem(sv)
 SV* sv;
 {
-    AV* av;
+    MAGIC* mg;
+    SV* value;
 
-    if (!LvTARGLEN(sv))
+    if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
 	return;
-    av = (AV*)LvTARG(sv);
-    if (LvTARGOFF(sv) <= AvFILL(av)) {
-	SV** svp = AvARRAY(av) + LvTARGOFF(sv);
-	LvTARG(sv) = newSVsv(*svp);
-	SvREFCNT_dec(*svp);
-	*svp = SvREFCNT_inc(LvTARG(sv));
+    if (mg->mg_obj) {
+	HV* hv = (HV*)LvTARG(sv);
+	HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
+	if (!he || (value = HeVAL(he)) == &sv_undef)
+	    croak(no_helem, SvPV(mg->mg_obj, na));
     }
-    else
-	LvTARG(sv) = Nullsv;
-    SvREFCNT_dec(av);
+    else {
+	AV* av = (AV*)LvTARG(sv);
+	if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av))
+	    LvTARG(sv) = Nullsv;	/* array can't be extended */
+	else {
+	    SV** svp = av_fetch(av, LvTARGOFF(sv), TRUE);
+	    if (!svp || (value = *svp) == &sv_undef)
+		croak(no_aelem, (I32)LvTARGOFF(sv));
+	}
+    }
+    (void)SvREFCNT_inc(value);
+    SvREFCNT_dec(LvTARG(sv));
+    LvTARG(sv) = value;
     LvTARGLEN(sv) = 0;
+    SvREFCNT_dec(mg->mg_obj);
+    mg->mg_obj = Nullsv;
+    mg->mg_flags &= ~MGf_REFCOUNTED;
 }
 
 int
@@ -1305,9 +1402,18 @@ MAGIC* mg;
 	IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
 	break;
     case '|':
-	IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
-	if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
-	    IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
+	{
+	    IO *io = GvIOp(defoutgv);
+	    if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) == 0)
+		IoFLAGS(io) &= ~IOf_FLUSH;
+	    else {
+		if (!(IoFLAGS(io) & IOf_FLUSH)) {
+		    PerlIO *ofp = IoOFP(io);
+		    if (ofp)
+			(void)PerlIO_flush(ofp);
+		    IoFLAGS(io) |= IOf_FLUSH;
+		}
+	    }
 	}
 	break;
     case '*':
@@ -1444,7 +1550,30 @@ MAGIC* mg;
 	tainting |= (uid && (euid != uid || egid != gid));
 	break;
     case ')':
+#ifdef HAS_SETGROUPS
+	{
+	    char *p = SvPV(sv, na);
+	    Groups_t gary[NGROUPS];
+
+	    SET_NUMERIC_STANDARD();
+	    while (isSPACE(*p))
+		++p;
+	    egid = I_V(atof(p));
+	    for (i = 0; i < NGROUPS; ++i) {
+		while (*p && !isSPACE(*p))
+		    ++p;
+		while (isSPACE(*p))
+		    ++p;
+		if (!*p)
+		    break;
+		gary[i] = I_V(atof(p));
+	    }
+	    if (i)
+		(void)setgroups(i, gary);
+	}
+#else  /* HAS_SETGROUPS */
 	egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+#endif /* HAS_SETGROUPS */
 	if (delaymagic) {
 	    delaymagic |= DM_EGID;
 	    break;				/* don't do magic till later */
@@ -1484,7 +1613,7 @@ MAGIC* mg;
 	    }
 	    /* can grab env area too? */
 	    if (origenviron && origenviron[0] == s + 1) {
-		my_setenv("NoNeSuCh", Nullch);
+		my_setenv("NoNe  SuCh", Nullch);
 					    /* force copy of environment */
 		for (i = 0; origenviron[i]; i++)
 		    if (origenviron[i] == s + 1)
@@ -1545,24 +1674,11 @@ int sig;
     SV *sv;
     CV *cv;
     AV *oldstack;
-    bool long_savestack = (savestack_ix + 14) < savestack_max;
-    bool long_cxstack = (cxstack_ix + 1) < cxstack_max;
-
-    /* Protect PUSHXXX in progress. */
-    if (long_cxstack)
-	cxstack_ix++;
 
     if (!psig_ptr[sig])
 	die("Signal SIG%s received, but no signal handler set.\n",
 	    sig_name[sig]);
 
-    /*
-     * Protect save in progress.  Max number of items pushed there is
-     * 3*n or 4. We cannot fix infinity, so we fix 4 (in fact 5).
-     */
-    if (long_savestack)
-	savestack_ix += 5;
-
     cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
     if (!cv || !CvROOT(cv)) {
 	if (dowarn)
@@ -1589,10 +1705,6 @@ int sig;
     perl_call_sv((SV*)cv, G_DISCARD);
 
     SWITCHSTACK(signalstack, oldstack);
-    if (long_savestack)
-	savestack_ix -= 5;	/* Unprotect save in progress. */
-    if (long_cxstack)
-	cxstack_ix--;		/* Unprotect PUSHXXX in progress. */
-    
+
     return;
 }