X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/bc4eb4d6f895e86a4afbc016eae943c7546c35f2..39b40493c96b93db5e5812d0a8923039da82a142:/util.c diff --git a/util.c b/util.c index 4a170aa..be75796 100644 --- a/util.c +++ b/util.c @@ -24,6 +24,7 @@ #include "EXTERN.h" #define PERL_IN_UTIL_C #include "perl.h" +#include "reentr.h" #ifdef USE_PERLIO #include "perliol.h" /* For PerlIOUnix_refcnt */ @@ -59,17 +60,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 @@ -95,7 +85,7 @@ Perl_safesysmalloc(MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: malloc"); + Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); #endif ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); @@ -131,7 +121,7 @@ Perl_safesysmalloc(MEM_SIZE size) if (PL_nomemok) return NULL; else { - return write_no_mem(); + croak_no_mem(); } } /*NOTREACHED*/ @@ -172,7 +162,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) = (struct perl_memory_debug_header *)where; if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: realloc from wrong pool"); + Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", + header->interpreter, aTHX); } assert(header->next->prev == header); assert(header->prev->next == header); @@ -188,7 +179,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: realloc"); + Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); #endif ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); @@ -233,7 +224,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (PL_nomemok) return NULL; else { - return write_no_mem(); + croak_no_mem(); } } /*NOTREACHED*/ @@ -258,14 +249,19 @@ Perl_safesysfree(Malloc_t where) = (struct perl_memory_debug_header *)where; if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: free from wrong pool"); + Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", + header->interpreter, aTHX); } if (!header->prev) { Perl_croak_nocontext("panic: duplicate free"); } - if (!(header->next) || header->next->prev != header - || header->prev->next != header) { - Perl_croak_nocontext("panic: bad free"); + if (!(header->next)) + Perl_croak_nocontext("panic: bad free, header->next==NULL"); + if (header->next->prev != header || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " + "header=%p, ->prev->next=%p", + header->next->prev, header, + header->prev->next); } /* Unlink us from the chain. */ header->next->prev = header->prev; @@ -301,12 +297,12 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #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) { @@ -317,7 +313,8 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING if ((SSize_t)size < 0 || (SSize_t)count < 0) - Perl_croak_nocontext("panic: calloc"); + Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, + (UV)size, (UV)count); #endif #ifdef PERL_TRACK_MEMPOOL /* Have to use malloc() because we've added some space for our tracking @@ -361,7 +358,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif if (PL_nomemok) return NULL; - return write_no_mem(); + croak_no_mem(); } } @@ -399,9 +396,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; @@ -429,38 +426,19 @@ 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 */ +/* same as instr but allow embedded nulls. The end pointers point to 1 beyond + * the final character desired to be checked */ char * Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -489,11 +467,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; @@ -502,7 +480,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; /**/ ) { @@ -540,20 +518,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; - /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in - SV flag usage. No real-world code would ever end up using a studied - scalar as a compile-time second argument to index, so this isn't a real - pessimisation. */ - if (SvSCREAM(sv)) + if (isGV_with_GP(sv) || SvROK(sv)) return; if (SvVALID(sv)) @@ -565,7 +539,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) || SvIsCOW(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); @@ -596,7 +572,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); @@ -615,17 +591,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. */ @@ -635,8 +609,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) /* =for apidoc fbm_instr -Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C +Returns the location of the SV in the string delimited by C and +C. It returns C if the string can't be found. The C does not have to be fbm_compiled, but the search will not be as fast then. @@ -644,14 +618,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; @@ -787,7 +760,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 */ @@ -795,7 +768,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])) { @@ -804,7 +777,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; @@ -830,174 +803,21 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } } -/* start_shift, end_shift are positive quantities which give offsets - of ends of some substring of bigstr. - If "last" we want the last occurrence. - old_posp is the way of communication between consequent calls if - the next call needs to find the . - The initial *old_posp should be -1. - - Note that we take into account SvTAIL, so one can get extra - optimizations if _ALL flag is set. - */ - -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if PL_multiline. In fact if !PL_multiline the authoritative answer - is not supported yet. */ - char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { dVAR; - register const unsigned char *big; - U32 pos = 0; /* hush a gcc warning */ - register I32 previous; - register I32 first; - register const unsigned char *little; - register I32 stop_pos; - register const unsigned char *littleend; - bool found = FALSE; - const MAGIC * mg; - const void *screamnext_raw = NULL; /* hush a gcc warning */ - bool cant_find = FALSE; /* hush a gcc warning */ - PERL_ARGS_ASSERT_SCREAMINSTR; - - assert(SvMAGICAL(bigstr)); - mg = mg_find(bigstr, PERL_MAGIC_study); - assert(mg); - assert(SvTYPE(littlestr) == SVt_PVMG); - assert(SvVALID(littlestr)); - - if (mg->mg_private == 1) { - const U8 *const screamfirst = (U8 *)mg->mg_ptr; - const U8 *const screamnext = screamfirst + 256; - - screamnext_raw = (const void *)screamnext; - - pos = *old_posp == -1 - ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; - cant_find = pos == (U8)~0; - } else if (mg->mg_private == 2) { - const U16 *const screamfirst = (U16 *)mg->mg_ptr; - const U16 *const screamnext = screamfirst + 256; - - screamnext_raw = (const void *)screamnext; - - pos = *old_posp == -1 - ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; - cant_find = pos == (U16)~0; - } else if (mg->mg_private == 4) { - const U32 *const screamfirst = (U32 *)mg->mg_ptr; - const U32 *const screamnext = screamfirst + 256; - - screamnext_raw = (const void *)screamnext; - - pos = *old_posp == -1 - ? screamfirst[BmRARE(littlestr)] : screamnext[*old_posp]; - cant_find = pos == (U32)~0; - } else - Perl_croak(aTHX_ "panic: unknown study size %u", mg->mg_private); - - if (cant_find) { - cant_find: - if ( BmRARE(littlestr) == '\n' - && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { - little = (const unsigned char *)(SvPVX_const(littlestr)); - littleend = little + SvCUR(littlestr); - first = *little++; - goto check_tail; - } - return NULL; - } - - little = (const unsigned char *)(SvPVX_const(littlestr)); - littleend = little + SvCUR(littlestr); - first = *little++; - /* The value of pos we can start at: */ - previous = BmPREVIOUS(littlestr); - big = (const unsigned char *)(SvPVX_const(bigstr)); - /* The value of pos we can stop at: */ - stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); - if (previous + start_shift > stop_pos) { -/* - stop_pos does not include SvTAIL in the count, so this check is incorrect - (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 -*/ -#if 0 - if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ - goto check_tail; -#endif - return NULL; - } - if (mg->mg_private == 1) { - const U8 *const screamnext = (const U8 *const) screamnext_raw; - while ((I32)pos < previous + start_shift) { - pos = screamnext[pos]; - if (pos == (U8)~0) - goto cant_find; - } - } else if (mg->mg_private == 2) { - const U16 *const screamnext = (const U16 *const) screamnext_raw; - while ((I32)pos < previous + start_shift) { - pos = screamnext[pos]; - if (pos == (U16)~0) - goto cant_find; - } - } else if (mg->mg_private == 4) { - const U32 *const screamnext = (const U32 *const) screamnext_raw; - while ((I32)pos < previous + start_shift) { - pos = screamnext[pos]; - if (pos == (U32)~0) - goto cant_find; - } - } - big -= previous; - while (1) { - if ((I32)pos >= stop_pos) break; - if (big[pos] == first) { - const unsigned char *s = little; - const unsigned char *x = big + pos + 1; - while (s < littleend) { - if (*s != *x++) - break; - ++s; - } - if (s == littleend) { - *old_posp = (I32)pos; - if (!last) return (char *)(big+pos); - found = TRUE; - } - } - if (mg->mg_private == 1) { - pos = ((const U8 *const)screamnext_raw)[pos]; - if (pos == (U8)~0) - break; - } else if (mg->mg_private == 2) { - pos = ((const U16 *const)screamnext_raw)[pos]; - if (pos == (U16)~0) - break; - } else if (mg->mg_private == 4) { - pos = ((const U32 *const)screamnext_raw)[pos]; - if (pos == (U32)~0) - break; - } - }; - if (last && found) - return (char *)(big+(*old_posp)); - check_tail: - if (!SvTAIL(littlestr) || (end_shift > 0)) - return NULL; - /* Ignore the trailing "\n". This code is not microoptimized */ - big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); - stop_pos = littleend - little; /* Actual littlestr len */ - if (stop_pos == 0) - return (char*)big; - big -= stop_pos; - if (*big == first - && ((stop_pos == 1) || - memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) - return (char*)big; + PERL_UNUSED_ARG(bigstr); + PERL_UNUSED_ARG(littlestr); + PERL_UNUSED_ARG(start_shift); + PERL_UNUSED_ARG(end_shift); + PERL_UNUSED_ARG(old_posp); + PERL_UNUSED_ARG(last); + + /* This function must only ever be called on a scalar with study magic, + but those do not happen any more. */ + Perl_croak(aTHX_ "panic: screaminstr"); return NULL; } @@ -1014,13 +834,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; @@ -1029,18 +851,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; @@ -1060,14 +884,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; @@ -1119,11 +945,13 @@ the new string can be freed with the C function. */ 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) { @@ -1147,7 +975,7 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr; + char *newaddr; STRLEN pvlen; if (!pv) return NULL; @@ -1155,7 +983,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); } @@ -1174,10 +1002,10 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); - PERL_ARGS_ASSERT_SAVESHAREDPVN; + /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { - return write_no_mem(); + croak_no_mem(); } newaddr[len] = '\0'; return (char*)memcpy(newaddr, pv, len); @@ -1197,7 +1025,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; @@ -1455,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 @@ -1511,7 +1340,7 @@ 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 @@ -1606,7 +1435,7 @@ Perl_die_sv(pTHX_ SV *baseex) { PERL_ARGS_ASSERT_DIE_SV; croak_sv(baseex); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ return NULL; } @@ -1628,7 +1457,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; } @@ -1640,7 +1469,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; } @@ -1740,7 +1569,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 */ @@ -1751,7 +1580,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } @@ -1766,9 +1595,32 @@ 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; + + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, sizeof(PL_no_mem)-1); + 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); } /* @@ -1994,7 +1846,8 @@ S_ckwarn_common(pTHX_ U32 w) STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size) { - const MEM_SIZE len_wanted = sizeof(STRLEN) + size; + const MEM_SIZE len_wanted = + sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; @@ -2004,6 +1857,8 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, PerlMemShared_realloc(buffer, len_wanted)); buffer[0] = size; Copy(bits, (buffer + 1), size, char); + if (size < WARNsize) + Zero((char *)(buffer + 1) + size, WARNsize - size, char); return buffer; } @@ -2032,8 +1887,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? */ @@ -2081,7 +1936,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); @@ -2094,7 +1949,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); @@ -2129,7 +1985,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; @@ -2145,7 +2001,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #endif /* WIN32 || NETWARE */ -#endif /* !VMS && !EPOC*/ +#endif /* !VMS */ #ifdef UNLINK_ALL_VERSIONS I32 @@ -2164,12 +2020,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++; @@ -2187,12 +2045,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; @@ -2202,12 +2062,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; @@ -2217,14 +2079,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; @@ -2288,343 +2152,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]; @@ -2634,7 +2169,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"); } @@ -2735,7 +2270,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) int pid2, status; PerlLIO_close(p[This]); if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); @@ -2757,14 +2292,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; @@ -2780,7 +2315,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"); } @@ -2849,9 +2384,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) default, binary, low-level mode; see PerlIOBuf_open(). */ PerlLIO_setmode((*mode == 'r'), O_BINARY); #endif -#ifdef THREADS_HAVE_PIDS - PL_ppid = (IV)getppid(); -#endif PL_forkprocess = 0; #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ @@ -2894,7 +2426,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) int pid2, status; PerlLIO_close(p[This]); if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); @@ -2907,20 +2439,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 * @@ -2942,7 +2460,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) } #endif #endif -#endif #endif /* !DOSISH */ @@ -2953,6 +2470,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 @@ -2967,6 +2487,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 @@ -3202,12 +2725,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; @@ -3235,22 +2757,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; @@ -3360,7 +2869,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); @@ -3369,7 +2878,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 @@ -3404,19 +2913,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++; @@ -3482,11 +2996,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 @@ -3609,28 +3123,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 @@ -3681,6 +3192,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ + /* diag_listed_as: Can't execute %s */ Perl_croak(aTHX_ "Can't %s %s%s%s", (xfailed ? "execute" : "find"), (xfailed ? xfailed : scriptname), @@ -3704,8 +3216,9 @@ Perl_get_context(void) #if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; - if (pthread_getspecific(PL_thr_key, &t)) - Perl_croak_nocontext("panic: pthread_getspecific"); + int error = pthread_getspecific(PL_thr_key, &t) + if (error) + Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); return (void*)t; # else # ifdef I_MACH_CTHREADS @@ -3728,8 +3241,11 @@ Perl_set_context(void *t) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else - if (pthread_setspecific(PL_thr_key, t)) - Perl_croak_nocontext("panic: pthread_setspecific"); + { + const int error = pthread_setspecific(PL_thr_key, t); + if (error) + Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); + } # endif #else PERL_UNUSED_ARG(t); @@ -3859,15 +3375,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), @@ -3894,7 +3410,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) ? "" : "()"); @@ -3907,26 +3423,18 @@ Perl_report_evil_fh(pTHX_ const GV *gv) (const char *) (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"); - if (name && SvPOK(name) && *SvPV_nolen(name)) { - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s %"SVf, func, pars, vile, type, SVfARG(name)); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) - Perl_warner( - aTHX_ packWARN(warn_type), - "\t(Are you trying to call %s%s on dirhandle %"SVf"?)\n", - func, pars, SVfARG(name) - ); - } - else { - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s", func, pars, vile, type); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + 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 ? " " : "", + SVfARG(have_name ? name : &PL_sv_no)); + if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) Perl_warner( aTHX_ packWARN(warn_type), - "\t(Are you trying to call %s%s on dirhandle?)\n", - func, pars + "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", + func, pars, have_name ? " " : "", + SVfARG(have_name ? name : &PL_sv_no) ); - } } } @@ -4061,15 +3569,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 @@ -4164,9 +3664,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 * @@ -4279,7 +3777,7 @@ 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; @@ -4532,6 +4030,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 == '.') { @@ -4544,7 +4043,7 @@ dotted_decimal_version: /* and we never support negative versions */ if ( *d == '-') { - BADVERSION(s,errstr,"Invalid version format (negative version number)"); + BADVERSION(s,errstr,"Invalid version format (negative version number)"); } /* consume all of the integer part */ @@ -4594,7 +4093,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)"); @@ -4616,6 +4115,7 @@ dotted_decimal_version: if ( ! isDIGIT(d[1]) ) { BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); } + width = j; d++; alpha = TRUE; } @@ -4667,7 +4167,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; @@ -4675,17 +4175,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++; @@ -4693,6 +4187,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); } } @@ -4702,13 +4197,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)) { @@ -4857,7 +4361,7 @@ Perl_new_version(pTHX_ SV *ver) dVAR; SV * const rv = newSV(0); PERL_ARGS_ASSERT_NEW_VERSION; - if ( sv_derived_from(ver,"version") && SvROK(ver) ) + if ( sv_isobject(ver) && sv_derived_from(ver, "version") ) /* can just copy directly */ { I32 key; @@ -4879,7 +4383,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)); @@ -4950,18 +4454,37 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) { + STRLEN len; + /* may get too much accuracy */ char tbuf[64]; + SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; + char *buf; #ifdef USE_LOCALE_NUMERIC - char *loc = setlocale(LC_NUMERIC, "C"); + char *loc = NULL; + if (! PL_numeric_standard) { + loc = savepv(setlocale(LC_NUMERIC, NULL)); + setlocale(LC_NUMERIC, "C"); + } #endif - STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); + if (sv) { + Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); + buf = SvPV(sv, len); + } + else { + len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); + buf = tbuf; + } #ifdef USE_LOCALE_NUMERIC - setlocale(LC_NUMERIC, loc); + if (loc) { + setlocale(LC_NUMERIC, loc); + Safefree(loc); + } #endif - while (tbuf[len-1] == '0' && len > 0) len--; - if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ - version = savepvn(tbuf, len); + while (buf[len-1] == '0' && len > 0) len--; + if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ + version = savepvn(buf, len); + SvREFCNT_dec(sv); } #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ @@ -4999,7 +4522,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; } @@ -5490,7 +5013,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; @@ -5516,6 +5039,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; @@ -5708,6 +5232,10 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) return opt; } +#ifdef VMS +# include +#endif + U32 Perl_seed(pTHX) { @@ -5739,7 +5267,6 @@ Perl_seed(pTHX) #endif U32 u; #ifdef VMS -# include /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; @@ -5790,74 +5317,86 @@ 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; -#ifdef USE_ITHREADS -bool -Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) -{ - const char * stashpv = CopSTASHPV(c); - const char * name = HvNAME_get(hv); - PERL_UNUSED_CONTEXT; - PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH; - - if (!stashpv || !name) - return stashpv == name; - if ( HvNAMEUTF8(hv) && !(CopSTASH_flags(c) & SVf_UTF8 ? 1 : 0) ) { - if (CopSTASH_flags(c) & SVf_UTF8) { - return (bytes_cmp_utf8( - (const U8*)stashpv, strlen(stashpv), - (const U8*)name, HEK_LEN(HvNAME_HEK(hv))) == 0); + 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 { - return (bytes_cmp_utf8( - (const U8*)name, HEK_LEN(HvNAME_HEK(hv)), - (const U8*)stashpv, strlen(stashpv)) == 0); + /* 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 - return (stashpv == name - || strEQ(stashpv, name)); - return FALSE; -} #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 @@ -5909,6 +5448,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; @@ -6165,7 +5708,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; @@ -6184,7 +5726,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; } @@ -6202,7 +5744,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; @@ -6230,7 +5771,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; } @@ -6263,15 +5804,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'; @@ -6430,7 +5970,7 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, } if (sv) { SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); - SV *pmsv = sv_derived_from(sv, "version") + SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") ? sv : sv_2mortal(new_version(sv)); xssv = upg_version(xssv, 0); if ( vcmp(pmsv,xssv) ) { @@ -6542,7 +6082,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; @@ -6551,7 +6091,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); @@ -6593,6 +6133,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 @@ -6607,7 +6150,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 } @@ -6631,8 +6174,8 @@ Perl_get_re_arg(pTHX_ SV *sv) { * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */