X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c13a5c80de2334e935eada0927b9f5f7c862a45e..a3be5ee7857e3bd21db692b2200f237c8d791830:/util.c diff --git a/util.c b/util.c index 3428a25..67136fe 100644 --- a/util.c +++ b/util.c @@ -12,7 +12,7 @@ * 'Very useful, no doubt, that was to Saruman; yet it seems that he was * not content.' --Gandalf to Pippin * - * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -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,46 +37,86 @@ #endif #endif +#include +#include + #ifdef __Lynx__ /* Missing protos on LynxOS */ int putenv(char *); #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include # endif #endif -#define FLUSH +#ifdef USE_C_BACKTRACE +# ifdef I_BFD +# define USE_BFD +# ifdef PERL_DARWIN +# undef USE_BFD /* BFD is useless in OS X. */ +# endif +# ifdef USE_BFD +# include +# endif +# endif +# ifdef I_DLFCN +# include +# endif +# ifdef I_EXECINFO +# include +# endif +#endif -#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) -# define FD_CLOEXEC 1 /* NeXT needs this */ +#ifdef PERL_DEBUG_READONLY_COW +# include #endif +#define FLUSH + /* NOTE: Do not call the next three routines directly. Use the macros * in handy.h, so that we can easily redefine everything to do tracking of * allocated hunks back to the original New to track down any memory leaks. * XXX This advice seems to be widely ignored :-( --AD August 1996. */ -static char * -S_write_no_mem(pTHX) +#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) +# define ALWAYS_NEED_THX +#endif + +#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW) +static void +S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header) { - 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 (header->readonly + && mprotect(header, header->size, PROT_READ|PROT_WRITE)) + Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", + header, header->size, errno); } -#if defined (DEBUGGING) || defined(PERL_IMPLICIT_SYS) || defined (PERL_TRACK_MEMPOOL) -# define ALWAYS_NEED_THX +static void +S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header) +{ + if (header->readonly + && mprotect(header, header->size, PROT_READ)) + Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", + header, header->size, errno); +} +# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo) +# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo) +#else +# define maybe_protect_rw(foo) NOOP +# define maybe_protect_ro(foo) NOOP +#endif + +#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW) + /* Use memory_debug_header */ +# define USE_MDH +# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \ + || defined(PERL_DEBUG_READONLY_COW) +# define MDH_HAS_SIZE +# endif #endif /* paranoid version of system's malloc() */ @@ -87,24 +128,24 @@ 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 + size += PERL_MEMORY_DEBUG_HEADER_SIZE; #ifdef DEBUGGING - if ((long)size < 0) - Perl_croak_nocontext("panic: malloc"); + if ((SSize_t)size < 0) + Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); +#endif + if (!size) size = 1; /* malloc(0) is NASTY on our system */ +#ifdef PERL_DEBUG_READONLY_COW + if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { + perror("mmap failed"); + abort(); + } +#else + ptr = (Malloc_t)PerlMem_malloc(size?size:1); #endif - ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); if (ptr != NULL) { -#ifdef PERL_TRACK_MEMPOOL +#ifdef USE_MDH struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; #endif @@ -119,26 +160,30 @@ Perl_safesysmalloc(MEM_SIZE size) header->prev = &PL_memory_debug_header; header->next = PL_memory_debug_header.next; PL_memory_debug_header.next = header; + maybe_protect_rw(header->next); header->next->prev = header; -# ifdef PERL_POISON - header->size = size; + maybe_protect_ro(header->next); +# ifdef PERL_DEBUG_READONLY_COW + header->readonly = 0; # endif - ptr = (Malloc_t)((char*)ptr+sTHX); #endif +#ifdef MDH_HAS_SIZE + header->size = size; +#endif + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - return ptr; -} + + } else { #ifndef ALWAYS_NEED_THX dTHX; #endif if (PL_nomemok) - return NULL; - else { - return write_no_mem(); - } + ptr = NULL; + else + croak_no_mem(); } - /*NOTREACHED*/ + return ptr; } /* paranoid version of system's realloc() */ @@ -150,97 +195,113 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) dTHX; #endif Malloc_t ptr; +#ifdef PERL_DEBUG_READONLY_COW + const MEM_SIZE oldsize = where + ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size + : 0; +#endif #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) 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; + ptr = NULL; } + else if (!where) { + ptr = safesysmalloc(size); + } + else { +#ifdef USE_MDH + where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + size += PERL_MEMORY_DEBUG_HEADER_SIZE; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; - if (!where) - return safesysmalloc(size); -#ifdef PERL_TRACK_MEMPOOL - where = (Malloc_t)((char*)where-sTHX); - size += sTHX; - { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where; - - if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: realloc from wrong pool"); - } - assert(header->next->prev == header); - assert(header->prev->next == header); +# ifdef PERL_TRACK_MEMPOOL + if (header->interpreter != aTHX) { + Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", + header->interpreter, aTHX); + } + assert(header->next->prev == header); + assert(header->prev->next == header); # ifdef PERL_POISON - if (header->size > size) { - const MEM_SIZE freed_up = header->size - size; - char *start_of_freed = ((char *)where) + size; - PoisonFree(start_of_freed, freed_up, char); - } - header->size = size; + if (header->size > size) { + const MEM_SIZE freed_up = header->size - size; + char *start_of_freed = ((char *)where) + size; + PoisonFree(start_of_freed, freed_up, char); + } # endif - } +# endif +# ifdef MDH_HAS_SIZE + header->size = size; +# endif + } #endif #ifdef DEBUGGING - if ((long)size < 0) - Perl_croak_nocontext("panic: realloc"); + if ((SSize_t)size < 0) + Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); +#endif +#ifdef PERL_DEBUG_READONLY_COW + if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { + perror("mmap failed"); + abort(); + } + Copy(where,ptr,oldsize < size ? oldsize : size,char); + if (munmap(where, oldsize)) { + perror("munmap failed"); + abort(); + } +#else + ptr = (Malloc_t)PerlMem_realloc(where,size); #endif - ptr = (Malloc_t)PerlMem_realloc(where,size); - PERL_ALLOC_CHECK(ptr); + PERL_ALLOC_CHECK(ptr); /* MUST do this fixup first, before doing ANYTHING else, as anything else might allocate memory/free/move memory, and until we do the fixup, it may well be chasing (and writing to) free memory. */ + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL - if (ptr != NULL) { - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)ptr; # ifdef PERL_POISON - if (header->size < size) { - const MEM_SIZE fresh = size - header->size; - char *start_of_fresh = ((char *)ptr) + size; - PoisonNew(start_of_fresh, fresh, char); - } + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } # endif - header->next->prev = header; - header->prev->next = header; - - ptr = (Malloc_t)((char*)ptr+sTHX); - } + maybe_protect_rw(header->next); + header->next->prev = header; + maybe_protect_ro(header->next); + maybe_protect_rw(header->prev); + header->prev->next = header; + maybe_protect_ro(header->prev); #endif + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + } /* In particular, must do that fixup above before logging anything via *printf(), as it can reallocate memory, which can cause SEGVs. */ - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - - if (ptr != NULL) { - return ptr; - } - else { + if (ptr == NULL) { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - else { - return write_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); } } - /*NOTREACHED*/ + return ptr; } /* safe version of system's free() */ @@ -250,38 +311,61 @@ Perl_safesysfree(Malloc_t where) { #ifdef ALWAYS_NEED_THX dTHX; -#else - dVAR; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { -#ifdef PERL_TRACK_MEMPOOL - where = (Malloc_t)((char*)where-sTHX); +#ifdef USE_MDH + Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); { struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)where; + = (struct perl_memory_debug_header *)where_intrn; +# ifdef MDH_HAS_SIZE + const MEM_SIZE size = header->size; +# endif +# ifdef PERL_TRACK_MEMPOOL 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. */ + maybe_protect_rw(header->next); header->next->prev = header->prev; + maybe_protect_ro(header->next); + maybe_protect_rw(header->prev); header->prev->next = header->next; + maybe_protect_ro(header->prev); + maybe_protect_rw(header); # ifdef PERL_POISON - PoisonNew(where, header->size, char); + PoisonNew(where_intrn, size, char); # endif /* Trigger the duplicate free warning. */ header->next = NULL; +# endif +# ifdef PERL_DEBUG_READONLY_COW + if (munmap(where_intrn, size)) { + perror("munmap failed"); + abort(); + } +# endif } +#else + Malloc_t where_intrn = where; +#endif /* USE_MDH */ +#ifndef PERL_DEBUG_READONLY_COW + PerlMem_free(where_intrn); #endif - PerlMem_free(where); } } @@ -294,36 +378,36 @@ 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(USE_MDH) || 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(USE_MDH) || defined(DEBUGGING) total_size = size * count; #endif } else - Perl_croak_nocontext("%s", PL_memory_wrap); -#ifdef PERL_TRACK_MEMPOOL - if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) - total_size += sTHX; + croak_memory_wrap(); +#ifdef USE_MDH + if (PERL_MEMORY_DEBUG_HEADER_SIZE <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += PERL_MEMORY_DEBUG_HEADER_SIZE; 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 ((long)size < 0 || (long)count < 0) - Perl_croak_nocontext("panic: calloc"); + if ((SSize_t)size < 0 || (SSize_t)count < 0) + Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, + (UV)size, (UV)count); #endif -#ifdef PERL_TRACK_MEMPOOL +#ifdef PERL_DEBUG_READONLY_COW + if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE, + MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) { + perror("mmap failed"); + abort(); + } +#elif defined(PERL_TRACK_MEMPOOL) /* Have to use malloc() because we've added some space for our tracking header. */ /* malloc(0) is non-portable. */ @@ -339,22 +423,31 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); if (ptr != NULL) { -#ifdef PERL_TRACK_MEMPOOL +#ifdef USE_MDH { struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; +# ifndef PERL_DEBUG_READONLY_COW memset((void*)ptr, 0, total_size); +# endif +# ifdef PERL_TRACK_MEMPOOL header->interpreter = aTHX; /* Link us into the list. */ header->prev = &PL_memory_debug_header; header->next = PL_memory_debug_header.next; PL_memory_debug_header.next = header; + maybe_protect_rw(header->next); header->next->prev = header; -# ifdef PERL_POISON + maybe_protect_ro(header->next); +# ifdef PERL_DEBUG_READONLY_COW + header->readonly = 0; +# endif +# endif +# ifdef MDH_HAS_SIZE header->size = total_size; # endif - ptr = (Malloc_t)((char*)ptr+sTHX); + ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); } #endif return ptr; @@ -365,7 +458,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif if (PL_nomemok) return NULL; - return write_no_mem(); + croak_no_mem(); } } @@ -376,25 +469,33 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Malloc_t Perl_malloc (MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_malloc(nbytes); } Malloc_t Perl_calloc (MEM_SIZE elements, MEM_SIZE size) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_calloc(elements, size); } Malloc_t Perl_realloc (Malloc_t where, MEM_SIZE nbytes) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif return (Malloc_t)PerlMem_realloc(where, nbytes); } Free_t Perl_mfree (Malloc_t where) { - dTHXs; +#ifdef PERL_IMPLICIT_SYS + dTHX; +#endif PerlMem_free(where); } @@ -403,9 +504,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; @@ -433,38 +534,20 @@ 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 (late 1994) 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) @@ -493,11 +576,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; @@ -506,7 +589,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; /**/ ) { @@ -543,21 +626,16 @@ Analyses the string in order to make fast searches on it using fbm_instr() 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)) @@ -569,7 +647,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 +680,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 +699,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. */ @@ -639,8 +717,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. @@ -648,14 +726,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; @@ -790,8 +867,9 @@ 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; + + assert(mg); --littlelen; /* Last char found by table lookup */ @@ -799,7 +877,8 @@ 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; + const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + I32 tmp; top2: if ((tmp = table[*s])) { @@ -808,7 +887,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; @@ -834,112 +913,6 @@ 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; - register I32 pos; - register I32 previous; - register I32 first; - register const unsigned char *little; - register I32 stop_pos; - register const unsigned char *littleend; - I32 found = 0; - - PERL_ARGS_ASSERT_SCREAMINSTR; - - assert(SvTYPE(littlestr) == SVt_PVMG); - assert(SvVALID(littlestr)); - - if (*old_posp == -1 - ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 - : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { - 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; - } - while (pos < previous + start_shift) { - if (!(pos += PL_screamnext[pos])) - goto cant_find; - } - big -= previous; - do { - register const unsigned char *s, *x; - if (pos >= stop_pos) break; - if (big[pos] != first) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s == littleend) { - *old_posp = pos; - if (!last) return (char *)(big+pos); - found = 1; - } - } while ( pos += PL_screamnext[pos] ); - 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; - return NULL; -} - /* =for apidoc foldEQ @@ -953,13 +926,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; @@ -968,18 +943,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; @@ -999,14 +976,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; @@ -1022,10 +1001,15 @@ Perl_foldEQ_locale(const char *s1, const char *s2, register I32 len) =for apidoc savepv -Perl's version of C. Returns a pointer to a newly allocated -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. +Perl's version of C. Returns a pointer to a newly allocated +string which is a duplicate of C. The size of the string is +determined by C, which means it may not contain embedded C +characters and must have a trailing 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 */ @@ -1049,20 +1033,27 @@ Perl_savepv(pTHX_ const char *pv) /* =for apidoc savepvn -Perl's version of what C would be if it existed. Returns a +Perl's version of what C would be if it existed. Returns a 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 +C bytes from C, plus a trailing +C 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) { @@ -1086,15 +1077,18 @@ which is shared between threads. char * Perl_savesharedpv(pTHX_ const char *pv) { - register char *newaddr; + char *newaddr; STRLEN pvlen; + + PERL_UNUSED_CONTEXT; + if (!pv) return NULL; pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - return write_no_mem(); + croak_no_mem(); } return (char*)memcpy(newaddr, pv, pvlen); } @@ -1103,7 +1097,7 @@ Perl_savesharedpv(pTHX_ const char *pv) =for apidoc savesharedpvn A version of C which allocates the duplicate string in memory -which is shared between threads. (With the specific difference that a NULL +which is shared between threads. (With the specific difference that a NULL pointer is not acceptable) =cut @@ -1113,10 +1107,11 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); - PERL_ARGS_ASSERT_SAVESHAREDPVN; + PERL_UNUSED_CONTEXT; + /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { - return write_no_mem(); + croak_no_mem(); } newaddr[len] = '\0'; return (char*)memcpy(newaddr, pv, len); @@ -1128,6 +1123,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 */ @@ -1136,7 +1135,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; @@ -1170,7 +1169,6 @@ Perl_savesharedsvpv(pTHX_ SV *sv) STATIC SV * S_mess_alloc(pTHX) { - dVAR; SV *sv; XPVMG *any; @@ -1289,20 +1287,24 @@ 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) { const OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { + for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -1313,7 +1315,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; } @@ -1351,9 +1353,20 @@ required) to modify and return C instead of allocating a new SV. SV * Perl_mess_sv(pTHX_ SV *basemsg, bool consume) { - dVAR; SV *sv; +#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR) + { + char *ws; + int wi; + /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */ + if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) && + (wi = grok_atou(ws, NULL)) > 0) { + Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1); + } + } +#endif + PERL_ARGS_ASSERT_MESS_SV; if (SvROK(basemsg)) { @@ -1383,7 +1396,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, OpSIBLING(PL_curcop), PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1394,10 +1408,13 @@ 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'); - Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, - PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + *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 + : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } @@ -1427,7 +1444,6 @@ this function. SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - dVAR; SV * const sv = mess_alloc(); PERL_ARGS_ASSERT_VMESS; @@ -1439,7 +1455,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ SV* msv) { - dVAR; IO *io; MAGIC *mg; @@ -1448,20 +1463,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 } } @@ -1486,7 +1494,6 @@ S_with_queued_errors(pTHX_ SV *ex) STATIC bool S_invoke_exception_hook(pTHX_ SV *ex, bool warn) { - dVAR; HV *stash; GV *gv; CV *cv; @@ -1507,7 +1514,6 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn) SV *exarg; ENTER; - save_re_context(); if (warn) { SAVESPTR(*hook); *hook = NULL; @@ -1538,14 +1544,24 @@ The function never actually returns. =cut */ +#ifdef _MSC_VER +# pragma warning( push ) +# pragma warning( disable : 4646 ) /* warning C4646: function declared with + __declspec(noreturn) has non-void return type */ +# pragma warning( disable : 4645 ) /* warning C4645: function declared with +__declspec(noreturn) has a return statement */ +#endif OP * Perl_die_sv(pTHX_ SV *baseex) { PERL_ARGS_ASSERT_DIE_SV; croak_sv(baseex); /* NOTREACHED */ - return NULL; + NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif /* =for apidoc Am|OP *|die|const char *pat|... @@ -1558,6 +1574,13 @@ The function never actually returns. */ #if defined(PERL_IMPLICIT_CONTEXT) +#ifdef _MSC_VER +# pragma warning( push ) +# pragma warning( disable : 4646 ) /* warning C4646: function declared with + __declspec(noreturn) has non-void return type */ +# pragma warning( disable : 4645 ) /* warning C4645: function declared with +__declspec(noreturn) has a return statement */ +#endif OP * Perl_die_nocontext(const char* pat, ...) { @@ -1565,22 +1588,35 @@ Perl_die_nocontext(const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); - return NULL; + NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif #endif /* PERL_IMPLICIT_CONTEXT */ +#ifdef _MSC_VER +# pragma warning( push ) +# pragma warning( disable : 4646 ) /* warning C4646: function declared with + __declspec(noreturn) has non-void return type */ +# pragma warning( disable : 4645 ) /* warning C4645: function declared with +__declspec(noreturn) has a return statement */ +#endif OP * Perl_die(pTHX_ const char* pat, ...) { va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); - return NULL; + NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif /* =for apidoc Am|void|croak_sv|SV *baseex @@ -1677,7 +1713,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1688,7 +1724,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } @@ -1696,16 +1732,43 @@ Perl_croak(pTHX_ const char *pat, ...) =for apidoc Am|void|croak_no_modify Exactly equivalent to C, but generates -terser object code than using C. Less code used on exception code +terser object code than using C. Less code used on exception code paths reduces CPU cache pressure. =cut */ void -Perl_croak_no_modify(pTHX) +Perl_croak_no_modify(void) +{ + 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(void) +{ + dTHX; + + int fd = PerlIO_fileno(Perl_error_log); + if (fd < 0) + SETERRNO(EBADF,RMS_IFI); + else { + /* Can't use PerlIO to write as it allocates memory */ + PERL_UNUSED_RESULT(PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1)); + } + my_exit(1); +} + +/* does not return, used only in POPSTACK */ +void +Perl_croak_popstack(void) { - Perl_croak(aTHX_ "%s", PL_no_modify); + dTHX; + PerlIO_printf(Perl_error_log, "panic: POPSTACK\n"); + my_exit(1); } /* @@ -1862,8 +1925,13 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - invoke_exception_hook(msv, FALSE); - die_unwind(msv); + if (PL_parser && PL_parser->error_count) { + qerror(msv); + } + else { + invoke_exception_hook(msv, FALSE); + die_unwind(msv); + } } else { Perl_vwarn(aTHX_ pat, args); @@ -1875,10 +1943,14 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) bool Perl_ckwarn(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set, use $^W. */ - if (isLEXWARN_off) - return PL_dowarn & G_WARN_ON; + if (isLEXWARN_off) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return PL_dowarn & G_WARN_ON; + } return ckwarn_common(w); } @@ -1888,10 +1960,14 @@ Perl_ckwarn(pTHX_ U32 w) bool Perl_ckwarn_d(pTHX_ U32 w) { - dVAR; /* If lexical warnings have not been set then default classes warn. */ - if (isLEXWARN_off) - return TRUE; + if (isLEXWARN_off) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return TRUE; + } return ckwarn_common(w); } @@ -1899,8 +1975,13 @@ Perl_ckwarn_d(pTHX_ U32 w) static bool S_ckwarn_common(pTHX_ U32 w) { - if (PL_curcop->cop_warnings == pWARN_ALL) - return TRUE; + if (PL_curcop->cop_warnings == pWARN_ALL) { + /* TODO: Hardcoding this here sucks, see the commit that added this */ + if (w == WARN_VOID_UNUSUAL) + return FALSE; + else + return TRUE; + } if (PL_curcop->cop_warnings == pWARN_NONE) return FALSE; @@ -1931,7 +2012,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; @@ -1941,6 +2023,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; } @@ -1968,57 +2052,61 @@ 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); - int nlen, vlen; - - /* where does it go? */ - for (i = 0; environ[i]; i++) { - if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') - break; - } - - if (environ == PL_origenviron) { /* need we copy environment? */ - I32 j; - I32 max; - char **tmpenv; - - max = i; - while (environ[max]) - max++; - tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); - for (j=0; j= 0); + if (from - to >= 0) { while (len--) *to++ = *from++; @@ -2124,12 +2215,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; @@ -2139,12 +2232,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; @@ -2154,14 +2249,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; @@ -2225,343 +2322,13 @@ 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__) - dVAR; +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) 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]; @@ -2571,7 +2338,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"); } @@ -2604,7 +2371,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) /* Close error pipe automatically if exec works */ - fcntl(pp[1], F_SETFD, FD_CLOEXEC); + if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) + return NULL; #endif } /* Now dup our end of _the_ pipe to right position */ @@ -2672,7 +2440,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); @@ -2684,8 +2452,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); #else -# ifdef OS2 /* Same, without fork()ing and all extra overhead... */ +# if defined(OS2) /* Same, without fork()ing and all extra overhead... */ return my_syspopen4(aTHX_ NULL, mode, n, args); +# elif defined(WIN32) + return win32_popenlist(mode, n, args); # else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; @@ -2694,14 +2464,13 @@ 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; @@ -2717,7 +2486,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"); } @@ -2749,7 +2518,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) if (did_pipes) { PerlLIO_close(pp[0]); #if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(pp[1], F_SETFD, FD_CLOEXEC); + if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) + return NULL; #endif } if (p[THIS] != (*mode == 'r')) { @@ -2786,9 +2556,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 */ @@ -2831,7 +2598,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); @@ -2844,20 +2611,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 * @@ -2879,7 +2632,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) } #endif #endif -#endif #endif /* !DOSISH */ @@ -2887,9 +2639,12 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) void Perl_atfork_lock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* 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 @@ -2901,9 +2656,12 @@ Perl_atfork_lock(void) void Perl_atfork_unlock(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* 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 @@ -2933,25 +2691,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) @@ -2992,10 +2731,10 @@ dup2(int oldfd, int newfd) Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { - dVAR; struct sigaction act, oact; #ifdef USE_ITHREADS + dVAR; /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) return (Sighandler_t) SIG_ERR; @@ -3033,7 +2772,9 @@ Perl_rsignal_state(pTHX_ int signo) int Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif struct sigaction act; PERL_ARGS_ASSERT_RSIGNAL_SAVE; @@ -3061,7 +2802,10 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) int Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) { +#ifdef USE_ITHREADS dVAR; +#endif + PERL_UNUSED_CONTEXT; #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -3139,12 +2883,10 @@ 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; @@ -3152,19 +2894,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); @@ -3172,22 +2916,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; @@ -3212,12 +2943,18 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 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 @@ -3264,7 +3001,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 @@ -3297,7 +3034,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); @@ -3306,7 +3043,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 @@ -3341,27 +3078,32 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 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; - I32 items, linear, half; + 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; - I32 todo; + const char *q = from; + IV todo; for (todo = len; todo > 0; todo--) *p++ = *q++; } half = count / 2; while (items <= half) { - I32 size = items * len; + IV size = items * len; memcpy(p, to, size); p += size; items *= 2; @@ -3415,15 +3157,14 @@ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) { - dVAR; 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 @@ -3546,28 +3287,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 @@ -3618,6 +3356,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), @@ -3637,12 +3376,13 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, void * Perl_get_context(void) { - dVAR; #if defined(USE_ITHREADS) + dVAR; # 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 @@ -3659,14 +3399,19 @@ Perl_get_context(void) void Perl_set_context(void *t) { +#if defined(USE_ITHREADS) dVAR; +#endif PERL_ARGS_ASSERT_SET_CONTEXT; #if defined(USE_ITHREADS) # 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); @@ -3679,7 +3424,8 @@ Perl_set_context(void *t) struct perl_vars * Perl_GetVars(pTHX) { - return &PL_Vars; + PERL_UNUSED_CONTEXT; + return &PL_Vars; } #endif @@ -3736,110 +3482,16 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - const MGVTBL* result; PERL_UNUSED_CONTEXT; - switch(vtbl_id) { - case want_vtbl_sv: - result = &PL_vtbl_sv; - break; - case want_vtbl_env: - result = &PL_vtbl_env; - break; - case want_vtbl_envelem: - result = &PL_vtbl_envelem; - break; - case want_vtbl_sig: - result = &PL_vtbl_sig; - break; - case want_vtbl_sigelem: - result = &PL_vtbl_sigelem; - break; - case want_vtbl_pack: - result = &PL_vtbl_pack; - break; - case want_vtbl_packelem: - result = &PL_vtbl_packelem; - break; - case want_vtbl_dbline: - result = &PL_vtbl_dbline; - break; - case want_vtbl_isa: - result = &PL_vtbl_isa; - break; - case want_vtbl_isaelem: - result = &PL_vtbl_isaelem; - break; - case want_vtbl_arylen: - result = &PL_vtbl_arylen; - break; - case want_vtbl_mglob: - result = &PL_vtbl_mglob; - break; - case want_vtbl_nkeys: - result = &PL_vtbl_nkeys; - break; - case want_vtbl_taint: - result = &PL_vtbl_taint; - break; - case want_vtbl_substr: - result = &PL_vtbl_substr; - break; - case want_vtbl_vec: - result = &PL_vtbl_vec; - break; - case want_vtbl_pos: - result = &PL_vtbl_pos; - break; - case want_vtbl_bm: - result = &PL_vtbl_bm; - break; - case want_vtbl_fm: - result = &PL_vtbl_fm; - break; - case want_vtbl_uvar: - result = &PL_vtbl_uvar; - break; - case want_vtbl_defelem: - result = &PL_vtbl_defelem; - break; - case want_vtbl_regexp: - result = &PL_vtbl_regexp; - break; - case want_vtbl_regdata: - result = &PL_vtbl_regdata; - break; - case want_vtbl_regdatum: - result = &PL_vtbl_regdatum; - break; -#ifdef USE_LOCALE_COLLATE - case want_vtbl_collxfrm: - result = &PL_vtbl_collxfrm; - break; -#endif - case want_vtbl_amagic: - result = &PL_vtbl_amagic; - break; - case want_vtbl_amagicelem: - result = &PL_vtbl_amagicelem; - break; - case want_vtbl_backref: - result = &PL_vtbl_backref; - break; - case want_vtbl_utf8: - result = &PL_vtbl_utf8; - break; - default: - result = NULL; - break; - } - return (MGVTBL*)result; + return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) + ? NULL : (MGVTBL*)PL_magic_vtables + 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) @@ -3890,14 +3542,16 @@ void Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) { if (ckWARN(WARN_IO)) { - const char * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; + HEK * const name + = gv && (isGV_with_GP(gv)) + ? GvENAME_HEK((gv)) + : NULL; const char * const direction = have == '>' ? "out" : "in"; - if (name && *name) + if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for %sput", - name, direction); + "Filehandle %"HEKf" opened only for %sput", + HEKfARG(name), direction); else Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput", direction); @@ -3922,39 +3576,33 @@ Perl_report_evil_fh(pTHX_ const GV *gv) } if (ckWARN(warn_type)) { - const char * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; + SV * const name + = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? + sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; const char * const pars = (const char *)(OP_IS_FILETEST(op) ? "" : "()"); const char * const func = (const char *) - (op == OP_READLINE ? "readline" : /* "" not nice */ + (op == OP_READLINE || op == OP_RCATLINE + ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]); const char * const type = (const char *) (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"); - if (name && *name) { - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s %s", func, pars, vile, type, 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 %s?)\n", - func, pars, 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) ); - } } } @@ -3968,7 +3616,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) * */ -#ifdef HAS_GNULIBC +#ifdef __GLIBC__ # ifndef STRUCT_TM_HASZONE # define STRUCT_TM_HASZONE # endif @@ -3986,12 +3634,14 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ #ifdef HAS_TM_TM_ZONE Time_t now; const struct tm* my_tm; + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_INIT_TM; (void)time(&now); my_tm = localtime(&now); if (my_tm) Copy(my_tm, ptm, 1, struct tm); #else + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_INIT_TM; PERL_UNUSED_ARG(ptm); #endif @@ -4002,13 +3652,12 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ * semantics (and overhead) of mktime(). */ void -Perl_mini_mktime(pTHX_ struct tm *ptm) +Perl_mini_mktime(struct tm *ptm) { int yearday; int secs; int month, mday, year, jday; int odd_cent, odd_year; - PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_MINI_MKTIME; @@ -4089,15 +3738,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 @@ -4192,15 +3833,16 @@ 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 * Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, int mon, int year, int wday, int yday, int isdst) { #ifdef HAS_STRFTIME + + /* Note that yday and wday effectively are ignored by this function, as mini_mktime() overwrites them */ + char *buf; int buflen; struct tm mytm; @@ -4235,7 +3877,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 @@ -4259,7 +3905,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 */ @@ -4307,13 +3957,10 @@ 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; @@ -4455,916 +4102,11 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } -#define VERSION_MAX 0x7FFFFFFF - -/* -=for apidoc prescan_version - -Validate that a given string can be parsed as a version object, but doesn't -actually perform the parsing. Can use either strict or lax validation rules. -Can optionally set a number of hint variables to save the parsing code -some time when tokenizing. - -=cut -*/ -const char * -Perl_prescan_version(pTHX_ const char *s, bool strict, - const char **errstr, - bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { - bool qv = (sqv ? *sqv : FALSE); - int width = 3; - int saw_decimal = 0; - bool alpha = FALSE; - const char *d = s; - - PERL_ARGS_ASSERT_PRESCAN_VERSION; - - if (qv && isDIGIT(*d)) - goto dotted_decimal_version; - - if (*d == 'v') { /* explicit v-string */ - d++; - if (isDIGIT(*d)) { - qv = TRUE; - } - else { /* degenerate v-string */ - /* requires v1.2.3 */ - BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - -dotted_decimal_version: - if (strict && d[0] == '0' && isDIGIT(d[1])) { - /* no leading zeros allowed */ - BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); - } +#include "vutil.c" - while (isDIGIT(*d)) /* integer part */ - d++; - - if (*d == '.') - { - saw_decimal++; - d++; /* decimal point */ - } - else - { - if (strict) { - /* require v1.2.3 */ - BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - else { - goto version_prescan_finish; - } - } - - { - int i = 0; - int j = 0; - while (isDIGIT(*d)) { /* just keep reading */ - i++; - while (isDIGIT(*d)) { - d++; j++; - /* maximum 3 digits between decimal */ - if (strict && j > 3) { - BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); - } - } - if (*d == '_') { - if (strict) { - BADVERSION(s,errstr,"Invalid version format (no underscores)"); - } - if ( alpha ) { - BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); - } - d++; - alpha = TRUE; - } - else if (*d == '.') { - if (alpha) { - BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); - } - saw_decimal++; - d++; - } - else if (!isDIGIT(*d)) { - break; - } - j = 0; - } - - if (strict && i < 2) { - /* requires v1.2.3 */ - BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); - } - } - } /* end if dotted-decimal */ - else - { /* decimal versions */ - /* special strict case for leading '.' or '0' */ - if (strict) { - if (*d == '.') { - BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); - } - if (*d == '0' && isDIGIT(d[1])) { - BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); - } - } - - /* consume all of the integer part */ - while (isDIGIT(*d)) - d++; - - /* look for a fractional part */ - if (*d == '.') { - /* we found it, so consume it */ - saw_decimal++; - d++; - } - else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') { - if ( d == s ) { - /* found nothing */ - BADVERSION(s,errstr,"Invalid version format (version required)"); - } - /* found just an integer */ - goto version_prescan_finish; - } - else if ( d == s ) { - /* didn't find either integer or period */ - BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); - } - else if (*d == '_') { - /* underscore can't come after integer part */ - if (strict) { - BADVERSION(s,errstr,"Invalid version format (no underscores)"); - } - else if (isDIGIT(d[1])) { - BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); - } - else { - BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); - } - } - else { - /* anything else after integer part is just invalid data */ - BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); - } - - /* scan the fractional part after the decimal point*/ - - if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) { - /* strict or lax-but-not-the-end */ - BADVERSION(s,errstr,"Invalid version format (fractional part required)"); - } - - while (isDIGIT(*d)) { - d++; - if (*d == '.' && isDIGIT(d[-1])) { - if (alpha) { - BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); - } - if (strict) { - BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); - } - d = (char *)s; /* start all over again */ - qv = TRUE; - goto dotted_decimal_version; - } - if (*d == '_') { - if (strict) { - BADVERSION(s,errstr,"Invalid version format (no underscores)"); - } - if ( alpha ) { - BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); - } - if ( ! isDIGIT(d[1]) ) { - BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); - } - d++; - alpha = TRUE; - } - } - } - -version_prescan_finish: - while (isSPACE(*d)) - d++; - - if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) { - /* trailing non-numeric data */ - BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); - } - - if (sqv) - *sqv = qv; - if (swidth) - *swidth = width; - if (ssaw_decimal) - *ssaw_decimal = saw_decimal; - if (salpha) - *salpha = alpha; - return d; -} - -/* -=for apidoc scan_version - -Returns a pointer to the next character after the parsed -version string, as well as upgrading the passed in SV to -an RV. - -Function must be called with an already existing SV like - - sv = newSV(0); - s = scan_version(s, SV *sv, bool qv); - -Performs some preprocessing to the string to ensure that -it has the correct characteristics of a version. Flags the -object if it contains an underscore (which denotes this -is an alpha version). The boolean qv denotes that the version -should be interpreted as if it had multiple decimals, even if -it doesn't. - -=cut -*/ - -const char * -Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) -{ - const char *start; - const char *pos; - const char *last; - const char *errstr = NULL; - int saw_decimal = 0; - 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 */ - - 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++; - - last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); - if (errstr) { - /* "undef" is a special case and not an error */ - if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { - Perl_croak(aTHX_ "%s", errstr); - } - } - - start = s; - if (*s == 'v') - s++; - pos = s; - - 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)) { - I32 rev; - - for (;;) { - rev = 0; - { - /* this is atoi() that delimits on underscores */ - const char *end = pos; - I32 mult = 1; - I32 orev; - - /* the following if() will only be true after the decimal - * point of a version originally created with a bare - * floating point number, i.e. not quoted in any way - */ - if ( !qv && s > start && saw_decimal == 1 ) { - mult *= 100; - while ( s < end ) { - orev = rev; - rev += (*s - '0') * mult; - mult /= 10; - if ( (PERL_ABS(orev) > PERL_ABS(rev)) - || (PERL_ABS(rev) > VERSION_MAX )) { - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version %d",VERSION_MAX); - s = end - 1; - rev = VERSION_MAX; - vinf = 1; - } - s++; - if ( *s == '_' ) - s++; - } - } - else { - while (--end >= s) { - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if ( (PERL_ABS(orev) > PERL_ABS(rev)) - || (PERL_ABS(rev) > VERSION_MAX )) { - Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version"); - end = s - 1; - rev = VERSION_MAX; - vinf = 1; - } - } - } - } - - /* Append revision */ - av_push(av, newSViv(rev)); - if ( vinf ) { - s = last; - break; - } - else if ( *pos == '.' ) - s = ++pos; - else if ( *pos == '_' && isDIGIT(pos[1]) ) - s = ++pos; - else if ( *pos == ',' && isDIGIT(pos[1]) ) - s = ++pos; - else if ( isDIGIT(*pos) ) - s = pos; - else { - s = pos; - break; - } - if ( qv ) { - while ( isDIGIT(*pos) ) - pos++; - } - else { - int digits = 0; - while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { - if ( *pos != '_' ) - digits++; - pos++; - } - } - } - } - if ( qv ) { /* quoted versions always get at least three terms*/ - I32 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: - gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) - for ( len = 2 - len; len > 0; len-- ) - av_push(MUTABLE_AV(sv), newSViv(0)); - */ - len = 2 - len; - while (len-- > 0) - av_push(av, newSViv(0)); - } - - /* need to save off the current version string for later */ - if ( vinf ) { - SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); - (void)hv_stores(MUTABLE_HV(hv), "original", orig); - (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); - } - else if ( s > start ) { - SV * orig = newSVpvn(start,s-start); - if ( qv && saw_decimal == 1 && *start != 'v' ) { - /* need to insert a v to be consistent */ - sv_insert(orig, 0, 0, "v", 1); - } - (void)hv_stores(MUTABLE_HV(hv), "original", orig); - } - else { - (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); - av_push(av, newSViv(0)); - } - - /* And finally, store the AV in the hash */ - (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); - - /* fix RT#19517 - special case 'undef' as string */ - if ( *s == 'u' && strEQ(s,"undef") ) { - s += 5; - } - - return s; -} - -/* -=for apidoc new_version - -Returns a new version object based on the passed in SV: - - SV *sv = new_version(SV *ver); - -Does not alter the passed in ver SV. See "upg_version" if you -want to upgrade the SV. - -=cut -*/ - -SV * -Perl_new_version(pTHX_ SV *ver) -{ - dVAR; - SV * const rv = newSV(0); - PERL_ARGS_ASSERT_NEW_VERSION; - if ( sv_derived_from(ver,"version") ) /* can just copy directly */ - { - I32 key; - AV * const av = newAV(); - AV *sav; - /* This will get reblessed later if a derived class*/ - SV * const hv = newSVrv(rv, "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 - - if ( SvROK(ver) ) - ver = SvRV(ver); - - /* Begin copying all of the elements */ - if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) - (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - - 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)); - (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); - } - - if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) - { - SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); - (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); - } - - sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); - /* This will get reblessed later if a derived class*/ - for ( key = 0; key <= av_len(sav); key++ ) - { - const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); - av_push(av, newSViv(rev)); - } - - (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); - return rv; - } -#ifdef SvVOK - { - const MAGIC* const mg = SvVSTRING_mg(ver); - if ( mg ) { /* already a v-string */ - const STRLEN len = mg->mg_len; - char * const version = savepvn( (const char*)mg->mg_ptr, len); - sv_setpvn(rv,version,len); - /* this is for consistency with the pure Perl class */ - if ( isDIGIT(*version) ) - sv_insert(rv, 0, 0, "v", 1); - Safefree(version); - } - else { -#endif - sv_setsv(rv,ver); /* make a duplicate */ -#ifdef SvVOK - } - } -#endif - return upg_version(rv, FALSE); -} - -/* -=for apidoc upg_version - -In-place upgrade of the supplied SV to a version object. - - SV *sv = upg_version(SV *sv, bool qv); - -Returns a pointer to the upgraded SV. Set the boolean qv if you want -to force this SV to be interpreted as an "extended" version. - -=cut -*/ - -SV * -Perl_upg_version(pTHX_ SV *ver, bool qv) -{ - const char *version, *s; -#ifdef SvVOK - const MAGIC *mg; -#endif - - PERL_ARGS_ASSERT_UPG_VERSION; - - if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) - { - /* may get too much accuracy */ - char tbuf[64]; -#ifdef USE_LOCALE_NUMERIC - char *loc = setlocale(LC_NUMERIC, "C"); -#endif - STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); -#ifdef USE_LOCALE_NUMERIC - setlocale(LC_NUMERIC, loc); -#endif - while (tbuf[len-1] == '0' && len > 0) len--; - if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ - version = savepvn(tbuf, len); - } -#ifdef SvVOK - else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ - version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - qv = TRUE; - } -#endif - else /* must be a string or something like a string */ - { - STRLEN len; - version = savepv(SvPV(ver,len)); -#ifndef SvVOK -# if PERL_VERSION > 5 - /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ - if ( len >= 3 && !instr(version,".") && !instr(version,"_")) { - /* may be a v-string */ - char *testv = (char *)version; - STRLEN tlen = len; - for (tlen=0; tlen < len; tlen++, testv++) { - /* if one of the characters is non-text assume v-string */ - if (testv[0] < ' ') { - SV * const nsv = sv_newmortal(); - const char *nver; - const char *pos; - int saw_decimal = 0; - sv_setpvf(nsv,"v%vd",ver); - pos = nver = savepv(SvPV_nolen(nsv)); - - /* scan the resulting formatted string */ - pos++; /* skip the leading 'v' */ - while ( *pos == '.' || isDIGIT(*pos) ) { - if ( *pos == '.' ) - saw_decimal++ ; - pos++; - } - - /* is definitely a v-string */ - if ( saw_decimal >= 2 ) { - Safefree(version); - version = nver; - } - break; - } - } - } -# endif -#endif - } - - s = scan_version(version, ver, qv); - if ( *s != '\0' ) - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); - Safefree(version); - return ver; -} - -/* -=for apidoc vverify - -Validates that the SV contains valid internal structure for a version object. -It may be passed either the version object (RV) or the hash itself (HV). If -the structure is valid, it returns the HV. If the structure is invalid, -it returns NULL. - - SV *hv = vverify(sv); - -Note that it only confirms the bare minimum structure (so as not to get -confused by derived classes which may contain additional hash entries): - -=over 4 - -=item * The SV is an HV or a reference to an HV - -=item * The hash contains a "version" key - -=item * The "version" key has a reference to an AV as its value - -=back - -=cut -*/ - -SV * -Perl_vverify(pTHX_ SV *vs) -{ - SV *sv; - - PERL_ARGS_ASSERT_VVERIFY; - - if ( SvROK(vs) ) - vs = SvRV(vs); - - /* see if the appropriate elements exist */ - if ( SvTYPE(vs) == SVt_PVHV - && hv_exists(MUTABLE_HV(vs), "version", 7) - && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) - && SvTYPE(sv) == SVt_PVAV ) - return vs; - else - return NULL; -} - -/* -=for apidoc vnumify - -Accepts a version object and returns the normalized floating -point representation. Call like: - - sv = vnumify(rv); - -NOTE: you can pass either the object directly or the SV -contained within the RV. - -The SV returned has a refcount of 1. - -=cut -*/ - -SV * -Perl_vnumify(pTHX_ SV *vs) -{ - I32 i, len, digit; - int width; - bool alpha = FALSE; - SV *sv; - AV *av; - - PERL_ARGS_ASSERT_VNUMIFY; - - /* extract the HV from the object */ - vs = vverify(vs); - if ( ! vs ) - Perl_croak(aTHX_ "Invalid version object"); - - /* see if various flags exist */ - if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) - alpha = TRUE; - if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) - width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); - else - width = 3; - - - /* attempt to retrieve the version array */ - if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { - return newSVpvs("0"); - } - - len = av_len(av); - if ( len == -1 ) - { - return newSVpvs("0"); - } - - digit = SvIV(*av_fetch(av, 0, 0)); - sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); - for ( i = 1 ; i < len ; i++ ) - { - digit = SvIV(*av_fetch(av, i, 0)); - if ( width < 3 ) { - const int denom = (width == 2 ? 10 : 100); - const div_t term = div((int)PERL_ABS(digit),denom); - Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); - } - else { - Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); - } - } - - if ( len > 0 ) - { - digit = SvIV(*av_fetch(av, len, 0)); - if ( alpha && width == 3 ) /* alpha version */ - sv_catpvs(sv,"_"); - Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); - } - else /* len == 0 */ - { - sv_catpvs(sv, "000"); - } - return sv; -} - -/* -=for apidoc vnormal - -Accepts a version object and returns the normalized string -representation. Call like: - - sv = vnormal(rv); - -NOTE: you can pass either the object directly or the SV -contained within the RV. - -The SV returned has a refcount of 1. - -=cut -*/ - -SV * -Perl_vnormal(pTHX_ SV *vs) -{ - I32 i, len, digit; - bool alpha = FALSE; - SV *sv; - AV *av; - - PERL_ARGS_ASSERT_VNORMAL; - - /* extract the HV from the object */ - vs = vverify(vs); - if ( ! vs ) - Perl_croak(aTHX_ "Invalid version object"); - - if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) - alpha = TRUE; - av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); - - len = av_len(av); - if ( len == -1 ) - { - return newSVpvs(""); - } - digit = SvIV(*av_fetch(av, 0, 0)); - sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); - for ( i = 1 ; i < len ; i++ ) { - digit = SvIV(*av_fetch(av, i, 0)); - Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); - } - - if ( len > 0 ) - { - /* handle last digit specially */ - digit = SvIV(*av_fetch(av, len, 0)); - if ( alpha ) - Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); - else - Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); - } - - if ( len <= 2 ) { /* short version, must be at least three */ - for ( len = 2 - len; len != 0; len-- ) - sv_catpvs(sv,".0"); - } - return sv; -} - -/* -=for apidoc vstringify - -In order to maintain maximum compatibility with earlier versions -of Perl, this function will return either the floating point -notation or the multiple dotted notation, depending on whether -the original version contained 1 or more dots, respectively. - -The SV returned has a refcount of 1. - -=cut -*/ - -SV * -Perl_vstringify(pTHX_ SV *vs) -{ - PERL_ARGS_ASSERT_VSTRINGIFY; - - /* extract the HV from the object */ - vs = vverify(vs); - if ( ! vs ) - Perl_croak(aTHX_ "Invalid version object"); - - if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { - SV *pv; - pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); - if ( SvPOK(pv) ) - return newSVsv(pv); - else - return &PL_sv_undef; - } - else { - if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) - return vnormal(vs); - else - return vnumify(vs); - } -} - -/* -=for apidoc vcmp - -Version object aware cmp. Both operands must already have been -converted into version objects. - -=cut -*/ - -int -Perl_vcmp(pTHX_ SV *lhv, SV *rhv) -{ - I32 i,l,m,r,retval; - bool lalpha = FALSE; - bool ralpha = FALSE; - I32 left = 0; - I32 right = 0; - AV *lav, *rav; - - PERL_ARGS_ASSERT_VCMP; - - /* extract the HVs from the objects */ - lhv = vverify(lhv); - rhv = vverify(rhv); - if ( ! ( lhv && rhv ) ) - Perl_croak(aTHX_ "Invalid version object"); - - /* get the left hand term */ - lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); - if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) - lalpha = TRUE; - - /* and the right hand term */ - rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); - if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) - ralpha = TRUE; - - l = av_len(lav); - r = av_len(rav); - m = l < r ? l : r; - retval = 0; - i = 0; - while ( i <= m && retval == 0 ) - { - left = SvIV(*av_fetch(lav,i,0)); - right = SvIV(*av_fetch(rav,i,0)); - if ( left < right ) - retval = -1; - if ( left > right ) - retval = +1; - i++; - } - - /* tiebreaker for alpha with identical terms */ - if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) ) - { - if ( lalpha && !ralpha ) - { - retval = -1; - } - else if ( ralpha && !lalpha) - { - retval = +1; - } - } - - if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ - { - if ( l < r ) - { - while ( i <= r && retval == 0 ) - { - if ( SvIV(*av_fetch(rav,i,0)) != 0 ) - retval = -1; /* not a match after all */ - i++; - } - } - else - { - while ( i <= l && retval == 0 ) - { - if ( SvIV(*av_fetch(lav,i,0)) != 0 ) - retval = +1; /* not a match after all */ - i++; - } - } - } - return retval; -} - -#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) -# define EMULATE_SOCKETPAIR_UDP -#endif +#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT) +# define EMULATE_SOCKETPAIR_UDP +#endif #ifdef EMULATE_SOCKETPAIR_UDP static int @@ -5512,7 +4254,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; @@ -5538,6 +4280,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; @@ -5613,7 +4356,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { } #else /* In any case have a stub so that there's code corresponding - * to the my_socketpair in global.sym. */ + * to the my_socketpair in embed.fnc. */ int Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #ifdef HAS_SOCKETPAIR @@ -5629,7 +4372,8 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { =for apidoc sv_nosharing Dummy routine which "shares" an SV when there is no sharing module present. -Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument. +Or "locks" it. Or "unlocks" it. In other +words, ignores its single SV argument. Exists to avoid test for a NULL function pointer and because it could potentially warn under some level of strict-ness. @@ -5673,9 +4417,9 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { - opt = (U32) atoi(p); - while (isDIGIT(*p)) - p++; + const char* endptr; + opt = (U32) grok_atou(p, &endptr); + p = endptr; if (*p && *p != '\n' && *p != '\r') { if(isSPACE(*p)) goto the_end_of_the_opts_parser; else @@ -5730,10 +4474,13 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) return opt; } +#ifdef VMS +# include +#endif + U32 Perl_seed(pTHX) { - dVAR; /* * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which @@ -5761,7 +4508,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]; @@ -5812,63 +4558,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; -#ifdef USE_ITHREADS -bool -Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) -{ - const char * const stashpv = CopSTASHPV(c); - const char * const name = HvNAME_get(hv); - PERL_UNUSED_CONTEXT; - PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH; + 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 (stashpv == name) - return TRUE; - if (stashpv && name) - if (strEQ(stashpv, name)) - return TRUE; - return FALSE; -} + 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 @@ -5880,8 +4648,9 @@ Perl_init_global_struct(pTHX) { struct perl_vars *plvarsp = NULL; # ifdef PERL_GLOBAL_STRUCT - const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); - const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); + const IV nppaddr = C_ARRAY_LENGTH(Gppaddr); + const IV ncheck = C_ARRAY_LENGTH(Gcheck); + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT_PRIVATE /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); @@ -5894,18 +4663,15 @@ Perl_init_global_struct(pTHX) # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC -# define PERLVAR(var,type) /**/ -# define PERLVARA(var,n,type) /**/ -# define PERLVARI(var,type,init) plvarsp->var = init; -# define PERLVARIC(var,type,init) plvarsp->var = init; -# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# define PERLVAR(prefix,var,type) /**/ +# define PERLVARA(prefix,var,n,type) /**/ +# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; +# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; # include "perlvars.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC # ifdef PERL_GLOBAL_STRUCT plvarsp->Gppaddr = (Perl_ppaddr_t*) @@ -5923,6 +4689,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; @@ -5935,11 +4705,16 @@ Perl_init_global_struct(pTHX) void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) { + int veto = plvarsp->Gveto_cleanup; + PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; + PERL_UNUSED_CONTEXT; # ifdef PERL_GLOBAL_STRUCT # ifdef PERL_UNSET_VARS PERL_UNSET_VARS(plvarsp); # endif + if (veto) + return; free(plvarsp->Gppaddr); free(plvarsp->Gcheck); # ifdef PERL_GLOBAL_STRUCT_PRIVATE @@ -5959,7 +4734,7 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) * The default implementation reads a single env var, PERL_MEM_LOG, * expecting one or more of the following: * - * \d+ - fd fd to write to : must be 1st (atoi) + * \d+ - fd fd to write to : must be 1st (grok_atou) * 'm' - memlog was PERL_MEM_LOG=1 * 's' - svlog was PERL_SV_LOG=1 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 @@ -6027,14 +4802,15 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, * timeval. */ { STRLEN len; - int fd = atoi(pmlenv); + const char* endptr; + int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */ if (!fd) fd = PERL_MEM_LOG_FD; if (strchr(pmlenv, 't')) { len = my_snprintf(buf, sizeof(buf), MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); - PerlLIO_write(fd, buf, len); + PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); } switch (mlt) { case MLT_ALLOC: @@ -6069,7 +4845,7 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, default: len = 0; } - PerlLIO_write(fd, buf, len); + PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len)); } } } @@ -6146,7 +4922,7 @@ Perl_mem_log_del_sv(const SV *sv, =for apidoc my_sprintf The C library C, wrapped if necessary, to ensure that it will return -the length of the string written to the buffer. Only rare pre-ANSI systems +the length of the string written to the buffer. Only rare pre-ANSI systems need the wrapper function - usually this is a direct call to C. =cut @@ -6165,6 +4941,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) #endif /* +=for apidoc quadmath_format_single + +quadmath_snprintf() is very strict about its format string and will +fail, returning -1, if the format is invalid. It acccepts exactly +one format spec. + +quadmath_format_single() checks that the intended single spec looks +sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>, +and has C before it. This is not a full "printf syntax check", +just the basics. + +Returns the format if it is valid, NULL if not. + +quadmath_format_single() can and will actually patch in the missing +C, if necessary. In this case it will return the modified copy of +the format, B + +See also L. + +=cut +*/ +#ifdef USE_QUADMATH +const char* +Perl_quadmath_format_single(const char* format) +{ + STRLEN len; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE; + + if (format[0] != '%' || strchr(format + 1, '%')) + return NULL; + len = strlen(format); + /* minimum length three: %Qg */ + if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL) + return NULL; + if (format[len - 2] != 'Q') { + char* fixed; + Newx(fixed, len + 1, char); + memcpy(fixed, format, len - 1); + fixed[len - 1] = 'Q'; + fixed[len ] = format[len - 1]; + fixed[len + 1] = 0; + return (const char*)fixed; + } + return format; +} +#endif + +/* +=for apidoc quadmath_format_needed + +quadmath_format_needed() returns true if the format string seems to +contain at least one non-Q-prefixed %[efgaEFGA] format specifier, +or returns false otherwise. + +The format specifier detection is not complete printf-syntax detection, +but it should catch most common cases. + +If true is returned, those arguments B in theory be processed +with quadmath_snprintf(), but in case there is more than one such +format specifier (see L), and if there is +anything else beyond that one (even just a single byte), they +B be processed because quadmath_snprintf() is very strict, +accepting only one format spec, and nothing else. +In this case, the code should probably fail. + +=cut +*/ +#ifdef USE_QUADMATH +bool +Perl_quadmath_format_needed(const char* format) +{ + const char *p = format; + const char *q; + + PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED; + + while ((q = strchr(p, '%'))) { + q++; + if (*q == '+') /* plus */ + q++; + if (*q == '#') /* alt */ + q++; + if (*q == '*') /* width */ + q++; + else { + if (isDIGIT(*q)) { + while (isDIGIT(*q)) q++; + } + } + if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */ + q++; + if (*q == '*') + q++; + else + while (isDIGIT(*q)) q++; + } + if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */ + return TRUE; + p = q + 1; + } + return FALSE; +} +#endif + +/* =for apidoc my_snprintf The C library C functionality, if available and @@ -6179,15 +5061,59 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - dTHX; - int retval; + int retval = -1; va_list ap; PERL_ARGS_ASSERT_MY_SNPRINTF; +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif va_start(ap, format); +#ifdef USE_QUADMATH + { + const char* qfmt = quadmath_format_single(format); + bool quadmath_valid = FALSE; + if (qfmt) { + /* If the format looked promising, use it as quadmath. */ + retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV)); + if (retval == -1) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + quadmath_valid = TRUE; + if (qfmt != format) + Safefree(qfmt); + qfmt = NULL; + } + assert(qfmt == NULL); + /* quadmath_format_single() will return false for example for + * "foo = %g", or simply "%g". We could handle the %g by + * using quadmath for the NV args. More complex cases of + * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise + * quadmath-valid but has stuff in front). + * + * Handling the "Q-less" cases right would require walking + * through the va_list and rewriting the format, calling + * quadmath for the NVs, building a new va_list, and then + * letting vsnprintf/vsprintf to take care of the other + * arguments. This may be doable. + * + * We do not attempt that now. But for paranoia, we here try + * to detect some common (but not all) cases where the + * "Q-less" %[efgaEFGA] formats are present, and die if + * detected. This doesn't fix the problem, but it stops the + * vsnprintf/vsprintf pulling doubles off the va_list when + * __float128 NVs should be pulled off instead. + * + * If quadmath_format_needed() returns false, we are reasonably + * certain that we can call vnsprintf() or vsprintf() safely. */ + if (!quadmath_valid && quadmath_format_needed(format)) + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format); + + } +#endif + if (retval == -1) #ifdef HAS_VSNPRINTF - retval = vsnprintf(buffer, len, format, ap); + retval = vsnprintf(buffer, len, format, ap); #else - retval = vsprintf(buffer, format, ap); + retval = vsprintf(buffer, format, ap); #endif va_end(ap); /* vsprintf() shows failure with < 0 */ @@ -6198,7 +5124,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; } @@ -6216,19 +5142,29 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { - dTHX; +#ifdef USE_QUADMATH + PERL_UNUSED_ARG(buffer); + PERL_UNUSED_ARG(len); + PERL_UNUSED_ARG(format); + PERL_UNUSED_ARG(ap); + Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); + return 0; +#else int retval; #ifdef NEED_VA_COPY va_list apc; PERL_ARGS_ASSERT_MY_VSNPRINTF; - +#ifndef HAS_VSNPRINTF + PERL_UNUSED_VAR(len); +#endif Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); # else retval = vsprintf(buffer, format, apc); # endif + va_end(apc); #else # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); @@ -6244,8 +5180,9 @@ 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; +#endif } void @@ -6277,15 +5214,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'; @@ -6421,8 +5357,139 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) #endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ #endif /* PERL_IMPLICIT_CONTEXT */ -void -Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, + +/* Perl_xs_handshake(): + implement the various XS_*_BOOTCHECK macros, which are added to .c + files by ExtUtils::ParseXS, to check that the perl the module was built + with is binary compatible with the running perl. + + usage: + Perl_xs_handshake(U32 key, void * v_my_perl, const char * file, + [U32 items, U32 ax], [char * api_version], [char * xs_version]) + + The meaning of the varargs is determined the U32 key arg (which is not + a format string). The fields of key are assembled by using HS_KEY(). + + Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type + "PerlInterpreter *" and represents the callers context; otherwise it is + of type "CV *", and is the boot xsub's CV. + + v_my_perl will catch where a threaded future perl526.dll calling IO.dll + for example, and IO.dll was linked with threaded perl524.dll, and both + perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader + successfully can load IO.dll into the process but simultaneously it + loaded an interpreter of a different version into the process, and XS + code will naturally pass SV*s created by perl524.dll for perl526.dll to + use through perl526.dll's my_perl->Istack_base. + + v_my_perl cannot be the first arg, since then 'key' will be out of + place in a threaded vs non-threaded mixup; and analyzing the key + number's bitfields won't reveal the problem, since it will be a valid + key (unthreaded perl) on interp side, but croak will report the XS mod's + key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if + it's a threaded perl and an unthreaded XS module, threaded perl will + look at an uninit C stack or an uninit register to get 'key' + (remember that it assumes that the 1st arg is the interp cxt). + + 'file' is the source filename of the caller. +*/ + +I32 +Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) +{ + va_list args; + U32 items, ax; + void * got; + void * need; +#ifdef PERL_IMPLICIT_CONTEXT + dTHX; + tTHX xs_interp; +#else + CV* cv; + SV *** xs_spp; +#endif + PERL_ARGS_ASSERT_XS_HANDSHAKE; + va_start(args, file); + + got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH)); + need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH); + if (UNLIKELY(got != need)) + goto bad_handshake; +/* try to catch where a 2nd threaded perl interp DLL is loaded into a process + by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the + 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so + dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub + passed to the XS DLL */ +#ifdef PERL_IMPLICIT_CONTEXT + xs_interp = (tTHX)v_my_perl; + got = xs_interp; + need = my_perl; +#else +/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is + loaded into a process by a XS DLL built by an unthreaded perl522.dll perl, + but the DynaLoder/Perl that started the process and loaded the XS DLL is + unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *) + through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's + location in the unthreaded perl binary) stored in CV * to figure out if this + Perl_xs_handshake was called by the same pp_entersub */ + cv = (CV*)v_my_perl; + xs_spp = (SV***)CvHSCXT(cv); + got = xs_spp; + need = &PL_stack_sp; +#endif + if(UNLIKELY(got != need)) { + bad_handshake:/* recycle branch and string from above */ + if(got != (void *)HSf_NOCHK) + noperl_die("%s: loadable library and perl binaries are mismatched" + " (got handshake key %p, needed %p)\n", + file, got, need); + } + + if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */ + SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */ + PL_xsubfilename = file; /* so the old name must be restored for + additional XSUBs to register themselves */ + (void)gv_fetchfile(file); + } + + if(key & HSf_POPMARK) { + ax = POPMARK; + { SV **mark = PL_stack_base + ax++; + { dSP; + items = (I32)(SP - MARK); + } + } + } else { + items = va_arg(args, U32); + ax = va_arg(args, U32); + } + { + U32 apiverlen; + assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX); + if((apiverlen = HS_GETAPIVERLEN(key))) { + char * api_p = va_arg(args, char*); + if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 + || memNE(api_p, "v" PERL_API_VERSION_STRING, + sizeof("v" PERL_API_VERSION_STRING)-1)) + Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s", + api_p, SVfARG(PL_stack_base[ax + 0]), + "v" PERL_API_VERSION_STRING); + } + } + { + U32 xsverlen; + assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX); + if((xsverlen = HS_GETXSVERLEN(key))) + S_xs_version_bootcheck(aTHX_ + items, ax, va_arg(args, char*), xsverlen); + } + va_end(args); + return ax; +} + + +STATIC void +S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, STRLEN xs_len) { SV *sv; @@ -6436,30 +5503,30 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, else { /* XXX GV_ADDWARN */ vn = "XS_VERSION"; - sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0); if (!sv || !SvOK(sv)) { vn = "VERSION"; - sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0); + sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0); } } 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) ) { SV *string = vstringify(xssv); SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf - " does not match ", module, string); + " does not match ", SVfARG(module), SVfARG(string)); SvREFCNT_dec(string); string = vstringify(pmsv); if (vn) { - Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn, - string); + Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn, + SVfARG(string)); } else { - Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string); + Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string)); } SvREFCNT_dec(string); @@ -6469,36 +5536,26 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, } } -void -Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p, - STRLEN api_len) -{ - SV *xpt = NULL; - SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP); - SV *runver; +/* +=for apidoc my_strlcat - PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; +The C library C if available, or a Perl implementation of it. +This operates on C C-terminated strings. - /* This might croak */ - compver = upg_version(compver, 0); - /* This should never croak */ - runver = new_version(PL_apiversion); - if (vcmp(compver, runver)) { - SV *compver_string = vstringify(compver); - SV *runver_string = vstringify(runver); - xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf - " of %"SVf" does not match %"SVf, - compver_string, module, runver_string); - Perl_sv_2mortal(aTHX_ xpt); +C appends string C to the end of C. It will append at +most S> characters. It will then C-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 C-terminated string). - SvREFCNT_dec(compver_string); - SvREFCNT_dec(runver_string); - } - SvREFCNT_dec(runver); - if (xpt) - Perl_croak_sv(aTHX_ xpt); -} +Note that C is the full size of the destination buffer and +the result is guaranteed to be C-terminated if there is room. Note that +room for the C 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) @@ -6516,6 +5573,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 C-terminated strings. + +C copies up to S> characters from the string C +to C, C-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) @@ -6538,41 +5609,60 @@ long _ftol( double ); /* Defined by VC6 C libs. */ long _ftol2( double dblSource ) { return _ftol( dblSource ); } #endif +PERL_STATIC_INLINE bool +S_gv_has_usable_name(pTHX_ GV *gv) +{ + GV **gvp; + return GvSTASH(gv) + && HvENAME(GvSTASH(gv)) + && (gvp = (GV **)hv_fetchhek( + GvSTASH(gv), GvNAME_HEK(gv), 0 + )) + && *gvp == gv; +} + void 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; - /* We do not care about using sv to call CV; + /* When we are called from pp_goto (svp is null), + * we do not care about using dbsv to call CV; * it's for informational purposes only. */ PERL_ARGS_ASSERT_GET_DB_SUB; - PL_tainted = FALSE; + TAINT_set(FALSE); save_item(dbsv); if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + if (!svp && !CvLEXICAL(cv)) { + gv_efullname3(dbsv, gv, NULL); + } + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + || ( /* Could be imported, and old sub redefined. */ + (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) + && !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((const GV *)*svp) == cv) - && (gv = (GV *)*svp) + /* Use GV from the stack as a fallback. */ + && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) ) ) - )) { - /* Use GV from the stack as a fallback. */ + ) { /* GV is potentially non-unique, or contain different CV. */ SV * const tmp = newRV(MUTABLE_SV(cv)); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } else { - gv_efullname3(dbsv, gv, NULL); + sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); + sv_catpvs(dbsv, "::"); + sv_cathek(dbsv, GvNAME_HEK(gv)); } } else { @@ -6582,11 +5672,15 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) (void)SvIOK_on(dbsv); SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */ } + SvSETMAGIC(dbsv); TAINT_IF(save_taint); +#ifdef NO_TAINT_SUPPORT + PERL_UNUSED_VAR(save_taint); +#endif } int -Perl_my_dirfd(pTHX_ DIR * dir) { +Perl_my_dirfd(DIR * dir) { /* Most dirfd implementations have problems when passed NULL. */ if(!dir) @@ -6596,8 +5690,8 @@ Perl_my_dirfd(pTHX_ DIR * dir) { #elif defined(HAS_DIR_DD_FD) return dir->dd_fd; #else - Perl_die(aTHX_ PL_no_func, "dirfd"); - /* NOT REACHED */ + Perl_croak_nocontext(PL_no_func, "dirfd"); + NOT_REACHED; /* NOT REACHED */ return 0; #endif } @@ -6618,11 +5712,775 @@ 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 +} + +#ifdef USE_C_BACKTRACE + +/* Possibly move all this USE_C_BACKTRACE code into a new file. */ + +#ifdef USE_BFD + +typedef struct { + /* abfd is the BFD handle. */ + bfd* abfd; + /* bfd_syms is the BFD symbol table. */ + asymbol** bfd_syms; + /* bfd_text is handle to the the ".text" section of the object file. */ + asection* bfd_text; + /* Since opening the executable and scanning its symbols is quite + * heavy operation, we remember the filename we used the last time, + * and do the opening and scanning only if the filename changes. + * This removes most (but not all) open+scan cycles. */ + const char* fname_prev; +} bfd_context; + +/* Given a dl_info, update the BFD context if necessary. */ +static void bfd_update(bfd_context* ctx, Dl_info* dl_info) +{ + /* BFD open and scan only if the filename changed. */ + if (ctx->fname_prev == NULL || + strNE(dl_info->dli_fname, ctx->fname_prev)) { + if (ctx->abfd) { + bfd_close(ctx->abfd); + } + ctx->abfd = bfd_openr(dl_info->dli_fname, 0); + if (ctx->abfd) { + if (bfd_check_format(ctx->abfd, bfd_object)) { + IV symbol_size = bfd_get_symtab_upper_bound(ctx->abfd); + if (symbol_size > 0) { + Safefree(ctx->bfd_syms); + Newx(ctx->bfd_syms, symbol_size, asymbol*); + ctx->bfd_text = + bfd_get_section_by_name(ctx->abfd, ".text"); + } + else + ctx->abfd = NULL; + } + else + ctx->abfd = NULL; + } + ctx->fname_prev = dl_info->dli_fname; + } +} + +/* Given a raw frame, try to symbolize it and store + * symbol information (source file, line number) away. */ +static void bfd_symbolize(bfd_context* ctx, + void* raw_frame, + char** symbol_name, + STRLEN* symbol_name_size, + char** source_name, + STRLEN* source_name_size, + STRLEN* source_line) +{ + *symbol_name = NULL; + *symbol_name_size = 0; + if (ctx->abfd) { + IV offset = PTR2IV(raw_frame) - PTR2IV(ctx->bfd_text->vma); + if (offset > 0 && + bfd_canonicalize_symtab(ctx->abfd, ctx->bfd_syms) > 0) { + const char *file; + const char *func; + unsigned int line = 0; + if (bfd_find_nearest_line(ctx->abfd, ctx->bfd_text, + ctx->bfd_syms, offset, + &file, &func, &line) && + file && func && line > 0) { + /* Size and copy the source file, use only + * the basename of the source file. + * + * NOTE: the basenames are fine for the + * Perl source files, but may not always + * be the best idea for XS files. */ + const char *p, *b = NULL; + /* Look for the last slash. */ + for (p = file; *p; p++) { + if (*p == '/') + b = p + 1; + } + if (b == NULL || *b == 0) { + b = file; + } + *source_name_size = p - b + 1; + Newx(*source_name, *source_name_size + 1, char); + Copy(b, *source_name, *source_name_size + 1, char); + + *symbol_name_size = strlen(func); + Newx(*symbol_name, *symbol_name_size + 1, char); + Copy(func, *symbol_name, *symbol_name_size + 1, char); + + *source_line = line; + } + } + } +} + +#endif /* #ifdef USE_BFD */ + +#ifdef PERL_DARWIN + +/* OS X has no public API for for 'symbolicating' (Apple official term) + * stack addresses to {function_name, source_file, line_number}. + * Good news: there is command line utility atos(1) which does that. + * Bad news 1: it's a command line utility. + * Bad news 2: one needs to have the Developer Tools installed. + * Bad news 3: in newer releases it needs to be run as 'xcrun atos'. + * + * To recap: we need to open a pipe for reading for a utility which + * might not exist, or exists in different locations, and then parse + * the output. And since this is all for a low-level API, we cannot + * use high-level stuff. Thanks, Apple. */ + +typedef struct { + /* tool is set to the absolute pathname of the tool to use: + * xcrun or atos. */ + const char* tool; + /* format is set to a printf format string used for building + * the external command to run. */ + const char* format; + /* unavail is set if e.g. xcrun cannot be found, or something + * else happens that makes getting the backtrace dubious. Note, + * however, that the context isn't persistent, the next call to + * get_c_backtrace() will start from scratch. */ + bool unavail; + /* fname is the current object file name. */ + const char* fname; + /* object_base_addr is the base address of the shared object. */ + void* object_base_addr; +} atos_context; + +/* Given |dl_info|, updates the context. If the context has been + * marked unavailable, return immediately. If not but the tool has + * not been set, set it to either "xcrun atos" or "atos" (also set the + * format to use for creating commands for piping), or if neither is + * unavailable (one needs the Developer Tools installed), mark the context + * an unavailable. Finally, update the filename (object name), + * and its base address. */ + +static void atos_update(atos_context* ctx, + Dl_info* dl_info) +{ + if (ctx->unavail) + return; + if (ctx->tool == NULL) { + const char* tools[] = { + "/usr/bin/xcrun", + "/usr/bin/atos" + }; + const char* formats[] = { + "/usr/bin/xcrun atos -o '%s' -l %08x %08x 2>&1", + "/usr/bin/atos -d -o '%s' -l %08x %08x 2>&1" + }; + struct stat st; + UV i; + for (i = 0; i < C_ARRAY_LENGTH(tools); i++) { + if (stat(tools[i], &st) == 0 && S_ISREG(st.st_mode)) { + ctx->tool = tools[i]; + ctx->format = formats[i]; + break; + } + } + if (ctx->tool == NULL) { + ctx->unavail = TRUE; + return; + } + } + if (ctx->fname == NULL || + strNE(dl_info->dli_fname, ctx->fname)) { + ctx->fname = dl_info->dli_fname; + ctx->object_base_addr = dl_info->dli_fbase; + } +} + +/* Given an output buffer end |p| and its |start|, matches + * for the atos output, extracting the source code location + * and returning non-NULL if possible, returning NULL otherwise. */ +static const char* atos_parse(const char* p, + const char* start, + STRLEN* source_name_size, + STRLEN* source_line) { + /* atos() output is something like: + * perl_parse (in miniperl) (perl.c:2314)\n\n". + * We cannot use Perl regular expressions, because we need to + * stay low-level. Therefore here we have a rolled-out version + * of a state machine which matches _backwards_from_the_end_ and + * if there's a success, returns the starts of the filename, + * also setting the filename size and the source line number. + * The matched regular expression is roughly "\(.*:\d+\)\s*$" */ + const char* source_number_start; + const char* source_name_end; + const char* source_line_end; + const char* close_paren; + /* Skip trailing whitespace. */ + while (p > start && isspace(*p)) p--; + /* Now we should be at the close paren. */ + if (p == start || *p != ')') + return NULL; + close_paren = p; + p--; + /* Now we should be in the line number. */ + if (p == start || !isdigit(*p)) + return NULL; + /* Skip over the digits. */ + while (p > start && isdigit(*p)) + p--; + /* Now we should be at the colon. */ + if (p == start || *p != ':') + return NULL; + source_number_start = p + 1; + source_name_end = p; /* Just beyond the end. */ + p--; + /* Look for the open paren. */ + while (p > start && *p != '(') + p--; + if (p == start) + return NULL; + p++; + *source_name_size = source_name_end - p; + *source_line = grok_atou(source_number_start, &source_line_end); + if (source_line_end != close_paren) + return NULL; + return p; +} + +/* Given a raw frame, read a pipe from the symbolicator (that's the + * technical term) atos, reads the result, and parses the source code + * location. We must stay low-level, so we use snprintf(), pipe(), + * and fread(), and then also parse the output ourselves. */ +static void atos_symbolize(atos_context* ctx, + void* raw_frame, + char** source_name, + STRLEN* source_name_size, + STRLEN* source_line) +{ + char cmd[1024]; + const char* p; + Size_t cnt; + + if (ctx->unavail) + return; + /* Simple security measure: if there's any funny business with + * the object name (used as "-o '%s'" ), leave since at least + * partially the user controls it. */ + for (p = ctx->fname; *p; p++) { + if (*p == '\'' || iscntrl(*p)) { + ctx->unavail = TRUE; + return; + } + } + cnt = snprintf(cmd, sizeof(cmd), ctx->format, + ctx->fname, ctx->object_base_addr, raw_frame); + if (cnt < sizeof(cmd)) { + /* Undo nostdio.h #defines that disable stdio. + * This is somewhat naughty, but is used elsewhere + * in the core, and affects only OS X. */ +#undef FILE +#undef popen +#undef fread +#undef pclose + FILE* fp = popen(cmd, "r"); + /* At the moment we open a new pipe for each stack frame. + * This is naturally somewhat slow, but hopefully generating + * stack traces is never going to in a performance critical path. + * + * We could play tricks with atos by batching the stack + * addresses to be resolved: atos can either take multiple + * addresses from the command line, or read addresses from + * a file (though the mess of creating temporary files would + * probably negate much of any possible speedup). + * + * Normally there are only two objects present in the backtrace: + * perl itself, and the libdyld.dylib. (Note that the object + * filenames contain the full pathname, so perl may not always + * be in the same place.) Whenever the object in the + * backtrace changes, the base address also changes. + * + * The problem with batching the addresses, though, would be + * matching the results with the addresses: the parsing of + * the results is already painful enough with a single address. */ + if (fp) { + char out[1024]; + UV cnt = fread(out, 1, sizeof(out), fp); + if (cnt < sizeof(out)) { + const char* p = atos_parse(out + cnt, out, + source_name_size, + source_line); + if (p) { + Newx(*source_name, + *source_name_size + 1, char); + Copy(p, *source_name, + *source_name_size + 1, char); + } + } + pclose(fp); + } + } +} + +#endif /* #ifdef PERL_DARWIN */ + +/* +=for apidoc get_c_backtrace + +Collects the backtrace (aka "stacktrace") into a single linear +malloced buffer, which the caller B Perl_free_c_backtrace(). + +Scans the frames back by depth + skip, then drops the skip innermost, +returning at most depth frames. + +=cut +*/ + +Perl_c_backtrace* +Perl_get_c_backtrace(pTHX_ int depth, int skip) +{ + /* Note that here we must stay as low-level as possible: Newx(), + * Copy(), Safefree(); since we may be called from anywhere, + * so we should avoid higher level constructs like SVs or AVs. + * + * Since we are using safesysmalloc() via Newx(), don't try + * getting backtrace() there, unless you like deep recursion. */ + + /* Currently only implemented with backtrace() and dladdr(), + * for other platforms NULL is returned. */ + +#if defined(HAS_BACKTRACE) && defined(HAS_DLADDR) + /* backtrace() is available via in glibc and in most + * modern BSDs; dladdr() is available via . */ + + /* We try fetching this many frames total, but then discard + * the |skip| first ones. For the remaining ones we will try + * retrieving more information with dladdr(). */ + int try_depth = skip + depth; + + /* The addresses (program counters) returned by backtrace(). */ + void** raw_frames; + + /* Retrieved with dladdr() from the addresses returned by backtrace(). */ + Dl_info* dl_infos; + + /* Sizes _including_ the terminating \0 of the object name + * and symbol name strings. */ + STRLEN* object_name_sizes; + STRLEN* symbol_name_sizes; + +#ifdef USE_BFD + /* The symbol names comes either from dli_sname, + * or if using BFD, they can come from BFD. */ + char** symbol_names; +#endif + + /* The source code location information. Dug out with e.g. BFD. */ + char** source_names; + STRLEN* source_name_sizes; + STRLEN* source_lines; + + Perl_c_backtrace* bt = NULL; /* This is what will be returned. */ + int got_depth; /* How many frames were returned from backtrace(). */ + UV frame_count = 0; /* How many frames we return. */ + UV total_bytes = 0; /* The size of the whole returned backtrace. */ + +#ifdef USE_BFD + bfd_context bfd_ctx; +#endif +#ifdef PERL_DARWIN + atos_context atos_ctx; +#endif + + /* Here are probably possibilities for optimizing. We could for + * example have a struct that contains most of these and then + * allocate |try_depth| of them, saving a bunch of malloc calls. + * Note, however, that |frames| could not be part of that struct + * because backtrace() will want an array of just them. Also be + * careful about the name strings. */ + Newx(raw_frames, try_depth, void*); + Newx(dl_infos, try_depth, Dl_info); + Newx(object_name_sizes, try_depth, STRLEN); + Newx(symbol_name_sizes, try_depth, STRLEN); + Newx(source_names, try_depth, char*); + Newx(source_name_sizes, try_depth, STRLEN); + Newx(source_lines, try_depth, STRLEN); +#ifdef USE_BFD + Newx(symbol_names, try_depth, char*); +#endif + + /* Get the raw frames. */ + got_depth = (int)backtrace(raw_frames, try_depth); + + /* We use dladdr() instead of backtrace_symbols() because we want + * the full details instead of opaque strings. This is useful for + * two reasons: () the details are needed for further symbolic + * digging, for example in OS X (2) by having the details we fully + * control the output, which in turn is useful when more platforms + * are added: we can keep out output "portable". */ + + /* We want a single linear allocation, which can then be freed + * with a single swoop. We will do the usual trick of first + * walking over the structure and seeing how much we need to + * allocate, then allocating, and then walking over the structure + * the second time and populating it. */ + + /* First we must compute the total size of the buffer. */ + total_bytes = sizeof(Perl_c_backtrace_header); + if (got_depth > skip) { + int i; +#ifdef USE_BFD + bfd_init(); /* Is this safe to call multiple times? */ + Zero(&bfd_ctx, 1, bfd_context); +#endif +#ifdef PERL_DARWIN + Zero(&atos_ctx, 1, atos_context); +#endif + for (i = skip; i < try_depth; i++) { + Dl_info* dl_info = &dl_infos[i]; + + total_bytes += sizeof(Perl_c_backtrace_frame); + + source_names[i] = NULL; + source_name_sizes[i] = 0; + source_lines[i] = 0; + + /* Yes, zero from dladdr() is failure. */ + if (dladdr(raw_frames[i], dl_info)) { + object_name_sizes[i] = + dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0; + symbol_name_sizes[i] = + dl_info->dli_sname ? strlen(dl_info->dli_sname) : 0; +#ifdef USE_BFD + bfd_update(&bfd_ctx, dl_info); + bfd_symbolize(&bfd_ctx, raw_frames[i], + &symbol_names[i], + &symbol_name_sizes[i], + &source_names[i], + &source_name_sizes[i], + &source_lines[i]); +#endif +#if PERL_DARWIN + atos_update(&atos_ctx, dl_info); + atos_symbolize(&atos_ctx, + raw_frames[i], + &source_names[i], + &source_name_sizes[i], + &source_lines[i]); +#endif + + /* Plus ones for the terminating \0. */ + total_bytes += object_name_sizes[i] + 1; + total_bytes += symbol_name_sizes[i] + 1; + total_bytes += source_name_sizes[i] + 1; + + frame_count++; + } else { + break; + } + } +#ifdef USE_BFD + Safefree(bfd_ctx.bfd_syms); +#endif + } + + /* Now we can allocate and populate the result buffer. */ + Newxc(bt, total_bytes, char, Perl_c_backtrace); + Zero(bt, total_bytes, char); + bt->header.frame_count = frame_count; + bt->header.total_bytes = total_bytes; + if (frame_count > 0) { + Perl_c_backtrace_frame* frame = bt->frame_info; + char* name_base = (char *)(frame + frame_count); + char* name_curr = name_base; /* Outputting the name strings here. */ + UV i; + for (i = skip; i < skip + frame_count; i++) { + Dl_info* dl_info = &dl_infos[i]; + + frame->addr = raw_frames[i]; + frame->object_base_addr = dl_info->dli_fbase; + frame->symbol_addr = dl_info->dli_saddr; + + /* Copies a string, including the \0, and advances the name_curr. + * Also copies the start and the size to the frame. */ +#define PERL_C_BACKTRACE_STRCPY(frame, doffset, src, dsize, size) \ + if (size && src) \ + Copy(src, name_curr, size, char); \ + frame->doffset = name_curr - (char*)bt; \ + frame->dsize = size; \ + name_curr += size; \ + *name_curr++ = 0; + + PERL_C_BACKTRACE_STRCPY(frame, object_name_offset, + dl_info->dli_fname, + object_name_size, object_name_sizes[i]); + +#ifdef USE_BFD + PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, + symbol_names[i], + symbol_name_size, symbol_name_sizes[i]); + Safefree(symbol_names[i]); +#else + PERL_C_BACKTRACE_STRCPY(frame, symbol_name_offset, + dl_info->dli_sname, + symbol_name_size, symbol_name_sizes[i]); +#endif + + PERL_C_BACKTRACE_STRCPY(frame, source_name_offset, + source_names[i], + source_name_size, source_name_sizes[i]); + Safefree(source_names[i]); + +#undef PERL_C_BACKTRACE_STRCPY + + frame->source_line_number = source_lines[i]; + + frame++; + } + assert(total_bytes == + (UV)(sizeof(Perl_c_backtrace_header) + + frame_count * sizeof(Perl_c_backtrace_frame) + + name_curr - name_base)); + } +#ifdef USE_BFD + Safefree(symbol_names); + if (bfd_ctx.abfd) { + bfd_close(bfd_ctx.abfd); + } +#endif + Safefree(source_lines); + Safefree(source_name_sizes); + Safefree(source_names); + Safefree(symbol_name_sizes); + Safefree(object_name_sizes); + /* Assuming the strings returned by dladdr() are pointers + * to read-only static memory (the object file), so that + * they do not need freeing (and cannot be). */ + Safefree(dl_infos); + Safefree(raw_frames); + return bt; +#else + PERL_UNUSED_ARGV(depth); + PERL_UNUSED_ARGV(skip); + return NULL; +#endif +} + +/* +=for apidoc free_c_backtrace + +Deallocates a backtrace received from get_c_bracktrace. + +=cut +*/ + +/* +=for apidoc get_c_backtrace_dump + +Returns a SV a dump of |depth| frames of the call stack, skipping +the |skip| innermost ones. depth of 20 is usually enough. + +The appended output looks like: + +... +1 10e004812:0082 Perl_croak util.c:1716 /usr/bin/perl +2 10df8d6d2:1d72 perl_parse perl.c:3975 /usr/bin/perl +... + +The fields are tab-separated. The first column is the depth (zero +being the innermost non-skipped frame). In the hex:offset, the hex is +where the program counter was in S_parse_body, and the :offset (might +be missing) tells how much inside the S_parse_body the program counter was. + +The util.c:1716 is the source code file and line number. + +The /usr/bin/perl is obvious (hopefully). + +Unknowns are C<"-">. Unknowns can happen unfortunately quite easily: +if the platform doesn't support retrieving the information; +if the binary is missing the debug information; +if the optimizer has transformed the code by for example inlining. + +=cut +*/ + +SV* +Perl_get_c_backtrace_dump(pTHX_ int depth, int skip) +{ + Perl_c_backtrace* bt; + + bt = get_c_backtrace(depth, skip + 1 /* Hide ourselves. */); + if (bt) { + Perl_c_backtrace_frame* frame; + SV* dsv = newSVpvs(""); + UV i; + for (i = 0, frame = bt->frame_info; + i < bt->header.frame_count; i++, frame++) { + Perl_sv_catpvf(aTHX_ dsv, "%d", (int)i); + Perl_sv_catpvf(aTHX_ dsv, "\t%p", frame->addr ? frame->addr : "-"); + /* Symbol (function) names might disappear without debug info. + * + * The source code location might disappear in case of the + * optimizer inlining or otherwise rearranging the code. */ + if (frame->symbol_addr) { + Perl_sv_catpvf(aTHX_ dsv, ":%04x", + (int) + ((char*)frame->addr - (char*)frame->symbol_addr)); + } + Perl_sv_catpvf(aTHX_ dsv, "\t%s", + frame->symbol_name_size && + frame->symbol_name_offset ? + (char*)bt + frame->symbol_name_offset : "-"); + if (frame->source_name_size && + frame->source_name_offset && + frame->source_line_number) { + Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf, + (char*)bt + frame->source_name_offset, + (UV)frame->source_line_number); + } else { + Perl_sv_catpvf(aTHX_ dsv, "\t-"); + } + Perl_sv_catpvf(aTHX_ dsv, "\t%s", + frame->object_name_size && + frame->object_name_offset ? + (char*)bt + frame->object_name_offset : "-"); + /* The frame->object_base_addr is not output, + * but it is used for symbolizing/symbolicating. */ + sv_catpvs(dsv, "\n"); + } + + Perl_free_c_backtrace(aTHX_ bt); + + return dsv; + } + + return NULL; +} + +/* +=for apidoc dump_c_backtrace + +Dumps the C backtrace to the given fp. + +Returns true if a backtrace could be retrieved, false if not. + +=cut +*/ + +bool +Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip) +{ + SV* sv; + + PERL_ARGS_ASSERT_DUMP_C_BACKTRACE; + + sv = Perl_get_c_backtrace_dump(aTHX_ depth, skip); + if (sv) { + sv_2mortal(sv); + PerlIO_printf(fp, "%s", SvPV_nolen(sv)); + return TRUE; + } + return FALSE; +} + +#endif /* #ifdef USE_C_BACKTRACE */ + +/* * 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: */