X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=f61b66d1ae4d950fe27a48ed5ec69664f6de056d;hb=c73bb82c00a639630ef310b1ac1d896f5afcedab;hp=22af92170bb753f0cb89852c2f1c515727b4d5c2;hpb=6ff81951f79dec32e15a779d288c1047f0e4fefb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 22af921..f61b66d 100644
--- a/util.c
+++ b/util.c
@@ -14,7 +14,6 @@
 
 #include "EXTERN.h"
 #include "perl.h"
-#include "perlmem.h"
 
 #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
 #include <signal.h>
@@ -122,13 +121,18 @@ saferealloc(Malloc_t where,MEM_SIZE size)
 	my_exit(1);
     }
 #endif /* HAS_64K_LIMIT */
+    if (!size) {
+	safefree(where);
+	return NULL;
+    }
+
     if (!where)
-	croak("Null realloc");
+	return safemalloc(size);
 #ifdef DEBUGGING
     if ((long)size < 0)
 	croak("panic: realloc");
 #endif
-    ptr = PerlMem_realloc(where,size?size:1);	/* realloc(0) is NASTY on our system */
+    ptr = PerlMem_realloc(where,size);
 
 #if !(defined(I286) || defined(atarist))
     DEBUG_m( {
@@ -844,13 +848,13 @@ char *
 mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
 {
     char *xbuf;
-    STRLEN xalloc, xin, xout;
+    STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
 
     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
     /* the +1 is for the terminating NUL. */
 
-    xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
-    New(171, xbuf, xalloc, char);
+    xAlloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
+    New(171, xbuf, xAlloc, char);
     if (! xbuf)
 	goto bad;
 
@@ -860,13 +864,13 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen)
 	SSize_t xused;
 
 	for (;;) {
-	    xused = strxfrm(xbuf + xout, s + xin, xalloc - xout);
+	    xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
 	    if (xused == -1)
 		goto bad;
-	    if (xused < xalloc - xout)
+	    if (xused < xAlloc - xout)
 		break;
-	    xalloc = (2 * xalloc) + 1;
-	    Renew(xbuf, xalloc, char);
+	    xAlloc = (2 * xAlloc) + 1;
+	    Renew(xbuf, xAlloc, char);
 	    if (! xbuf)
 		goto bad;
 	}
@@ -1178,7 +1182,7 @@ savepvn(char *sv, register I32 len)
 
 /* the SV for form() and mess() is not kept in an arena */
 
-static SV *
+STATIC SV *
 mess_alloc(void)
 {
     SV *sv;
@@ -1193,23 +1197,11 @@ mess_alloc(void)
     return sv;
 }
 
-#ifdef I_STDARG
 char *
 form(const char* pat, ...)
-#else
-/*VARARGS0*/
-char *
-form(pat, va_alist)
-    const char *pat;
-    va_dcl
-#endif
 {
     va_list args;
-#ifdef I_STDARG
     va_start(args, pat);
-#else
-    va_start(args);
-#endif
     if (!mess_sv)
 	mess_sv = mess_alloc();
     sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
@@ -1249,16 +1241,8 @@ mess(const char *pat, va_list *args)
     return SvPVX(sv);
 }
 
-#ifdef I_STDARG
 OP *
 die(const char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
-    const char *pat;
-    va_dcl
-#endif
 {
     dTHR;
     va_list args;
@@ -1274,12 +1258,8 @@ die(pat, va_alist)
 			  thr, curstack, mainstack));
 #endif /* USE_THREADS */
 
-#ifdef I_STDARG
     va_start(args, pat);
-#else
-    va_start(args);
-#endif
-    message = mess(pat, &args);
+    message = pat ? mess(pat, &args) : Nullch;
     va_end(args);
 
 #ifdef USE_THREADS
@@ -1300,16 +1280,21 @@ die(pat, va_alist)
 	    SV *msg;
 
 	    ENTER;
-	    msg = newSVpv(message, 0);
-	    SvREADONLY_on(msg);
-	    SAVEFREESV(msg);
+	    if(message) {
+		msg = newSVpv(message, 0);
+		SvREADONLY_on(msg);
+		SAVEFREESV(msg);
+	    }
+	    else {
+		msg = ERRSV;
+	    }
 
-	    PUSHSTACK(SI_DIEHOOK);
+	    PUSHSTACKi(SI_DIEHOOK);
 	    PUSHMARK(SP);
 	    XPUSHs(msg);
 	    PUTBACK;
 	    perl_call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK();
+	    POPSTACK;
 	    LEAVE;
 	}
     }
@@ -1325,16 +1310,8 @@ die(pat, va_alist)
     return restartop;
 }
 
-#ifdef I_STDARG
 void
 croak(const char* pat, ...)
-#else
-/*VARARGS0*/
-void
-croak(pat, va_alist)
-    char *pat;
-    va_dcl
-#endif
 {
     dTHR;
     va_list args;
@@ -1343,11 +1320,7 @@ croak(pat, va_alist)
     GV *gv;
     CV *cv;
 
-#ifdef I_STDARG
     va_start(args, pat);
-#else
-    va_start(args);
-#endif
     message = mess(pat, &args);
     va_end(args);
 #ifdef USE_THREADS
@@ -1370,12 +1343,12 @@ croak(pat, va_alist)
 	    SvREADONLY_on(msg);
 	    SAVEFREESV(msg);
 
-	    PUSHSTACK(SI_DIEHOOK);
+	    PUSHSTACKi(SI_DIEHOOK);
 	    PUSHMARK(SP);
 	    XPUSHs(msg);
 	    PUTBACK;
 	    perl_call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK();
+	    POPSTACK;
 	    LEAVE;
 	}
     }
@@ -1389,14 +1362,7 @@ croak(pat, va_alist)
 }
 
 void
-#ifdef I_STDARG
 warn(const char* pat,...)
-#else
-/*VARARGS0*/
-warn(pat,va_alist)
-    const char *pat;
-    va_dcl
-#endif
 {
     va_list args;
     char *message;
@@ -1404,11 +1370,7 @@ warn(pat,va_alist)
     GV *gv;
     CV *cv;
 
-#ifdef I_STDARG
     va_start(args, pat);
-#else
-    va_start(args);
-#endif
     message = mess(pat, &args);
     va_end(args);
 
@@ -1430,12 +1392,12 @@ warn(pat,va_alist)
 	    SvREADONLY_on(msg);
 	    SAVEFREESV(msg);
 
-	    PUSHSTACK(SI_WARNHOOK);
+	    PUSHSTACKi(SI_WARNHOOK);
 	    PUSHMARK(SP);
 	    XPUSHs(msg);
 	    PUTBACK;
 	    perl_call_sv((SV*)cv, G_DISCARD);
-	    POPSTACK();
+	    POPSTACK;
 	    LEAVE;
 	    return;
 	}
@@ -1667,7 +1629,6 @@ register I32 len;
 }
 #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
 
-#if defined(I_STDARG) || defined(I_VARARGS)
 #ifndef HAS_VPRINTF
 
 #ifdef USE_CHAR_VSPRINTF
@@ -1698,7 +1659,6 @@ char *args;
 }
 
 #endif /* HAS_VPRINTF */
-#endif /* I_VARARGS || I_STDARGS */
 
 #ifdef MYSWAP
 #if BYTEORDER != 0x4321
@@ -1871,6 +1831,8 @@ my_popen(char *cmd, char *mode)
     if (pid == 0) {
 	GV* tmpgv;
 
+#undef THIS
+#undef THAT
 #define THIS that
 #define THAT This
 	PerlLIO_close(p[THAT]);
@@ -1930,8 +1892,8 @@ char	*mode;
 #endif /* !DOSISH */
 
 #ifdef DUMP_FDS
-dump_fds(s)
-char *s;
+void
+dump_fds(char *s)
 {
     int fd;
     struct stat tmpstatbuf;
@@ -1943,7 +1905,7 @@ char *s;
     }
     PerlIO_printf(PerlIO_stderr(),"\n");
 }
-#endif
+#endif	/* DUMP_FDS */
 
 #ifndef HAS_DUP2
 int
@@ -2086,6 +2048,7 @@ my_pclose(PerlIO *ptr)
     int status;
     SV **svp;
     int pid;
+    int pid2;
     bool close_failed;
     int saved_errno;
 #ifdef VMS
@@ -2120,8 +2083,8 @@ my_pclose(PerlIO *ptr)
     rsignal_save(SIGINT, SIG_IGN, &istat);
     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
     do {
-	pid = wait4pid(pid, &status, 0);
-    } while (pid == -1 && errno == EINTR);
+	pid2 = wait4pid(pid, &status, 0);
+    } while (pid2 == -1 && errno == EINTR);
     rsignal_restore(SIGHUP, &hstat);
     rsignal_restore(SIGINT, &istat);
     rsignal_restore(SIGQUIT, &qstat);
@@ -2129,7 +2092,7 @@ my_pclose(PerlIO *ptr)
 	SETERRNO(saved_errno, saved_vaxc_errno);
 	return -1;
     }
-    return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
+    return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
 }
 #endif /* !DOSISH */
 
@@ -2170,7 +2133,7 @@ wait4pid(int pid, int *statusp, int flags)
     if (!HAS_WAITPID_RUNTIME)
 	goto hard_way;
 #  endif
-    return waitpid(pid,statusp,flags);
+    return PerlProc_waitpid(pid,statusp,flags);
 #endif
 #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
@@ -2182,7 +2145,7 @@ wait4pid(int pid, int *statusp, int flags)
 	if (flags)
 	    croak("Can't do waitpid with flags");
 	else {
-	    while ((result = wait(statusp)) != pid && pid > 0 && result >= 0)
+	    while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
 		pidgone(result,*statusp);
 	    if (result < 0)
 		*statusp = -1;
@@ -2413,6 +2376,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
     dTHR;
     char *xfound = Nullch;
     char *xfailed = Nullch;
+    char tmpbuf[512];
     register char *s;
     I32 len;
     int retval;
@@ -2456,6 +2420,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
      *       this will not look in '.' if it's not in the PATH)
      */
+    tmpbuf[0] = '\0';
 
 #ifdef VMS
 #  ifdef ALWAYS_DEFTYPES
@@ -2475,16 +2440,16 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 	/* The first time through, just add SEARCH_EXTS to whatever we
 	 * already have, so we can check for default file types. */
 	while (deftypes ||
-	       (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) )
+	       (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
 	{
 	    if (deftypes) {
 		deftypes = 0;
-		*tokenbuf = '\0';
+		*tmpbuf = '\0';
 	    }
-	    if ((strlen(tokenbuf) + strlen(scriptname)
-		 + MAX_EXT_LEN) >= sizeof tokenbuf)
+	    if ((strlen(tmpbuf) + strlen(scriptname)
+		 + MAX_EXT_LEN) >= sizeof tmpbuf)
 		continue;	/* don't search dir with too-long name */
-	    strcat(tokenbuf, scriptname);
+	    strcat(tmpbuf, scriptname);
 #else  /* !VMS */
 
 #ifdef DOSISH
@@ -2513,12 +2478,12 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 #ifdef SEARCH_EXTS
 	    if (cur == scriptname) {
 		len = strlen(scriptname);
-		if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
+		if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
 		    break;
-		cur = strcpy(tokenbuf, scriptname);
+		cur = strcpy(tmpbuf, scriptname);
 	    }
 	} while (extidx >= 0 && ext[extidx]	/* try an extension? */
-		 && strcpy(tokenbuf+len, ext[extidx++]));
+		 && strcpy(tmpbuf+len, ext[extidx++]));
 #endif
     }
 #endif
@@ -2538,44 +2503,44 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 		    && *s != ','
 #  endif
 		    && *s != ';'; len++, s++) {
-		if (len < sizeof tokenbuf)
-		    tokenbuf[len] = *s;
+		if (len < sizeof tmpbuf)
+		    tmpbuf[len] = *s;
 	    }
-	    if (len < sizeof tokenbuf)
-		tokenbuf[len] = '\0';
+	    if (len < sizeof tmpbuf)
+		tmpbuf[len] = '\0';
 #else  /* ! (atarist || DOSISH) */
-	    s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+	    s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
 			':',
 			&len);
 #endif /* ! (atarist || DOSISH) */
 	    if (s < bufend)
 		s++;
-	    if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
+	    if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
 		continue;	/* don't search dir with too-long name */
 	    if (len
 #if defined(atarist) || defined(DOSISH)
-		&& tokenbuf[len - 1] != '/'
-		&& tokenbuf[len - 1] != '\\'
+		&& tmpbuf[len - 1] != '/'
+		&& tmpbuf[len - 1] != '\\'
 #endif
 	       )
-		tokenbuf[len++] = '/';
-	    if (len == 2 && tokenbuf[0] == '.')
+		tmpbuf[len++] = '/';
+	    if (len == 2 && tmpbuf[0] == '.')
 		seen_dot = 1;
-	    (void)strcpy(tokenbuf + len, scriptname);
+	    (void)strcpy(tmpbuf + len, scriptname);
 #endif  /* !VMS */
 
 #ifdef SEARCH_EXTS
-	    len = strlen(tokenbuf);
+	    len = strlen(tmpbuf);
 	    if (extidx > 0)	/* reset after previous loop */
 		extidx = 0;
 	    do {
 #endif
-	    	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
-		retval = PerlLIO_stat(tokenbuf,&statbuf);
+	    	DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
+		retval = PerlLIO_stat(tmpbuf,&statbuf);
 #ifdef SEARCH_EXTS
 	    } while (  retval < 0		/* not there */
 		    && extidx>=0 && ext[extidx]	/* try an extension? */
-		    && strcpy(tokenbuf+len, ext[extidx++])
+		    && strcpy(tmpbuf+len, ext[extidx++])
 		);
 #endif
 	    if (retval < 0)
@@ -2587,28 +2552,31 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags)
 #endif
 		)
 	    {
-		xfound = tokenbuf;              /* bingo! */
+		xfound = tmpbuf;              /* bingo! */
 		break;
 	    }
 	    if (!xfailed)
-		xfailed = savepv(tokenbuf);
+		xfailed = savepv(tmpbuf);
 	}
 #ifndef DOSISH
 	if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
 #endif
 	    seen_dot = 1;			/* Disable message. */
-	if (!xfound) 
-	    scriptname = NULL;
-/*	    croak("Can't %s %s%s%s",
-		  (xfailed ? "execute" : "find"),
-		  (xfailed ? xfailed : scriptname),
-		  (xfailed ? "" : " on PATH"),
-		  (xfailed || seen_dot) ? "" : ", '.' not in PATH"); */
+	if (!xfound) {
+	    if (flags & 1) {			/* do or die? */
+	        croak("Can't %s %s%s%s",
+		      (xfailed ? "execute" : "find"),
+		      (xfailed ? xfailed : scriptname),
+		      (xfailed ? "" : " on PATH"),
+		      (xfailed || seen_dot) ? "" : ", '.' not in PATH");
+	    }
+	    scriptname = Nullch;
+	}
 	if (xfailed)
 	    Safefree(xfailed);
 	scriptname = xfound;
     }
-    return scriptname;
+    return (scriptname ? savepv(scriptname) : Nullch);
 }
 
 
@@ -2877,3 +2845,22 @@ get_op_descs(void)
 {
  return op_desc;
 }
+
+char *
+get_no_modify(void)
+{
+ return (char*)no_modify;
+}
+
+U32 *
+get_opargs(void)
+{
+ return opargs;
+}
+
+
+SV **
+get_specialsv_list(void)
+{
+ return specialsv_list;
+}