* '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.
#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
#endif
#endif
+#include <math.h>
+#include <stdlib.h>
+
#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
#endif
-#ifdef I_SYS_WAIT
-# include <sys/wait.h>
-#endif
-
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
# 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 <bfd.h>
+# endif
+# endif
+# ifdef I_DLFCN
+# include <dlfcn.h>
+# endif
+# ifdef I_EXECINFO
+# include <execinfo.h>
+# 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 <sys/mman.h>
#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() */
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
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() */
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() */
{
#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);
}
}
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. */
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;
#endif
if (PL_nomemok)
return NULL;
- return write_no_mem();
+ croak_no_mem();
}
}
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);
}
/* 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;
/* 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)
/* 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;
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; /**/ ) {
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))
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);
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);
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. */
/*
=for apidoc fbm_instr
-Returns the location of the SV in the string delimited by C<str> and
-C<strend>. It returns C<NULL> if the string can't be found. The C<sv>
+Returns the location of the SV in the string delimited by C<big> and
+C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
does not have to be fbm_compiled, but the search will not be as fast
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;
{
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 */
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])) {
goto check_end;
}
else { /* less expensive than calling strncmp() */
- register unsigned char * const olds = s;
+ unsigned char * const olds = s;
tmp = littlelen;
}
}
-/* 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
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;
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;
*/
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;
=for apidoc savepv
-Perl's version of C<strdup()>. Returns a pointer to a newly allocated
-string which is a duplicate of C<pv>. The size of the string is
-determined by C<strlen()>. The memory allocated for the new string can
-be freed with the C<Safefree()> function.
+Perl's version of C<strdup()>. Returns a pointer to a newly allocated
+string which is a duplicate of C<pv>. The size of the string is
+determined by C<strlen()>, which means it may not contain embedded C<NUL>
+characters and must have a trailing C<NUL>. The memory allocated for the new
+string can be freed with the C<Safefree()> 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<L</savesharedpv>>.
=cut
*/
/*
=for apidoc savepvn
-Perl's version of what C<strndup()> would be if it existed. Returns a
+Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+C<len> bytes from C<pv>, plus a trailing
+C<NUL> byte. The memory allocated for
the new string can be freed with the C<Safefree()> 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<L</savesharedpvn>>.
+
=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) {
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);
}
=for apidoc savesharedpvn
A version of C<savepvn()> 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
{
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);
A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
the passed in SV using C<SvPV()>
+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<L</savesharedsvpv>>.
+
=cut
*/
{
STRLEN len;
const char * const pv = SvPV_const(sv, len);
- register char *newaddr;
+ char *newaddr;
PERL_ARGS_ASSERT_SAVESVPV;
STATIC SV *
S_mess_alloc(pTHX)
{
- dVAR;
SV *sv;
XPVMG *any;
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
/* 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;
}
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)) {
* 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;
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)));
}
SV *
Perl_vmess(pTHX_ const char *pat, va_list *args)
{
- dVAR;
SV * const sv = mess_alloc();
PERL_ARGS_ASSERT_VMESS;
void
Perl_write_to_stderr(pTHX_ SV* msv)
{
- dVAR;
IO *io;
MAGIC *mg;
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
}
}
STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
- dVAR;
HV *stash;
GV *gv;
CV *cv;
SV *exarg;
ENTER;
- save_re_context();
if (warn) {
SAVESPTR(*hook);
*hook = NULL;
=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|...
*/
#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, ...)
{
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
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
=for apidoc Am|void|croak_no_modify
Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
-terser object code than using C<Perl_croak>. Less code used on exception code
+terser object code than using C<Perl_croak>. 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);
}
/*
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);
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);
}
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);
}
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;
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;
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;
}
{
#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<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
- Copy(environ[j], tmpenv[j], len+1, char);
- }
- tmpenv[max] = NULL;
- environ = tmpenv; /* tell exec where it is now */
- }
- if (!val) {
- safesysfree(environ[i]);
- while (environ[i]) {
- environ[i] = environ[i+1];
- i++;
- }
- return;
- }
- if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
- environ[i+1] = NULL; /* make sure it's null terminated */
- }
- else
- safesysfree(environ[i]);
- nlen = strlen(nam);
- vlen = strlen(val);
+ /* most putenv()s leak, so we manipulate environ directly */
+ I32 i;
+ 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<max; j++) { /* copy environment */
+ const int len = strlen(environ[j]);
+ tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ Copy(environ[j], tmpenv[j], len+1, char);
+ }
+ tmpenv[max] = NULL;
+ environ = tmpenv; /* tell exec where it is now */
+ }
+ if (!val) {
+ safesysfree(environ[i]);
+ while (environ[i]) {
+ environ[i] = environ[i+1];
+ i++;
+ }
+ return;
+ }
+ if (!environ[i]) { /* does not exist yet */
+ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ[i+1] = NULL; /* make sure it's null terminated */
+ }
+ else
+ safesysfree(environ[i]);
+ nlen = strlen(nam);
+ vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(environ[i], nam, nlen, val, vlen);
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
-# if defined(__CYGWIN__) || defined(EPOC) || 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))
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
# else
# if defined(HAS_UNSETENV)
if (val == NULL) {
- (void)unsetenv(nam);
+ if (environ) /* old glibc can crash with null environ */
+ (void)unsetenv(nam);
} else {
const int nlen = strlen(nam);
const int vlen = strlen(val);
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
- register char *envstr;
+ char *envstr;
const int nlen = strlen(nam);
int vlen;
#endif /* WIN32 || NETWARE */
-#endif /* !VMS && !EPOC*/
+#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
I32
/* this is a drop-in replacement for bcopy() */
#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
-Perl_my_bcopy(register const char *from,register char *to,register I32 len)
+Perl_my_bcopy(const char *from, char *to, I32 len)
{
char * const retval = to;
PERL_ARGS_ASSERT_MY_BCOPY;
+ assert(len >= 0);
+
if (from - to >= 0) {
while (len--)
*to++ = *from++;
/* 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;
/* 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;
/* 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;
#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];
PERL_FLUSHALL_FOR_CHILD;
This = (*mode == 'w');
that = !This;
- if (PL_tainting) {
+ if (TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
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 */
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);
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;
}
/* 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;
#endif
This = (*mode == 'w');
that = !This;
- if (doexec && PL_tainting) {
+ if (doexec && TAINTING_get) {
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
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')) {
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 */
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);
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 *
}
#endif
#endif
-#endif
#endif /* !DOSISH */
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
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
#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)
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;
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;
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)
#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;
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);
#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;
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
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
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);
}
#endif
-#if defined(atarist) || defined(OS2) || defined(EPOC)
+#if defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
#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;
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
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
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),
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
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);
struct perl_vars *
Perl_GetVars(pTHX)
{
- return &PL_Vars;
+ PERL_UNUSED_CONTEXT;
+ return &PL_Vars;
}
#endif
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)
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);
}
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" : /* "<HANDLE>" not nice */
+ (op == OP_READLINE || op == OP_RCATLINE
+ ? "readline" : /* "<HANDLE>" 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)
);
- }
}
}
*
*/
-#ifdef HAS_GNULIBC
+#ifdef __GLIBC__
# ifndef STRUCT_TM_HASZONE
# define STRUCT_TM_HASZONE
# endif
#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
* 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;
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
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;
#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
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 */
* 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;
#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
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;
return S_socketpair_udp(fd);
#endif
+ aTHXa(PERL_GET_THX);
listener = PerlSock_socket(AF_INET, type, 0);
if (listener == -1)
return -1;
}
#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
=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.
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
return opt;
}
+#ifdef VMS
+# include <starlet.h>
+#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
#endif
U32 u;
#ifdef VMS
-# include <starlet.h>
/* when[] = (low 32 bits, high 32 bits) of time since epoch
* in 100-ns units, typically incremented ever 10 ms. */
unsigned int when[2];
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
{
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));
# 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*)
# 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;
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
* 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
* 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:
default:
len = 0;
}
- PerlLIO_write(fd, buf, len);
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
}
}
}
=for apidoc my_sprintf
The C library C<sprintf>, 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<sprintf>.
=cut
#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<Q> 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<Q>, if necessary. In this case it will return the modified copy of
+the format, B<which the caller will need to free.>
+
+See also L</quadmath_format_needed>.
+
+=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<should> in theory be processed
+with quadmath_snprintf(), but in case there is more than one such
+format specifier (see L</quadmath_format_single>), and if there is
+anything else beyond that one (even just a single byte), they
+B<cannot> 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<snprintf> functionality, if available and
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 */
(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;
}
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);
(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
(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';
#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;
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);
}
}
-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<strlcat> if available, or a Perl implementation of it.
+This operates on C C<NUL>-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<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
+most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
+unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
+practice this should not happen as it means that either C<size> is incorrect or
+that C<dst> is not a proper C<NUL>-terminated string).
- SvREFCNT_dec(compver_string);
- SvREFCNT_dec(runver_string);
- }
- SvREFCNT_dec(runver);
- if (xpt)
- Perl_croak_sv(aTHX_ xpt);
-}
+Note that C<size> is the full size of the destination buffer and
+the result is guaranteed to be C<NUL>-terminated if there is room. Note that
+room for the C<NUL> should be included in C<size>.
+
+=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)
}
#endif
+
+/*
+=for apidoc my_strlcpy
+
+The C library C<strlcpy> if available, or a Perl implementation of it.
+This operates on C C<NUL>-terminated strings.
+
+C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
+to C<dst>, C<NUL>-terminating the result if C<size> 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)
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 {
(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)
#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
}
}
/*
+ * 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<must> 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 <execinfo.h> in glibc and in most
+ * modern BSDs; dladdr() is available via <dlfcn.h>. */
+
+ /* 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:
*/