X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/316ebaf2966c5b6fd47a9d1dc6fb64fcbd262379..5fb413889777319544fb826f2cd3d8e78459b0a8:/util.c diff --git a/util.c b/util.c index 42926b3..447a19f 100644 --- a/util.c +++ b/util.c @@ -45,22 +45,40 @@ int putenv(char *); #endif +#ifdef __amigaos__ +# include "amigaos4/amigaio.h" +#endif + #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include # endif #endif +#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 + #ifdef PERL_DEBUG_READONLY_COW # include #endif #define FLUSH -#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) -# define FD_CLOEXEC 1 /* NeXT needs this */ -#endif - /* 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. @@ -114,7 +132,12 @@ Perl_safesysmalloc(MEM_SIZE size) dTHX; #endif Malloc_t ptr; + +#ifdef USE_MDH + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; size += PERL_MEMORY_DEBUG_HEADER_SIZE; +#endif #ifdef DEBUGGING if ((SSize_t)size < 0) Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); @@ -156,21 +179,25 @@ Perl_safesysmalloc(MEM_SIZE size) #ifdef MDH_HAS_SIZE header->size = size; #endif - ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); + 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 { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - else { - croak_no_mem(); - } + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } - /*NOTREACHED*/ + return ptr; } /* paranoid version of system's realloc() */ @@ -193,105 +220,109 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!size) { safesysfree(where); - return NULL; + ptr = NULL; } - - if (!where) - return safesysmalloc(size); + 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; + where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size) + goto out_of_memory; + size += PERL_MEMORY_DEBUG_HEADER_SIZE; + { + struct perl_memory_debug_header *const header + = (struct perl_memory_debug_header *)where; # 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); + 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); - } + 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; + header->size = size; # endif - } + } #endif #ifdef DEBUGGING - if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); + 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(); - } + 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); + ptr = (Malloc_t)PerlMem_realloc(where,size); #endif - 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) { + if (ptr != NULL) { #ifdef PERL_TRACK_MEMPOOL - 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 - 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); + 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); - } + 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) { +#ifdef USE_MDH + out_of_memory: +#endif + { #ifndef ALWAYS_NEED_THX - dTHX; + dTHX; #endif - if (PL_nomemok) - return NULL; - else { - croak_no_mem(); + if (PL_nomemok) + ptr = NULL; + else + croak_no_mem(); + } } } - /*NOTREACHED*/ + return ptr; } /* safe version of system's free() */ @@ -301,16 +332,14 @@ 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 USE_MDH - where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); + 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; @@ -340,21 +369,23 @@ Perl_safesysfree(Malloc_t where) maybe_protect_ro(header->prev); maybe_protect_rw(header); # ifdef PERL_POISON - PoisonNew(where, 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, size)) { + if (munmap(where_intrn, size)) { perror("munmap failed"); abort(); } # endif } -#endif +#else + Malloc_t where_intrn = where; +#endif /* USE_MDH */ #ifndef PERL_DEBUG_READONLY_COW - PerlMem_free(where); + PerlMem_free(where_intrn); #endif } } @@ -459,25 +490,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); } @@ -512,24 +551,34 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend return (char *)from; } -/* return ptr to little string in big string, NULL if not found */ -/* This routine was donated by Corey Satten. */ +/* +=head1 Miscellaneous Functions -char * -Perl_instr(const char *big, const char *little) -{ +=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end - PERL_ARGS_ASSERT_INSTR; +Find the first (leftmost) occurrence of a sequence of bytes within another +sequence. This is the Perl version of C, extended to handle +arbitrary sequences, potentially containing embedded C characters (C +is what the initial C in the function name stands for; some systems have an +equivalent, C, but with a somewhat different API). - /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL - * 'little' */ - if (!little) - return (char*)big; - return strstr((char*)big, (char*)little); -} +Another way of thinking about this function is finding a needle in a haystack. +C points to the first byte in the haystack. C points to one byte +beyond the final byte in the haystack. C points to the first byte in +the needle. C points to one byte beyond the final byte in the +needle. All the parameters must be non-C. -/* same as instr but allow embedded nulls. The end pointers point to 1 beyond - * the final character desired to be checked */ +The function returns C if there is no occurrence of C within +C. If C is the empty string, C is returned. + +Because this function operates at the byte level, and because of the inherent +characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the +needle and the haystack are strings with the same UTF-8ness, but not if the +UTF-8ness differs. + +=cut + +*/ char * Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -555,7 +604,18 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char return NULL; } -/* reverse of the above--find last substring */ +/* +=head1 Miscellaneous Functions + +=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end + +Like C>, but instead finds the final (rightmost) occurrence of a +sequence of bytes within another sequence, returning C if there is no +such occurrence. + +=cut + +*/ char * Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -599,7 +659,7 @@ Perl_rninstr(const char *big, const char *bigend, const char *little, const char =for apidoc fbm_compile -Analyses the string in order to make fast searches on it using fbm_instr() +Analyses the string in order to make fast searches on it using C -- the Boyer-Moore algorithm. =cut @@ -608,7 +668,6 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - dVAR; const U8 *s; STRLEN i; STRLEN len; @@ -693,21 +752,37 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s[rarest], (UV)rarest)); } -/* If SvTAIL(littlestr), it has a fake '\n' at end. */ -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if multiline */ /* =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 -does not have to be fbm_compiled, but the search will not be as fast +C (C) is the char following the last char). +It returns C if the string can't be found. The C +does not have to be C, but the search will not be as fast then. =cut + +If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string +during FBM compilation due to FBMcf_TAIL in flags. It indicates that +the littlestr must be anchored to the end of bigstr (or to any \n if +FBMrf_MULTILINE). + +E.g. The regex compiler would compile /abc/ to a littlestr of "abc", +while /abc$/ compiles to "abc\n" with SvTAIL() true. + +A littlestr of "abc", !SvTAIL matches as /abc/; +a littlestr of "ab\n", SvTAIL matches as: + without FBMrf_MULTILINE: /ab\n?\z/ + with FBMrf_MULTILINE: /ab\n/ || /ab\z/; + +(According to Ilya from 1999; I don't know if this is still true, DAPM 2015): + "If SvTAIL is actually due to \Z or \z, this gives false positives + if multiline". */ + char * Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags) { @@ -732,82 +807,103 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U switch (littlelen) { /* Special cases for 0, 1 and 2 */ case 0: return (char*)big; /* Cannot be SvTAIL! */ + case 1: - if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ - /* Know that bigend != big. */ - if (bigend[-1] == '\n') - return (char *)(bigend - 1); - return (char *) bigend; - } - s = big; - while (s < bigend) { - if (*s == *little) - return (char *)s; - s++; - } + if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + /* [-1] is safe because we know that bigend != big. */ + return (char *) (bigend - (bigend[-1] == '\n')); + + s = (unsigned char *)memchr((void*)big, *little, bigend-big); + if (s) + return (char *)s; if (SvTAIL(littlestr)) return (char *) bigend; return NULL; + case 2: if (SvTAIL(littlestr) && !multiline) { - if (bigend[-1] == '\n' && bigend[-2] == *little) + /* a littlestr with SvTAIL must be of the form "X\n" (where X + * is a single char). It is anchored, and can only match + * "....X\n" or "....X" */ + if (bigend[-2] == *little && bigend[-1] == '\n') return (char*)bigend - 2; if (bigend[-1] == *little) return (char*)bigend - 1; return NULL; } + { - /* This should be better than FBM if c1 == c2, and almost - as good otherwise: maybe better since we do less indirection. - And we save a lot of memory by caching no table. */ - const unsigned char c1 = little[0]; - const unsigned char c2 = little[1]; - - s = big + 1; - bigend--; - if (c1 != c2) { - while (s <= bigend) { - if (s[0] == c2) { - if (s[-1] == c1) - return (char*)s - 1; - s += 2; - continue; - } - next_chars: - if (s[0] == c1) { - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c2) - return (char*)s; - else { - s++; - goto next_chars; - } - } - else - s += 2; - } - goto check_1char_anchor; - } - /* Now c1 == c2 */ - while (s <= bigend) { - if (s[0] == c1) { - if (s[-1] == c1) - return (char*)s - 1; - if (s == bigend) - goto check_1char_anchor; - if (s[1] == c1) - return (char*)s; - s += 3; - } - else - s += 2; - } - } - check_1char_anchor: /* One char and anchor! */ - if (SvTAIL(littlestr) && (*bigend == *little)) - return (char *)bigend; /* bigend is already decremented. */ - return NULL; + /* memchr() is likely to be very fast, possibly using whatever + * hardware support is available, such as checking a whole + * cache line in one instruction. + * So for a 2 char pattern, calling memchr() is likely to be + * faster than running FBM, or rolling our own. The previous + * version of this code was roll-your-own which typically + * only needed to read every 2nd char, which was good back in + * the day, but no longer. + */ + unsigned char c1 = little[0]; + unsigned char c2 = little[1]; + + /* *** for all this case, bigend points to the last char, + * not the trailing \0: this makes the conditions slightly + * simpler */ + bigend--; + s = big; + if (c1 != c2) { + while (s < bigend) { + /* do a quick test for c1 before calling memchr(); + * this avoids the expensive fn call overhead when + * there are lots of c1's */ + if (LIKELY(*s != c1)) { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s) + break; + } + if (s[1] == c2) + return (char*)s; + + /* failed; try searching for c2 this time; that way + * we don't go pathologically slow when the string + * consists mostly of c1's or vice versa. + */ + s += 2; + if (s > bigend) + break; + s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1); + if (!s) + break; + if (s[-1] == c1) + return (char*)s - 1; + } + } + else { + /* c1, c2 the same */ + while (s < bigend) { + if (s[0] == c1) { + got_1char: + if (s[1] == c1) + return (char*)s; + s += 2; + } + else { + s++; + s = (unsigned char *)memchr((void*)s, c1, bigend - s); + if (!s || s >= bigend) + break; + goto got_1char; + } + } + } + + /* failed to find 2 chars; try anchored match at end without + * the \n */ + if (SvTAIL(littlestr) && bigend[0] == little[0]) + return (char *)bigend; + return NULL; + } + default: break; /* Only lengths 0 1 and 2 have special-case code. */ } @@ -827,7 +923,9 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } return NULL; } + if (!SvVALID(littlestr)) { + /* not compiled; use Perl_ninstr() instead */ char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); @@ -861,15 +959,30 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U oldlittle = little; if (s < bigend) { const unsigned char * const table = (const unsigned char *) mg->mg_ptr; + const unsigned char lastc = *little; I32 tmp; top2: if ((tmp = table[*s])) { - if ((s += tmp) < bigend) - goto top2; - goto check_end; + /* *s != lastc; earliest position it could match now is + * tmp slots further on */ + if ((s += tmp) >= bigend) + goto check_end; + if (LIKELY(*s != lastc)) { + s++; + s = (unsigned char *)memchr((void*)s, lastc, bigend - s); + if (!s) { + s = bigend; + goto check_end; + } + goto top2; + } } - else { /* less expensive than calling strncmp() */ + + + /* hand-rolled strncmp(): less expensive than calling the + * real function (maybe???) */ + { unsigned char * const olds = s; tmp = littlelen; @@ -896,28 +1009,12 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } } -char * -Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) -{ - dVAR; - PERL_ARGS_ASSERT_SCREAMINSTR; - PERL_UNUSED_ARG(bigstr); - PERL_UNUSED_ARG(littlestr); - PERL_UNUSED_ARG(start_shift); - PERL_UNUSED_ARG(end_shift); - PERL_UNUSED_ARG(old_posp); - PERL_UNUSED_ARG(last); - - /* This function must only ever be called on a scalar with study magic, - but those do not happen any more. */ - Perl_croak(aTHX_ "panic: screaminstr"); - return NULL; -} /* =for apidoc foldEQ -Returns true if the leading len bytes of the strings s1 and s2 are the same +Returns true if the leading C bytes of the strings C and C are the +same case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes match themselves and their opposite case counterparts. Non-cased and non-ASCII range bytes match only themselves. @@ -970,8 +1067,8 @@ Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len) /* =for apidoc foldEQ_locale -Returns true if the leading len bytes of the strings s1 and s2 are the same -case-insensitively in the current locale; false otherwise. +Returns true if the leading C bytes of the strings C and C are the +same case-insensitively in the current locale; false otherwise. =cut */ @@ -1004,8 +1101,9 @@ Perl_foldEQ_locale(const char *s1, const char *s2, I32 len) 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. +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 @@ -1036,7 +1134,7 @@ Perl_savepv(pTHX_ const char *pv) 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 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 @@ -1079,6 +1177,9 @@ Perl_savesharedpv(pTHX_ const char *pv) { char *newaddr; STRLEN pvlen; + + PERL_UNUSED_CONTEXT; + if (!pv) return NULL; @@ -1094,7 +1195,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 C pointer is not acceptable) =cut @@ -1104,6 +1205,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); + PERL_UNUSED_CONTEXT; /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { @@ -1165,7 +1267,6 @@ Perl_savesharedsvpv(pTHX_ SV *sv) STATIC SV * S_mess_alloc(pTHX) { - dVAR; SV *sv; XPVMG *any; @@ -1288,7 +1389,6 @@ const COP* Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, bool opnext) { - dVAR; /* 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. */ @@ -1302,7 +1402,7 @@ Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop, 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 @@ -1351,9 +1451,22 @@ 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; + UV wi; + /* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */ + if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) + && grok_atoUV(ws, &wi, NULL) + && wi <= PERL_INT_MAX + ) { + Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1); + } + } +#endif + PERL_ARGS_ASSERT_MESS_SV; if (SvROK(basemsg)) { @@ -1384,7 +1497,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) */ const COP *cop = - closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE); + closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE); if (!cop) cop = PL_curcop; @@ -1416,7 +1529,8 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) =for apidoc Am|SV *|vmess|const char *pat|va_list *args C and C are a sprintf-style format pattern and encapsulated -argument list. These are used to generate a string message. If the +argument list, respectively. These are used to generate a string message. If +the message does not end with a newline, then it will be extended with some indication of the current location in the code, as described for L. @@ -1431,7 +1545,6 @@ this function. SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - dVAR; SV * const sv = mess_alloc(); PERL_ARGS_ASSERT_VMESS; @@ -1443,7 +1556,6 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) void Perl_write_to_stderr(pTHX_ SV* msv) { - dVAR; IO *io; MAGIC *mg; @@ -1483,7 +1595,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; @@ -1535,14 +1646,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); - assert(0); /* NOTREACHED */ - return NULL; + /* NOTREACHED */ + NORETURN_FUNCTION_END; } +#ifdef _MSC_VER +# pragma warning( pop ) +#endif /* =for apidoc Am|OP *|die|const char *pat|... @@ -1555,6 +1676,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, ...) { @@ -1562,22 +1690,35 @@ Perl_die_nocontext(const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - assert(0); /* 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); - assert(0); /* 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 @@ -1674,7 +1815,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1685,7 +1826,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - assert(0); /* NOTREACHED */ + NOT_REACHED; /* NOTREACHED */ va_end(args); } @@ -1712,13 +1853,14 @@ void Perl_croak_no_mem(void) { dTHX; - int rc; - /* Can't use PerlIO to write as it allocates memory */ - rc = PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, sizeof(PL_no_mem)-1); - /* silently ignore failures */ - PERL_UNUSED_VAR(rc); + 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); } @@ -1882,11 +2024,19 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { dVAR; PERL_ARGS_ASSERT_VWARNER; - if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { + if ( + (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && + !(PL_in_eval & EVAL_KEEPERR) + ) { 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); @@ -1898,7 +2048,6 @@ 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; @@ -1911,7 +2060,6 @@ 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; @@ -1987,6 +2135,9 @@ void Perl_my_setenv(pTHX_ const char *nam, const char *val) { dVAR; +#ifdef __amigaos4__ + amigaos4_obtain_environ(__FUNCTION__); +#endif #ifdef USE_ITHREADS /* only parent thread can modify process environment */ if (PL_curinterp == aTHX) @@ -2028,7 +2179,11 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) environ[i] = environ[i+1]; i++; } +#ifdef __amigaos4__ + goto my_setenv_out; +#else return; +#endif } if (!environ[i]) { /* does not exist yet */ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*)); @@ -2044,7 +2199,11 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); } else { # endif -# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) + /* This next branch should only be called #if defined(HAS_SETENV), but + Configure doesn't test for that yet. For Solaris, setenv() and unsetenv() + were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient. + */ +# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN) # if defined(HAS_UNSETENV) if (val == NULL) { (void)unsetenv(nam); @@ -2085,6 +2244,10 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) } #endif } +#ifdef __amigaos4__ +my_setenv_out: + amigaos4_release_environ(__FUNCTION__); +#endif } #else /* WIN32 || NETWARE */ @@ -2125,17 +2288,20 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ } #endif -/* this is a drop-in replacement for bcopy() */ -#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) -char * -Perl_my_bcopy(const char *from, char *to, I32 len) +/* this is a drop-in replacement for bcopy(), except for the return + * value, which we need to be able to emulate memcpy() */ +#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY)) +void * +Perl_my_bcopy(const void *vfrom, void *vto, size_t len) { - char * const retval = to; +#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY) + bcopy(vfrom, vto, len); +#else + const unsigned char *from = (const unsigned char *)vfrom; + unsigned char *to = (unsigned char *)vto; PERL_ARGS_ASSERT_MY_BCOPY; - assert(len >= 0); - if (from - to >= 0) { while (len--) *to++ = *from++; @@ -2146,57 +2312,53 @@ Perl_my_bcopy(const char *from, char *to, I32 len) while (len--) *(--to) = *(--from); } - return retval; +#endif + + return vto; } #endif /* this is a drop-in replacement for memset() */ #ifndef HAS_MEMSET void * -Perl_my_memset(char *loc, I32 ch, I32 len) +Perl_my_memset(void *vloc, int ch, size_t len) { - char * const retval = loc; + unsigned char *loc = (unsigned char *)vloc; PERL_ARGS_ASSERT_MY_MEMSET; - assert(len >= 0); - while (len--) *loc++ = ch; - return retval; + return vloc; } #endif /* this is a drop-in replacement for bzero() */ #if !defined(HAS_BZERO) && !defined(HAS_MEMSET) -char * -Perl_my_bzero(char *loc, I32 len) +void * +Perl_my_bzero(void *vloc, size_t len) { - char * const retval = loc; + unsigned char *loc = (unsigned char *)vloc; PERL_ARGS_ASSERT_MY_BZERO; - assert(len >= 0); - while (len--) *loc++ = 0; - return retval; + return vloc; } #endif /* 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, I32 len) +int +Perl_my_memcmp(const void *vs1, const void *vs2, size_t len) { - const U8 *a = (const U8 *)s1; - const U8 *b = (const U8 *)s2; - I32 tmp; + const U8 *a = (const U8 *)vs1; + const U8 *b = (const U8 *)vs2; + int tmp; PERL_ARGS_ASSERT_MY_MEMCMP; - assert(len >= 0); - while (len--) { if ((tmp = *a++ - *b++)) return tmp; @@ -2263,8 +2425,7 @@ vsprintf(char *dest, const char *pat, void *args) 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(NETWARE) && !defined(__LIBCATAMOUNT__) - dVAR; +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) int p[2]; I32 This, that; Pid_t pid; @@ -2308,9 +2469,10 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) /* Close parent's end of error status pipe (if any) */ if (did_pipes) { PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) /* 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 */ @@ -2390,8 +2552,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; @@ -2399,12 +2563,11 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) #endif } - /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) + /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */ +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { - dVAR; int p[2]; I32 This, that; Pid_t pid; @@ -2455,7 +2618,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')) { @@ -2574,9 +2738,18 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) /* this is called in parent before the fork() */ void Perl_atfork_lock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_ACQUIRE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_ACQUIRE(PL_malloc_mutex) +# endif + PERL_TSA_ACQUIRE(PL_op_mutex) +#endif { - dVAR; #if defined(USE_ITHREADS) + dVAR; /* locks must be held in locking order (if any) */ # ifdef USE_PERLIO MUTEX_LOCK(&PL_perlio_mutex); @@ -2591,9 +2764,18 @@ Perl_atfork_lock(void) /* this is called in both parent and child after the fork() */ void Perl_atfork_unlock(void) +#if defined(USE_ITHREADS) +# ifdef USE_PERLIO + PERL_TSA_RELEASE(PL_perlio_mutex) +# endif +# ifdef MYMALLOC + PERL_TSA_RELEASE(PL_malloc_mutex) +# endif + PERL_TSA_RELEASE(PL_op_mutex) +#endif { - 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); @@ -2620,6 +2802,8 @@ Perl_my_fork(void) pid = fork(); #endif return pid; +#elif defined(__amigaos4__) + return amigaos_fork(); #else /* this "canna happen" since nothing should be calling here if !HAS_FORK */ Perl_croak_nocontext("fork() not available"); @@ -2667,10 +2851,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; @@ -2708,7 +2892,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; @@ -2736,7 +2922,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) @@ -2814,11 +3003,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(__LIBCATAMOUNT__) +#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { - dVAR; int status; SV **svp; Pid_t pid; @@ -2875,7 +3063,6 @@ 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; #ifdef PERL_USES_PL_PIDSTATUS @@ -2914,7 +3101,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) *statusp = SvIVX(sv); /* The hash iterator is currently on this entry, so simply calling hv_delete would trigger the lazy delete, which on - aggregate does more work, beacuse next call to hv_iterinit() + aggregate does more work, because next call to hv_iterinit() would spot the flag, and have to call the delete routine, while in the meantime any new entries can't re-use that memory. */ @@ -3090,7 +3277,6 @@ 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]; @@ -3163,6 +3349,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) ) { + Stat_t statbuf; if (deftypes) { deftypes = 0; *tmpbuf = '\0'; @@ -3189,13 +3376,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0 - && !S_ISDIR(PL_statbuf.st_mode)) { - dosearch = 0; - scriptname = cur; + { + Stat_t statbuf; + if (PerlLIO_stat(cur,&statbuf) >= 0 + && !S_ISDIR(statbuf.st_mode)) { + dosearch = 0; + scriptname = cur; #ifdef SEARCH_EXTS - break; + break; #endif + } } #ifdef SEARCH_EXTS if (cur == scriptname) { @@ -3221,6 +3411,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, bufend = s + strlen(s); while (s < bufend) { + Stat_t statbuf; # ifdef DOSISH for (len = 0; *s && *s != ';'; len++, s++) { @@ -3257,8 +3448,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, do { #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); - retval = PerlLIO_stat(tmpbuf,&PL_statbuf); - if (S_ISDIR(PL_statbuf.st_mode)) { + retval = PerlLIO_stat(tmpbuf,&statbuf); + if (S_ISDIR(statbuf.st_mode)) { retval = -1; } #ifdef SEARCH_EXTS @@ -3269,10 +3460,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif if (retval < 0) continue; - if (S_ISREG(PL_statbuf.st_mode) - && cando(S_IRUSR,TRUE,&PL_statbuf) + if (S_ISREG(statbuf.st_mode) + && cando(S_IRUSR,TRUE,&statbuf) #if !defined(DOSISH) - && cando(S_IXUSR,TRUE,&PL_statbuf) + && cando(S_IXUSR,TRUE,&statbuf) #endif ) { @@ -3283,11 +3474,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && - (PerlLIO_stat(scriptname,&PL_statbuf) < 0 - || S_ISDIR(PL_statbuf.st_mode))) + { + Stat_t statbuf; + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&statbuf) < 0 + || S_ISDIR(statbuf.st_mode))) +#endif + seen_dot = 1; /* Disable message. */ +#ifndef DOSISH + } #endif - seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ /* diag_listed_as: Can't execute %s */ @@ -3310,8 +3506,8 @@ 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; int error = pthread_getspecific(PL_thr_key, &t) @@ -3333,7 +3529,9 @@ 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 @@ -3356,7 +3554,8 @@ Perl_set_context(void *t) struct perl_vars * Perl_GetVars(pTHX) { - return &PL_Vars; + PERL_UNUSED_CONTEXT; + return &PL_Vars; } #endif @@ -3416,7 +3615,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) PERL_UNUSED_CONTEXT; return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) - ? NULL : PL_magic_vtables + vtbl_id; + ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id; } I32 @@ -3482,7 +3681,7 @@ Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %"HEKf" opened only for %sput", - name, direction); + HEKfARG(name), direction); else Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput", direction); @@ -3565,12 +3764,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 @@ -3581,13 +3782,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; @@ -3770,6 +3970,9 @@ 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; @@ -3870,7 +4073,7 @@ return FALSE =for apidoc getcwd_sv -Fill the sv with current working directory +Fill C with current working directory =cut */ @@ -3878,7 +4081,7 @@ Fill the sv with current working directory /* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars. * rewritten again by dougm, optimized for use with xs TARG, and to prefer * getcwd(3) if available - * Comments from the orignal: + * Comments from the original: * This is a faster version of getcwd. It's also more dangerous * because you might chdir out of a directory that you can't chdir * back into. */ @@ -3887,7 +4090,6 @@ int Perl_getcwd_sv(pTHX_ SV *sv) { #ifndef PERL_MICRO - dVAR; SvTAINTED_on(sv); PERL_ARGS_ASSERT_GETCWD_SV; @@ -4302,7 +4504,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { 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. -Exists to avoid test for a NULL function pointer and because it could +Exists to avoid test for a C function pointer and because it could potentially warn under some level of strict-ness. =cut @@ -4321,7 +4523,7 @@ Perl_sv_nosharing(pTHX_ SV *sv) Dummy routine which reports that object can be destroyed when there is no sharing module present. It ignores its single SV argument, and returns -'true'. Exists to avoid test for a NULL function pointer and because it +'true'. Exists to avoid test for a C function pointer and because it could potentially warn under some level of strict-ness. =cut @@ -4345,16 +4547,23 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { - opt = (U32) atoi(p); - while (isDIGIT(*p)) - p++; - if (*p && *p != '\n' && *p != '\r') { - if(isSPACE(*p)) goto the_end_of_the_opts_parser; - else - Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); - } - } - else { + const char* endptr; + UV uv; + if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) { + opt = (U32)uv; + p = endptr; + if (p && *p && *p != '\n' && *p != '\r') { + if (isSPACE(*p)) + goto the_end_of_the_opts_parser; + else + Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); + } + } + else { + Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p); + } + } + else { for (; *p; p++) { switch (*p) { case PERL_UNICODE_STDIN: @@ -4409,7 +4618,6 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) 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 @@ -4436,16 +4644,10 @@ Perl_seed(pTHX) int fd; #endif U32 u; -#ifdef VMS - /* when[] = (low 32 bits, high 32 bits) of time since epoch - * in 100-ns units, typically incremented ever 10 ms. */ - unsigned int when[2]; -#else -# ifdef HAS_GETTIMEOFDAY +#ifdef HAS_GETTIMEOFDAY struct timeval when; -# else +#else Time_t when; -# endif #endif /* This test is an escape hatch, this symbol isn't set by Configure. */ @@ -4455,7 +4657,11 @@ Perl_seed(pTHX) * if there isn't enough entropy available. You can compile with * PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there * is enough real entropy to fill the seed. */ -# define PERL_RANDOM_DEVICE "/dev/urandom" +# ifdef __amigaos4__ +# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4" +# else +# define PERL_RANDOM_DEVICE "/dev/urandom" +# endif #endif fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0); if (fd != -1) { @@ -4467,17 +4673,12 @@ Perl_seed(pTHX) } #endif -#ifdef VMS - _ckvmssts(sys$gettim(when)); - u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1]; -#else -# ifdef HAS_GETTIMEOFDAY +#ifdef HAS_GETTIMEOFDAY PerlProc_gettimeofday(&when,NULL); u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec; -# else +#else (void)time(&when); u = (U32)SEED_C1 * when; -# endif #endif u += SEED_C3 * (U32)PerlProc_getpid(); u += SEED_C4 * (U32)PTR2UV(PL_stack_sp); @@ -4490,7 +4691,6 @@ Perl_seed(pTHX) void Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer) { - dVAR; const char *env_pv; unsigned long i; @@ -4580,6 +4780,7 @@ Perl_init_global_struct(pTHX) # ifdef PERL_GLOBAL_STRUCT 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)); @@ -4637,6 +4838,7 @@ 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); @@ -4655,14 +4857,14 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #ifdef PERL_MEM_LOG -/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the +/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also * given, and you supply your own implementation. * * 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_atoUV) * 'm' - memlog was PERL_MEM_LOG=1 * 's' - svlog was PERL_SV_LOG=1 * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 @@ -4725,19 +4927,26 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, (void)time(&when); # endif /* If there are other OS specific ways of hires time than - * gettimeofday() (see ext/Time-HiRes), the easiest way is + * gettimeofday() (see dist/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ { STRLEN len; - int fd = atoi(pmlenv); - if (!fd) + const char* endptr; + int fd; + UV uv; + if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */ + && uv && uv <= PERL_INT_MAX + ) { + fd = (int)uv; + } else { 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: @@ -4772,7 +4981,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)); } } } @@ -4797,6 +5006,8 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_ALLOC; + mem_log_common_if(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname); @@ -4809,6 +5020,8 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_REALLOC; + mem_log_common_if(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname); @@ -4820,6 +5033,8 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_FREE; + mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); return oldalloc; @@ -4868,6 +5083,112 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) #endif /* +=for apidoc quadmath_format_single + +C is very strict about its C string and will +fail, returning -1, if the format is invalid. It accepts exactly +one format spec. + +C 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. + +C 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 + +C returns true if the C string seems to +contain at least one non-Q-prefixed C<%[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 C, 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 C 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 @@ -4882,14 +5203,59 @@ getting C. int Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) { - 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 */ @@ -4918,16 +5284,24 @@ C instead, or getting C. int Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) { +#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; - Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, apc); # endif va_end(apc); @@ -4935,6 +5309,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); # else + PERL_UNUSED_ARG(len); retval = vsprintf(buffer, format, ap); # endif #endif /* #ifdef NEED_VA_COPY */ @@ -4948,6 +5323,7 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap ) Perl_croak_nocontext("panic: my_vsnprintf buffer overflow"); return retval; +#endif } void @@ -5122,8 +5498,141 @@ 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 */ + /* XSUBs can't be perl lang/perl5db.pl debugged + if (PERLDB_LINE_OR_SAVESRC) + (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; @@ -5137,10 +5646,10 @@ 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) { @@ -5151,16 +5660,16 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, 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); @@ -5170,51 +5679,21 @@ 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; - - PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK; - - /* 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); - - SvREFCNT_dec(compver_string); - SvREFCNT_dec(runver_string); - } - SvREFCNT_dec(runver); - if (xpt) - Perl_croak_sv(aTHX_ xpt); -} - /* =for apidoc my_strlcat The C library C if available, or a Perl implementation of it. -This operates on C NUL-terminated strings. +This operates on C C-terminated strings. C appends string C to the end of C. It will append at -most S> characters. It will then NUL-terminate, +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 NUL-terminated string). +that C is not a proper C-terminated string). Note that C is the full size of the destination buffer and -the result is guaranteed to be NUL-terminated if there is room. Note that room -for the NUL should be included in C. +the result is guaranteed to be C-terminated if there is room. Note that +room for the C should be included in C. =cut @@ -5242,10 +5721,10 @@ Perl_my_strlcat(char *dst, const char *src, Size_t size) =for apidoc my_strlcpy The C library C if available, or a Perl implementation of it. -This operates on C NUL-terminated strings. +This operates on C C-terminated strings. C copies up to S> characters from the string C -to C, NUL-terminating the result if C is not 0. +to C, C-terminating the result if C is not 0. =cut @@ -5288,7 +5767,6 @@ S_gv_has_usable_name(pTHX_ GV *gv) void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { - dVAR; SV * const dbsv = GvSVn(PL_DBsub); const bool save_taint = TAINT_get; @@ -5304,10 +5782,10 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - if (!svp) { + if (!svp && !CvLEXICAL(cv)) { gv_efullname3(dbsv, gv, NULL); } - else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv) || strEQ(GvNAME(gv), "END") || ( /* Could be imported, and old sub redefined. */ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) @@ -5327,10 +5805,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) else { sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); sv_catpvs(dbsv, "::"); - sv_catpvn_flags( - dbsv, GvNAME(gv), GvNAMELEN(gv), - GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES - ); + sv_cathek(dbsv, GvNAME_HEK(gv)); } } else { @@ -5348,7 +5823,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) } int -Perl_my_dirfd(pTHX_ DIR * dir) { +Perl_my_dirfd(DIR * dir) { /* Most dirfd implementations have problems when passed NULL. */ if(!dir) @@ -5358,8 +5833,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"); - assert(0); /* NOT REACHED */ + Perl_croak_nocontext(PL_no_func, "dirfd"); + NOT_REACHED; /* NOTREACHED */ return 0; #endif } @@ -5432,7 +5907,7 @@ 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); + *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16); #else random_state->seed[0] = FREEBSD_DRAND48_SEED_0; random_state->seed[1] = (U16) seed; @@ -5476,14 +5951,780 @@ Perl_drand48_r(perl_drand48_t *random_state) } #endif } - -/* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: +#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; + UV uv; + + /* 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; + if (grok_atoUV(source_number_start, &uv, &source_line_end) + && source_line_end == close_paren + && uv <= PERL_INT_MAX + ) { + *source_line = (STRLEN)uv; + return p; + } + return NULL; +} + +/* 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 - 1, out, + source_name_size, + source_line); + if (p) { + Newx(*source_name, + *source_name_size, char); + Copy(p, *source_name, + *source_name_size, 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 C. + +Scans the frames back by S>, then drops the C innermost, +returning at most C 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]; + + object_name_sizes[i] = 0; + 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)) { + total_bytes += sizeof(Perl_c_backtrace_frame); + + 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 containing a dump of C frames of the call stack, skipping +the C innermost ones. C 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 C, and the :offset (might +be missing) tells how much inside the C the program counter was. + +The C is the source code file and line number. + +The F 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 C. + +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 */ + +#ifdef PERL_TSA_ACTIVE + +/* pthread_mutex_t and perl_mutex are typedef equivalent + * so casting the pointers is fine. */ + +int perl_tsa_mutex_lock(perl_mutex* mutex) +{ + return pthread_mutex_lock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_unlock(perl_mutex* mutex) +{ + return pthread_mutex_unlock((pthread_mutex_t *) mutex); +} + +int perl_tsa_mutex_destroy(perl_mutex* mutex) +{ + return pthread_mutex_destroy((pthread_mutex_t *) mutex); +} + +#endif + + +#ifdef USE_DTRACE + +/* log a sub call or return */ + +void +Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) +{ + const char *func; + const char *file; + const char *stash; + const COP *start; + line_t line; + + PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; + + if (CvNAMED(cv)) { + HEK *hek = CvNAME_HEK(cv); + func = HEK_KEY(hek); + } + else { + GV *gv = CvGV(cv); + func = GvENAME(gv); + } + start = (const COP *)CvSTART(cv); + file = CopFILE(start); + line = CopLINE(start); + stash = CopSTASHPV(start); + + if (is_call) { + PERL_SUB_ENTRY(func, file, line, stash); + } + else { + PERL_SUB_RETURN(func, file, line, stash); + } +} + + +/* log a require file loading/loaded */ + +void +Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; + + if (is_loading) { + PERL_LOADING_FILE(name); + } + else { + PERL_LOADED_FILE(name); + } +} + + +/* log an op execution */ + +void +Perl_dtrace_probe_op(pTHX_ const OP *op) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_OP; + + PERL_OP_ENTRY(OP_NAME(op)); +} + + +/* log a compile/run phase change */ + +void +Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) +{ + const char *ph_old = PL_phase_names[PL_phase]; + const char *ph_new = PL_phase_names[phase]; + + PERL_PHASE_CHANGE(ph_new, ph_old); +} + +#endif + +/* * ex: set ts=8 sts=4 sw=4 et: */