X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c947b31cf1422f59c2ed95f6d3de272c2793a60c..7ff1117359e03ce00638e9ee1daad537321e75d6:/util.c diff --git a/util.c b/util.c index d0fea67..e305943 100644 --- a/util.c +++ b/util.c @@ -24,8 +24,9 @@ #include "EXTERN.h" #define PERL_IN_UTIL_C #include "perl.h" +#include "reentr.h" -#ifdef USE_PERLIO +#if defined(USE_PERLIO) #include "perliol.h" /* For PerlIOUnix_refcnt */ #endif @@ -36,6 +37,9 @@ #endif #endif +#include +#include + #ifdef __Lynx__ /* Missing protos on LynxOS */ int putenv(char *); @@ -59,17 +63,6 @@ int putenv(char *); * XXX This advice seems to be widely ignored :-( --AD August 1996. */ -static char * -S_write_no_mem(pTHX) -{ - dVAR; - /* 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); - NORETURN_FUNCTION_END; -} - #if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) # define ALWAYS_NEED_THX #endif @@ -83,13 +76,6 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; -#ifdef HAS_64K_LIMIT - if (size > 0xffff) { - PerlIO_printf(Perl_error_log, - "Allocation too large: %lx\n", size) FLUSH; - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ #ifdef PERL_TRACK_MEMPOOL size += sTHX; #endif @@ -131,7 +117,7 @@ Perl_safesysmalloc(MEM_SIZE size) if (PL_nomemok) return NULL; else { - return write_no_mem(); + croak_no_mem(); } } /*NOTREACHED*/ @@ -150,13 +136,6 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ -#ifdef HAS_64K_LIMIT - if (size > 0xffff) { - PerlIO_printf(Perl_error_log, - "Reallocation too large: %lx\n", size) FLUSH; - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ if (!size) { safesysfree(where); return NULL; @@ -234,7 +213,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (PL_nomemok) return NULL; else { - return write_no_mem(); + croak_no_mem(); } } /*NOTREACHED*/ @@ -296,31 +275,24 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) dTHX; #endif Malloc_t ptr; -#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) +#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) MEM_SIZE total_size = 0; #endif /* Even though calloc() for zero bytes is strange, be robust. */ if (size && (count <= MEM_SIZE_MAX / size)) { -#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING) +#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) total_size = size * count; #endif } else - Perl_croak_nocontext("%s", PL_memory_wrap); + croak_memory_wrap(); #ifdef PERL_TRACK_MEMPOOL if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) total_size += sTHX; else - Perl_croak_nocontext("%s", PL_memory_wrap); + croak_memory_wrap(); #endif -#ifdef HAS_64K_LIMIT - if (total_size > 0xffff) { - PerlIO_printf(Perl_error_log, - "Allocation too large: %lx\n", total_size) FLUSH; - my_exit(1); - } -#endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((SSize_t)size < 0 || (SSize_t)count < 0) Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, @@ -368,7 +340,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif if (PL_nomemok) return NULL; - return write_no_mem(); + croak_no_mem(); } } @@ -406,9 +378,9 @@ Free_t Perl_mfree (Malloc_t where) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) { - register I32 tolen; + I32 tolen; PERL_ARGS_ASSERT_DELIMCPY; @@ -436,35 +408,15 @@ Perl_delimcpy(register char *to, register const char *toend, register const char /* This routine was donated by Corey Satten. */ char * -Perl_instr(register const char *big, register const char *little) +Perl_instr(const char *big, const char *little) { - register I32 first; PERL_ARGS_ASSERT_INSTR; + /* libc prior to 4.6.27 did not work properly on a NULL 'little' */ if (!little) return (char*)big; - first = *little++; - if (!first) - return (char*)big; - while (*big) { - register const char *s, *x; - if (*big++ != first) - continue; - for (x=big,s=little; *s; /**/ ) { - if (!*x) - return NULL; - if (*s != *x) - break; - else { - s++; - x++; - } - } - if (!*s) - return (char*)(big-1); - } - return NULL; + return strstr((char*)big, (char*)little); } /* same as instr but allow embedded nulls. The end pointers point to 1 beyond @@ -497,11 +449,11 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char /* reverse of the above--find last substring */ char * -Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend) +Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) { - register const char *bigbeg; - register const I32 first = *little; - register const char * const littleend = lend; + const char *bigbeg; + const I32 first = *little; + const char * const littleend = lend; PERL_ARGS_ASSERT_RNINSTR; @@ -510,7 +462,7 @@ Perl_rninstr(register const char *big, const char *bigend, const char *little, c bigbeg = big; big = bigend - (littleend - little++); while (big >= bigbeg) { - register const char *s, *x; + const char *s, *x; if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { @@ -548,16 +500,16 @@ void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { dVAR; - register const U8 *s; + const U8 *s; STRLEN i; STRLEN len; - STRLEN rarest = 0; U32 frequency = 256; MAGIC *mg; + PERL_DEB( STRLEN rarest = 0 ); PERL_ARGS_ASSERT_FBM_COMPILE; - if (isGV_with_GP(sv)) + if (isGV_with_GP(sv) || SvROK(sv)) return; if (SvVALID(sv)) @@ -569,7 +521,9 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) if (mg && mg->mg_len >= 0) mg->mg_len++; } - s = (U8*)SvPV_force_mutable(sv, len); + if (!SvPOK(sv) || SvNIOKp(sv)) + s = (U8*)SvPV_force_mutable(sv, len); + else s = (U8 *)SvPV_mutable(sv, len); if (len == 0) /* TAIL might be on a zero-length string. */ return; SvUPGRADE(sv, SVt_PVMG); @@ -600,7 +554,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) the BM table. */ const U8 mlen = (len>255) ? 255 : (U8)len; const unsigned char *const sb = s + len - mlen; /* first char (maybe) */ - register U8 *table; + U8 *table; Newx(table, 256, U8); memset((void*)table, mlen, 256); @@ -619,17 +573,15 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { if (PL_freq[s[i]] < frequency) { - rarest = i; + PERL_DEB( rarest = i ); frequency = PL_freq[s[i]]; } } - BmRARE(sv) = s[rarest]; - BmPREVIOUS(sv) = rarest; BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", - BmRARE(sv), BmPREVIOUS(sv))); + s[rarest], (UV)rarest)); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -648,14 +600,13 @@ then. */ char * -Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags) +Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) { - register unsigned char *s; + unsigned char *s; STRLEN l; - register const unsigned char *little - = (const unsigned char *)SvPV_const(littlestr,l); - register STRLEN littlelen = l; - register const I32 multiline = flags & FBMrf_MULTILINE; + const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); + STRLEN littlelen = l; + const I32 multiline = flags & FBMrf_MULTILINE; PERL_ARGS_ASSERT_FBM_INSTR; @@ -791,7 +742,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit { const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm); const unsigned char * const table = (const unsigned char *) mg->mg_ptr; - register const unsigned char *oldlittle; + const unsigned char *oldlittle; --littlelen; /* Last char found by table lookup */ @@ -799,7 +750,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit little += littlelen; /* last char */ oldlittle = little; if (s < bigend) { - register I32 tmp; + I32 tmp; top2: if ((tmp = table[*s])) { @@ -808,7 +759,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit goto check_end; } else { /* less expensive than calling strncmp() */ - register unsigned char * const olds = s; + unsigned char * const olds = s; tmp = littlelen; @@ -865,13 +816,15 @@ range bytes match only themselves. I32 -Perl_foldEQ(const char *s1, const char *s2, register I32 len) +Perl_foldEQ(const char *s1, const char *s2, I32 len) { - register const U8 *a = (const U8 *)s1; - register const U8 *b = (const U8 *)s2; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; PERL_ARGS_ASSERT_FOLDEQ; + assert(len >= 0); + while (len--) { if (*a != *b && *a != PL_fold[*b]) return 0; @@ -880,18 +833,20 @@ Perl_foldEQ(const char *s1, const char *s2, register I32 len) return 1; } I32 -Perl_foldEQ_latin1(const char *s1, const char *s2, register I32 len) +Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) { /* Compare non-utf8 using Unicode (Latin1) semantics. Does not work on * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these. Nor * does it check that the strings each have at least 'len' characters */ - register const U8 *a = (const U8 *)s1; - register const U8 *b = (const U8 *)s2; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; PERL_ARGS_ASSERT_FOLDEQ_LATIN1; + assert(len >= 0); + while (len--) { if (*a != *b && *a != PL_fold_latin1[*b]) { return 0; @@ -911,14 +866,16 @@ case-insensitively in the current locale; false otherwise. */ I32 -Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len) +Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) { dVAR; - register const U8 *a = (const U8 *)s1; - register const U8 *b = (const U8 *)s2; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; PERL_ARGS_ASSERT_FOLDEQ_LOCALE; + assert(len >= 0); + while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) return 0; @@ -939,6 +896,10 @@ string which is a duplicate of C. The size of the string is determined by C. The memory allocated for the new string can be freed with the C function. +On some platforms, Windows for example, all allocated memory owned by a thread +is deallocated when that thread ends. So if you need that not to happen, you +need to use the shared memory functions, such as C>. + =cut */ @@ -966,15 +927,21 @@ pointer to a newly allocated string which is a duplicate of the first C bytes from C, plus a trailing NUL byte. The memory allocated for the new string can be freed with the C function. +On some platforms, Windows for example, all allocated memory owned by a thread +is deallocated when that thread ends. So if you need that not to happen, you +need to use the shared memory functions, such as C>. + =cut */ char * -Perl_savepvn(pTHX_ const char *pv, register I32 len) +Perl_savepvn(pTHX_ const char *pv, I32 len) { - register char *newaddr; + char *newaddr; PERL_UNUSED_CONTEXT; + assert(len >= 0); + Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { @@ -998,7 +965,7 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr; + char *newaddr; STRLEN pvlen; if (!pv) return NULL; @@ -1006,7 +973,7 @@ Perl_savesharedpv(pTHX_ const char *pv) pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - return write_no_mem(); + croak_no_mem(); } return (char*)memcpy(newaddr, pv, pvlen); } @@ -1028,7 +995,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { - return write_no_mem(); + croak_no_mem(); } newaddr[len] = '\0'; return (char*)memcpy(newaddr, pv, len); @@ -1040,6 +1007,10 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) A version of C/C which gets the string to duplicate from the passed in SV using C +On some platforms, Windows for example, all allocated memory owned by a thread +is deallocated when that thread ends. So if you need that not to happen, you +need to use the shared memory functions, such as C>. + =cut */ @@ -1048,7 +1019,7 @@ Perl_savesvpv(pTHX_ SV *sv) { STRLEN len; const char * const pv = SvPV_const(sv, len); - register char *newaddr; + char *newaddr; PERL_ARGS_ASSERT_SAVESVPV; @@ -1201,15 +1172,20 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } -STATIC const COP* -S_closest_cop(pTHX_ const COP *cop, const OP *o) +const COP* +Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, + bool opnext) { dVAR; - /* Look for PL_op starting from o. cop is the last COP we've seen. */ + /* Look for curop starting from o. cop is the last COP we've seen. */ + /* opnext means that curop is actually the ->op_next of the op we are + seeking. */ PERL_ARGS_ASSERT_CLOSEST_COP; - if (!o || o == PL_op) + if (!o || !curop || ( + opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop + )) return cop; if (o->op_flags & OPf_KIDS) { @@ -1225,7 +1201,7 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) /* Keep searching, and return when we've found something. */ - new_cop = closest_cop(cop, kid); + new_cop = closest_cop(cop, kid, curop, opnext); if (new_cop) return new_cop; } @@ -1295,7 +1271,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) * from the sibling of PL_curcop. */ - const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + const COP *cop = + closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1306,8 +1283,9 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) && IoLINES(GvIOp(PL_last_in_gv))) { + STRLEN l; const bool line_mode = (RsSIMPLE(PL_rs) && - SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); + *SvPV_const(PL_rs,l) == '\n' && l == 1); Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf, SVfARG(PL_last_in_gv == PL_argvgv ? &PL_sv_no @@ -1362,20 +1340,13 @@ Perl_write_to_stderr(pTHX_ SV* msv) if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) - Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT", + Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT), G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv); else { -#ifdef USE_SFIO - /* SFIO can really mess with your errno */ - dSAVED_ERRNO; -#endif PerlIO * const serr = Perl_error_log; do_print(msv, serr); (void)PerlIO_flush(serr); -#ifdef USE_SFIO - RESTORE_ERRNO; -#endif } } @@ -1457,7 +1428,7 @@ Perl_die_sv(pTHX_ SV *baseex) { PERL_ARGS_ASSERT_DIE_SV; croak_sv(baseex); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ return NULL; } @@ -1479,7 +1450,7 @@ Perl_die_nocontext(const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); return NULL; } @@ -1491,7 +1462,7 @@ Perl_die(pTHX_ const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); return NULL; } @@ -1591,7 +1562,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1602,7 +1573,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } @@ -1617,9 +1588,35 @@ paths reduces CPU cache pressure. */ void -Perl_croak_no_modify(pTHX) +Perl_croak_no_modify() { - Perl_croak(aTHX_ "%s", PL_no_modify); + Perl_croak_nocontext( "%s", PL_no_modify); +} + +/* does not return, used in util.c perlio.c and win32.c + This is typically called when malloc returns NULL. +*/ +void +Perl_croak_no_mem() +{ + dTHX; + int rc; + + /* Can't use PerlIO to write as it allocates memory */ + rc = PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, sizeof(PL_no_mem)-1); + /* silently ignore failures */ + PERL_UNUSED_VAR(rc); + my_exit(1); +} + +/* does not return, used only in POPSTACK */ +void +Perl_croak_popstack(void) +{ + dTHX; + PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); + my_exit(1); } /* @@ -1886,8 +1883,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #ifndef PERL_USE_SAFE_PUTENV if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ - register I32 i; - register const I32 len = strlen(nam); + I32 i; + const I32 len = strlen(nam); int nlen, vlen; /* where does it go? */ @@ -1935,7 +1932,7 @@ 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(__SYMBIAN32__) || defined(__riscos__) +# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) # if defined(HAS_UNSETENV) if (val == NULL) { (void)unsetenv(nam); @@ -1948,7 +1945,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) # else # if defined(HAS_UNSETENV) if (val == NULL) { - (void)unsetenv(nam); + if (environ) /* old glibc can crash with null environ */ + (void)unsetenv(nam); } else { const int nlen = strlen(nam); const int vlen = strlen(val); @@ -1983,7 +1981,7 @@ void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; - register char *envstr; + char *envstr; const int nlen = strlen(nam); int vlen; @@ -1999,7 +1997,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #endif /* WIN32 || NETWARE */ -#endif /* !VMS && !EPOC*/ +#endif /* !VMS */ #ifdef UNLINK_ALL_VERSIONS I32 @@ -2018,12 +2016,14 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ /* this is a drop-in replacement for bcopy() */ #if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) char * -Perl_my_bcopy(register const char *from,register char *to,register I32 len) +Perl_my_bcopy(const char *from, char *to, I32 len) { char * const retval = to; PERL_ARGS_ASSERT_MY_BCOPY; + assert(len >= 0); + if (from - to >= 0) { while (len--) *to++ = *from++; @@ -2041,12 +2041,14 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) /* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(register char *loc, register I32 ch, register I32 len) +Perl_my_memset(char *loc, I32 ch, I32 len) { char * const retval = loc; PERL_ARGS_ASSERT_MY_MEMSET; + assert(len >= 0); + while (len--) *loc++ = ch; return retval; @@ -2056,12 +2058,14 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) /* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) char * -Perl_my_bzero(register char *loc, register I32 len) +Perl_my_bzero(char *loc, I32 len) { char * const retval = loc; PERL_ARGS_ASSERT_MY_BZERO; + assert(len >= 0); + while (len--) *loc++ = 0; return retval; @@ -2071,14 +2075,16 @@ Perl_my_bzero(register char *loc, register I32 len) /* this is a drop-in replacement for memcmp() */ #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP) I32 -Perl_my_memcmp(const char *s1, const char *s2, register I32 len) +Perl_my_memcmp(const char *s1, const char *s2, I32 len) { - register const U8 *a = (const U8 *)s1; - register const U8 *b = (const U8 *)s2; - register I32 tmp; + const U8 *a = (const U8 *)s1; + const U8 *b = (const U8 *)s2; + I32 tmp; PERL_ARGS_ASSERT_MY_MEMCMP; + assert(len >= 0); + while (len--) { if ((tmp = *a++ - *b++)) return tmp; @@ -2142,343 +2148,14 @@ vsprintf(char *dest, const char *pat, void *args) #endif /* HAS_VPRINTF */ -#ifdef MYSWAP -#if BYTEORDER != 0x4321 -short -Perl_my_swap(pTHX_ short s) -{ -#if (BYTEORDER & 1) == 0 - short result; - - result = ((s & 255) << 8) + ((s >> 8) & 255); - return result; -#else - return s; -#endif -} - -long -Perl_my_htonl(pTHX_ long l) -{ - union { - long result; - char c[sizeof(long)]; - } u; - -#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 -#if BYTEORDER == 0x12345678 - u.result = 0; -#endif - u.c[0] = (l >> 24) & 255; - u.c[1] = (l >> 16) & 255; - u.c[2] = (l >> 8) & 255; - u.c[3] = l & 255; - return u.result; -#else -#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) - Perl_croak(aTHX_ "Unknown BYTEORDER\n"); -#else - register I32 o; - register I32 s; - - for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { - u.c[o & 0xf] = (l >> s) & 255; - } - return u.result; -#endif -#endif -} - -long -Perl_my_ntohl(pTHX_ long l) -{ - union { - long l; - char c[sizeof(long)]; - } u; - -#if BYTEORDER == 0x1234 - u.c[0] = (l >> 24) & 255; - u.c[1] = (l >> 16) & 255; - u.c[2] = (l >> 8) & 255; - u.c[3] = l & 255; - return u.l; -#else -#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf) - Perl_croak(aTHX_ "Unknown BYTEORDER\n"); -#else - register I32 o; - register I32 s; - - u.l = l; - l = 0; - for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) { - l |= (u.c[o & 0xf] & 255) << s; - } - return l; -#endif -#endif -} - -#endif /* BYTEORDER != 0x4321 */ -#endif /* MYSWAP */ - -/* - * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'. - * If these functions are defined, - * the BYTEORDER is neither 0x1234 nor 0x4321. - * However, this is not assumed. - * -DWS - */ - -#define HTOLE(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register U32 i; \ - register U32 s = 0; \ - for (i = 0; i < sizeof(u.c); i++, s += 8) { \ - u.c[i] = (n >> s) & 0xFF; \ - } \ - return u.value; \ - } - -#define LETOH(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register U32 i; \ - register U32 s = 0; \ - u.value = n; \ - n = 0; \ - for (i = 0; i < sizeof(u.c); i++, s += 8) { \ - n |= ((type)(u.c[i] & 0xFF)) << s; \ - } \ - return n; \ - } - -/* - * Big-endian byte order functions. - */ - -#define HTOBE(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register U32 i; \ - register U32 s = 8*(sizeof(u.c)-1); \ - for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ - u.c[i] = (n >> s) & 0xFF; \ - } \ - return u.value; \ - } - -#define BETOH(name,type) \ - type \ - name (register type n) \ - { \ - union { \ - type value; \ - char c[sizeof(type)]; \ - } u; \ - register U32 i; \ - register U32 s = 8*(sizeof(u.c)-1); \ - u.value = n; \ - n = 0; \ - for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ - n |= ((type)(u.c[i] & 0xFF)) << s; \ - } \ - return n; \ - } - -/* - * If we just can't do it... - */ - -#define NOT_AVAIL(name,type) \ - type \ - name (register type n) \ - { \ - Perl_croak_nocontext(#name "() not available"); \ - return n; /* not reached */ \ - } - - -#if defined(HAS_HTOVS) && !defined(htovs) -HTOLE(htovs,short) -#endif -#if defined(HAS_HTOVL) && !defined(htovl) -HTOLE(htovl,long) -#endif -#if defined(HAS_VTOHS) && !defined(vtohs) -LETOH(vtohs,short) -#endif -#if defined(HAS_VTOHL) && !defined(vtohl) -LETOH(vtohl,long) -#endif - -#ifdef PERL_NEED_MY_HTOLE16 -# if U16SIZE == 2 -HTOLE(Perl_my_htole16,U16) -# else -NOT_AVAIL(Perl_my_htole16,U16) -# endif -#endif -#ifdef PERL_NEED_MY_LETOH16 -# if U16SIZE == 2 -LETOH(Perl_my_letoh16,U16) -# else -NOT_AVAIL(Perl_my_letoh16,U16) -# endif -#endif -#ifdef PERL_NEED_MY_HTOBE16 -# if U16SIZE == 2 -HTOBE(Perl_my_htobe16,U16) -# else -NOT_AVAIL(Perl_my_htobe16,U16) -# endif -#endif -#ifdef PERL_NEED_MY_BETOH16 -# if U16SIZE == 2 -BETOH(Perl_my_betoh16,U16) -# else -NOT_AVAIL(Perl_my_betoh16,U16) -# endif -#endif - -#ifdef PERL_NEED_MY_HTOLE32 -# if U32SIZE == 4 -HTOLE(Perl_my_htole32,U32) -# else -NOT_AVAIL(Perl_my_htole32,U32) -# endif -#endif -#ifdef PERL_NEED_MY_LETOH32 -# if U32SIZE == 4 -LETOH(Perl_my_letoh32,U32) -# else -NOT_AVAIL(Perl_my_letoh32,U32) -# endif -#endif -#ifdef PERL_NEED_MY_HTOBE32 -# if U32SIZE == 4 -HTOBE(Perl_my_htobe32,U32) -# else -NOT_AVAIL(Perl_my_htobe32,U32) -# endif -#endif -#ifdef PERL_NEED_MY_BETOH32 -# if U32SIZE == 4 -BETOH(Perl_my_betoh32,U32) -# else -NOT_AVAIL(Perl_my_betoh32,U32) -# endif -#endif - -#ifdef PERL_NEED_MY_HTOLE64 -# if U64SIZE == 8 -HTOLE(Perl_my_htole64,U64) -# else -NOT_AVAIL(Perl_my_htole64,U64) -# endif -#endif -#ifdef PERL_NEED_MY_LETOH64 -# if U64SIZE == 8 -LETOH(Perl_my_letoh64,U64) -# else -NOT_AVAIL(Perl_my_letoh64,U64) -# endif -#endif -#ifdef PERL_NEED_MY_HTOBE64 -# if U64SIZE == 8 -HTOBE(Perl_my_htobe64,U64) -# else -NOT_AVAIL(Perl_my_htobe64,U64) -# endif -#endif -#ifdef PERL_NEED_MY_BETOH64 -# if U64SIZE == 8 -BETOH(Perl_my_betoh64,U64) -# else -NOT_AVAIL(Perl_my_betoh64,U64) -# endif -#endif - -#ifdef PERL_NEED_MY_HTOLES -HTOLE(Perl_my_htoles,short) -#endif -#ifdef PERL_NEED_MY_LETOHS -LETOH(Perl_my_letohs,short) -#endif -#ifdef PERL_NEED_MY_HTOBES -HTOBE(Perl_my_htobes,short) -#endif -#ifdef PERL_NEED_MY_BETOHS -BETOH(Perl_my_betohs,short) -#endif - -#ifdef PERL_NEED_MY_HTOLEI -HTOLE(Perl_my_htolei,int) -#endif -#ifdef PERL_NEED_MY_LETOHI -LETOH(Perl_my_letohi,int) -#endif -#ifdef PERL_NEED_MY_HTOBEI -HTOBE(Perl_my_htobei,int) -#endif -#ifdef PERL_NEED_MY_BETOHI -BETOH(Perl_my_betohi,int) -#endif - -#ifdef PERL_NEED_MY_HTOLEL -HTOLE(Perl_my_htolel,long) -#endif -#ifdef PERL_NEED_MY_LETOHL -LETOH(Perl_my_letohl,long) -#endif -#ifdef PERL_NEED_MY_HTOBEL -HTOBE(Perl_my_htobel,long) -#endif -#ifdef PERL_NEED_MY_BETOHL -BETOH(Perl_my_betohl,long) -#endif - -void -Perl_my_swabn(void *ptr, int n) -{ - register char *s = (char *)ptr; - register char *e = s + (n-1); - register char tc; - - PERL_ARGS_ASSERT_MY_SWABN; - - for (n /= 2; n > 0; s++, e--, n--) { - tc = *s; - *s = *e; - *e = tc; - } -} - PerlIO * Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) dVAR; int p[2]; - register I32 This, that; - register Pid_t pid; + I32 This, that; + Pid_t pid; SV *sv; I32 did_pipes = 0; int pp[2]; @@ -2488,7 +2165,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PERL_FLUSHALL_FOR_CHILD; This = (*mode == 'w'); that = !This; - if (PL_tainting) { + if (TAINTING_get) { taint_env(); taint_proper("Insecure %s%s", "EXEC"); } @@ -2611,14 +2288,14 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) } /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { dVAR; int p[2]; - register I32 This, that; - register Pid_t pid; + I32 This, that; + Pid_t pid; SV *sv; const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; @@ -2634,7 +2311,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #endif This = (*mode == 'w'); that = !This; - if (doexec && PL_tainting) { + if (doexec && TAINTING_get) { taint_env(); taint_proper("Insecure %s%s", "EXEC"); } @@ -2758,20 +2435,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) return PerlIO_fdopen(p[This], mode); } #else -#if defined(atarist) || defined(EPOC) -FILE *popen(); -PerlIO * -Perl_my_popen(pTHX_ const char *cmd, const char *mode) -{ - PERL_ARGS_ASSERT_MY_POPEN; - PERL_FLUSHALL_FOR_CHILD; - /* Call system's popen() to get a FILE *, then import it. - used 0 for 2nd parameter to PerlIO_importFILE; - apparently not used - */ - return PerlIO_importFILE(popen(cmd, mode), 0); -} -#else #if defined(DJGPP) FILE *djgpp_popen(); PerlIO * @@ -2793,7 +2456,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) } #endif #endif -#endif #endif /* !DOSISH */ @@ -2804,6 +2466,9 @@ Perl_atfork_lock(void) dVAR; #if defined(USE_ITHREADS) /* locks must be held in locking order (if any) */ +# ifdef USE_PERLIO + MUTEX_LOCK(&PL_perlio_mutex); +# endif # ifdef MYMALLOC MUTEX_LOCK(&PL_malloc_mutex); # endif @@ -2818,6 +2483,9 @@ Perl_atfork_unlock(void) dVAR; #if defined(USE_ITHREADS) /* locks must be released in same order as in atfork_lock() */ +# ifdef USE_PERLIO + MUTEX_UNLOCK(&PL_perlio_mutex); +# endif # ifdef MYMALLOC MUTEX_UNLOCK(&PL_malloc_mutex); # endif @@ -2847,25 +2515,6 @@ Perl_my_fork(void) #endif /* HAS_FORK */ } -#ifdef DUMP_FDS -void -Perl_dump_fds(pTHX_ const char *const s) -{ - int fd; - Stat_t tmpstatbuf; - - PERL_ARGS_ASSERT_DUMP_FDS; - - PerlIO_printf(Perl_debug_log,"%s", s); - for (fd = 0; fd < 32; fd++) { - if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) - PerlIO_printf(Perl_debug_log," %d",fd); - } - PerlIO_printf(Perl_debug_log,"\n"); - return; -} -#endif /* DUMP_FDS */ - #ifndef HAS_DUP2 int dup2(int oldfd, int newfd) @@ -3053,12 +2702,11 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { dVAR; - Sigsave_t hstat, istat, qstat; int status; SV **svp; Pid_t pid; @@ -3066,19 +2714,21 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) bool close_failed; dSAVEDERRNO; const int fd = PerlIO_fileno(ptr); + bool should_wait; + + svp = av_fetch(PL_fdpid,fd,TRUE); + pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; + SvREFCNT_dec(*svp); + *svp = NULL; -#ifdef USE_PERLIO +#if defined(USE_PERLIO) /* Find out whether the refcount is low enough for us to wait for the child proc without blocking. */ - const bool should_wait = PerlIOUnix_refcnt(fd) == 1; + should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0; #else - const bool should_wait = 1; + should_wait = pid > 0; #endif - svp = av_fetch(PL_fdpid,fd,TRUE); - pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; - SvREFCNT_dec(*svp); - *svp = &PL_sv_undef; #ifdef OS2 if (pid == -1) { /* Opened by popen. */ return my_syspclose(ptr); @@ -3086,22 +2736,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif close_failed = (PerlIO_close(ptr) == EOF); SAVE_ERRNO; -#ifdef UTS - if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ -#endif -#ifndef PERL_MICRO - rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat); - rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat); - rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat); -#endif if (should_wait) do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); -#ifndef PERL_MICRO - rsignal_restore(SIGHUP, &hstat); - rsignal_restore(SIGINT, &istat); - rsignal_restore(SIGQUIT, &qstat); -#endif if (close_failed) { RESTORE_ERRNO; return -1; @@ -3129,9 +2766,16 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) dVAR; I32 result = 0; PERL_ARGS_ASSERT_WAIT4PID; - if (!pid) - return -1; #ifdef PERL_USES_PL_PIDSTATUS + if (!pid) { + /* PERL_USES_PL_PIDSTATUS is only defined when neither + waitpid() nor wait4() is available, or on OS/2, which + doesn't appear to support waiting for a progress group + member, so we can only treat a 0 pid as an unknown child. + */ + errno = ECHILD; + return -1; + } { if (pid > 0) { /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the @@ -3178,7 +2822,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) - result = wait4((pid==-1)?0:pid,statusp,flags,NULL); + result = wait4(pid,statusp,flags,NULL); goto finish; #endif #ifdef PERL_USES_PL_PIDSTATUS @@ -3211,7 +2855,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) void S_pidgone(pTHX_ Pid_t pid, int status) { - register SV *sv; + SV *sv; sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); SvUPGRADE(sv,SVt_IV); @@ -3220,7 +2864,7 @@ S_pidgone(pTHX_ Pid_t pid, int status) } #endif -#if defined(atarist) || defined(OS2) || defined(EPOC) +#if defined(OS2) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -3255,19 +2899,24 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count) +Perl_repeatcpy(char *to, const char *from, I32 len, IV count) { PERL_ARGS_ASSERT_REPEATCPY; + assert(len >= 0); + + if (count < 0) + croak_memory_wrap(); + if (len == 1) memset(to, *from, count); else if (count) { - register char *p = to; + char *p = to; IV items, linear, half; linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; for (items = 0; items < linear; ++items) { - register const char *q = from; + const char *q = from; IV todo; for (todo = len; todo > 0; todo--) *p++ = *q++; @@ -3333,11 +2982,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *xfound = NULL; char *xfailed = NULL; char tmpbuf[MAXPATHLEN]; - register char *s; + char *s; I32 len = 0; int retval; char *bufend; -#if defined(DOSISH) && !defined(OS2) && !defined(atarist) +#if defined(DOSISH) && !defined(OS2) # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 #endif @@ -3460,28 +3109,25 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, bufend = s + strlen(s); while (s < bufend) { -#if defined(atarist) || defined(DOSISH) +# ifdef DOSISH for (len = 0; *s -# ifdef atarist - && *s != ',' -# endif && *s != ';'; len++, s++) { if (len < sizeof tmpbuf) tmpbuf[len] = *s; } if (len < sizeof tmpbuf) tmpbuf[len] = '\0'; -#else /* ! (atarist || DOSISH) */ +# else s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ':', &len); -#endif /* ! (atarist || DOSISH) */ +# endif if (s < bufend) s++; 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) +# ifdef DOSISH && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' # endif @@ -3664,7 +3310,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) I32 Perl_my_fflush_all(pTHX) { -#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO) +#if defined(USE_PERLIO) || defined(FFLUSH_NULL) return PerlIO_flush(NULL); #else # if defined(HAS__FWALK) @@ -3715,15 +3361,15 @@ void Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) { if (ckWARN(WARN_IO)) { - SV * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) - ? sv_2mortal(newSVhek(GvENAME_HEK((gv)))) + HEK * const name + = gv && (isGV_with_GP(gv)) + ? GvENAME_HEK((gv)) : NULL; const char * const direction = have == '>' ? "out" : "in"; - if (name && SvPOK(name) && *SvPV_nolen(name)) + if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %"SVf" opened only for %sput", + "Filehandle %"HEKf" opened only for %sput", name, direction); else Perl_warner(aTHX_ packWARN(WARN_IO), @@ -3750,7 +3396,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) if (ckWARN(warn_type)) { SV * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ? + = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; const char * const pars = (const char *)(OP_IS_FILETEST(op) ? "" : "()"); @@ -3763,7 +3409,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) (const char *) (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"); - const bool have_name = name && SvPOK(name) && *SvPV_nolen(name); + const bool have_name = name && SvCUR(name); Perl_warner(aTHX_ packWARN(warn_type), "%s%s on %s %s%s%"SVf, func, pars, vile, type, have_name ? " " : "", @@ -3788,7 +3434,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) * */ -#ifdef HAS_GNULIBC +#ifdef __GLIBC__ # ifndef STRUCT_TM_HASZONE # define STRUCT_TM_HASZONE # endif @@ -3909,15 +3555,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) year = 1900 + ptm->tm_year; month = ptm->tm_mon; mday = ptm->tm_mday; - /* allow given yday with no month & mday to dominate the result */ - if (ptm->tm_yday >= 0 && mday <= 0 && month <= 0) { - month = 0; - mday = 0; - jday = 1 + ptm->tm_yday; - } - else { - jday = 0; - } + jday = 0; if (month >= 2) month+=2; else @@ -4012,9 +3650,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) yearday = year*DAYS_PER_YEAR + year/4 - year/100 + year/400; yearday += 14*MONTH_TO_DAYS + 1; ptm->tm_yday = jday - yearday; - /* fix tm_wday if not overridden by caller */ - if ((unsigned)ptm->tm_wday > 6) - ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; + ptm->tm_wday = (jday + WEEKDAY_BIAS) % 7; } char * @@ -4055,7 +3691,11 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in #endif buflen = 64; Newx(buf, buflen, char); + + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ len = strftime(buf, buflen, fmt, &mytm); + GCC_DIAG_RESTORE; + /* ** The following is needed to handle to the situation where ** tmpbuf overflows. Basically we want to allocate a buffer @@ -4079,7 +3719,11 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in Renew(buf, bufsize, char); while (buf) { + + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */ buflen = strftime(buf, bufsize, fmt, &mytm); + GCC_DIAG_RESTORE; + if (buflen > 0 && buflen < bufsize) break; /* heuristic to prevent out-of-memory errors */ @@ -4127,13 +3771,11 @@ Fill the sv with current working directory * back into. */ int -Perl_getcwd_sv(pTHX_ register SV *sv) +Perl_getcwd_sv(pTHX_ SV *sv) { #ifndef PERL_MICRO dVAR; -#ifndef INCOMPLETE_TAINTS SvTAINTED_on(sv); -#endif PERL_ARGS_ASSERT_GETCWD_SV; @@ -4380,6 +4022,7 @@ dotted_decimal_version: } /* end if dotted-decimal */ else { /* decimal versions */ + int j = 0; /* may need this later */ /* special strict case for leading '.' or '0' */ if (strict) { if (*d == '.') { @@ -4442,7 +4085,7 @@ dotted_decimal_version: } while (isDIGIT(*d)) { - d++; + d++; j++; if (*d == '.' && isDIGIT(d[-1])) { if (alpha) { BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); @@ -4464,6 +4107,7 @@ dotted_decimal_version: if ( ! isDIGIT(d[1]) ) { BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); } + width = j; d++; alpha = TRUE; } @@ -4515,7 +4159,7 @@ it doesn't. const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { - const char *start; + const char *start = s; const char *pos; const char *last; const char *errstr = NULL; @@ -4523,17 +4167,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) int width = 3; bool alpha = FALSE; bool vinf = FALSE; - AV * const av = newAV(); - SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + AV * av; + SV * hv; PERL_ARGS_ASSERT_SCAN_VERSION; - (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ - -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif - while (isSPACE(*s)) /* leading whitespace is OK */ s++; @@ -4541,6 +4179,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if (errstr) { /* "undef" is a special case and not an error */ if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { + Safefree(start); Perl_croak(aTHX_ "%s", errstr); } } @@ -4550,13 +4189,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) s++; pos = s; + /* Now that we are through the prescan, start creating the object */ + av = newAV(); + 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 + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + if ( qv ) (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); if ( alpha ) (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); if ( !qv && width < 3 ) (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); - + while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { @@ -4643,7 +4291,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } } if ( qv ) { /* quoted versions always get at least three terms*/ - I32 len = av_len(av); + SSize_t len = av_len(av); /* This for loop appears to trigger a compiler bug on OS X, as it loops infinitely. Yes, len is negative. No, it makes no sense. Compiler in question is: @@ -4708,7 +4356,7 @@ Perl_new_version(pTHX_ SV *ver) if ( sv_isobject(ver) && sv_derived_from(ver, "version") ) /* can just copy directly */ { - I32 key; + SSize_t key; AV * const av = newAV(); AV *sav; /* This will get reblessed later if a derived class*/ @@ -4727,7 +4375,7 @@ Perl_new_version(pTHX_ SV *ver) if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); - + if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) { const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); @@ -4805,8 +4453,11 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; char *buf; #ifdef USE_LOCALE_NUMERIC - char *loc = savepv(setlocale(LC_NUMERIC, NULL)); - setlocale(LC_NUMERIC, "C"); + char *loc = NULL; + if (! PL_numeric_standard) { + loc = savepv(setlocale(LC_NUMERIC, NULL)); + setlocale(LC_NUMERIC, "C"); + } #endif if (sv) { Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); @@ -4817,8 +4468,10 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) buf = tbuf; } #ifdef USE_LOCALE_NUMERIC - setlocale(LC_NUMERIC, loc); - Safefree(loc); + if (loc) { + setlocale(LC_NUMERIC, loc); + Safefree(loc); + } #endif while (buf[len-1] == '0' && len > 0) len--; if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ @@ -4861,7 +4514,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) } /* is definitely a v-string */ - if ( saw_decimal >= 2 ) { + if ( saw_decimal >= 2 ) { Safefree(version); version = nver; } @@ -4947,7 +4600,8 @@ The SV returned has a refcount of 1. SV * Perl_vnumify(pTHX_ SV *vs) { - I32 i, len, digit; + SSize_t i, len; + I32 digit; int width; bool alpha = FALSE; SV *sv; @@ -5124,7 +4778,8 @@ converted into version objects. int Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { - I32 i,l,m,r,retval; + SSize_t i,l,m,r; + I32 retval; bool lalpha = FALSE; bool ralpha = FALSE; I32 left = 0; @@ -5352,7 +5007,7 @@ int Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { /* Stevens says that family must be AF_LOCAL, protocol 0. I'm going to enforce that, then ignore it, and use TCP (or UDP). */ - dTHX; + dTHXa(NULL); int listener = -1; int connector = -1; int acceptor = -1; @@ -5378,6 +5033,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { return S_socketpair_udp(fd); #endif + aTHXa(PERL_GET_THX); listener = PerlSock_socket(AF_INET, type, 0); if (listener == -1) return -1; @@ -5655,43 +5311,85 @@ Perl_seed(pTHX) return u; } -UV -Perl_get_hash_seed(pTHX) +void +Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) { dVAR; - const char *s = PerlEnv_getenv("PERL_HASH_SEED"); - UV myseed = 0; - - if (s) - while (isSPACE(*s)) - s++; - if (s && isDIGIT(*s)) - myseed = (UV)Atoul(s); - else -#ifdef USE_HASH_SEED_EXPLICIT - if (s) -#endif - { - /* Compute a random seed */ - (void)seedDrand01((Rand_seed_t)seed()); - myseed = (UV)(Drand01() * (NV)UV_MAX); -#if RANDBITS < (UVSIZE * 8) - /* Since there are not enough randbits to to reach all - * the bits of a UV, the low bits might need extra - * help. Sum in another random number that will - * fill in the low bits. */ - myseed += - (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); -#endif /* RANDBITS < (UVSIZE * 8) */ - if (myseed == 0) { /* Superparanoia. */ - myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ - if (myseed == 0) - Perl_croak(aTHX_ "Your random numbers are not that random"); - } - } - PL_rehash_seed_set = TRUE; - - return myseed; + const char *env_pv; + unsigned long i; + + PERL_ARGS_ASSERT_GET_HASH_SEED; + + env_pv= PerlEnv_getenv("PERL_HASH_SEED"); + + if ( env_pv ) +#ifndef USE_HASH_SEED_EXPLICIT + { + /* ignore leading spaces */ + while (isSPACE(*env_pv)) + env_pv++; +#ifdef USE_PERL_PERTURB_KEYS + /* if they set it to "0" we disable key traversal randomization completely */ + if (strEQ(env_pv,"0")) { + PL_hash_rand_bits_enabled= 0; + } else { + /* otherwise switch to deterministic mode */ + PL_hash_rand_bits_enabled= 2; + } +#endif + /* ignore a leading 0x... if it is there */ + if (env_pv[0] == '0' && env_pv[1] == 'x') + env_pv += 2; + + for( i = 0; isXDIGIT(*env_pv) && i < PERL_HASH_SEED_BYTES; i++ ) { + seed_buffer[i] = READ_XDIGIT(env_pv) << 4; + if ( isXDIGIT(*env_pv)) { + seed_buffer[i] |= READ_XDIGIT(env_pv); + } + } + while (isSPACE(*env_pv)) + env_pv++; + + if (*env_pv && !isXDIGIT(*env_pv)) { + Perl_warn(aTHX_ "perl: warning: Non hex character in '$ENV{PERL_HASH_SEED}', seed only partially set\n"); + } + /* should we check for unparsed crap? */ + /* should we warn about unused hex? */ + /* should we warn about insufficient hex? */ + } + else +#endif + { + (void)seedDrand01((Rand_seed_t)seed()); + + for( i = 0; i < PERL_HASH_SEED_BYTES; i++ ) { + seed_buffer[i] = (unsigned char)(Drand01() * (U8_MAX+1)); + } + } +#ifdef USE_PERL_PERTURB_KEYS + { /* initialize PL_hash_rand_bits from the hash seed. + * This value is highly volatile, it is updated every + * hash insert, and is used as part of hash bucket chain + * randomization and hash iterator randomization. */ + PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */ + for( i = 0; i < sizeof(UV) ; i++ ) { + PL_hash_rand_bits += seed_buffer[i % PERL_HASH_SEED_BYTES]; + PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,8); + } + } + env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS"); + if (env_pv) { + if (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) { + PL_hash_rand_bits_enabled= 0; + } else if (strEQ(env_pv,"1") || strEQ(env_pv,"RANDOM")) { + PL_hash_rand_bits_enabled= 1; + } else if (strEQ(env_pv,"2") || strEQ(env_pv,"DETERMINISTIC")) { + PL_hash_rand_bits_enabled= 2; + } else { + Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv); + } + } +#endif } #ifdef PERL_GLOBAL_STRUCT @@ -5744,6 +5442,10 @@ Perl_init_global_struct(pTHX) # ifdef PERL_SET_VARS PERL_SET_VARS(plvarsp); # endif +# ifdef PERL_GLOBAL_STRUCT_PRIVATE + plvarsp->Gsv_placeholder.sv_flags = 0; + memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed)); +# endif # undef PERL_GLOBAL_STRUCT_INIT # endif return plvarsp; @@ -6000,7 +5702,6 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - dTHX; int retval; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; @@ -6019,7 +5720,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) (len > 0 && (Size_t)retval >= len) #endif ) - Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + Perl_croak_nocontext("panic: my_snprintf buffer overflow"); return retval; } @@ -6037,7 +5738,6 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { - dTHX; int retval; #ifdef NEED_VA_COPY va_list apc; @@ -6065,7 +5765,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap (len > 0 && (Size_t)retval >= len) #endif ) - Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow"); + Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; } @@ -6098,15 +5798,14 @@ Perl_my_clearenv(pTHX) (void)clearenv(); # elif defined(HAS_UNSETENV) int bsiz = 80; /* Most envvar names will be shorter than this. */ - int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */ - char *buf = (char*)safesysmalloc(bufsiz); + char *buf = (char*)safesysmalloc(bsiz); while (*environ != NULL) { char *e = strchr(*environ, '='); int l = e ? e - *environ : (int)strlen(*environ); if (bsiz < l + 1) { (void)safesysfree(buf); bsiz = l + 1; /* + 1 for the \0. */ - buf = (char*)safesysmalloc(bufsiz); + buf = (char*)safesysmalloc(bsiz); } memcpy(buf, *environ, l); buf[l] = '\0'; @@ -6320,6 +6019,26 @@ Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, Perl_croak_sv(aTHX_ xpt); } +/* +=for apidoc my_strlcat + +The C library C if available, or a Perl implementation of it. +This operates on C NUL-terminated strings. + +C appends string C to the end of C. It will append at +most S> characters. It will then NUL-terminate, +unless C is 0 or the original C string was longer than C (in +practice this should not happen as it means that either C is incorrect or +that C is not a proper NUL-terminated string). + +Note that C is the full size of the destination buffer and +the result is guaranteed to be NUL-terminated if there is room. Note that room +for the NUL should be included in C. + +=cut + +Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat +*/ #ifndef HAS_STRLCAT Size_t Perl_my_strlcat(char *dst, const char *src, Size_t size) @@ -6337,6 +6056,20 @@ Perl_my_strlcat(char *dst, const char *src, Size_t size) } #endif + +/* +=for apidoc my_strlcpy + +The C library C if available, or a Perl implementation of it. +This operates on C NUL-terminated strings. + +C copies up to S> characters from the string C +to C, NUL-terminating the result if C is not 0. + +=cut + +Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy +*/ #ifndef HAS_STRLCPY Size_t Perl_my_strlcpy(char *dst, const char *src, Size_t size) @@ -6377,7 +6110,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { dVAR; SV * const dbsv = GvSVn(PL_DBsub); - const bool save_taint = PL_tainted; + const bool save_taint = TAINT_get; /* When we are called from pp_goto (svp is null), * we do not care about using dbsv to call CV; @@ -6386,7 +6119,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) PERL_ARGS_ASSERT_GET_DB_SUB; - PL_tainted = FALSE; + TAINT_set(FALSE); save_item(dbsv); if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); @@ -6428,6 +6161,9 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } TAINT_IF(save_taint); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_VAR(save_taint); +#endif } int @@ -6442,7 +6178,7 @@ Perl_my_dirfd(pTHX_ DIR * dir) { return dir->dd_fd; #else Perl_die(aTHX_ PL_no_func, "dirfd"); - /* NOT REACHED */ + assert(0); /* NOT REACHED */ return 0; #endif } @@ -6463,6 +6199,105 @@ Perl_get_re_arg(pTHX_ SV *sv) { } /* + * This code is derived from drand48() implementation from FreeBSD, + * found in lib/libc/gen/_rand48.c. + * + * The U64 implementation is original, based on the POSIX + * specification for drand48(). + */ + +/* +* Copyright (c) 1993 Martin Birgmeier +* All rights reserved. +* +* You may redistribute unmodified or modified versions of this source +* code provided that the above copyright notice and this and the +* following conditions are retained. +* +* This software is provided ``as is'', and comes with no warranties +* of any kind. I shall in no event be liable for anything that happens +* to anyone/anything when using this software. +*/ + +#define FREEBSD_DRAND48_SEED_0 (0x330e) + +#ifdef PERL_DRAND48_QUAD + +#define DRAND48_MULT U64_CONST(0x5deece66d) +#define DRAND48_ADD 0xb +#define DRAND48_MASK U64_CONST(0xffffffffffff) + +#else + +#define FREEBSD_DRAND48_SEED_1 (0xabcd) +#define FREEBSD_DRAND48_SEED_2 (0x1234) +#define FREEBSD_DRAND48_MULT_0 (0xe66d) +#define FREEBSD_DRAND48_MULT_1 (0xdeec) +#define FREEBSD_DRAND48_MULT_2 (0x0005) +#define FREEBSD_DRAND48_ADD (0x000b) + +const unsigned short _rand48_mult[3] = { + FREEBSD_DRAND48_MULT_0, + FREEBSD_DRAND48_MULT_1, + FREEBSD_DRAND48_MULT_2 +}; +const unsigned short _rand48_add = FREEBSD_DRAND48_ADD; + +#endif + +void +Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed) +{ + PERL_ARGS_ASSERT_DRAND48_INIT_R; + +#ifdef PERL_DRAND48_QUAD + *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16); +#else + random_state->seed[0] = FREEBSD_DRAND48_SEED_0; + random_state->seed[1] = (U16) seed; + random_state->seed[2] = (U16) (seed >> 16); +#endif +} + +double +Perl_drand48_r(perl_drand48_t *random_state) +{ + PERL_ARGS_ASSERT_DRAND48_R; + +#ifdef PERL_DRAND48_QUAD + *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD) + & DRAND48_MASK; + + return ldexp((double)*random_state, -48); +#else + { + U32 accu; + U16 temp[2]; + + accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0] + + (U32) _rand48_add; + temp[0] = (U16) accu; /* lower 16 bits */ + accu >>= sizeof(U16) * 8; + accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1] + + (U32) _rand48_mult[1] * (U32) random_state->seed[0]; + temp[1] = (U16) accu; /* middle 16 bits */ + accu >>= sizeof(U16) * 8; + accu += _rand48_mult[0] * random_state->seed[2] + + _rand48_mult[1] * random_state->seed[1] + + _rand48_mult[2] * random_state->seed[0]; + random_state->seed[0] = temp[0]; + random_state->seed[1] = temp[1]; + random_state->seed[2] = (U16) accu; + + return ldexp((double) random_state->seed[0], -48) + + ldexp((double) random_state->seed[1], -32) + + ldexp((double) random_state->seed[2], -16); + } +#endif +} + + +/* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4