X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=67ed3939515a2e99a1d0000c6ae179764faa14b3;hb=0bcc34c2b0b0cb62c0df3d5e562b779fb96595ba;hp=74facce9b2f13cad72f2da5ec76a10ec527a14ce;hpb=7b9a32411c4ec6251e6f3ab9bb69dd43222d7692;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/util.c b/util.c
index 74facce..67ed393 100644
--- a/util.c
+++ b/util.c
@@ -57,6 +57,16 @@ int putenv(char *);
  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  */
 
+static char *
+S_write_no_mem(pTHX)
+{
+    /* Can't use PerlIO to write as it allocates memory */
+    PerlLIO_write(PerlIO_fileno(Perl_error_log),
+		  PL_no_mem, strlen(PL_no_mem));
+    my_exit(1);
+    return Nullch;
+}
+
 /* paranoid version of system's malloc() */
 
 Malloc_t
@@ -83,11 +93,7 @@ Perl_safesysmalloc(MEM_SIZE size)
     else if (PL_nomemok)
 	return Nullch;
     else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
+	return S_write_no_mem(aTHX);
     }
     /*NOTREACHED*/
 }
@@ -132,11 +138,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     else if (PL_nomemok)
 	return Nullch;
     else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
+	return S_write_no_mem(aTHX);
     }
     /*NOTREACHED*/
 }
@@ -186,11 +188,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
     else if (PL_nomemok)
 	return Nullch;
     else {
-	/* Can't use PerlIO to write as it allocates memory */
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
-	return Nullch;
+	return S_write_no_mem(aTHX);
     }
     /*NOTREACHED*/
 }
@@ -291,7 +289,7 @@ char *
 Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
 {
     register const I32 first = *little;
-    register const char *littleend = lend;
+    register const char * const littleend = lend;
 
     if (!first && little >= littleend)
 	return (char*)big;
@@ -321,7 +319,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit
 {
     register const char *bigbeg;
     register const I32 first = *little;
-    register const char *littleend = lend;
+    register const char * const littleend = lend;
 
     if (!first && little >= littleend)
 	return (char*)bigend;
@@ -552,7 +550,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
 	return Nullch;
     }
     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
-	char *b = ninstr((char*)big,(char*)bigend,
+	char * const b = ninstr((char*)big,(char*)bigend,
 			 (char*)little, (char*)little + littlelen);
 
 	if (!b && SvTAIL(littlestr)) {	/* Automatically multiline!  */
@@ -569,7 +567,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
     }
 
     {	/* Do actual FBM.  */
-	register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
+	register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
 	register const unsigned char *oldlittle;
 
 	if (littlelen > (STRLEN)(bigend - big))
@@ -819,9 +817,7 @@ Perl_savesharedpv(pTHX_ const char *pv)
     pvlen = strlen(pv)+1;
     newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
-	PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		      PL_no_mem, strlen(PL_no_mem));
-	my_exit(1);
+	return S_write_no_mem(aTHX);
     }
     return memcpy(newaddr,pv,pvlen);
 }
@@ -839,7 +835,7 @@ char *
 Perl_savesvpv(pTHX_ SV *sv)
 {
     STRLEN len;
-    const char *pv = SvPV_const(sv, len);
+    const char * const pv = SvPV_const(sv, len);
     register char *newaddr;
 
     ++len;
@@ -985,7 +981,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o)
 SV *
 Perl_vmess(pTHX_ const char *pat, va_list *args)
 {
-    SV *sv = mess_alloc();
+    SV * const sv = mess_alloc();
     static const char dgd[] = " during global destruction.\n";
 
     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
@@ -1358,7 +1354,7 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     if (ckDEAD(err)) {
 	SV * const msv = vmess(pat, args);
 	STRLEN msglen;
-	const char *message = SvPV_const(msv, msglen);
+	const char * const message = SvPV_const(msv, msglen);
 	const I32 utf8 = SvUTF8(msv);
 
 	if (PL_diehook) {
@@ -1510,16 +1506,17 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
         if (val == NULL) {
             (void)unsetenv(nam);
         } else {
-            int nlen = strlen(nam);
-            int vlen = strlen(val);
-            char *new_env =
+	    const int nlen = strlen(nam);
+	    const int vlen = strlen(val);
+	    char * const new_env =
                 (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
             my_setenv_format(new_env, nam, nlen, val, vlen);
             (void)putenv(new_env);
         }
 #       else /* ! HAS_UNSETENV */
         char *new_env;
-        int nlen = strlen(nam), vlen;
+	const int nlen = strlen(nam);
+	int vlen;
         if (!val) {
 	   val = "";
         }
@@ -2232,7 +2229,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	PL_ppid = (IV)getppid();
 #endif
 	PL_forkprocess = 0;
+#ifdef PERL_USES_PL_PIDSTATUS
 	hv_clear(PL_pidstatus);	/* we have no children */
+#endif
 	return Nullfp;
 #undef THIS
 #undef THAT
@@ -2635,18 +2634,16 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     I32 result = 0;
     if (!pid)
 	return -1;
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
     {
-	char spid[TYPE_CHARS(IV)];
-
 	if (pid > 0) {
-	    SV** svp;
-	    const I32 len = my_sprintf(spid, "%"IVdf, (IV)pid);
-
-	    svp = hv_fetch(PL_pidstatus,spid,len,FALSE);
+	    /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
+	       pid, rather than a string form.  */
+	    SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
 	    if (svp && *svp != &PL_sv_undef) {
 		*statusp = SvIVX(*svp);
-		(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
+		(void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
+				G_DISCARD);
 		return pid;
 	    }
 	}
@@ -2655,12 +2652,13 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
 	    hv_iterinit(PL_pidstatus);
 	    if ((entry = hv_iternext(PL_pidstatus))) {
-		SV *sv = hv_iterval(PL_pidstatus,entry);
+		SV * const sv = hv_iterval(PL_pidstatus,entry);
 		I32 len;
+		const char * const spid = hv_iterkey(entry,&len);
 
-		pid = atoi(hv_iterkey(entry,(I32*)statusp));
+		assert (len == sizeof(Pid_t));
+		memcpy((char *)&pid, spid, len);
 		*statusp = SvIVX(sv);
-		len = my_sprintf(spid, "%"IVdf, (IV)pid);
 		/* The hash iterator is currently on this entry, so simply
 		   calling hv_delete would trigger the lazy delete, which on
 		   aggregate does more work, beacuse next call to hv_iterinit()
@@ -2686,7 +2684,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
     result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
     goto finish;
 #endif
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+#ifdef PERL_USES_PL_PIDSTATUS
 #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME)
   hard_way:
 #endif
@@ -2711,18 +2709,18 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 }
 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
 
+#ifdef PERL_USES_PL_PIDSTATUS
 void
 Perl_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
-    char spid[TYPE_CHARS(IV)];
-    const size_t len = my_sprintf(spid, "%"IVdf, (IV)pid);
 
-    sv = *hv_fetch(PL_pidstatus,spid,len,TRUE);
+    sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE);
     SvUPGRADE(sv,SVt_IV);
     SvIV_set(sv, status);
     return;
 }
+#endif
 
 #if defined(atarist) || defined(OS2) || defined(EPOC)
 int pclose();
@@ -2736,8 +2734,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 #endif
 {
     /* Needs work for PerlIO ! */
-    FILE *f = PerlIO_findFILE(ptr);
-    I32 result = pclose(f);
+    FILE * const f = PerlIO_findFILE(ptr);
+    const I32 result = pclose(f);
     PerlIO_releaseFILE(ptr,f);
     return result;
 }
@@ -2749,7 +2747,7 @@ I32
 Perl_my_pclose(pTHX_ PerlIO *ptr)
 {
     /* Needs work for PerlIO ! */
-    FILE *f = PerlIO_findFILE(ptr);
+    FILE * const f = PerlIO_findFILE(ptr);
     I32 result = djgpp_pclose(f);
     result = (result << 8) & 0xff00;
     PerlIO_releaseFILE(ptr,f);
@@ -2761,7 +2759,7 @@ void
 Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
 {
     register I32 todo;
-    register const char *frombase = from;
+    register const char * const frombase = from;
 
     if (len == 1) {
 	register const char c = *from;
@@ -2785,7 +2783,7 @@ Perl_same_dirent(pTHX_ const char *a, const char *b)
     char *fb = strrchr(b,'/');
     Stat_t tmpstatbuf1;
     Stat_t tmpstatbuf2;
-    SV *tmpsv = sv_newmortal();
+    SV * const tmpsv = sv_newmortal();
 
     if (fa)
 	fa++;
@@ -2838,7 +2836,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #endif
     /* additional extensions to try in each dir if scriptname not found */
 #ifdef SEARCH_EXTS
-    const char *const exts[] = { SEARCH_EXTS };
+    static const char *const exts[] = { SEARCH_EXTS };
     const char *const *const ext = search_ext ? search_ext : exts;
     int extidx = 0, i = 0;
     const char *curext = Nullch;
@@ -2871,16 +2869,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
 #  ifdef ALWAYS_DEFTYPES
     len = strlen(scriptname);
     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
-	int hasdir, idx = 0, deftypes = 1;
+	int idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
-	hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+	const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch);
 #  else
     if (dosearch) {
-	int hasdir, idx = 0, deftypes = 1;
+	int idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
-	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+	const int hasdir = (strpbrk(scriptname,":[</") != Nullch);
 #  endif
 	/* The first time through, just add SEARCH_EXTS to whatever we
 	 * already have, so we can check for default file types. */
@@ -3145,7 +3143,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
-    const MGVTBL* result = Null(MGVTBL*);
+    const MGVTBL* result;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3240,6 +3238,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
     case want_vtbl_utf8:
 	result = &PL_vtbl_utf8;
 	break;
+    default:
+	result = Null(MGVTBL*);
+	break;
     }
     return (MGVTBL*)result;
 }
@@ -3754,7 +3755,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv)
 	 * size from the heap if they are given a NULL buffer pointer.
 	 * The problem is that this behaviour is not portable. */
 	if (getcwd(buf, sizeof(buf) - 1)) {
-	    sv_setpvn(sv, buf, strlen(buf));
+	    sv_setpv(sv, buf);
 	    return TRUE;
 	}
 	else {
@@ -3914,8 +3915,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int saw_period = 0;
     int alpha = 0;
     int width = 3;
-    AV *av = newAV();
-    SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    AV * const av = newAV();
+    SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
 
 #ifndef NODEFAULT_SHAREKEYS
@@ -4148,8 +4149,8 @@ Perl_upg_version(pTHX_ SV *ver)
     if ( SvNOK(ver) ) /* may get too much accuracy */ 
     {
 	char tbuf[64];
-	sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
-	version = savepv(tbuf);
+	const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver));
+	version = savepvn(tbuf, len);
     }
 #ifdef SvVOK
     else if ( SvVOK(ver) ) { /* already a v-string */
@@ -4703,7 +4704,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 #endif
   tidy_up_and_fail:
     {
-	int save_errno = errno;
+	const int save_errno = errno;
 	if (listener != -1)
 	    PerlLIO_close(listener);
 	if (connector != -1)
@@ -4732,8 +4733,9 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
 =for apidoc sv_nosharing
 
 Dummy routine which "shares" an SV when there is no sharing module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
+Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
+Exists to avoid test for a NULL function pointer and because it could
+potentially warn under some level of strict-ness.
 
 =cut
 */
@@ -4744,39 +4746,6 @@ Perl_sv_nosharing(pTHX_ SV *sv)
     PERL_UNUSED_ARG(sv);
 }
 
-/*
-=for apidoc sv_nolocking
-
-Dummy routine which "locks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nolocking(pTHX_ SV *sv)
-{
-    PERL_UNUSED_ARG(sv);
-}
-
-
-/*
-=for apidoc sv_nounlocking
-
-Dummy routine which "unlocks" an SV when there is no locking module present.
-Exists to avoid test for a NULL function pointer and because it could potentially warn under
-some level of strict-ness.
-
-=cut
-*/
-
-void
-Perl_sv_nounlocking(pTHX_ SV *sv)
-{
-    PERL_UNUSED_ARG(sv);
-}
-
 U32
 Perl_parse_unicode_opts(pTHX_ const char **popt)
 {
@@ -4975,8 +4944,8 @@ Perl_init_global_struct(pTHX)
 #ifdef PERL_GLOBAL_STRUCT
 #  define PERL_GLOBAL_STRUCT_INIT
 #  include "opcode.h" /* the ppaddr and check */
-    IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
-    IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
+    const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t);
+    const IV ncheck  = sizeof(Gcheck) /sizeof(Perl_check_t);
 #  ifdef PERL_GLOBAL_STRUCT_PRIVATE
     /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
     plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
@@ -5050,11 +5019,12 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t
 #ifdef PERL_MEM_LOG_STDERR
     /* We can't use PerlIO for obvious reasons. */
     char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    sprintf(buf,
-	    "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n",
-	    filename, linenumber, funcname,
-	    n, typesize, typename, n * typesize, PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, strlen(buf));
+    const STRLEN len = my_sprintf(buf,
+				  "alloc: %s:%d:%s: %"IVdf" %"UVuf
+				  " %s = %"IVdf": %"UVxf"\n",
+				  filename, linenumber, funcname, n, typesize,
+				  typename, n * typesize, PTR2UV(newalloc));
+    PerlLIO_write(2,  buf, len));
 #endif
     return newalloc;
 }
@@ -5065,11 +5035,12 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc
 #ifdef PERL_MEM_LOG_STDERR
     /* We can't use PerlIO for obvious reasons. */
     char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    sprintf(buf,
-	    "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
-	    filename, linenumber, funcname,
-	    n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc));
-    PerlLIO_write(2,  buf, strlen(buf));
+    const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf
+				  " %s = %"IVdf": %"UVxf" -> %"UVxf"\n",
+				  filename, linenumber, funcname, n, typesize,
+				  typename, n * typesize, PTR2UV(oldalloc),
+				  PTR2UV(newalloc));
+    PerlLIO_write(2,  buf, len);
 #endif
     return newalloc;
 }
@@ -5080,9 +5051,10 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber,
 #ifdef PERL_MEM_LOG_STDERR
     /* We can't use PerlIO for obvious reasons. */
     char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
-    sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
-	    filename, linenumber, funcname, PTR2UV(oldalloc));
-    PerlLIO_write(2,  buf, strlen(buf));
+    const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n",
+				  filename, linenumber, funcname,
+				  PTR2UV(oldalloc));
+    PerlLIO_write(2,  buf, len);
 #endif
     return oldalloc;
 }
@@ -5110,6 +5082,60 @@ Perl_my_sprintf(char *buffer, const char* pat, ...)
 }
 #endif
 
+void
+Perl_my_clearenv(pTHX)
+{
+    dVAR;
+#if ! defined(PERL_MICRO)
+#  if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
+    PerlEnv_clearenv();
+#  else /* ! (PERL_IMPLICIT_SYS || WIN32) */
+#    if defined(USE_ENVIRON_ARRAY)
+#      if defined(USE_ITHREADS)
+    /* only the parent thread can clobber the process environment */
+    if (PL_curinterp == aTHX)
+#      endif /* USE_ITHREADS */
+    {
+#      if ! defined(PERL_USE_SAFE_PUTENV)
+    if ( !PL_use_safe_putenv) {
+      I32 i;
+      if (environ == PL_origenviron)
+        environ = (char**)safesysmalloc(sizeof(char*));
+      else
+        for (i = 0; environ[i]; i++)
+          (void)safesysfree(environ[i]);
+    }
+    environ[0] = NULL;
+#      else /* PERL_USE_SAFE_PUTENV */
+#        if defined(HAS_CLEARENV)
+    (void)clearenv();
+#        elif defined(HAS_UNSETENV)
+    int bsiz = 80; /* Most envvar names will be shorter than this. */
+    char *buf = (char*)safesysmalloc(bsiz * sizeof(char));
+    while (*environ != NULL) {
+      char *e = strchr(*environ, '=');
+      int l = e ? e - *environ : strlen(*environ);
+      if (bsiz < l + 1) {
+        (void)safesysfree(buf);
+        bsiz = l + 1;
+        buf = (char*)safesysmalloc(bsiz * sizeof(char));
+      } 
+      strncpy(buf, *environ, l);
+      *(buf + l) = '\0';
+      (void)unsetenv(buf);
+    }
+    (void)safesysfree(buf);
+#        else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
+    /* Just null environ and accept the leakage. */
+    *environ = NULL;
+#        endif /* HAS_CLEARENV || HAS_UNSETENV */
+#      endif /* ! PERL_USE_SAFE_PUTENV */
+    }
+#    endif /* USE_ENVIRON_ARRAY */
+#  endif /* PERL_IMPLICIT_SYS || WIN32 */
+#endif /* PERL_MICRO */
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd