X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=67ed3939515a2e99a1d0000c6ae179764faa14b3;hb=0bcc34c2b0b0cb62c0df3d5e562b779fb96595ba;hp=ccbb7f9eae65cbe0637be46f25d8eea5220872bd;hpb=7f315aed809e0b5d2b9e836b3ec901f6db88f7d1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index ccbb7f9..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; @@ -365,7 +363,7 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - const register U8 *s; + register const U8 *s; register U32 i; STRLEN len; I32 rarest = 0; @@ -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,8 +567,8 @@ 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; - const register unsigned char *oldlittle; + register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET; + register const unsigned char *oldlittle; if (littlelen > (STRLEN)(bigend - big)) return Nullch; @@ -632,13 +630,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - const register unsigned char *big; + register const unsigned char *big; register I32 pos; register I32 previous; register I32 first; - const register unsigned char *little; + register const unsigned char *little; register I32 stop_pos; - const register unsigned char *littleend; + register const unsigned char *littleend; I32 found = 0; if (*old_posp == -1 @@ -680,7 +678,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } big -= previous; do { - const register unsigned char *s, *x; + register const unsigned char *s, *x; if (pos >= stop_pos) break; if (big[pos] != first) continue; @@ -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) { @@ -1495,20 +1491,41 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); } else { # endif -# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) - setenv(nam, val, 1); +# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) +# if defined(HAS_UNSETENV) + if (val == NULL) { + (void)unsetenv(nam); + } else { + (void)setenv(nam, val, 1); + } +# else /* ! HAS_UNSETENV */ + (void)setenv(nam, val, 1); +# endif /* HAS_UNSETENV */ # else - char *new_env; - const int nlen = strlen(nam); - int vlen; - if (!val) { - val = ""; - } - vlen = strlen(val); - new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); - /* all that work just for this */ - my_setenv_format(new_env, nam, nlen, val, vlen); - (void)putenv(new_env); +# if defined(HAS_UNSETENV) + if (val == NULL) { + (void)unsetenv(nam); + } else { + 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; + const int nlen = strlen(nam); + int vlen; + if (!val) { + val = ""; + } + vlen = strlen(val); + new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); + /* all that work just for this */ + my_setenv_format(new_env, nam, nlen, val, vlen); + (void)putenv(new_env); +# endif /* HAS_UNSETENV */ # endif /* __CYGWIN__ */ #ifndef PERL_USE_SAFE_PUTENV } @@ -1543,7 +1560,7 @@ I32 Perl_setenv_getix(pTHX_ const char *nam) { register I32 i; - const register I32 len = strlen(nam); + register const I32 len = strlen(nam); for (i = 0; environ[i]; i++) { if ( @@ -2212,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 @@ -2615,17 +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; - sprintf(spid, "%"IVdf, (IV)pid); - svp = hv_fetch(PL_pidstatus,spid,strlen(spid),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; } } @@ -2634,12 +2652,21 @@ 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); - sprintf(spid, "%"IVdf, (IV)pid); - (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); + /* 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() + would spot the flag, and have to call the delete routine, + while in the meantime any new entries can't re-use that + memory. */ + hv_iterinit(PL_pidstatus); + (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); return pid; } } @@ -2657,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 @@ -2682,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)]; - sprintf(spid, "%"IVdf, (IV)pid); - sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),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(); @@ -2707,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; } @@ -2720,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); @@ -2732,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; @@ -2756,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++; @@ -2809,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; @@ -2842,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,":[ %"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; } @@ -5051,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; } @@ -5061,6 +5062,81 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, #endif /* PERL_MEM_LOG */ /* +=for apidoc my_sprintf + +The C library C, wrapped if necessary, to ensure that it will return +the length of the string written to the buffer. Only rare pre-ANSI systems +need the wrapper function - usually this is a direct call to C. + +=cut +*/ +#ifndef SPRINTF_RETURNS_STRLEN +int +Perl_my_sprintf(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} +#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 * c-basic-offset: 4