#include "perliol.h" /* For PerlIOUnix_refcnt */
#endif
-#ifndef PERL_MICRO
#include <signal.h>
#ifndef SIG_ERR
# define SIG_ERR ((Sighandler_t) -1)
#endif
-#endif
#include <math.h>
#include <stdlib.h>
{
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);
+ Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+ header, header->size, errno);
}
static void
{
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);
+ 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)
# endif
#endif
-/* paranoid version of system's malloc() */
+/*
+=for apidoc_section $memory
+=for apidoc safesysmalloc
+Paranoid version of system's malloc()
+
+=cut
+*/
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
+ Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
#endif
if (!size) size = 1; /* malloc(0) is NASTY on our system */
SAVE_ERRNO;
#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();
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
}
#else
ptr = (Malloc_t)PerlMem_malloc(size);
PERL_ALLOC_CHECK(ptr);
if (ptr != NULL) {
#ifdef USE_MDH
- 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;
#endif
#ifdef PERL_POISON
- PoisonNew(((char *)ptr), size, char);
+ PoisonNew(((char *)ptr), size, char);
#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;
- maybe_protect_ro(header->next);
+ 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;
+ maybe_protect_ro(header->next);
# ifdef PERL_DEBUG_READONLY_COW
- header->readonly = 0;
+ header->readonly = 0;
# endif
#endif
#ifdef MDH_HAS_SIZE
- header->size = 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));
+ 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));
/* malloc() can modify errno() even on success, but since someone
- writing perl code doesn't have any control over when perl calls
- malloc() we need to hide that.
- */
+ writing perl code doesn't have any control over when perl calls
+ malloc() we need to hide that.
+ */
RESTORE_ERRNO;
}
else {
if (PL_nomemok)
ptr = NULL;
else
- croak_no_mem();
+ croak_no_mem_ext(STR_WITH_LEN("util:safesysmalloc"));
}
}
return ptr;
}
-/* paranoid version of system's realloc() */
+/*
+=for apidoc safesysrealloc
+Paranoid version of system's realloc()
+
+=cut
+*/
Malloc_t
Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
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;
+ ? ((struct perl_memory_debug_header *)((char *)where - PERL_MEMORY_DEBUG_HEADER_SIZE))->size
+ : 0;
#endif
if (!size) {
- safesysfree(where);
- ptr = NULL;
+ safesysfree(where);
+ ptr = NULL;
}
else if (!where) {
- ptr = safesysmalloc(size);
+ ptr = safesysmalloc(size);
}
else {
dSAVE_ERRNO;
+ PERL_DEB(UV was_where = PTR2UV(where)); /* used in diags below */
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
goto out_of_memory;
- size += PERL_MEMORY_DEBUG_HEADER_SIZE;
- {
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ size += PERL_MEMORY_DEBUG_HEADER_SIZE;
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
# ifdef PERL_TRACK_MEMPOOL
- if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
- header->interpreter, aTHX);
- }
- assert(header->next->prev == header);
- assert(header->prev->next == header);
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc %p from wrong pool, %p!=%p",
+ where, header->interpreter, aTHX);
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
# ifdef PERL_POISON
- if (header->size > size) {
- const MEM_SIZE freed_up = header->size - size;
- char *start_of_freed = ((char *)where) + size;
- PoisonFree(start_of_freed, freed_up, char);
- }
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ PoisonFree(start_of_freed, freed_up, char);
+ }
# endif
# endif
# ifdef MDH_HAS_SIZE
- header->size = size;
+ header->size = size;
# endif
- }
+ }
#endif
#ifdef DEBUGGING
- if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: realloc %p , size=%" UVuf,
+ where, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
- if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
- Copy(where,ptr,oldsize < size ? oldsize : size,char);
- if (munmap(where, oldsize)) {
- perror("munmap failed");
- abort();
- }
+ if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ Copy(where,ptr,oldsize < size ? oldsize : size,char);
+ if (munmap(where, oldsize)) {
+ perror("munmap failed");
+ abort();
+ }
#else
- ptr = (Malloc_t)PerlMem_realloc(where,size);
+ ptr = (Malloc_t)PerlMem_realloc(where,size);
#endif
- PERL_ALLOC_CHECK(ptr);
+ PERL_ALLOC_CHECK(ptr);
/* MUST do this fixup first, before doing ANYTHING else, as anything else
might allocate memory/free/move memory, and until we do the fixup, it
may well be chasing (and writing to) free memory. */
- if (ptr != NULL) {
+ if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
# ifdef PERL_POISON
- if (header->size < size) {
- const MEM_SIZE fresh = size - header->size;
- char *start_of_fresh = ((char *)ptr) + size;
- PoisonNew(start_of_fresh, fresh, char);
- }
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ PoisonNew(start_of_fresh, fresh, char);
+ }
# endif
- maybe_protect_rw(header->next);
- header->next->prev = header;
- maybe_protect_ro(header->next);
- maybe_protect_rw(header->prev);
- header->prev->next = header;
- maybe_protect_ro(header->prev);
+ maybe_protect_rw(header->next);
+ header->next->prev = header;
+ maybe_protect_ro(header->next);
+ maybe_protect_rw(header->prev);
+ header->prev->next = header;
+ maybe_protect_ro(header->prev);
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- /* realloc() can modify errno() even on success, but since someone
- writing perl code doesn't have any control over when perl calls
- realloc() we need to hide that.
- */
- RESTORE_ERRNO;
- }
+ /* realloc() can modify errno() even on success, but since someone
+ writing perl code doesn't have any control over when perl calls
+ realloc() we need to hide that.
+ */
+ RESTORE_ERRNO;
+ }
/* 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",was_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) {
+ if (ptr == NULL) {
#ifdef USE_MDH
out_of_memory:
#endif
if (PL_nomemok)
ptr = NULL;
else
- croak_no_mem();
+ croak_no_mem_ext(STR_WITH_LEN("util:safesysrealloc"));
}
- }
+ }
}
return ptr;
}
-/* safe version of system's free() */
+/*
+=for apidoc safesysfree
+Safe version of system's free()
+
+=cut
+*/
Free_t
Perl_safesysfree(Malloc_t where)
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#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_intrn;
+ 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_intrn;
# ifdef MDH_HAS_SIZE
- const MEM_SIZE size = header->size;
+ const MEM_SIZE size = header->size;
# endif
# ifdef PERL_TRACK_MEMPOOL
- if (header->interpreter != aTHX) {
- 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))
- 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);
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: free %p from wrong pool, %p!=%p",
+ where, header->interpreter, aTHX);
+ }
+ if (!header->prev) {
+ Perl_croak_nocontext("panic: duplicate free");
+ }
+ if (!(header->next))
+ Perl_croak_nocontext("panic: bad free of %p, header->next==NULL",
+ where);
+ if (header->next->prev != header || header->prev->next != header) {
+ Perl_croak_nocontext("panic: bad free of %p, ->next->prev=%p, "
+ "header=%p, ->prev->next=%p",
+ where, 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_intrn, size, char);
+ PoisonNew(where_intrn, size, char);
# endif
- /* Trigger the duplicate free warning. */
- header->next = NULL;
+ /* Trigger the duplicate free warning. */
+ header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
- if (munmap(where_intrn, size)) {
- perror("munmap failed");
- abort();
- }
+ if (munmap(where_intrn, size)) {
+ perror("munmap failed");
+ abort();
+ }
# endif
- }
+ }
#else
- Malloc_t where_intrn = where;
+ Malloc_t where_intrn = where;
#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
- PerlMem_free(where_intrn);
+ PerlMem_free(where_intrn);
#endif
}
}
-/* safe version of system's calloc() */
+/*
+=for apidoc safesyscalloc
+Safe version of system's calloc()
+
+=cut
+*/
Malloc_t
Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size)) {
#if defined(USE_MDH) || defined(DEBUGGING)
- total_size = size * count;
+ total_size = size * count;
#endif
}
else
- croak_memory_wrap();
+ 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;
+ total_size += PERL_MEMORY_DEBUG_HEADER_SIZE;
else
- croak_memory_wrap();
+ croak_memory_wrap();
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
- (UV)size, (UV)count);
+ Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
+ (UV)size, (UV)count);
#endif
#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();
+ 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
/* Use calloc() because it might save a memset() if the memory is fresh
and clean from the OS. */
if (count && size)
- ptr = (Malloc_t)PerlMem_calloc(count, size);
+ ptr = (Malloc_t)PerlMem_calloc(count, size);
else /* calloc(0) is non-portable. */
- ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
+ ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1);
#endif
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
if (ptr != NULL) {
#ifdef USE_MDH
- {
- 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;
# ifndef PERL_DEBUG_READONLY_COW
- memset((void*)ptr, 0, total_size);
+ 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;
- maybe_protect_ro(header->next);
+ 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;
+ maybe_protect_ro(header->next);
# ifdef PERL_DEBUG_READONLY_COW
- header->readonly = 0;
+ header->readonly = 0;
# endif
# endif
# ifdef MDH_HAS_SIZE
- header->size = total_size;
+ header->size = total_size;
# endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- }
+ ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ }
#endif
- return ptr;
+ return ptr;
}
else {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- croak_no_mem();
+ if (PL_nomemok)
+ return NULL;
+ croak_no_mem_ext(STR_WITH_LEN("util:safesyscalloc"));
}
}
#endif
-/* copy a string up to some (non-backslashed) delimiter, if any.
- * With allow_escape, converts \<delimiter> to <delimiter>, while leaves
- * \<non-delimiter> as-is.
- * Returns the position in the src string of the closing delimiter, if
- * any, or returns fromend otherwise.
- * This is the internal implementation for Perl_delimcpy and
- * Perl_delimcpy_no_escape.
- */
+/* This is the value stored in *retlen in the two delimcpy routines below when
+ * there wasn't enough room in the destination to store everything it was asked
+ * to. The value is deliberately very large so that hopefully if code uses it
+ * unquestioningly to access memory, it will likely segfault. And it is small
+ * enough that if the caller does some arithmetic on it before accessing, it
+ * won't overflow into a small legal number. */
+#define DELIMCPY_OUT_OF_BOUNDS_RET I32_MAX
-static char *
-S_delimcpy_intern(char *to, const char *toend, const char *from,
- const char *fromend, int delim, I32 *retlen,
- const bool allow_escape)
-{
- I32 tolen;
+/*
+=for apidoc_section $string
+=for apidoc delimcpy_no_escape
- PERL_ARGS_ASSERT_DELIMCPY;
+Copy a source buffer to a destination buffer, stopping at (but not including)
+the first occurrence in the source of the delimiter byte, C<delim>. The source
+is the bytes between S<C<from> and C<from_end> - 1>. Similarly, the dest is
+C<to> up to C<to_end>.
- for (tolen = 0; from < fromend; from++, tolen++) {
- if (allow_escape && *from == '\\' && from + 1 < fromend) {
- if (from[1] != delim) {
- if (to < toend)
- *to++ = *from;
- tolen++;
- }
- from++;
- }
- else if (*from == delim)
- break;
- if (to < toend)
- *to++ = *from;
- }
- if (to < toend)
- *to = '\0';
- *retlen = tolen;
- return (char *)from;
-}
+The number of bytes copied is written to C<*retlen>.
+
+Returns the position of C<delim> in the C<from> buffer, but if there is no
+such occurrence before C<from_end>, then C<from_end> is returned, and the entire
+buffer S<C<from> .. C<from_end> - 1> is copied.
+
+If there is room in the destination available after the copy, an extra
+terminating safety C<NUL> byte is appended (not included in the returned
+length).
+
+The error case is if the destination buffer is not large enough to accommodate
+everything that should be copied. In this situation, a value larger than
+S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
+fits will be written to the destination. Not having room for the safety C<NUL>
+is not considered an error.
+=cut
+*/
char *
-Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+Perl_delimcpy_no_escape(char *to, const char *to_end,
+ const char *from, const char *from_end,
+ const int delim, I32 *retlen)
{
- PERL_ARGS_ASSERT_DELIMCPY;
+ const char * delim_pos;
+ Ptrdiff_t from_len = from_end - from;
+ Ptrdiff_t to_len = to_end - to;
+ SSize_t copy_len;
+
+ PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
+
+ assert(from_len >= 0);
+ assert(to_len >= 0);
+
+ /* Look for the first delimiter in the source */
+ delim_pos = (const char *) memchr(from, delim, from_len);
+
+ /* Copy up to where the delimiter was found, or the entire buffer if not
+ * found */
+ copy_len = (delim_pos) ? delim_pos - from : from_len;
+
+ /* If not enough room, copy as much as can fit, and set error return */
+ if (copy_len > to_len) {
+ Copy(from, to, to_len, char);
+ *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
+ }
+ else {
+ Copy(from, to, copy_len, char);
+
+ /* If there is extra space available, add a trailing NUL */
+ if (copy_len < to_len) {
+ to[copy_len] = '\0';
+ }
+
+ *retlen = copy_len;
+ }
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
+ return (char *) from + copy_len;
}
+/*
+=for apidoc delimcpy
+
+Copy a source buffer to a destination buffer, stopping at (but not including)
+the first occurrence in the source of an unescaped (defined below) delimiter
+byte, C<delim>. The source is the bytes between S<C<from> and C<from_end> -
+1>. Similarly, the dest is C<to> up to C<to_end>.
+
+The number of bytes copied is written to C<*retlen>.
+
+Returns the position of the first uncopied C<delim> in the C<from> buffer, but
+if there is no such occurrence before C<from_end>, then C<from_end> is returned,
+and the entire buffer S<C<from> .. C<from_end> - 1> is copied.
+
+If there is room in the destination available after the copy, an extra
+terminating safety C<NUL> byte is appended (not included in the returned
+length).
+
+The error case is if the destination buffer is not large enough to accommodate
+everything that should be copied. In this situation, a value larger than
+S<C<to_end> - C<to>> is written to C<*retlen>, and as much of the source as
+fits will be written to the destination. Not having room for the safety C<NUL>
+is not considered an error.
+
+In the following examples, let C<x> be the delimiter, and C<0> represent a C<NUL>
+byte (B<NOT> the digit C<0>). Then we would have
+
+ Source Destination
+ abcxdef abc0
+
+provided the destination buffer is at least 4 bytes long.
+
+An escaped delimiter is one which is immediately preceded by a single
+backslash. Escaped delimiters are copied, and the copy continues past the
+delimiter; the backslash is not copied:
+
+ Source Destination
+ abc\xdef abcxdef0
+
+(provided the destination buffer is at least 8 bytes long).
+
+It's actually somewhat more complicated than that. A sequence of any odd number
+of backslashes escapes the following delimiter, and the copy continues with
+exactly one of the backslashes stripped.
+
+ Source Destination
+ abc\xdef abcxdef0
+ abc\\\xdef abc\\xdef0
+ abc\\\\\xdef abc\\\\xdef0
+
+(as always, if the destination is large enough)
+
+An even number of preceding backslashes does not escape the delimiter, so that
+the copy stops just before it, and includes all the backslashes (no stripping;
+zero is considered even):
+
+ Source Destination
+ abcxdef abc0
+ abc\\xdef abc\\0
+ abc\\\\xdef abc\\\\0
+
+=cut
+*/
+
char *
-Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
- const char *fromend, int delim, I32 *retlen)
+Perl_delimcpy(char *to, const char *to_end,
+ const char *from, const char *from_end,
+ const int delim, I32 *retlen)
{
- PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
+ const char * const orig_to = to;
+ Ptrdiff_t copy_len = 0;
+ bool stopped_early = FALSE; /* Ran out of room to copy to */
+
+ PERL_ARGS_ASSERT_DELIMCPY;
+ assert(from_end >= from);
+ assert(to_end >= to);
+
+ /* Don't use the loop for the trivial case of the first character being the
+ * delimiter; otherwise would have to worry inside the loop about backing
+ * up before the start of 'from' */
+ if (LIKELY(from_end > from && *from != delim)) {
+ while ((copy_len = from_end - from) > 0) {
+ const char * backslash_pos;
+ const char * delim_pos;
+
+ /* Look for the next delimiter in the remaining portion of the
+ * source. A loop invariant is that we already know that the copy
+ * should include *from; this comes from the conditional before the
+ * loop, and how we set things up at the end of each iteration */
+ delim_pos = (const char *) memchr(from + 1, delim, copy_len - 1);
+
+ /* If didn't find it, done looking; set up so copies all of the
+ * source */
+ if (! delim_pos) {
+ copy_len = from_end - from;
+ break;
+ }
+
+ /* Look for a backslash immediately before the delimiter */
+ backslash_pos = delim_pos - 1;
+
+ /* If the delimiter is not escaped, this ends the copy */
+ if (*backslash_pos != '\\') {
+ copy_len = delim_pos - from;
+ break;
+ }
+
+ /* Here there is a backslash just before the delimiter, but it
+ * could be the final backslash in a sequence of them. Backup to
+ * find the first one in it. */
+ do {
+ backslash_pos--;
+ }
+ while (backslash_pos >= from && *backslash_pos == '\\');
+
+ /* If the number of backslashes is even, they just escape one
+ * another, leaving the delimiter unescaped, and stopping the copy.
+ * */
+ if (! ((delim_pos - (backslash_pos + 1)) & 1)) {
+ copy_len = delim_pos - from; /* even, copy up to delimiter */
+ break;
+ }
+
+ /* Here is odd, so the delimiter is escaped. We will try to copy
+ * all but the final backslash in the sequence */
+ copy_len = delim_pos - 1 - from;
+
+ /* Do the copy, but not beyond the end of the destination */
+ if (copy_len >= to_end - to) {
+ Copy(from, to, to_end - to, char);
+ stopped_early = TRUE;
+ to = (char *) to_end;
+ }
+ else {
+ Copy(from, to, copy_len, char);
+ to += copy_len;
+ }
+
+ /* Set up so next iteration will include the delimiter */
+ from = delim_pos;
+ }
+ }
+
+ /* Here, have found the final segment to copy. Copy that, but not beyond
+ * the size of the destination. If not enough room, copy as much as can
+ * fit, and set error return */
+ if (stopped_early || copy_len > to_end - to) {
+ Copy(from, to, to_end - to, char);
+ *retlen = DELIMCPY_OUT_OF_BOUNDS_RET;
+ }
+ else {
+ Copy(from, to, copy_len, char);
+
+ to += copy_len;
+
+ /* If there is extra space available, add a trailing NUL */
+ if (to < to_end) {
+ *to = '\0';
+ }
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
+ *retlen = to - orig_to;
+ }
+
+ return (char *) from + copy_len;
}
/*
-=head1 Miscellaneous Functions
-
=for apidoc ninstr
Find the first (leftmost) occurrence of a sequence of bytes within another
return ninstr(big, bigend, little, lend);
#else
- if (little >= lend)
- return (char*)big;
- {
- const char first = *little;
- bigend -= lend - little++;
- OUTER:
+ if (little >= lend) {
+ return (char*) big;
+ }
+ else {
+ const U8 first = *little;
+ Size_t lsize;
+
+ /* No match can start closer to the end of the haystack than the length
+ * of the needle. */
+ bigend -= lend - little;
+ little++; /* Look for 'first', then the remainder is in here */
+ lsize = lend - little;
+
while (big <= bigend) {
- if (*big++ == first) {
- const char *s, *x;
- for (x=big,s=little; s < lend; x++,s++) {
- if (*s != *x)
- goto OUTER;
- }
- return (char*)(big-1);
+ big = (char *) memchr((U8 *) big, first, bigend - big + 1);
+ if (big == NULL || big > bigend) {
+ return NULL;
+ }
+
+ if (memEQ(big + 1, little, lsize)) {
+ return (char*) big;
}
+ big++;
}
}
+
return NULL;
#endif
}
/*
-=head1 Miscellaneous Functions
-
=for apidoc rninstr
Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
char *
Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
- const char *bigbeg;
- const I32 first = *little;
- const char * const littleend = lend;
+ const Ptrdiff_t little_len = lend - little;
+ const Ptrdiff_t big_len = bigend - big;
PERL_ARGS_ASSERT_RNINSTR;
- if (little >= littleend)
- return (char*)bigend;
- bigbeg = big;
- big = bigend - (littleend - little++);
- while (big >= bigbeg) {
- const char *s, *x;
- if (*big-- != first)
- continue;
- for (x=big+2,s=little; s < littleend; /**/ ) {
- if (*s != *x)
- break;
- else {
- x++;
- s++;
- }
- }
- if (s >= littleend)
- return (char*)(big+1);
+ /* A non-existent needle trivially matches the rightmost possible position
+ * in the haystack */
+ if (UNLIKELY(little_len <= 0)) {
+ return (char*)bigend;
+ }
+
+ /* If the needle is larger than the haystack, the needle can't possibly fit
+ * inside the haystack. */
+ if (UNLIKELY(little_len > big_len)) {
+ return NULL;
+ }
+
+ /* Special case length 1 needles. It's trivial if we have memrchr();
+ * and otherwise we just do a per-byte search backwards.
+ *
+ * XXX When we don't have memrchr, we could use something like
+ * S_find_next_masked( or S_find_span_end() to do per-word searches */
+ if (little_len == 1) {
+ const char final = *little;
+
+#ifdef HAS_MEMRCHR
+
+ return (char *) memrchr(big, final, big_len);
+#else
+ const char * cur = bigend - 1;
+
+ do {
+ if (*cur == final) {
+ return (char *) cur;
+ }
+ } while (--cur >= big);
+
+ return NULL;
+#endif
+
+ }
+ else { /* Below, the needle is longer than a single byte */
+
+ /* We search backwards in the haystack for the final character of the
+ * needle. Each time one is found, we see if the characters just
+ * before it in the haystack match the rest of the needle. */
+ const char final = *(lend - 1);
+
+ /* What matches consists of 'little_len'-1 characters, then the final
+ * one */
+ const Size_t prefix_len = little_len - 1;
+
+ /* If the final character in the needle is any closer than this to the
+ * left edge, there wouldn't be enough room for all of it to fit in the
+ * haystack */
+ const char * const left_fence = big + prefix_len;
+
+ /* Start at the right edge */
+ char * cur = (char *) bigend;
+
+ /* memrchr() makes the search easy (and fast); otherwise, look
+ * backwards byte-by-byte. */
+ do {
+
+#ifdef HAS_MEMRCHR
+
+ cur = (char *) memrchr(left_fence, final, cur - left_fence);
+ if (cur == NULL) {
+ return NULL;
+ }
+#else
+ do {
+ cur--;
+ if (cur < left_fence) {
+ return NULL;
+ }
+ }
+ while (*cur != final);
+#endif
+
+ /* Here, we know that *cur is 'final'; see if the preceding bytes
+ * of the needle also match the corresponding haystack bytes */
+ if memEQ(cur - prefix_len, little, prefix_len) {
+ return cur - prefix_len;
+ }
+ } while (cur > left_fence);
+
+ return NULL;
}
- return NULL;
}
/* As a space optimization, we do not compile tables for strings of length
If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
/*
-=head1 Miscellaneous Functions
=for apidoc fbm_compile
PERL_ARGS_ASSERT_FBM_COMPILE;
if (isGV_with_GP(sv) || SvROK(sv))
- return;
+ return;
if (SvVALID(sv))
- return;
+ return;
if (flags & FBMcf_TAIL) {
- MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
- sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
- if (mg && mg->mg_len >= 0)
- mg->mg_len++;
+ MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
+ sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */
+ if (mg && mg->mg_len >= 0)
+ mg->mg_len++;
}
if (!SvPOK(sv) || SvNIOKp(sv))
- s = (U8*)SvPV_force_mutable(sv, len);
+ 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;
+ return;
SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
assert(mg);
if (len > 2) {
- /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
- the BM table. */
- const U8 mlen = (len>255) ? 255 : (U8)len;
- const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
- U8 *table;
-
- Newx(table, 256, U8);
- memset((void*)table, mlen, 256);
- mg->mg_ptr = (char *)table;
- mg->mg_len = 256;
-
- s += len - 1; /* last char */
- i = 0;
- while (s >= sb) {
- if (table[*s] == mlen)
- table[*s] = (U8)i;
- s--, i++;
- }
+ /* Shorter strings are special-cased in Perl_fbm_instr(), and don't use
+ the BM table. */
+ const U8 mlen = (len>255) ? 255 : (U8)len;
+ const unsigned char *const sb = s + len - mlen; /* first char (maybe) */
+ U8 *table;
+
+ Newx(table, 256, U8);
+ memset((void*)table, mlen, 256);
+ mg->mg_ptr = (char *)table;
+ mg->mg_len = 256;
+
+ s += len - 1; /* last char */
+ i = 0;
+ while (s >= sb) {
+ if (table[*s] == mlen)
+ table[*s] = (U8)i;
+ s--, i++;
+ }
}
BmUSEFUL(sv) = 100; /* Initial value */
assert(bigend >= big);
if ((STRLEN)(bigend - big) < littlelen) {
- if ( tail
- && ((STRLEN)(bigend - big) == littlelen - 1)
- && (littlelen == 1
- || (*big == *little &&
- memEQ((char *)big, (char *)little, littlelen - 1))))
- return (char*)big;
- return NULL;
+ if ( tail
+ && ((STRLEN)(bigend - big) == littlelen - 1)
+ && (littlelen == 1
+ || (*big == *little &&
+ memEQ((char *)big, (char *)little, littlelen - 1))))
+ return (char*)big;
+ return NULL;
}
switch (littlelen) { /* Special cases for 0, 1 and 2 */
case 0:
- return (char*)big; /* Cannot be SvTAIL! */
+ return (char*)big; /* Cannot be SvTAIL! */
case 1:
- if (tail && !multiline) /* Anchor only! */
- /* [-1] is safe because we know that bigend != big. */
- return (char *) (bigend - (bigend[-1] == '\n'));
+ if (tail && !multiline) /* Anchor only! */
+ /* [-1] is safe because we know that bigend != big. */
+ return (char *) (bigend - (bigend[-1] == '\n'));
- s = (unsigned char *)memchr((void*)big, *little, bigend-big);
+ s = (unsigned char *)memchr((void*)big, *little, bigend-big);
if (s)
return (char *)s;
- if (tail)
- return (char *) bigend;
- return NULL;
+ if (tail)
+ return (char *) bigend;
+ return NULL;
case 2:
- if (tail && !multiline) {
+ if (tail && !multiline) {
/* a littlestr with SvTAIL must be of the form "X\n" (where X
* is a single char). It is anchored, and can only match
* "....X\n" or "....X" */
if (bigend[-2] == *little && bigend[-1] == '\n')
- return (char*)bigend - 2;
- if (bigend[-1] == *little)
- return (char*)bigend - 1;
- return NULL;
- }
+ return (char*)bigend - 2;
+ if (bigend[-1] == *little)
+ return (char*)bigend - 1;
+ return NULL;
+ }
- {
+ {
/* memchr() is likely to be very fast, possibly using whatever
* hardware support is available, such as checking a whole
* cache line in one instruction.
* only needed to read every 2nd char, which was good back in
* the day, but no longer.
*/
- unsigned char c1 = little[0];
- unsigned char c2 = little[1];
+ unsigned char c1 = little[0];
+ unsigned char c2 = little[1];
/* *** for all this case, bigend points to the last char,
* not the trailing \0: this makes the conditions slightly
* simpler */
bigend--;
- s = big;
+ s = big;
if (c1 != c2) {
while (s < bigend) {
/* do a quick test for c1 before calling memchr();
}
default:
- break; /* Only lengths 0 1 and 2 have special-case code. */
+ break; /* Only lengths 0 1 and 2 have special-case code. */
}
if (tail && !multiline) { /* tail anchored? */
- s = bigend - littlelen;
- if (s >= big && bigend[-1] == '\n' && *s == *little
- /* Automatically of length > 2 */
- && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
- {
- return (char*)s; /* how sweet it is */
- }
- if (s[1] == *little
- && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
- {
- return (char*)s + 1; /* how sweet it is */
- }
- return NULL;
+ s = bigend - littlelen;
+ if (s >= big && bigend[-1] == '\n' && *s == *little
+ /* Automatically of length > 2 */
+ && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
+ {
+ return (char*)s; /* how sweet it is */
+ }
+ if (s[1] == *little
+ && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
+ {
+ return (char*)s + 1; /* how sweet it is */
+ }
+ return NULL;
}
if (!valid) {
/* not compiled; use Perl_ninstr() instead */
- char * const b = ninstr((char*)big,(char*)bigend,
- (char*)little, (char*)little + littlelen);
+ char * const b = ninstr((char*)big,(char*)bigend,
+ (char*)little, (char*)little + littlelen);
assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
- return b;
+ return b;
}
/* Do actual FBM. */
if (littlelen > (STRLEN)(bigend - big))
- return NULL;
+ return NULL;
{
- const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
- const unsigned char *oldlittle;
+ const MAGIC *const mg = mg_find(littlestr, PERL_MAGIC_bm);
+ const unsigned char *oldlittle;
- assert(mg);
+ assert(mg);
- --littlelen; /* Last char found by table lookup */
+ --littlelen; /* Last char found by table lookup */
- s = big + littlelen;
- little += littlelen; /* last char */
- oldlittle = little;
- if (s < bigend) {
- const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+ s = big + littlelen;
+ little += littlelen; /* last char */
+ oldlittle = little;
+ if (s < bigend) {
+ const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
const unsigned char lastc = *little;
- I32 tmp;
+ I32 tmp;
- top2:
- if ((tmp = table[*s])) {
+ top2:
+ if ((tmp = table[*s])) {
/* *s != lastc; earliest position it could match now is
* tmp slots further on */
- if ((s += tmp) >= bigend)
+ if ((s += tmp) >= bigend)
goto check_end;
if (LIKELY(*s != lastc)) {
s++;
}
goto top2;
}
- }
+ }
/* hand-rolled strncmp(): less expensive than calling the
* real function (maybe???) */
- {
- unsigned char * const olds = s;
-
- tmp = littlelen;
-
- while (tmp--) {
- if (*--s == *--little)
- continue;
- s = olds + 1; /* here we pay the price for failure */
- little = oldlittle;
- if (s < bigend) /* fake up continue to outer loop */
- goto top2;
- goto check_end;
- }
- return (char *)s;
- }
- }
+ {
+ unsigned char * const olds = s;
+
+ tmp = littlelen;
+
+ while (tmp--) {
+ if (*--s == *--little)
+ continue;
+ s = olds + 1; /* here we pay the price for failure */
+ little = oldlittle;
+ if (s < bigend) /* fake up continue to outer loop */
+ goto top2;
+ goto check_end;
+ }
+ return (char *)s;
+ }
+ }
check_end:
- if ( s == bigend
- && tail
- && memEQ((char *)(bigend - littlelen),
- (char *)(oldlittle - littlelen), littlelen) )
- return (char*)bigend - littlelen;
- return NULL;
+ if ( s == bigend
+ && tail
+ && memEQ((char *)(bigend - littlelen),
+ (char *)(oldlittle - littlelen), littlelen) )
+ return (char*)bigend - littlelen;
+ return NULL;
}
}
return NULL;
}
-/* copy a string to a safe spot */
-
-/*
-=head1 Memory Management
-
-=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()>, which means it may not contain embedded C<NUL>
-characters and must have a trailing C<NUL>. To prevent memory leaks, the
-memory allocated for the new string needs to be freed when no longer needed.
-This can be done with the L</C<Safefree>> function, or
-L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
-
-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
-*/
-
-char *
-Perl_savepv(pTHX_ const char *pv)
-{
- PERL_UNUSED_CONTEXT;
- if (!pv)
- return NULL;
- else {
- char *newaddr;
- const STRLEN pvlen = strlen(pv)+1;
- Newx(newaddr, pvlen, char);
- return (char*)memcpy(newaddr, pv, pvlen);
- }
-}
-
-/* same thing but with a known length */
-
-/*
-=for apidoc savepvn
-
-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
-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, Size_t len)
-{
- char *newaddr;
- PERL_UNUSED_CONTEXT;
-
- Newx(newaddr,len+1,char);
- /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
- if (pv) {
- /* might not be null terminated */
- newaddr[len] = '\0';
- return (char *) CopyD(pv,newaddr,len,char);
- }
- else {
- return (char *) ZeroD(newaddr,len+1,char);
- }
-}
-
/*
=for apidoc savesharedpv
PERL_UNUSED_CONTEXT;
if (!pv)
- return NULL;
+ return NULL;
pvlen = strlen(pv)+1;
newaddr = (char*)PerlMemShared_malloc(pvlen);
if (!newaddr) {
- croak_no_mem();
+ croak_no_mem_ext(STR_WITH_LEN("util:savesharedpv"));
}
return (char*)memcpy(newaddr, pv, pvlen);
}
/* PERL_ARGS_ASSERT_SAVESHAREDPVN; */
if (!newaddr) {
- croak_no_mem();
+ croak_no_mem_ext(STR_WITH_LEN("util:savesharedpvn"));
}
newaddr[len] = '\0';
return (char*)memcpy(newaddr, pv, len);
}
-/*
-=for apidoc savesvpv
-
-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
-*/
-
-char *
-Perl_savesvpv(pTHX_ SV *sv)
-{
- STRLEN len;
- const char * const pv = SvPV_const(sv, len);
- char *newaddr;
-
- PERL_ARGS_ASSERT_SAVESVPV;
-
- ++len;
- Newx(newaddr,len,char);
- return (char *) CopyD(pv,newaddr,len,char);
-}
-
-/*
-=for apidoc savesharedsvpv
-
-A version of C<savesharedpv()> which allocates the duplicate string in
-memory which is shared between threads.
-
-=cut
-*/
-
-char *
-Perl_savesharedsvpv(pTHX_ SV *sv)
-{
- STRLEN len;
- const char * const pv = SvPV_const(sv, len);
-
- PERL_ARGS_ASSERT_SAVESHAREDSVPV;
-
- return savesharedpvn(pv, len);
-}
-
/* the SV for Perl_form() and mess() is not kept in an arena */
STATIC SV *
XPVMG *any;
if (PL_phase != PERL_PHASE_DESTRUCT)
- return newSVpvs_flags("", SVs_TEMP);
+ return newSVpvs_flags("", SVs_TEMP);
if (PL_mess_sv)
- return PL_mess_sv;
+ return PL_mess_sv;
/* Create as PVMG now, to avoid any upgrading later */
Newx(sv, 1, SV);
return sv;
}
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
char *
Perl_form_nocontext(const char* pat, ...)
{
va_end(args);
return retval;
}
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $display
=for apidoc form
+=for apidoc_item form_nocontext
-Takes a sprintf-style format pattern and conventional
-(non-SV) arguments and returns the formatted string.
+These take a sprintf-style format pattern and conventional
+(non-SV) arguments and return the formatted string.
(char *) Perl_form(pTHX_ const char* pat, ...)
char * s = Perl_form("%d.%d",major,minor);
-Uses a single private buffer so if you want to format several strings you
-must explicitly copy the earlier strings away (and free the copies when you
-are done).
+They use a single (per-thread) private buffer so if you want to format several
+strings you must explicitly copy the earlier strings away (and free the copies
+when you are done).
+
+The two forms differ only in that C<form_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
+
+=for apidoc vform
+Like C<L</form>> but but the arguments are an encapsulated argument list.
=cut
*/
/*
=for apidoc mess
+=for apidoc_item mess_nocontext
-Take a sprintf-style format pattern and argument list. These are used to
-generate a string message. If the message does not end with a newline,
-then it will be extended with some indication of the current location
-in the code, as described for L</mess_sv>.
+These take a sprintf-style format pattern and argument list, which are used to
+generate a string message. If the message does not end with a newline, then it
+will be extended with some indication of the current location in the code, as
+described for C<L</mess_sv>>.
Normally, the resulting message is returned in a new mortal SV.
-During global destruction a single SV may be shared between uses of
+But during global destruction a single SV may be shared between uses of
this function.
+The two forms differ only in that C<mess_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
+
=cut
*/
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
SV *
Perl_mess_nocontext(const char *pat, ...)
{
va_end(args);
return retval;
}
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
SV *
Perl_mess(pTHX_ const char *pat, ...)
const COP*
Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
- bool opnext)
+ bool opnext)
{
/* 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
PERL_ARGS_ASSERT_CLOSEST_COP;
if (!o || !curop || (
- opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
+ opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
))
- return cop;
+ return cop;
if (o->op_flags & OPf_KIDS) {
- const OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
- const COP *new_cop;
+ const OP *kid;
+ 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
- * the get the file and line number. */
+ /* If the OP_NEXTSTATE has been optimised away we can still use it
+ * the get the file and line number. */
- if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
- cop = (const COP *)kid;
+ if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE)
+ cop = (const COP *)kid;
- /* Keep searching, and return when we've found something. */
+ /* Keep searching, and return when we've found something. */
- new_cop = closest_cop(cop, kid, curop, opnext);
- if (new_cop)
- return new_cop;
- }
+ new_cop = closest_cop(cop, kid, curop, opnext);
+ if (new_cop)
+ return new_cop;
+ }
}
/* Nothing found. */
PERL_ARGS_ASSERT_MESS_SV;
if (SvROK(basemsg)) {
- if (consume) {
- sv = basemsg;
- }
- else {
- sv = mess_alloc();
- sv_setsv(sv, basemsg);
- }
- return sv;
+ if (consume) {
+ sv = basemsg;
+ }
+ else {
+ sv = mess_alloc();
+ sv_setsv(sv, basemsg);
+ }
+ return sv;
}
if (SvPOK(basemsg) && consume) {
- sv = basemsg;
+ sv = basemsg;
}
else {
- sv = mess_alloc();
- sv_copypv(sv, basemsg);
+ sv = mess_alloc();
+ sv_copypv(sv, basemsg);
}
if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
- /*
- * Try and find the file and line for PL_op. This will usually be
- * PL_curcop, but it might be a cop that has been optimised away. We
- * can try to find such a cop by searching through the optree starting
- * from the sibling of PL_curcop.
- */
+ /*
+ * Try and find the file and line for PL_op. This will usually be
+ * PL_curcop, but it might be a cop that has been optimised away. We
+ * can try to find such a cop by searching through the optree starting
+ * from the sibling of PL_curcop.
+ */
if (PL_curcop) {
const COP *cop =
cop = PL_curcop;
if (CopLINE(cop))
- Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
- OutCopFILE(cop), (IV)CopLINE(cop));
+ Perl_sv_catpvf(aTHX_ sv, " at %s line %" LINE_Tf,
+ OutCopFILE(cop), CopLINE(cop));
}
- /* Seems that GvIO() can be untrustworthy during global destruction. */
- 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) &&
- *SvPV_const(PL_rs,l) == '\n' && l == 1);
- Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf,
- SVfARG(PL_last_in_gv == PL_argvgv
+ /* Seems that GvIO() can be untrustworthy during global destruction. */
+ 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) &&
+ *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)));
- }
- if (PL_phase == PERL_PHASE_DESTRUCT)
- sv_catpvs(sv, " during global destruction");
- sv_catpvs(sv, ".\n");
+ : newSVhek_mortal(GvNAME_HEK(PL_last_in_gv))),
+ line_mode ? "line" : "chunk",
+ (IV)IoLINES(GvIOp(PL_last_in_gv)));
+ }
+ if (PL_phase == PERL_PHASE_DESTRUCT)
+ sv_catpvs(sv, " during global destruction");
+ sv_catpvs(sv, ".\n");
}
return sv;
}
PERL_ARGS_ASSERT_WRITE_TO_STDERR;
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, SV_CONST(PRINT),
- G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
+ && (io = GvIO(PL_stderrgv))
+ && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
+ G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
- PerlIO * const serr = Perl_error_log;
+ PerlIO * const serr = Perl_error_log;
- do_print(msv, serr);
- (void)PerlIO_flush(serr);
+ do_print(msv, serr);
+ (void)PerlIO_flush(serr);
}
}
/*
-=head1 Warning and Dieing
+=for apidoc_section $warning
*/
/* Common code used in dieing and warning */
{
PERL_ARGS_ASSERT_WITH_QUEUED_ERRORS;
if (PL_errors && SvCUR(PL_errors) && !SvROK(ex)) {
- sv_catsv(PL_errors, ex);
- ex = sv_mortalcopy(PL_errors);
- SvCUR_set(PL_errors, 0);
+ sv_catsv(PL_errors, ex);
+ ex = sv_mortalcopy(PL_errors);
+ SvCUR_set(PL_errors, 0);
}
return ex;
}
-STATIC bool
-S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
+bool
+Perl_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
HV *stash;
GV *gv;
SV * const oldhook = *hook;
if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
- return FALSE;
+ return FALSE;
ENTER;
SAVESPTR(*hook);
cv = sv_2cv(oldhook, &stash, &gv, 0);
LEAVE;
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
- dSP;
- SV *exarg;
-
- ENTER;
- save_re_context();
- if (warn) {
- SAVESPTR(*hook);
- *hook = NULL;
- }
- exarg = newSVsv(ex);
- SvREADONLY_on(exarg);
- SAVEFREESV(exarg);
-
- PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
- PUSHMARK(SP);
- XPUSHs(exarg);
- PUTBACK;
- call_sv(MUTABLE_SV(cv), G_DISCARD);
- POPSTACK;
- LEAVE;
- return TRUE;
- }
+ dSP;
+ SV *exarg;
+
+ ENTER;
+ save_re_context();
+ if (warn) {
+ SAVESPTR(*hook);
+ *hook = NULL;
+ }
+ exarg = newSVsv(ex);
+ SvREADONLY_on(exarg);
+ SAVEFREESV(exarg);
+
+ PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK);
+ PUSHMARK(SP);
+ XPUSHs(exarg);
+ PUTBACK;
+ call_sv(MUTABLE_SV(cv), G_DISCARD);
+ POPSTACK;
+ LEAVE;
+ return TRUE;
+ }
return FALSE;
}
/*
=for apidoc die_sv
-Behaves the same as L</croak_sv>, except for the return type.
+This behaves the same as L</croak_sv>, except for the return type.
It should be used only where the C<OP *> return type is required.
The function never actually returns.
MSVC_DIAG_RESTORE
/*
-=for apidoc die
+=for apidoc die
+=for apidoc_item die_nocontext
-Behaves the same as L</croak>, except for the return type.
-It should be used only where the C<OP *> return type is required.
-The function never actually returns.
+These behave the same as L</croak>, except for the return type.
+They should be used only where the C<OP *> return type is required.
+They never actually return.
+
+The two forms differ only in that C<die_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
=cut
*/
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
/* silence __declspec(noreturn) warnings */
MSVC_DIAG_IGNORE(4646 4645)
}
MSVC_DIAG_RESTORE
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
/* silence __declspec(noreturn) warnings */
MSVC_DIAG_IGNORE(4646 4645)
/*
=for apidoc croak
+=for apidoc_item croak_nocontext
-This is an XS interface to Perl's C<die> function.
+These are XS interfaces to Perl's C<die> function.
-Take a sprintf-style format pattern and argument list. These are used to
-generate a string message. If the message does not end with a newline,
-then it will be extended with some indication of the current location
-in the code, as described for L</mess_sv>.
+They take a sprintf-style format pattern and argument list, which are used to
+generate a string message. If the message does not end with a newline, then it
+will be extended with some indication of the current location in the code, as
+described for C<L</mess_sv>>.
The error message will be used as an exception, by default
returning control to the nearest enclosing C<eval>, but subject to
-modification by a C<$SIG{__DIE__}> handler. In any case, the C<croak>
-function never returns normally.
+modification by a C<$SIG{__DIE__}> handler. In any case, these croak
+functions never return normally.
For historical reasons, if C<pat> is null then the contents of C<ERRSV>
(C<$@>) will be used as an error message or object instead of building an
error message from arguments. If you want to throw a non-string object,
or build an error message in an SV yourself, it is preferable to use
-the L</croak_sv> function, which does not involve clobbering C<ERRSV>.
+the C<L</croak_sv>> function, which does not involve clobbering C<ERRSV>.
+
+The two forms differ only in that C<croak_nocontext> does not take a thread
+context (C<aTHX>) parameter. It is usually preferred as it takes up fewer
+bytes of code than plain C<Perl_croak>, and time is rarely a critical resource
+when you are about to throw an exception.
=cut
*/
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
void
Perl_croak_nocontext(const char *pat, ...)
{
NOT_REACHED; /* NOTREACHED */
va_end(args);
}
-#endif /* PERL_IMPLICIT_CONTEXT */
-
-/* saves machine code for a common noreturn idiom typically used in Newx*() */
-GCC_DIAG_IGNORE_DECL(-Wunused-function);
-void
-Perl_croak_memory_wrap(void)
-{
- Perl_croak_nocontext("%s",PL_memory_wrap);
-}
-GCC_DIAG_RESTORE_DECL;
+#endif /* MULTIPLICITY */
void
Perl_croak(pTHX_ const char *pat, ...)
/*
=for apidoc 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
-paths reduces CPU cache pressure.
+This encapsulates a common reason for dying, generating terser object code than
+using the generic C<Perl_croak>. It is exactly equivalent to
+C<Perl_croak(aTHX_ "%s", PL_no_modify)> (which expands to something like
+"Modification of a read-only value attempted").
+
+Less code used on exception code paths reduces CPU cache pressure.
=cut
*/
This is typically called when malloc returns NULL.
*/
void
-Perl_croak_no_mem(void)
+Perl_croak_no_mem_ext(const char *context, STRLEN len)
{
dTHX;
+ PERL_ARGS_ASSERT_CROAK_NO_MEM_EXT;
+
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));
+ static const char oomp[] = "Out of memory in perl:";
+ if (
+ PerlLIO_write(fd, oomp, sizeof oomp - 1) >= 0
+ && PerlLIO_write(fd, context, len) >= 0
+ && PerlLIO_write(fd, "\n", 1) >= 0
+ ) {
+ /* nop */
+ }
}
my_exit(1);
}
+void
+Perl_croak_no_mem(void)
+{
+ croak_no_mem_ext(STR_WITH_LEN("???"));
+}
+
/* does not return, used only in POPSTACK */
void
Perl_croak_popstack(void)
SV *ex = mess_sv(baseex, 0);
PERL_ARGS_ASSERT_WARN_SV;
if (!invoke_exception_hook(ex, TRUE))
- write_to_stderr(ex);
+ write_to_stderr(ex);
}
/*
This is an XS interface to Perl's C<warn> function.
-C<pat> and C<args> are a sprintf-style format pattern and encapsulated
-argument list. These are used to generate a string message. If the
-message does not end with a newline, then it will be extended with
-some indication of the current location in the code, as described for
-L</mess_sv>.
-
-The error message or object will by default be written to standard error,
-but this is subject to modification by a C<$SIG{__WARN__}> handler.
+This is like C<L</warn>>, but C<args> are an encapsulated
+argument list.
Unlike with L</vcroak>, C<pat> is not permitted to be null.
SV *ex = vmess(pat, args);
PERL_ARGS_ASSERT_VWARN;
if (!invoke_exception_hook(ex, TRUE))
- write_to_stderr(ex);
+ write_to_stderr(ex);
}
/*
=for apidoc warn
+=for apidoc_item warn_nocontext
-This is an XS interface to Perl's C<warn> function.
+These are XS interfaces to Perl's C<warn> function.
-Take a sprintf-style format pattern and argument list. These are used to
-generate a string message. If the message does not end with a newline,
-then it will be extended with some indication of the current location
-in the code, as described for L</mess_sv>.
+They take a sprintf-style format pattern and argument list, which are used to
+generate a string message. If the message does not end with a newline, then it
+will be extended with some indication of the current location in the code, as
+described for C<L</mess_sv>>.
The error message or object will by default be written to standard error,
but this is subject to modification by a C<$SIG{__WARN__}> handler.
-Unlike with L</croak>, C<pat> is not permitted to be null.
+Unlike with C<L</croak>>, C<pat> is not permitted to be null.
+
+The two forms differ only in that C<warn_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
=cut
*/
-#if defined(PERL_IMPLICIT_CONTEXT)
+#if defined(MULTIPLICITY)
void
Perl_warn_nocontext(const char *pat, ...)
{
vwarn(pat, &args);
va_end(args);
}
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
void
Perl_warn(pTHX_ const char *pat, ...)
va_end(args);
}
-#if defined(PERL_IMPLICIT_CONTEXT)
+/*
+=for apidoc warner
+=for apidoc_item warner_nocontext
+
+These output a warning of the specified category (or categories) given by
+C<err>, using the sprintf-style format pattern C<pat>, and argument list.
+
+C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
+C<packWARN4> macros populated with the appropriate number of warning
+categories. If any of the warning categories they specify is fatal, a fatal
+exception is thrown.
+
+In any event a message is generated by the pattern and arguments. If the
+message does not end with a newline, then it will be extended with some
+indication of the current location in the code, as described for L</mess_sv>.
+
+The error message or object will by default be written to standard error,
+but this is subject to modification by a C<$SIG{__WARN__}> handler.
+
+C<pat> is not permitted to be null.
+
+The two forms differ only in that C<warner_nocontext> does not take a thread
+context (C<aTHX>) parameter, so is used in situations where the caller doesn't
+already have the thread context.
+
+These functions differ from the similarly named C<L</warn>> functions, in that
+the latter are for XS code to unconditionally display a warning, whereas these
+are for code that may be compiling a perl program, and does extra checking to
+see if the warning should be fatal.
+
+=for apidoc ck_warner
+=for apidoc_item ck_warner_d
+If none of the warning categories given by C<err> are enabled, do nothing;
+otherwise call C<L</warner>> or C<L</warner_nocontext>> with the passed-in
+parameters;.
+
+C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
+C<packWARN4> macros populated with the appropriate number of warning
+categories.
+
+The two forms differ only in that C<ck_warner_d> should be used if warnings for
+any of the categories are by default enabled.
+
+=for apidoc vwarner
+This is like C<L</warner>>, but C<args> are an encapsulated argument list.
+
+=for apidoc fatal_warner
+
+Like L</warner> except that it acts as if fatal warnings are enabled
+for the warning.
+
+If called when there are pending compilation errors this function may
+return.
+
+This is currently used to generate "used only once" fatal warnings
+since the COP where the name being reported is no longer the current
+COP when the warning is generated and may be useful for similar cases.
+
+C<err> must be one of the C<L</packWARN>>, C<packWARN2>, C<packWARN3>,
+C<packWARN4> macros populated with the appropriate number of warning
+categories.
+
+=for apidoc vfatal_warner
+
+This is like C<L</fatal_warner>> but C<args> are an encapsulated
+argument list.
+
+=cut
+*/
+
+#if defined(MULTIPLICITY)
void
Perl_warner_nocontext(U32 err, const char *pat, ...)
{
vwarner(err, pat, &args);
va_end(args);
}
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
void
Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
PERL_ARGS_ASSERT_CK_WARNER_D;
if (Perl_ckwarn_d(aTHX_ err)) {
- va_list args;
- va_start(args, pat);
- vwarner(err, pat, &args);
- va_end(args);
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
}
}
PERL_ARGS_ASSERT_CK_WARNER;
if (Perl_ckwarn(aTHX_ err)) {
- va_list args;
- va_start(args, pat);
- vwarner(err, pat, &args);
- va_end(args);
+ va_list args;
+ va_start(args, pat);
+ vwarner(err, pat, &args);
+ va_end(args);
}
}
(PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
!(PL_in_eval & EVAL_KEEPERR)
) {
- SV * const msv = vmess(pat, args);
+ vfatal_warner(err, pat, args);
+ }
+ else {
+ Perl_vwarn(aTHX_ pat, args);
+ }
+}
+
+void
+Perl_fatal_warner(pTHX_ U32 err, const char *pat, ...)
+{
+ PERL_ARGS_ASSERT_FATAL_WARNER;
+
+ va_list args;
+ va_start(args, pat);
+ vfatal_warner(err, pat, &args);
+ va_end(args);
+}
+
+void
+Perl_vfatal_warner(pTHX_ U32 err, const char *pat, va_list *args)
+{
+ PERL_ARGS_ASSERT_VFATAL_WARNER;
- if (PL_parser && PL_parser->error_count) {
- qerror(msv);
- }
- else {
- invoke_exception_hook(msv, FALSE);
- die_unwind(msv);
- }
+ PERL_UNUSED_ARG(err);
+
+ SV * const msv = vmess(pat, args);
+
+ if (PL_parser && PL_parser->error_count) {
+ qerror(msv);
}
else {
- Perl_vwarn(aTHX_ pat, args);
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
}
}
{
/* If lexical warnings have not been set, use $^W. */
if (isLEXWARN_off)
- return PL_dowarn & G_WARN_ON;
+ return PL_dowarn & G_WARN_ON;
return ckwarn_common(w);
}
{
/* If lexical warnings have not been set then default classes warn. */
if (isLEXWARN_off)
- return TRUE;
+ return TRUE;
return ckwarn_common(w);
}
S_ckwarn_common(pTHX_ U32 w)
{
if (PL_curcop->cop_warnings == pWARN_ALL)
- return TRUE;
+ return TRUE;
if (PL_curcop->cop_warnings == pWARN_NONE)
- return FALSE;
+ return FALSE;
/* Check the assumption that at least the first slot is non-zero. */
assert(unpackWARN1(w));
/* Check the assumption that it is valid to stop as soon as a zero slot is
seen. */
if (!unpackWARN2(w)) {
- assert(!unpackWARN3(w));
- assert(!unpackWARN4(w));
+ assert(!unpackWARN3(w));
+ assert(!unpackWARN4(w));
} else if (!unpackWARN3(w)) {
- assert(!unpackWARN4(w));
+ assert(!unpackWARN4(w));
}
-
+
/* Right, dealt with all the special cases, which are implemented as non-
pointers, so there is a pointer to a real warnings mask. */
do {
- if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
- return TRUE;
+ if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)))
+ return TRUE;
} while (w >>= WARNshift);
return FALSE;
}
-/* Set buffer=NULL to get a new one. */
-STRLEN *
-Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits,
- STRLEN size) {
- const MEM_SIZE len_wanted =
- sizeof(STRLEN) + (size > WARNsize ? size : WARNsize);
+char *
+Perl_new_warnings_bitfield(pTHX_ char *buffer, const char *const bits,
+ STRLEN size) {
+ const MEM_SIZE len_wanted = (size > WARNsize ? size : WARNsize);
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD;
- buffer = (STRLEN*)
- (specialWARN(buffer) ?
- PerlMemShared_malloc(len_wanted) :
- PerlMemShared_realloc(buffer, len_wanted));
- buffer[0] = size;
- Copy(bits, (buffer + 1), size, char);
+ /* pass in null as the source string as we will do the
+ * copy ourselves. */
+ buffer = rcpv_new(NULL, len_wanted, RCPVf_NO_COPY);
+ Copy(bits, buffer, size, char);
if (size < WARNsize)
- Zero((char *)(buffer + 1) + size, WARNsize - size, char);
+ Zero(buffer + size, WARNsize - size, char);
return buffer;
}
-#ifdef USE_ENVIRON_ARRAY
+#if defined(USE_ENVIRON_ARRAY) || defined(WIN32)
/* NB: VMS' my_setenv() is in vms.c */
-/* Configure doesn't test for HAS_SETENV yet, so decide based on platform.
- * For Solaris, setenv() and unsetenv() were introduced in Solaris 9, so
- * testing for HAS UNSETENV is sufficient.
- */
-# if defined(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
-# define MY_HAS_SETENV
-# endif
-
/* small wrapper for use by Perl_my_setenv that mallocs, or reallocs if
* 'current' is non-null, with up to three sizes that are added together.
* It handles integer overflow.
*/
-# ifndef MY_HAS_SETENV
+# ifndef HAS_SETENV
static char *
S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
{
}
# endif
-
-# if !defined(WIN32) && !defined(NETWARE)
-
/*
+=for apidoc_section $utility
=for apidoc my_setenv
A wrapper for the C library L<setenv(3)>. Don't use the latter, as the perl
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
-# ifdef __amigaos4__
- amigaos4_obtain_environ(__FUNCTION__);
-# endif
-
-# ifdef USE_ITHREADS
- /* only parent thread can modify process environment, so no need to use a
- * mutex */
- if (PL_curinterp == aTHX)
-# endif
- {
-
-# ifndef PERL_USE_SAFE_PUTENV
- if (!PL_use_safe_putenv) {
- /* most putenv()s leak, so we manipulate environ directly */
- UV i;
- Size_t vlen, nlen = strlen(nam);
-
- /* where does it go? */
- for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
- break;
- }
-
- if (environ == PL_origenviron) { /* need we copy environment? */
- UV j, max;
- char **tmpenv;
-
- max = i;
- while (environ[max])
- max++;
-
- /* XXX shouldn't that be max+1 rather than max+2 ??? - DAPM */
- tmpenv = (char**)S_env_alloc(NULL, max, 2, 0, sizeof(char*));
-
- for (j=0; j<max; j++) { /* copy environment */
- const Size_t len = strlen(environ[j]);
- tmpenv[j] = S_env_alloc(NULL, len, 1, 0, 1);
- 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++;
- }
-# ifdef __amigaos4__
- goto my_setenv_out;
-# else
- return;
-# endif
- }
-
- if (!environ[i]) { /* does not exist yet */
- environ = (char**)S_env_alloc(environ, i, 2, 0, sizeof(char*));
- environ[i+1] = NULL; /* make sure it's null terminated */
- }
- else
- safesysfree(environ[i]);
-
- vlen = strlen(val);
-
- environ[i] = S_env_alloc(NULL, nlen, vlen, 2, 1);
- /* all that work just for this */
- my_setenv_format(environ[i], nam, nlen, val, vlen);
- }
- else {
-
-# endif /* !PERL_USE_SAFE_PUTENV */
+# if defined(USE_ITHREADS) && !defined(WIN32)
+ /* only parent thread can modify process environment, so no need to use a
+ * mutex */
+ if (PL_curinterp != aTHX)
+ return;
+# endif
-# ifdef MY_HAS_SETENV
-# if defined(HAS_UNSETENV)
+# if defined(HAS_SETENV) && defined(HAS_UNSETENV)
if (val == NULL) {
- (void)unsetenv(nam);
+ unsetenv(nam);
} else {
- (void)setenv(nam, val, 1);
+ setenv(nam, val, 1);
}
-# else /* ! HAS_UNSETENV */
- (void)setenv(nam, val, 1);
-# endif /* HAS_UNSETENV */
-# elif defined(HAS_UNSETENV)
+# elif defined(HAS_UNSETENV)
if (val == NULL) {
if (environ) /* old glibc can crash with null environ */
- (void)unsetenv(nam);
+ unsetenv(nam);
} else {
- const Size_t nlen = strlen(nam);
- const Size_t vlen = strlen(val);
- char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
+ const Size_t nlen = strlen(nam);
+ const Size_t vlen = strlen(val);
+ char * const new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(new_env, nam, nlen, val, vlen);
- (void)putenv(new_env);
+ putenv(new_env);
}
-# else /* ! HAS_UNSETENV */
+# else /* ! HAS_UNSETENV */
- char *new_env;
- const Size_t nlen = strlen(nam);
- Size_t vlen;
+ const Size_t nlen = strlen(nam);
if (!val) {
- val = "";
+ val = "";
}
- vlen = strlen(val);
- new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
+ Size_t vlen = strlen(val);
+ char *new_env = S_env_alloc(NULL, nlen, vlen, 2, 1);
/* all that work just for this */
my_setenv_format(new_env, nam, nlen, val, vlen);
- (void)putenv(new_env);
-
-# endif /* MY_HAS_SETENV */
-
-# ifndef PERL_USE_SAFE_PUTENV
- }
+# ifndef WIN32
+ putenv(new_env);
+# else
+ PerlEnv_putenv(new_env);
+ safesysfree(new_env);
# endif
- }
-# ifdef __amigaos4__
-my_setenv_out:
- amigaos4_release_environ(__FUNCTION__);
-# endif
-}
-
-# else /* WIN32 || NETWARE */
-
-void
-Perl_my_setenv(pTHX_ const char *nam, const char *val)
-{
- char *envstr;
- const Size_t nlen = strlen(nam);
- Size_t vlen;
-
- if (!val) {
- val = "";
- }
- vlen = strlen(val);
- envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
- my_setenv_format(envstr, nam, nlen, val, vlen);
- (void)PerlEnv_putenv(envstr);
- safesysfree(envstr);
+# endif /* HAS_SETENV */
}
-# endif /* WIN32 || NETWARE */
-
-#endif /* USE_ENVIRON_ARRAY */
-
-
-
+#endif /* USE_ENVIRON_ARRAY || WIN32 */
#ifdef UNLINK_ALL_VERSIONS
I32
PERL_ARGS_ASSERT_UNLNK;
while (PerlLIO_unlink(f) >= 0)
- retries++;
+ retries++;
return retries ? 0 : -1;
}
#endif
+#if defined(OEMVS)
+ #if (__CHARSET_LIB == 1)
+ static int chgfdccsid(int fd, unsigned short ccsid)
+ {
+ attrib_t attr;
+ memset(&attr, 0, sizeof(attr));
+ attr.att_filetagchg = 1;
+ attr.att_filetag.ft_ccsid = ccsid;
+ if (ccsid != FT_BINARY) {
+ attr.att_filetag.ft_txtflag = 1;
+ }
+ return __fchattr(fd, &attr, sizeof(attr));
+ }
+ #endif
+#endif
+
+/*
+=for apidoc my_popen_list
+
+Implementing function on some systems for PerlProc_popen_list()
+
+=cut
+*/
+
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
int p[2];
I32 This, that;
Pid_t pid;
This = (*mode == 'w');
that = !This;
if (TAINTING_get) {
- taint_env();
- taint_proper("Insecure %s%s", "EXEC");
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe_cloexec(p) < 0)
- return NULL;
+ return NULL;
/* Try for another pipe pair for error return */
if (PerlProc_pipe_cloexec(pp) >= 0)
- did_pipes = 1;
+ did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
- if (errno != EAGAIN) {
- PerlLIO_close(p[This]);
- PerlLIO_close(p[that]);
- if (did_pipes) {
- PerlLIO_close(pp[0]);
- PerlLIO_close(pp[1]);
- }
- return NULL;
- }
- Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
- sleep(5);
+ if (errno != EAGAIN) {
+ PerlLIO_close(p[This]);
+ PerlLIO_close(p[that]);
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[1]);
+ }
+ return NULL;
+ }
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+ sleep(5);
}
if (pid == 0) {
- /* Child */
+ /* Child */
#undef THIS
#undef THAT
#define THIS that
#define THAT This
- /* Close parent's end of error status pipe (if any) */
- if (did_pipes)
- PerlLIO_close(pp[0]);
- /* Now dup our end of _the_ pipe to right position */
- if (p[THIS] != (*mode == 'r')) {
- PerlLIO_dup2(p[THIS], *mode == 'r');
- PerlLIO_close(p[THIS]);
- if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
- PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
- }
- else {
- setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
- PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
+ /* Close parent's end of error status pipe (if any) */
+ if (did_pipes)
+ PerlLIO_close(pp[0]);
+#if defined(OEMVS)
+ #if (__CHARSET_LIB == 1)
+ chgfdccsid(p[THIS], 819);
+ chgfdccsid(p[THAT], 819);
+ #endif
+#endif
+ /* Now dup our end of _the_ pipe to right position */
+ if (p[THIS] != (*mode == 'r')) {
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
+ if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
+ PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
+ }
+ else {
+ setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
+ PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
}
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
- /* No automatic close - do it by hand */
+ /* No automatic close - do it by hand */
# ifndef NOFILE
# define NOFILE 20
# endif
- {
- int fd;
+ {
+ int fd;
- for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
- if (fd != pp[1])
- PerlLIO_close(fd);
- }
- }
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
+ if (fd != pp[1])
+ PerlLIO_close(fd);
+ }
+ }
#endif
- do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
- PerlProc__exit(1);
+ do_aexec5(NULL, args-1, args-1+n, pp[1], did_pipes);
+ PerlProc__exit(1);
#undef THIS
#undef THAT
}
/* Parent */
if (did_pipes)
- PerlLIO_close(pp[1]);
+ PerlLIO_close(pp[1]);
/* Keep the lower of the two fd numbers */
if (p[that] < p[This]) {
- PerlLIO_dup2_cloexec(p[This], p[that]);
- PerlLIO_close(p[This]);
- p[This] = p[that];
+ PerlLIO_dup2_cloexec(p[This], p[that]);
+ PerlLIO_close(p[This]);
+ p[This] = p[that];
}
else
- PerlLIO_close(p[that]); /* close child's end of pipe */
+ PerlLIO_close(p[that]); /* close child's end of pipe */
sv = *av_fetch(PL_fdpid,p[This],TRUE);
SvUPGRADE(sv,SVt_IV);
PL_forkprocess = pid;
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
- int errkid;
- unsigned read_total = 0;
+ int errkid;
+ unsigned read_total = 0;
- while (read_total < sizeof(int)) {
+ while (read_total < sizeof(int)) {
const SSize_t n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+read_total),
- (sizeof(int)) - read_total);
- if (n1 <= 0)
- break;
- read_total += n1;
- }
- PerlLIO_close(pp[0]);
- did_pipes = 0;
- if (read_total) { /* Error */
- int pid2, status;
- PerlLIO_close(p[This]);
- if (read_total != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
- do {
- pid2 = wait4pid(pid, &status, 0);
- } while (pid2 == -1 && errno == EINTR);
- errno = errkid; /* Propagate errno from kid */
- return NULL;
- }
+ (void*)(((char*)&errkid)+read_total),
+ (sizeof(int)) - read_total);
+ if (n1 <= 0)
+ break;
+ read_total += n1;
+ }
+ PerlLIO_close(pp[0]);
+ did_pipes = 0;
+ if (read_total) { /* Error */
+ int pid2, status;
+ PerlLIO_close(p[This]);
+ if (read_total != sizeof(int))
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", read_total);
+ do {
+ pid2 = wait4pid(pid, &status, 0);
+ } while (pid2 == -1 && errno == EINTR);
+ errno = errkid; /* Propagate errno from kid */
+ return NULL;
+ }
}
if (did_pipes)
- PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[0]);
+#if defined(OEMVS)
+ #if (__CHARSET_LIB == 1)
+ PerlIO* io = PerlIO_fdopen(p[This], mode);
+ if (io) {
+ chgfdccsid(p[This], 819);
+ }
+ return io;
+ #else
return PerlIO_fdopen(p[This], mode);
+ #endif
+#else
+ return PerlIO_fdopen(p[This], mode);
+#endif
+
#else
# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, mode, n, args);
/* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
+
+/*
+=for apidoc_section $io
+=for apidoc my_popen
+
+A wrapper for the C library L<popen(3)>. Don't use the latter, as the Perl
+version knows things that interact with the rest of the perl interpreter.
+
+=cut
+*/
+
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
#ifdef OS2
if (doexec) {
- return my_syspopen(aTHX_ cmd,mode);
+ return my_syspopen(aTHX_ cmd,mode);
}
#endif
This = (*mode == 'w');
that = !This;
if (doexec && TAINTING_get) {
- taint_env();
- taint_proper("Insecure %s%s", "EXEC");
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
}
if (PerlProc_pipe_cloexec(p) < 0)
- return NULL;
+ return NULL;
if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
- did_pipes = 1;
+ did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
- if (errno != EAGAIN) {
- PerlLIO_close(p[This]);
- PerlLIO_close(p[that]);
- if (did_pipes) {
- PerlLIO_close(pp[0]);
- PerlLIO_close(pp[1]);
- }
- if (!doexec)
- Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
- return NULL;
- }
- Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
- sleep(5);
+ if (errno != EAGAIN) {
+ PerlLIO_close(p[This]);
+ PerlLIO_close(p[that]);
+ if (did_pipes) {
+ PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[1]);
+ }
+ if (!doexec)
+ Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno));
+ return NULL;
+ }
+ Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds");
+ sleep(5);
}
if (pid == 0) {
#undef THAT
#define THIS that
#define THAT This
- if (did_pipes)
- PerlLIO_close(pp[0]);
- if (p[THIS] != (*mode == 'r')) {
- PerlLIO_dup2(p[THIS], *mode == 'r');
- PerlLIO_close(p[THIS]);
- if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
- PerlLIO_close(p[THAT]);
- }
- else {
- setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
- PerlLIO_close(p[THAT]);
- }
+ if (did_pipes)
+ PerlLIO_close(pp[0]);
+#if defined(OEMVS)
+ #if (__CHARSET_LIB == 1)
+ chgfdccsid(p[THIS], 819);
+ chgfdccsid(p[THAT], 819);
+ #endif
+#endif
+ if (p[THIS] != (*mode == 'r')) {
+ PerlLIO_dup2(p[THIS], *mode == 'r');
+ PerlLIO_close(p[THIS]);
+ if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
+ PerlLIO_close(p[THAT]);
+ }
+ else {
+ setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
+ PerlLIO_close(p[THAT]);
+ }
#ifndef OS2
- if (doexec) {
+ if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
#ifndef NOFILE
#define NOFILE 20
#endif
- {
- int fd;
+ {
+ int fd;
- for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
- if (fd != pp[1])
- PerlLIO_close(fd);
- }
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
+ if (fd != pp[1])
+ PerlLIO_close(fd);
+ }
#endif
- /* may or may not use the shell */
- do_exec3(cmd, pp[1], did_pipes);
- PerlProc__exit(1);
- }
+ /* may or may not use the shell */
+ do_exec3(cmd, pp[1], did_pipes);
+ PerlProc__exit(1);
+ }
#endif /* defined OS2 */
#ifdef PERLIO_USING_CRLF
default, binary, low-level mode; see PerlIOBuf_open(). */
PerlLIO_setmode((*mode == 'r'), O_BINARY);
#endif
- PL_forkprocess = 0;
+ PL_forkprocess = 0;
#ifdef PERL_USES_PL_PIDSTATUS
- hv_clear(PL_pidstatus); /* we have no children */
+ hv_clear(PL_pidstatus); /* we have no children */
#endif
- return NULL;
+ return NULL;
#undef THIS
#undef THAT
}
if (did_pipes)
- PerlLIO_close(pp[1]);
+ PerlLIO_close(pp[1]);
if (p[that] < p[This]) {
- PerlLIO_dup2_cloexec(p[This], p[that]);
- PerlLIO_close(p[This]);
- p[This] = p[that];
+ PerlLIO_dup2_cloexec(p[This], p[that]);
+ PerlLIO_close(p[This]);
+ p[This] = p[that];
}
else
- PerlLIO_close(p[that]);
+ PerlLIO_close(p[that]);
sv = *av_fetch(PL_fdpid,p[This],TRUE);
SvUPGRADE(sv,SVt_IV);
SvIV_set(sv, pid);
PL_forkprocess = pid;
if (did_pipes && pid > 0) {
- int errkid;
- unsigned n = 0;
+ int errkid;
+ unsigned n = 0;
- while (n < sizeof(int)) {
+ while (n < sizeof(int)) {
const SSize_t n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+n),
- (sizeof(int)) - n);
- if (n1 <= 0)
- break;
- n += n1;
- }
- PerlLIO_close(pp[0]);
- did_pipes = 0;
- if (n) { /* Error */
- int pid2, status;
- PerlLIO_close(p[This]);
- if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
- do {
- pid2 = wait4pid(pid, &status, 0);
- } while (pid2 == -1 && errno == EINTR);
- errno = errkid; /* Propagate errno from kid */
- return NULL;
- }
+ (void*)(((char*)&errkid)+n),
+ (sizeof(int)) - n);
+ if (n1 <= 0)
+ break;
+ n += n1;
+ }
+ PerlLIO_close(pp[0]);
+ did_pipes = 0;
+ if (n) { /* Error */
+ int pid2, status;
+ PerlLIO_close(p[This]);
+ if (n != sizeof(int))
+ Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
+ do {
+ pid2 = wait4pid(pid, &status, 0);
+ } while (pid2 == -1 && errno == EINTR);
+ errno = errkid; /* Propagate errno from kid */
+ return NULL;
+ }
}
if (did_pipes)
- PerlLIO_close(pp[0]);
+ PerlLIO_close(pp[0]);
+#if defined(OEMVS)
+ #if (__CHARSET_LIB == 1)
+ PerlIO* io = PerlIO_fdopen(p[This], mode);
+ if (io) {
+ chgfdccsid(p[This], 819);
+ }
+ return io;
+ #else
return PerlIO_fdopen(p[This], mode);
-}
-#elif defined(DJGPP)
-FILE *djgpp_popen();
-PerlIO *
-Perl_my_popen(pTHX_ const char *cmd, const char *mode)
-{
- 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(djgpp_popen(cmd, mode), 0);
+ #endif
+#else
+ return PerlIO_fdopen(p[This], mode);
+#endif
}
#elif defined(__LIBCATAMOUNT__)
PerlIO *
#endif
}
+/*
+=for apidoc_section $concurrency
+=for apidoc my_fork
+
+This is for the use of C<PerlProc_fork> as a wrapper for the C library
+L<fork(2)> on some platforms to hide some platform quirks. It should not be
+used except through C<PerlProc_fork>.
+
+=cut
+*/
+
+
Pid_t
Perl_my_fork(void)
{
{
#if defined(HAS_FCNTL) && defined(F_DUPFD)
if (oldfd == newfd)
- return oldfd;
+ return oldfd;
PerlLIO_close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
int fd;
if (oldfd == newfd)
- return oldfd;
+ return oldfd;
PerlLIO_close(newfd);
/* good enough for low fd's... */
while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
- if (fdx >= DUP2_MAX_FDS) {
- PerlLIO_close(fd);
- fd = -1;
- break;
- }
- fdtmp[fdx++] = fd;
+ if (fdx >= DUP2_MAX_FDS) {
+ PerlLIO_close(fd);
+ fd = -1;
+ break;
+ }
+ fdtmp[fdx++] = fd;
}
while (fdx > 0)
- PerlLIO_close(fdtmp[--fdx]);
+ PerlLIO_close(fdtmp[--fdx]);
return fd;
#endif
}
#endif
-#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
/*
+=for apidoc_section $signals
=for apidoc rsignal
-A wrapper for the C library L<signal(2)>. Don't use the latter, as the Perl
-version knows things that interact with the rest of the perl interpreter.
+A wrapper for the C library functions L<sigaction(2)> or L<signal(2)>.
+Use this instead of those libc functions, as the Perl version gives the
+safest available implementation, and knows things that interact with the
+rest of the perl interpreter.
=cut
*/
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return (Sighandler_t) SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
act.sa_handler = handler;
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
- act.sa_flags |= SA_NOCLDWAIT;
+ act.sa_flags |= SA_NOCLDWAIT;
#endif
if (sigaction(signo, &act, &oact) == -1)
- return (Sighandler_t) SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return (Sighandler_t) oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
+/*
+=for apidoc_section $signals
+=for apidoc rsignal_state
+
+Returns a the current signal handler for signal C<signo>.
+See L</C<rsignal>>.
+
+=cut
+*/
+
Sighandler_t
Perl_rsignal_state(pTHX_ int signo)
{
PERL_UNUSED_CONTEXT;
if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
- return (Sighandler_t) SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
else
- return (Sighandler_t) oact.sa_handler;
+ return (Sighandler_t) oact.sa_handler;
}
int
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
-#ifdef USE_ITHREADS
-#endif
struct sigaction act;
PERL_ARGS_ASSERT_RSIGNAL_SAVE;
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return -1;
+ return -1;
#endif
act.sa_handler = handler;
#endif
#if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */
if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN)
- act.sa_flags |= SA_NOCLDWAIT;
+ act.sa_flags |= SA_NOCLDWAIT;
#endif
return sigaction(signo, &act, save);
}
int
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
-#ifdef USE_ITHREADS
-#endif
PERL_UNUSED_CONTEXT;
#ifdef USE_ITHREADS
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return -1;
+ return -1;
#endif
return sigaction(signo, save, (struct sigaction *)NULL);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return (Sighandler_t) SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
return PerlProc_signal(signo, handler);
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return (Sighandler_t) SIG_ERR;
+ return (Sighandler_t) SIG_ERR;
#endif
PL_sig_trapped = 0;
oldsig = PerlProc_signal(signo, sig_trap);
PerlProc_signal(signo, oldsig);
if (PL_sig_trapped)
- PerlProc_kill(PerlProc_getpid(), signo);
+ PerlProc_kill(PerlProc_getpid(), signo);
return oldsig;
}
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return -1;
+ return -1;
#endif
*save = PerlProc_signal(signo, handler);
return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0;
#if defined(USE_ITHREADS) && !defined(WIN32)
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
- return -1;
+ return -1;
#endif
return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0;
}
#endif /* !HAS_SIGACTION */
-#endif /* !PERL_MICRO */
- /* VMS' my_pclose() is in VMS.c; same with OS/2 */
+ /* VMS' my_pclose() is in VMS.c */
+
+/*
+=for apidoc_section $io
+=for apidoc my_pclose
+
+A wrapper for the C library L<pclose(3)>. Don't use the latter, as the Perl
+version knows things that interact with the rest of the perl interpreter.
+
+=cut
+*/
+
#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
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;
+ svp = av_fetch(PL_fdpid, fd, FALSE);
+ if (svp) {
+ pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+ SvREFCNT_dec(*svp);
+ *svp = NULL;
+ } else {
+ pid = -1;
+ }
#if defined(USE_PERLIO)
/* Find out whether the refcount is low enough for us to wait for the
#endif
#ifdef OS2
- if (pid == -1) { /* Opened by popen. */
- return my_syspclose(ptr);
+ if (pid == -2) { /* Opened by popen. */
+ return my_syspclose(ptr);
}
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
if (should_wait) do {
- pid2 = wait4pid(pid, &status, 0);
+ pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
if (close_failed) {
- RESTORE_ERRNO;
- return -1;
+ RESTORE_ERRNO;
+ return -1;
}
return(
should_wait
}
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
return -1;
}
{
- if (pid > 0) {
- /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
- pid, rather than a string form. */
- SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
- if (svp && *svp != &PL_sv_undef) {
- *statusp = SvIVX(*svp);
- (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
- G_DISCARD);
- return pid;
- }
- }
- else {
- HE *entry;
-
- hv_iterinit(PL_pidstatus);
- if ((entry = hv_iternext(PL_pidstatus))) {
- SV * const sv = hv_iterval(PL_pidstatus,entry);
- I32 len;
- const char * const spid = hv_iterkey(entry,&len);
-
- assert (len == sizeof(Pid_t));
- memcpy((char *)&pid, spid, len);
- *statusp = SvIVX(sv);
- /* The hash iterator is currently on this entry, so simply
- calling hv_delete would trigger the lazy delete, which on
- aggregate does more work, because next call to hv_iterinit()
- would spot the flag, and have to call the delete routine,
- while in the meantime any new entries can't re-use that
- memory. */
- hv_iterinit(PL_pidstatus);
- (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
- return pid;
- }
- }
+ if (pid > 0) {
+ /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
+ pid, rather than a string form. */
+ SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE);
+ if (svp && *svp != &PL_sv_undef) {
+ *statusp = SvIVX(*svp);
+ (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),
+ G_DISCARD);
+ return pid;
+ }
+ }
+ else {
+ HE *entry;
+
+ hv_iterinit(PL_pidstatus);
+ if ((entry = hv_iternext(PL_pidstatus))) {
+ SV * const sv = hv_iterval(PL_pidstatus,entry);
+ I32 len;
+ const char * const spid = hv_iterkey(entry,&len);
+
+ assert (len == sizeof(Pid_t));
+ memcpy((char *)&pid, spid, len);
+ *statusp = SvIVX(sv);
+ /* The hash iterator is currently on this entry, so simply
+ calling hv_delete would trigger the lazy delete, which on
+ aggregate does more work, because next call to hv_iterinit()
+ would spot the flag, and have to call the delete routine,
+ while in the meantime any new entries can't re-use that
+ memory. */
+ hv_iterinit(PL_pidstatus);
+ (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD);
+ return pid;
+ }
+ }
}
#endif
#ifdef HAS_WAITPID
# ifdef HAS_WAITPID_RUNTIME
if (!HAS_WAITPID_RUNTIME)
- goto hard_way;
+ goto hard_way;
# endif
result = PerlProc_waitpid(pid,statusp,flags);
goto finish;
hard_way:
#endif
{
- if (flags)
- Perl_croak(aTHX_ "Can't do waitpid with flags");
- else {
- while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
- pidgone(result,*statusp);
- if (result < 0)
- *statusp = -1;
- }
+ if (flags)
+ Perl_croak(aTHX_ "Can't do waitpid with flags");
+ else {
+ while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
+ pidgone(result,*statusp);
+ if (result < 0)
+ *statusp = -1;
+ }
}
#endif
#if defined(HAS_WAITPID) || defined(HAS_WAIT4)
finish:
#endif
if (result < 0 && errno == EINTR) {
- PERL_ASYNC_CHECK();
- errno = EINTR; /* reset in case a signal handler changed $! */
+ PERL_ASYNC_CHECK();
+ errno = EINTR; /* reset in case a signal handler changed $! */
}
return result;
}
-#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
+#endif /* !DOSISH || OS2 || WIN32 */
#ifdef PERL_USES_PL_PIDSTATUS
void
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
- in os2ish.h. */
+ in os2ish.h. */
my_syspclose(PerlIO *ptr)
#else
I32
}
#endif
-#if defined(DJGPP)
-int djgpp_pclose();
-I32
-Perl_my_pclose(pTHX_ PerlIO *ptr)
-{
- /* Needs work for PerlIO ! */
- FILE * const f = PerlIO_findFILE(ptr);
- I32 result = djgpp_pclose(f);
- result = (result << 8) & 0xff00;
- PerlIO_releaseFILE(ptr,f);
- return result;
-}
-#endif
+/*
+=for apidoc repeatcpy
+
+Make C<count> copies of the C<len> bytes beginning at C<from>, placing them
+into memory beginning at C<to>, which must be big enough to accommodate them
+all.
+
+=cut
+*/
#define PERL_REPEATCPY_LINEAR 4
void
-Perl_repeatcpy(char *to, const char *from, I32 len, IV count)
+Perl_repeatcpy(char *to, const char *from, SSize_t len, IV count)
{
PERL_ARGS_ASSERT_REPEATCPY;
assert(len >= 0);
if (count < 0)
- croak_memory_wrap();
+ croak_memory_wrap();
if (len == 1)
- memset(to, *from, count);
+ memset(to, *from, count);
else if (count) {
- char *p = to;
- IV items, linear, half;
-
- linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
- for (items = 0; items < linear; ++items) {
- const char *q = from;
- IV todo;
- for (todo = len; todo > 0; todo--)
- *p++ = *q++;
+ char *p = to;
+ IV items, linear, half;
+
+ linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR;
+ for (items = 0; items < linear; ++items) {
+ const char *q = from;
+ IV todo;
+ for (todo = len; todo > 0; todo--)
+ *p++ = *q++;
}
- half = count / 2;
- while (items <= half) {
- IV size = items * len;
- memcpy(p, to, size);
- p += size;
- items *= 2;
- }
+ half = count / 2;
+ while (items <= half) {
+ IV size = items * len;
+ memcpy(p, to, size);
+ p += size;
+ items *= 2;
+ }
- if (count > items)
- memcpy(p, to, (count - items) * len);
+ if (count > items)
+ memcpy(p, to, (count - items) * len);
}
}
PERL_ARGS_ASSERT_SAME_DIRENT;
if (fa)
- fa++;
+ fa++;
else
- fa = a;
+ fa = a;
if (fb)
- fb++;
+ fb++;
else
- fb = b;
+ fb = b;
if (strNE(a,b))
- return FALSE;
+ return FALSE;
if (fa == a)
- sv_setpvs(tmpsv, ".");
+ sv_setpvs(tmpsv, ".");
else
- sv_setpvn(tmpsv, a, fa - a);
+ sv_setpvn(tmpsv, a, fa - a);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0)
- return FALSE;
+ return FALSE;
if (fb == b)
- sv_setpvs(tmpsv, ".");
+ sv_setpvs(tmpsv, ".");
else
- sv_setpvn(tmpsv, b, fb - b);
+ sv_setpvn(tmpsv, b, fb - b);
if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0)
- return FALSE;
+ return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
- tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
+ tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
}
#endif /* !HAS_RENAME */
char*
Perl_find_script(pTHX_ const char *scriptname, bool dosearch,
- const char *const *const search_ext, I32 flags)
+ const char *const *const search_ext, I32 flags)
{
const char *xfound = NULL;
char *xfailed = NULL;
# ifdef ALWAYS_DEFTYPES
len = strlen(scriptname);
if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
- int idx = 0, deftypes = 1;
- bool seen_dot = 1;
+ int idx = 0, deftypes = 1;
+ bool seen_dot = 1;
- const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
+ const int hasdir = !dosearch || (strpbrk(scriptname,":[</") != NULL);
# else
if (dosearch) {
- int idx = 0, deftypes = 1;
- bool seen_dot = 1;
+ int idx = 0, deftypes = 1;
+ bool seen_dot = 1;
- const int hasdir = (strpbrk(scriptname,":[</") != NULL);
+ const int hasdir = (strpbrk(scriptname,":[</") != NULL);
# endif
- /* The first time through, just add SEARCH_EXTS to whatever we
- * already have, so we can check for default file types. */
- while (deftypes ||
- (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
- {
- Stat_t statbuf;
- if (deftypes) {
- deftypes = 0;
- *tmpbuf = '\0';
- }
- if ((strlen(tmpbuf) + strlen(scriptname)
- + MAX_EXT_LEN) >= sizeof tmpbuf)
- continue; /* don't search dir with too-long name */
- my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
+ /* The first time through, just add SEARCH_EXTS to whatever we
+ * already have, so we can check for default file types. */
+ while (deftypes ||
+ (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
+ {
+ Stat_t statbuf;
+ if (deftypes) {
+ deftypes = 0;
+ *tmpbuf = '\0';
+ }
+ if ((strlen(tmpbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf));
#else /* !VMS */
#ifdef DOSISH
if (strEQ(scriptname, "-"))
- dosearch = 0;
+ dosearch = 0;
if (dosearch) { /* Look in '.' first. */
- const char *cur = scriptname;
+ const char *cur = scriptname;
#ifdef SEARCH_EXTS
- if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
- while (ext[i])
- if (strEQ(ext[i++],curext)) {
- extidx = -1; /* already has an ext */
- break;
- }
- do {
-#endif
- DEBUG_p(PerlIO_printf(Perl_debug_log,
- "Looking for %s\n",cur));
- {
- Stat_t statbuf;
- if (PerlLIO_stat(cur,&statbuf) >= 0
- && !S_ISDIR(statbuf.st_mode)) {
- dosearch = 0;
- scriptname = cur;
+ if ((curext = strrchr(scriptname,'.'))) /* possible current ext */
+ while (ext[i])
+ if (strEQ(ext[i++],curext)) {
+ extidx = -1; /* already has an ext */
+ break;
+ }
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log,
+ "Looking for %s\n",cur));
+ {
+ Stat_t statbuf;
+ if (PerlLIO_stat(cur,&statbuf) >= 0
+ && !S_ISDIR(statbuf.st_mode)) {
+ dosearch = 0;
+ scriptname = cur;
#ifdef SEARCH_EXTS
- break;
+ break;
#endif
- }
- }
+ }
+ }
#ifdef SEARCH_EXTS
- if (cur == scriptname) {
- len = strlen(scriptname);
- if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
- break;
- my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
- cur = tmpbuf;
- }
- } while (extidx >= 0 && ext[extidx] /* try an extension? */
- && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
+ if (cur == scriptname) {
+ len = strlen(scriptname);
+ if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
+ break;
+ my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf));
+ cur = tmpbuf;
+ }
+ } while (extidx >= 0 && ext[extidx] /* try an extension? */
+ && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len));
#endif
}
#endif
if (dosearch && !strchr(scriptname, '/')
#ifdef DOSISH
- && !strchr(scriptname, '\\')
+ && !strchr(scriptname, '\\')
#endif
- && (s = PerlEnv_getenv("PATH")))
+ && (s = PerlEnv_getenv("PATH")))
{
- bool seen_dot = 0;
+ bool seen_dot = 0;
- bufend = s + strlen(s);
- while (s < bufend) {
- Stat_t statbuf;
+ bufend = s + strlen(s);
+ while (s < bufend) {
+ Stat_t statbuf;
# ifdef DOSISH
- for (len = 0; *s
- && *s != ';'; len++, s++) {
- if (len < sizeof tmpbuf)
- tmpbuf[len] = *s;
- }
- if (len < sizeof tmpbuf)
- tmpbuf[len] = '\0';
+ for (len = 0; *s
+ && *s != ';'; len++, s++) {
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = *s;
+ }
+ if (len < sizeof tmpbuf)
+ tmpbuf[len] = '\0';
# else
- s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
+ s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend,
':', &len);
# 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 (s < bufend)
+ s++;
+ if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
+ continue; /* don't search dir with too-long name */
+ if (len
# ifdef DOSISH
- && tmpbuf[len - 1] != '/'
- && tmpbuf[len - 1] != '\\'
+ && tmpbuf[len - 1] != '/'
+ && tmpbuf[len - 1] != '\\'
# endif
- )
- tmpbuf[len++] = '/';
- if (len == 2 && tmpbuf[0] == '.')
- seen_dot = 1;
- (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
+ )
+ tmpbuf[len++] = '/';
+ if (len == 2 && tmpbuf[0] == '.')
+ seen_dot = 1;
+ (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
#endif /* !VMS */
#ifdef SEARCH_EXTS
- len = strlen(tmpbuf);
- if (extidx > 0) /* reset after previous loop */
- extidx = 0;
- do {
-#endif
- DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
- retval = PerlLIO_stat(tmpbuf,&statbuf);
- if (S_ISDIR(statbuf.st_mode)) {
- retval = -1;
- }
+ len = strlen(tmpbuf);
+ if (extidx > 0) /* reset after previous loop */
+ extidx = 0;
+ do {
+#endif
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
+ retval = PerlLIO_stat(tmpbuf,&statbuf);
+ if (S_ISDIR(statbuf.st_mode)) {
+ retval = -1;
+ }
#ifdef SEARCH_EXTS
- } while ( retval < 0 /* not there */
- && extidx>=0 && ext[extidx] /* try an extension? */
- && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
- );
-#endif
- if (retval < 0)
- continue;
- if (S_ISREG(statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&statbuf)
+ } while ( retval < 0 /* not there */
+ && extidx>=0 && ext[extidx] /* try an extension? */
+ && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)
+ );
+#endif
+ if (retval < 0)
+ continue;
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf)
#if !defined(DOSISH)
- && cando(S_IXUSR,TRUE,&statbuf)
-#endif
- )
- {
- xfound = tmpbuf; /* bingo! */
- break;
- }
- if (!xfailed)
- xfailed = savepv(tmpbuf);
- }
+ && cando(S_IXUSR,TRUE,&statbuf)
+#endif
+ )
+ {
+ xfound = tmpbuf; /* bingo! */
+ break;
+ }
+ if (!xfailed)
+ xfailed = savepv(tmpbuf);
+ }
#ifndef DOSISH
- {
- Stat_t statbuf;
- if (!xfound && !seen_dot && !xfailed &&
- (PerlLIO_stat(scriptname,&statbuf) < 0
- || S_ISDIR(statbuf.st_mode)))
+ {
+ Stat_t statbuf;
+ if (!xfound && !seen_dot && !xfailed &&
+ (PerlLIO_stat(scriptname,&statbuf) < 0
+ || S_ISDIR(statbuf.st_mode)))
#endif
- seen_dot = 1; /* Disable message. */
+ seen_dot = 1; /* Disable message. */
#ifndef DOSISH
- }
-#endif
- 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),
- (xfailed ? "" : " on PATH"),
- (xfailed || seen_dot) ? "" : ", '.' not in PATH");
- }
- scriptname = NULL;
- }
- Safefree(xfailed);
- scriptname = xfound;
+ }
+#endif
+ 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),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH");
+ }
+ scriptname = NULL;
+ }
+ Safefree(xfailed);
+ scriptname = xfound;
}
return (scriptname ? savepv(scriptname) : NULL);
}
#ifndef PERL_GET_CONTEXT_DEFINED
-void *
-Perl_get_context(void)
-{
-#if defined(USE_ITHREADS)
-# ifdef OLD_PTHREADS_API
- pthread_addr_t t;
- int error = pthread_getspecific(PL_thr_key, &t);
- if (error)
- Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
- return (void*)t;
-# elif defined(I_MACH_CTHREADS)
- return (void*)cthread_data(cthread_self());
-# else
- return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
-# endif
-#else
- return (void*)NULL;
-#endif
-}
+/*
+=for apidoc_section $embedding
+=for apidoc set_context
+
+Implements L<perlapi/C<PERL_SET_CONTEXT>>, which you should use instead.
+
+=cut
+*/
void
Perl_set_context(void *t)
{
-#if defined(USE_ITHREADS)
-#endif
PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
+# ifdef PERL_USE_THREAD_LOCAL
+ PL_current_context = t;
+# endif
# ifdef I_MACH_CTHREADS
cthread_set_data(cthread_self(), t);
# else
+ /* We set thread-specific value always, as C++ code has to read it with
+ * pthreads, because the declaration syntax for thread local storage for C11
+ * is incompatible with C++, meaning that we can't expose the thread local
+ * variable to C++ code. */
{
- const int error = pthread_setspecific(PL_thr_key, t);
- if (error)
- Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+ const int error = pthread_setspecific(PL_thr_key, t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
}
# endif
+
+ PERL_SET_NON_tTHX_CONTEXT((PerlInterpreter *) t);
+
#else
PERL_UNUSED_ARG(t);
#endif
#endif /* !PERL_GET_CONTEXT_DEFINED */
+/*
+=for apidoc get_op_names
+
+Return a pointer to the array of all the names of the various OPs
+Given an opcode from the enum in F<opcodes.h>, C<PL_op_name[opcode]> returns a
+pointer to a C language string giving its name.
+
+=cut
+*/
+
char **
Perl_get_op_names(pTHX)
{
return (char **)PL_op_name;
}
+/*
+=for apidoc get_op_descs
+
+Return a pointer to the array of all the descriptions of the various OPs
+Given an opcode from the enum in F<opcodes.h>, C<PL_op_desc[opcode]> returns a
+pointer to a C language string giving its description.
+
+=cut
+*/
+
char **
Perl_get_op_descs(pTHX)
{
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_GETENV_LEN;
if (env_trans)
- *len = strlen(env_trans);
+ *len = strlen(env_trans);
return env_trans;
}
#endif
+/*
+=for apidoc_section $io
+=for apidoc my_fflush_all
-MGVTBL*
-Perl_get_vtbl(pTHX_ int vtbl_id)
-{
- PERL_UNUSED_CONTEXT;
+Implements C<PERL_FLUSHALL_FOR_CHILD> on some platforms.
- return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
- ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
-}
+=cut
+ */
I32
Perl_my_fflush_all(pTHX)
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
- if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
- STDIO_STREAM_ARRAY[i]._file < open_max &&
- STDIO_STREAM_ARRAY[i]._flag)
- PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
+ if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
+ STDIO_STREAM_ARRAY[i]._file < open_max &&
+ STDIO_STREAM_ARRAY[i]._flag)
+ PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
return 0;
}
# endif
= gv && (isGV_with_GP(gv))
? GvENAME_HEK((gv))
: NULL;
- const char * const direction = have == '>' ? "out" : "in";
+ const char * const direction = have == '>' ? "out" : "in";
- if (name && HEK_LEN(name))
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %" HEKf " opened only for %sput",
- HEKfARG(name), direction);
- else
- Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle opened only for %sput", direction);
+ if (name && HEK_LEN(name))
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle %" HEKf " opened only for %sput",
+ HEKfARG(name), direction);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_IO),
+ "Filehandle opened only for %sput", direction);
}
}
I32 warn_type;
if (io && IoTYPE(io) == IoTYPE_CLOSED) {
- vile = "closed";
- warn_type = WARN_CLOSED;
+ vile = "closed";
+ warn_type = WARN_CLOSED;
}
else {
- vile = "unopened";
- warn_type = WARN_UNOPENED;
+ vile = "unopened";
+ warn_type = WARN_UNOPENED;
}
if (ckWARN(warn_type)) {
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 || 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");
- 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%s%" SVf "?)\n",
- func, pars, have_name ? " " : "",
- SVfARG(have_name ? name : &PL_sv_no)
- );
+ newSVhek_mortal(GvENAME_HEK(gv)) : NULL;
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
+ const char * const func =
+ (const char *)
+ (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");
+ 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%s%" SVf "?)\n",
+ func, pars, have_name ? " " : "",
+ SVfARG(have_name ? name : &PL_sv_no)
+ );
}
}
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
- ENV_LOCALE_READ_LOCK;
+
+ LOCALTIME_LOCK;
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
- ENV_LOCALE_READ_UNLOCK;
+ LOCALTIME_UNLOCK;
#else
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
}
/*
- * mini_mktime - normalise struct tm values without the localtime()
- * semantics (and overhead) of mktime().
+=for apidoc_section $time
+=for apidoc mini_mktime
+normalise S<C<struct tm>> values without the localtime() semantics (and
+overhead) of mktime().
+
+=cut
*/
void
Perl_mini_mktime(struct tm *ptm)
PERL_ARGS_ASSERT_MINI_MKTIME;
-#define DAYS_PER_YEAR 365
-#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
-#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
-#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
-#define SECS_PER_HOUR (60*60)
-#define SECS_PER_DAY (24*SECS_PER_HOUR)
+#define DAYS_PER_YEAR 365
+#define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1)
+#define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1)
+#define DAYS_PER_QCENT (4*DAYS_PER_CENT+1)
+#define SECS_PER_HOUR (60*60)
+#define SECS_PER_DAY (24*SECS_PER_HOUR)
/* parentheses deliberately absent on these two, otherwise they don't work */
-#define MONTH_TO_DAYS 153/5
-#define DAYS_TO_MONTH 5/153
+#define MONTH_TO_DAYS 153/5
+#define DAYS_TO_MONTH 5/153
/* offset to bias by March (month 4) 1st between month/mday & year finding */
-#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
+#define YEAR_ADJUST (4*MONTH_TO_DAYS+1)
/* as used here, the algorithm leaves Sunday as day 1 unless we adjust it */
-#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
+#define WEEKDAY_BIAS 6 /* (1+6)%7 makes Sunday 0 again */
/*
* Year/day algorithm notes:
mday = ptm->tm_mday;
jday = 0;
if (month >= 2)
- month+=2;
+ month+=2;
else
- month+=14, year--;
+ month+=14, year--;
yearday = DAYS_PER_YEAR * year + year/4 - year/100 + year/400;
yearday += month*MONTH_TO_DAYS + mday + jday;
/*
* be rationalised, however.
*/
if ((unsigned) ptm->tm_sec <= 60) {
- secs = 0;
+ secs = 0;
}
else {
- secs = ptm->tm_sec;
- ptm->tm_sec = 0;
+ secs = ptm->tm_sec;
+ ptm->tm_sec = 0;
}
secs += 60 * ptm->tm_min;
secs += SECS_PER_HOUR * ptm->tm_hour;
if (secs < 0) {
- if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
- /* got negative remainder, but need positive time */
- /* back off an extra day to compensate */
- yearday += (secs/SECS_PER_DAY)-1;
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
- }
- else {
- yearday += (secs/SECS_PER_DAY);
- secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
- }
+ if (secs-(secs/SECS_PER_DAY*SECS_PER_DAY) < 0) {
+ /* got negative remainder, but need positive time */
+ /* back off an extra day to compensate */
+ yearday += (secs/SECS_PER_DAY)-1;
+ secs -= SECS_PER_DAY * (secs/SECS_PER_DAY - 1);
+ }
+ else {
+ yearday += (secs/SECS_PER_DAY);
+ secs -= SECS_PER_DAY * (secs/SECS_PER_DAY);
+ }
}
else if (secs >= SECS_PER_DAY) {
- yearday += (secs/SECS_PER_DAY);
- secs %= SECS_PER_DAY;
+ yearday += (secs/SECS_PER_DAY);
+ secs %= SECS_PER_DAY;
}
ptm->tm_hour = secs/SECS_PER_HOUR;
secs %= SECS_PER_HOUR;
year += odd_year;
yearday %= DAYS_PER_YEAR;
if (!yearday && (odd_cent==4 || odd_year==4)) { /* catch Feb 29 */
- month = 1;
- yearday = 29;
+ month = 1;
+ yearday = 29;
}
else {
- yearday += YEAR_ADJUST; /* recover March 1st crock */
- month = yearday*DAYS_TO_MONTH;
- yearday -= month*MONTH_TO_DAYS;
- /* recover other leap-year adjustment */
- if (month > 13) {
- month-=14;
- year++;
- }
- else {
- month-=2;
- }
+ yearday += YEAR_ADJUST; /* recover March 1st crock */
+ month = yearday*DAYS_TO_MONTH;
+ yearday -= month*MONTH_TO_DAYS;
+ /* recover other leap-year adjustment */
+ if (month > 13) {
+ month-=14;
+ year++;
+ }
+ else {
+ month-=2;
+ }
}
ptm->tm_year = year - 1900;
if (yearday) {
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
-
- /* strftime(), but with a different API so that the return value is a pointer
- * to the formatted result (which MUST be arranged to be FREED BY THE
- * CALLER). This allows this function to increase the buffer size as needed,
- * so that the caller doesn't have to worry about that.
- *
- * Note that yday and wday effectively are ignored by this function, as
- * mini_mktime() overwrites them */
-
- char *buf;
- int buflen;
- struct tm mytm;
- int len;
-
- PERL_ARGS_ASSERT_MY_STRFTIME;
-
- init_tm(&mytm); /* XXX workaround - see init_tm() above */
- mytm.tm_sec = sec;
- mytm.tm_min = min;
- mytm.tm_hour = hour;
- mytm.tm_mday = mday;
- mytm.tm_mon = mon;
- mytm.tm_year = year;
- mytm.tm_wday = wday;
- mytm.tm_yday = yday;
- mytm.tm_isdst = isdst;
- mini_mktime(&mytm);
- /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
-#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
- STMT_START {
- struct tm mytm2;
- mytm2 = mytm;
- mktime(&mytm2);
-#ifdef HAS_TM_TM_GMTOFF
- mytm.tm_gmtoff = mytm2.tm_gmtoff;
-#endif
-#ifdef HAS_TM_TM_ZONE
- mytm.tm_zone = mytm2.tm_zone;
-#endif
- } STMT_END;
-#endif
- buflen = 64;
- Newx(buf, buflen, char);
-
- GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
- len = strftime(buf, buflen, fmt, &mytm);
- GCC_DIAG_RESTORE_STMT;
-
- /*
- ** The following is needed to handle to the situation where
- ** tmpbuf overflows. Basically we want to allocate a buffer
- ** and try repeatedly. The reason why it is so complicated
- ** is that getting a return value of 0 from strftime can indicate
- ** one of the following:
- ** 1. buffer overflowed,
- ** 2. illegal conversion specifier, or
- ** 3. the format string specifies nothing to be returned(not
- ** an error). This could be because format is an empty string
- ** or it specifies %p that yields an empty string in some locale.
- ** If there is a better way to make it portable, go ahead by
- ** all means.
- */
- if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
- return buf;
- else {
- /* Possibly buf overflowed - try again with a bigger buf */
- const int fmtlen = strlen(fmt);
- int bufsize = fmtlen + buflen;
-
- Renew(buf, bufsize, char);
- while (buf) {
-
- GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
- buflen = strftime(buf, bufsize, fmt, &mytm);
- GCC_DIAG_RESTORE_STMT;
-
- if (inRANGE(buflen, 1, bufsize - 1))
- break;
- /* heuristic to prevent out-of-memory errors */
- if (bufsize > 100*fmtlen) {
- Safefree(buf);
- buf = NULL;
- break;
- }
- bufsize *= 2;
- Renew(buf, bufsize, char);
- }
- return buf;
- }
-#else
- Perl_croak(aTHX_ "panic: no strftime");
- return NULL;
-#endif
-}
-
-
#define SV_CWD_RETURN_UNDEF \
sv_set_undef(sv); \
return FALSE
#define SV_CWD_ISDOT(dp) \
(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
- (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
+ (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
=for apidoc getcwd_sv
int
Perl_getcwd_sv(pTHX_ SV *sv)
{
-#ifndef PERL_MICRO
SvTAINTED_on(sv);
PERL_ARGS_ASSERT_GETCWD_SV;
#ifdef HAS_GETCWD
{
- char buf[MAXPATHLEN];
-
- /* Some getcwd()s automatically allocate a buffer of the given
- * size from the heap if they are given a NULL buffer pointer.
- * The problem is that this behaviour is not portable. */
- if (getcwd(buf, sizeof(buf) - 1)) {
- sv_setpv(sv, buf);
- return TRUE;
- }
- else {
- SV_CWD_RETURN_UNDEF;
- }
+ char buf[MAXPATHLEN];
+
+ /* Some getcwd()s automatically allocate a buffer of the given
+ * size from the heap if they are given a NULL buffer pointer.
+ * The problem is that this behaviour is not portable. */
+ if (getcwd(buf, sizeof(buf) - 1)) {
+ sv_setpv(sv, buf);
+ return TRUE;
+ }
+ else {
+ SV_CWD_RETURN_UNDEF;
+ }
}
#else
SvUPGRADE(sv, SVt_PV);
if (PerlLIO_lstat(".", &statbuf) < 0) {
- SV_CWD_RETURN_UNDEF;
+ SV_CWD_RETURN_UNDEF;
}
orig_cdev = statbuf.st_dev;
cino = orig_cino;
for (;;) {
- DIR *dir;
- int namelen;
- odev = cdev;
- oino = cino;
-
- if (PerlDir_chdir("..") < 0) {
- SV_CWD_RETURN_UNDEF;
- }
- if (PerlLIO_stat(".", &statbuf) < 0) {
- SV_CWD_RETURN_UNDEF;
- }
-
- cdev = statbuf.st_dev;
- cino = statbuf.st_ino;
-
- if (odev == cdev && oino == cino) {
- break;
- }
- if (!(dir = PerlDir_open("."))) {
- SV_CWD_RETURN_UNDEF;
- }
-
- while ((dp = PerlDir_read(dir)) != NULL) {
+ DIR *dir;
+ int namelen;
+ odev = cdev;
+ oino = cino;
+
+ if (PerlDir_chdir("..") < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ if (PerlLIO_stat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ cdev = statbuf.st_dev;
+ cino = statbuf.st_ino;
+
+ if (odev == cdev && oino == cino) {
+ break;
+ }
+ if (!(dir = PerlDir_open("."))) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ while ((dp = PerlDir_read(dir)) != NULL) {
#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
+ namelen = dp->d_namlen;
#else
- namelen = strlen(dp->d_name);
+ namelen = strlen(dp->d_name);
#endif
- /* skip . and .. */
- if (SV_CWD_ISDOT(dp)) {
- continue;
- }
+ /* skip . and .. */
+ if (SV_CWD_ISDOT(dp)) {
+ continue;
+ }
- if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
- SV_CWD_RETURN_UNDEF;
- }
+ if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
- tdev = statbuf.st_dev;
- tino = statbuf.st_ino;
- if (tino == oino && tdev == odev) {
- break;
- }
- }
+ tdev = statbuf.st_dev;
+ tino = statbuf.st_ino;
+ if (tino == oino && tdev == odev) {
+ break;
+ }
+ }
- if (!dp) {
- SV_CWD_RETURN_UNDEF;
- }
+ if (!dp) {
+ SV_CWD_RETURN_UNDEF;
+ }
- if (pathlen + namelen + 1 >= MAXPATHLEN) {
- SV_CWD_RETURN_UNDEF;
- }
+ if (pathlen + namelen + 1 >= MAXPATHLEN) {
+ SV_CWD_RETURN_UNDEF;
+ }
- SvGROW(sv, pathlen + namelen + 1);
+ SvGROW(sv, pathlen + namelen + 1);
- if (pathlen) {
- /* shift down */
- Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
- }
+ if (pathlen) {
+ /* shift down */
+ Move(SvPVX_const(sv), SvPVX(sv) + namelen + 1, pathlen, char);
+ }
- /* prepend current directory to the front */
- *SvPVX(sv) = '/';
- Move(dp->d_name, SvPVX(sv)+1, namelen, char);
- pathlen += (namelen + 1);
+ /* prepend current directory to the front */
+ *SvPVX(sv) = '/';
+ Move(dp->d_name, SvPVX(sv)+1, namelen, char);
+ pathlen += (namelen + 1);
#ifdef VOID_CLOSEDIR
- PerlDir_close(dir);
+ PerlDir_close(dir);
#else
- if (PerlDir_close(dir) < 0) {
- SV_CWD_RETURN_UNDEF;
- }
+ if (PerlDir_close(dir) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
#endif
}
if (pathlen) {
- SvCUR_set(sv, pathlen);
- *SvEND(sv) = '\0';
- SvPOK_only(sv);
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
- if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
- SV_CWD_RETURN_UNDEF;
- }
+ if (PerlDir_chdir(SvPVX_const(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
}
if (PerlLIO_stat(".", &statbuf) < 0) {
- SV_CWD_RETURN_UNDEF;
+ SV_CWD_RETURN_UNDEF;
}
cdev = statbuf.st_dev;
cino = statbuf.st_ino;
if (cdev != orig_cdev || cino != orig_cino) {
- Perl_croak(aTHX_ "Unstable directory path, "
- "current directory changed unexpectedly");
+ Perl_croak(aTHX_ "Unstable directory path, "
+ "current directory changed unexpectedly");
}
return TRUE;
#endif
-#else
- return FALSE;
-#endif
}
#include "vutil.c"
memset(&addresses, 0, sizeof(addresses));
i = 1;
do {
- sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
- if (sockets[i] == -1)
- goto tidy_up_and_fail;
-
- addresses[i].sin_family = AF_INET;
- addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
- addresses[i].sin_port = 0; /* kernel choses port. */
- if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
- sizeof(struct sockaddr_in)) == -1)
- goto tidy_up_and_fail;
+ sockets[i] = PerlSock_socket(AF_INET, SOCK_DGRAM, PF_INET);
+ if (sockets[i] == -1)
+ goto tidy_up_and_fail;
+
+ addresses[i].sin_family = AF_INET;
+ addresses[i].sin_addr.s_addr = htonl(INADDR_LOOPBACK);
+ addresses[i].sin_port = 0; /* kernel chooses port. */
+ if (PerlSock_bind(sockets[i], (struct sockaddr *) &addresses[i],
+ sizeof(struct sockaddr_in)) == -1)
+ goto tidy_up_and_fail;
} while (i--);
/* Now have 2 UDP sockets. Find out which port each is connected to, and
for each connect the other socket to it. */
i = 1;
do {
- if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
- &size) == -1)
- goto tidy_up_and_fail;
- if (size != sizeof(struct sockaddr_in))
- goto abort_tidy_up_and_fail;
- /* !1 is 0, !0 is 1 */
- if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
- sizeof(struct sockaddr_in)) == -1)
- goto tidy_up_and_fail;
+ if (PerlSock_getsockname(sockets[i], (struct sockaddr *) &addresses[i],
+ &size) == -1)
+ goto tidy_up_and_fail;
+ if (size != sizeof(struct sockaddr_in))
+ goto abort_tidy_up_and_fail;
+ /* !1 is 0, !0 is 1 */
+ if (PerlSock_connect(sockets[!i], (struct sockaddr *) &addresses[i],
+ sizeof(struct sockaddr_in)) == -1)
+ goto tidy_up_and_fail;
} while (i--);
/* Now we have 2 sockets connected to each other. I don't trust some other
a packet from each to the other. */
i = 1;
do {
- /* I'm going to send my own port number. As a short.
- (Who knows if someone somewhere has sin_port as a bitfield and needs
- this routine. (I'm assuming crays have socketpair)) */
- port = addresses[i].sin_port;
- got = PerlLIO_write(sockets[i], &port, sizeof(port));
- if (got != sizeof(port)) {
- if (got == -1)
- goto tidy_up_and_fail;
- goto abort_tidy_up_and_fail;
- }
+ /* I'm going to send my own port number. As a short.
+ (Who knows if someone somewhere has sin_port as a bitfield and needs
+ this routine. (I'm assuming crays have socketpair)) */
+ port = addresses[i].sin_port;
+ got = PerlLIO_write(sockets[i], &port, sizeof(port));
+ if (got != sizeof(port)) {
+ if (got == -1)
+ goto tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
+ }
} while (i--);
/* Packets sent. I don't trust them to have arrived though.
*/
{
- struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
- int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
- fd_set rset;
-
- FD_ZERO(&rset);
- FD_SET((unsigned int)sockets[0], &rset);
- FD_SET((unsigned int)sockets[1], &rset);
-
- got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
- if (got != 2 || !FD_ISSET(sockets[0], &rset)
- || !FD_ISSET(sockets[1], &rset)) {
- /* I hope this is portable and appropriate. */
- if (got == -1)
- goto tidy_up_and_fail;
- goto abort_tidy_up_and_fail;
- }
+ struct timeval waitfor = {0, 100000}; /* You have 0.1 seconds */
+ int max = sockets[1] > sockets[0] ? sockets[1] : sockets[0];
+ fd_set rset;
+
+ FD_ZERO(&rset);
+ FD_SET((unsigned int)sockets[0], &rset);
+ FD_SET((unsigned int)sockets[1], &rset);
+
+ got = PerlSock_select(max + 1, &rset, NULL, NULL, &waitfor);
+ if (got != 2 || !FD_ISSET(sockets[0], &rset)
+ || !FD_ISSET(sockets[1], &rset)) {
+ /* I hope this is portable and appropriate. */
+ if (got == -1)
+ goto tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
+ }
}
/* And the paranoia department even now doesn't trust it to have arrive
(hence MSG_DONTWAIT). Or that what arrives was sent by us. */
{
- struct sockaddr_in readfrom;
- unsigned short buffer[2];
+ struct sockaddr_in readfrom;
+ unsigned short buffer[2];
- i = 1;
- do {
+ i = 1;
+ do {
#ifdef MSG_DONTWAIT
- got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
- sizeof(buffer), MSG_DONTWAIT,
- (struct sockaddr *) &readfrom, &size);
+ got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
+ sizeof(buffer), MSG_DONTWAIT,
+ (struct sockaddr *) &readfrom, &size);
#else
- got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
- sizeof(buffer), 0,
- (struct sockaddr *) &readfrom, &size);
-#endif
-
- if (got == -1)
- goto tidy_up_and_fail;
- if (got != sizeof(port)
- || size != sizeof(struct sockaddr_in)
- /* Check other socket sent us its port. */
- || buffer[0] != (unsigned short) addresses[!i].sin_port
- /* Check kernel says we got the datagram from that socket */
- || readfrom.sin_family != addresses[!i].sin_family
- || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
- || readfrom.sin_port != addresses[!i].sin_port)
- goto abort_tidy_up_and_fail;
- } while (i--);
+ got = PerlSock_recvfrom(sockets[i], (char *) &buffer,
+ sizeof(buffer), 0,
+ (struct sockaddr *) &readfrom, &size);
+#endif
+
+ if (got == -1)
+ goto tidy_up_and_fail;
+ if (got != sizeof(port)
+ || size != sizeof(struct sockaddr_in)
+ /* Check other socket sent us its port. */
+ || buffer[0] != (unsigned short) addresses[!i].sin_port
+ /* Check kernel says we got the datagram from that socket */
+ || readfrom.sin_family != addresses[!i].sin_family
+ || readfrom.sin_addr.s_addr != addresses[!i].sin_addr.s_addr
+ || readfrom.sin_port != addresses[!i].sin_port)
+ goto abort_tidy_up_and_fail;
+ } while (i--);
}
/* My caller (my_socketpair) has validated that this is non-NULL */
fd[0] = sockets[0];
errno = ECONNABORTED;
tidy_up_and_fail:
{
- dSAVE_ERRNO;
- if (sockets[0] != -1)
- PerlLIO_close(sockets[0]);
- if (sockets[1] != -1)
- PerlLIO_close(sockets[1]);
- RESTORE_ERRNO;
- return -1;
+ dSAVE_ERRNO;
+ if (sockets[0] != -1)
+ PerlLIO_close(sockets[0]);
+ if (sockets[1] != -1)
+ PerlLIO_close(sockets[1]);
+ RESTORE_ERRNO;
+ return -1;
}
}
#endif /* EMULATE_SOCKETPAIR_UDP */
#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET)
+
+/*
+=for apidoc my_socketpair
+
+Emulates L<socketpair(2)> on systems that don't have it, but which do have
+enough functionality for the emulation.
+
+=cut
+*/
+
int
Perl_my_socketpair (int family, int type, int protocol, int fd[2]) {
/* Stevens says that family must be AF_LOCAL, protocol 0.
if (protocol
#ifdef AF_UNIX
- || family != AF_UNIX
+ || family != AF_UNIX
#endif
) {
- errno = EAFNOSUPPORT;
- return -1;
+ errno = EAFNOSUPPORT;
+ return -1;
}
if (!fd) {
- errno = EINVAL;
- return -1;
+ errno = EINVAL;
+ return -1;
}
#ifdef SOCK_CLOEXEC
#ifdef EMULATE_SOCKETPAIR_UDP
if (type == SOCK_DGRAM)
- return S_socketpair_udp(fd);
+ return S_socketpair_udp(fd);
#endif
aTHXa(PERL_GET_THX);
listener = PerlSock_socket(AF_INET, type, 0);
if (listener == -1)
- return -1;
+ return -1;
memset(&listen_addr, 0, sizeof(listen_addr));
listen_addr.sin_family = AF_INET;
listen_addr.sin_addr.s_addr = htonl(INADDR_LOOPBACK);
- listen_addr.sin_port = 0; /* kernel choses port. */
+ listen_addr.sin_port = 0; /* kernel chooses port. */
if (PerlSock_bind(listener, (struct sockaddr *) &listen_addr,
- sizeof(listen_addr)) == -1)
- goto tidy_up_and_fail;
+ sizeof(listen_addr)) == -1)
+ goto tidy_up_and_fail;
if (PerlSock_listen(listener, 1) == -1)
- goto tidy_up_and_fail;
+ goto tidy_up_and_fail;
connector = PerlSock_socket(AF_INET, type, 0);
if (connector == -1)
- goto tidy_up_and_fail;
+ goto tidy_up_and_fail;
/* We want to find out the port number to connect to. */
size = sizeof(connect_addr);
if (PerlSock_getsockname(listener, (struct sockaddr *) &connect_addr,
- &size) == -1)
- goto tidy_up_and_fail;
+ &size) == -1)
+ goto tidy_up_and_fail;
if (size != sizeof(connect_addr))
- goto abort_tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
if (PerlSock_connect(connector, (struct sockaddr *) &connect_addr,
- sizeof(connect_addr)) == -1)
- goto tidy_up_and_fail;
+ sizeof(connect_addr)) == -1)
+ goto tidy_up_and_fail;
size = sizeof(listen_addr);
acceptor = PerlSock_accept(listener, (struct sockaddr *) &listen_addr,
- &size);
+ &size);
if (acceptor == -1)
- goto tidy_up_and_fail;
+ goto tidy_up_and_fail;
if (size != sizeof(listen_addr))
- goto abort_tidy_up_and_fail;
+ goto abort_tidy_up_and_fail;
PerlLIO_close(listener);
/* Now check we are talking to ourself by matching port and host on the
two sockets. */
if (PerlSock_getsockname(connector, (struct sockaddr *) &connect_addr,
- &size) == -1)
- goto tidy_up_and_fail;
+ &size) == -1)
+ goto tidy_up_and_fail;
if (size != sizeof(connect_addr)
- || listen_addr.sin_family != connect_addr.sin_family
- || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
- || listen_addr.sin_port != connect_addr.sin_port) {
- goto abort_tidy_up_and_fail;
+ || listen_addr.sin_family != connect_addr.sin_family
+ || listen_addr.sin_addr.s_addr != connect_addr.sin_addr.s_addr
+ || listen_addr.sin_port != connect_addr.sin_port) {
+ goto abort_tidy_up_and_fail;
}
fd[0] = connector;
fd[1] = acceptor;
#endif
tidy_up_and_fail:
{
- dSAVE_ERRNO;
- if (listener != -1)
- PerlLIO_close(listener);
- if (connector != -1)
- PerlLIO_close(connector);
- if (acceptor != -1)
- PerlLIO_close(acceptor);
- RESTORE_ERRNO;
- return -1;
+ dSAVE_ERRNO;
+ if (listener != -1)
+ PerlLIO_close(listener);
+ if (connector != -1)
+ PerlLIO_close(connector);
+ if (acceptor != -1)
+ PerlLIO_close(acceptor);
+ RESTORE_ERRNO;
+ return -1;
}
}
#else
}
}
else {
- for (; *p; p++) {
- switch (*p) {
- case PERL_UNICODE_STDIN:
- opt |= PERL_UNICODE_STDIN_FLAG; break;
- case PERL_UNICODE_STDOUT:
- opt |= PERL_UNICODE_STDOUT_FLAG; break;
- case PERL_UNICODE_STDERR:
- opt |= PERL_UNICODE_STDERR_FLAG; break;
- case PERL_UNICODE_STD:
- opt |= PERL_UNICODE_STD_FLAG; break;
- case PERL_UNICODE_IN:
- opt |= PERL_UNICODE_IN_FLAG; break;
- case PERL_UNICODE_OUT:
- opt |= PERL_UNICODE_OUT_FLAG; break;
- case PERL_UNICODE_INOUT:
- opt |= PERL_UNICODE_INOUT_FLAG; break;
- case PERL_UNICODE_LOCALE:
- opt |= PERL_UNICODE_LOCALE_FLAG; break;
- case PERL_UNICODE_ARGV:
- opt |= PERL_UNICODE_ARGV_FLAG; break;
- case PERL_UNICODE_UTF8CACHEASSERT:
- opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
- default:
- if (*p != '\n' && *p != '\r') {
- if(isSPACE(*p)) goto the_end_of_the_opts_parser;
- else
- Perl_croak(aTHX_
- "Unknown Unicode option letter '%c'", *p);
- }
- }
- }
+ for (; *p; p++) {
+ switch (*p) {
+ case PERL_UNICODE_STDIN:
+ opt |= PERL_UNICODE_STDIN_FLAG; break;
+ case PERL_UNICODE_STDOUT:
+ opt |= PERL_UNICODE_STDOUT_FLAG; break;
+ case PERL_UNICODE_STDERR:
+ opt |= PERL_UNICODE_STDERR_FLAG; break;
+ case PERL_UNICODE_STD:
+ opt |= PERL_UNICODE_STD_FLAG; break;
+ case PERL_UNICODE_IN:
+ opt |= PERL_UNICODE_IN_FLAG; break;
+ case PERL_UNICODE_OUT:
+ opt |= PERL_UNICODE_OUT_FLAG; break;
+ case PERL_UNICODE_INOUT:
+ opt |= PERL_UNICODE_INOUT_FLAG; break;
+ case PERL_UNICODE_LOCALE:
+ opt |= PERL_UNICODE_LOCALE_FLAG; break;
+ case PERL_UNICODE_ARGV:
+ opt |= PERL_UNICODE_ARGV_FLAG; break;
+ case PERL_UNICODE_UTF8CACHEASSERT:
+ opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break;
+ default:
+ if (*p != '\n' && *p != '\r') {
+ if(isSPACE(*p)) goto the_end_of_the_opts_parser;
+ else
+ Perl_croak(aTHX_
+ "Unknown Unicode option letter '%c'", *p);
+ }
+ }
+ }
}
}
else
if (opt & ~PERL_UNICODE_ALL_FLAGS)
Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
- (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
+ (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
*popt = p;
# include <starlet.h>
#endif
+/* hash a pointer and return a U32
+ *
+ * this code was derived from Sereal, which was derived from autobox.
+ */
+
+PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
+#if PTRSIZE == 8
+ /*
+ * This is one of Thomas Wang's hash functions for 64-bit integers from:
+ * http://www.concentric.net/~Ttwang/tech/inthash.htm
+ */
+ u = (~u) + (u << 18);
+ u = u ^ (u >> 31);
+ u = u * 21;
+ u = u ^ (u >> 11);
+ u = u + (u << 6);
+ u = u ^ (u >> 22);
+#else
+ /*
+ * This is one of Bob Jenkins' hash functions for 32-bit integers
+ * from: https://burtleburtle.net/bob/hash/integer.html
+ */
+ u = (u + 0x7ed55d16) + (u << 12);
+ u = (u ^ 0xc761c23c) ^ (u >> 19);
+ u = (u + 0x165667b1) + (u << 5);
+ u = (u + 0xd3a2646c) ^ (u << 9);
+ u = (u + 0xfd7046c5) + (u << 3);
+ u = (u ^ 0xb55a4f09) ^ (u >> 16);
+#endif
+ return (U32)u;
+}
+
+
U32
Perl_seed(pTHX)
{
#endif
fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
- if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
- u = 0;
- PerlLIO_close(fd);
- if (u)
- return u;
+ if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
+ u = 0;
+ PerlLIO_close(fd);
+ if (u)
+ return u;
}
#endif
u += SEED_C3 * (U32)PerlProc_getpid();
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
- u += SEED_C5 * (U32)PTR2UV(&when);
+ UV ptruv = PTR2UV(&when);
+ u += SEED_C5 * ptr_hash(ptruv);
#endif
return u;
}
PERL_ARGS_ASSERT_GET_HASH_SEED;
+ Zero(seed_buffer, PERL_HASH_SEED_BYTES, U8);
+ Zero((U8*)PL_hash_state_w, PERL_HASH_STATE_BYTES, U8);
+
#ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_HASH_SEED");
if ( env_pv )
{
+ if (DEBUG_h_TEST)
+ PerlIO_printf(Perl_debug_log,"Got PERL_HASH_SEED=<%s>\n", env_pv);
/* ignore leading spaces */
while (isSPACE(*env_pv))
env_pv++;
}
}
#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);
- }
- }
# ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_PERTURB_KEYS");
if (env_pv) {
+ if (DEBUG_h_TEST)
+ PerlIO_printf(Perl_debug_log,
+ "Got PERL_PERTURB_KEYS=<%s>\n", 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")) {
}
}
# endif
+ { /* 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. */
+ if (PL_hash_rand_bits_enabled == 1) {
+ /* random mode initialize from seed() like we would our RNG() */
+ PL_hash_rand_bits= seed();
+ }
+ else {
+ /* Use a constant */
+ PL_hash_rand_bits= 0xbe49d17f; /* I just picked a number */
+ /* and then mix in the leading bytes of the hash seed */
+ 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);
+ }
+ }
+ if (!PL_hash_rand_bits) {
+ /* we use an XORSHIFT RNG to munge PL_hash_rand_bits,
+ * which means it cannot be 0 or it will stay 0 for the
+ * lifetime of the process, so if by some insane chance we
+ * ended up with a 0 after the above initialization
+ * then set it to this. This really should not happen, or
+ * very very very rarely.
+ */
+ PL_hash_rand_bits = 0x8110ba9d; /* a randomly chosen prime */
+ }
+ }
#endif
}
+void
+Perl_debug_hash_seed(pTHX_ bool via_debug_h)
+{
+ PERL_ARGS_ASSERT_DEBUG_HASH_SEED;
+#if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG)
+ {
+ const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
+ bool via_env = cBOOL(s && strNE(s, "0") && strNE(s,""));
+
+ if ( via_env != via_debug_h ) {
+ const unsigned char *seed= PERL_HASH_SEED;
+ const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES;
+ PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC);
+ while (seed < seed_end) {
+ PerlIO_printf(Perl_debug_log, "%02x", *seed++);
+ }
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)",
+ PL_HASH_RAND_BITS_ENABLED,
+ PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" :
+ PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM"
+ : "DETERMINISTIC");
+ if (DEBUG_h_TEST)
+ PerlIO_printf(Perl_debug_log,
+ " RAND_BITS=0x%" UVxf, PL_hash_rand_bits);
+#endif
+ PerlIO_printf(Perl_debug_log, "\n");
+ }
+ }
+#endif /* #if (defined(USE_HASH_SEED) ... */
+}
+
+
+
+
#ifdef PERL_MEM_LOG
/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer
* the Perl_mem_log_...() will use (either via sprintf or snprintf).
*/
-#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128
+#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 256
/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...()
* writes to. In the default logger, this is settable at runtime.
static void
S_mem_log_common(enum mem_log_type mlt, const UV n,
- const UV typesize, const char *type_name, const SV *sv,
- Malloc_t oldalloc, Malloc_t newalloc,
- const char *filename, const int linenumber,
- const char *funcname)
+ const UV typesize, const char *type_name, const SV *sv,
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
const char *pmlenv;
+ dTHX;
PERL_ARGS_ASSERT_MEM_LOG_COMMON;
+ PL_mem_log[0] |= 0x2; /* Flag that the call is from this code */
pmlenv = PerlEnv_getenv("PERL_MEM_LOG");
+ PL_mem_log[0] &= ~0x2;
if (!pmlenv)
- return;
+ return;
if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s'))
{
- /* We can't use SVs or PerlIO for obvious reasons,
- * so we'll use stdio and low-level IO instead. */
- char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
+ /* We can't use SVs or PerlIO for obvious reasons,
+ * so we'll use stdio and low-level IO instead. */
+ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE];
# ifdef HAS_GETTIMEOFDAY
# define MEM_LOG_TIME_FMT "%10d.%06d: "
# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec
- struct timeval tv;
- gettimeofday(&tv, 0);
+ struct timeval tv;
+ PerlProc_gettimeofday(&tv, 0);
# else
# define MEM_LOG_TIME_FMT "%10d: "
# define MEM_LOG_TIME_ARG (int)when
Time_t when;
(void)time(&when);
# endif
- /* If there are other OS specific ways of hires time than
- * gettimeofday() (see dist/Time-HiRes), the easiest way is
- * probably that they would be used to fill in the struct
- * timeval. */
- {
- STRLEN len;
+ /* If there are other OS specific ways of hires time than
+ * gettimeofday() (see dist/Time-HiRes), the easiest way is
+ * probably that they would be used to fill in the struct
+ * timeval. */
+ {
+ STRLEN len;
const char* endptr = pmlenv + strlen(pmlenv);
- int fd;
+ int fd;
UV uv;
if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
&& uv && uv <= PERL_INT_MAX
) {
fd = (int)uv;
} else {
- fd = PERL_MEM_LOG_FD;
+ fd = PERL_MEM_LOG_FD;
}
- if (strchr(pmlenv, 't')) {
- len = my_snprintf(buf, sizeof(buf),
- MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
- PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
- }
- switch (mlt) {
- case MLT_ALLOC:
- len = my_snprintf(buf, sizeof(buf),
- "alloc: %s:%d:%s: %" IVdf " %" UVuf
- " %s = %" IVdf ": %" UVxf "\n",
- filename, linenumber, funcname, n, typesize,
- type_name, n * typesize, PTR2UV(newalloc));
- break;
- case MLT_REALLOC:
- len = my_snprintf(buf, sizeof(buf),
- "realloc: %s:%d:%s: %" IVdf " %" UVuf
- " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
- filename, linenumber, funcname, n, typesize,
- type_name, n * typesize, PTR2UV(oldalloc),
- PTR2UV(newalloc));
- break;
- case MLT_FREE:
- len = my_snprintf(buf, sizeof(buf),
- "free: %s:%d:%s: %" UVxf "\n",
- filename, linenumber, funcname,
- PTR2UV(oldalloc));
- break;
- case MLT_NEW_SV:
- case MLT_DEL_SV:
- len = my_snprintf(buf, sizeof(buf),
- "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
- mlt == MLT_NEW_SV ? "new" : "del",
- filename, linenumber, funcname,
- PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
- break;
- default:
- len = 0;
- }
- PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
- }
+ if (strchr(pmlenv, 't')) {
+ len = my_snprintf(buf, sizeof(buf),
+ MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG);
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
+ }
+ switch (mlt) {
+ case MLT_ALLOC:
+ len = my_snprintf(buf, sizeof(buf),
+ "alloc: %s:%d:%s: %" IVdf " %" UVuf
+ " %s = %" IVdf ": %" UVxf "\n",
+ filename, linenumber, funcname, n, typesize,
+ type_name, n * typesize, PTR2UV(newalloc));
+ break;
+ case MLT_REALLOC:
+ len = my_snprintf(buf, sizeof(buf),
+ "realloc: %s:%d:%s: %" IVdf " %" UVuf
+ " %s = %" IVdf ": %" UVxf " -> %" UVxf "\n",
+ filename, linenumber, funcname, n, typesize,
+ type_name, n * typesize, PTR2UV(oldalloc),
+ PTR2UV(newalloc));
+ break;
+ case MLT_FREE:
+ len = my_snprintf(buf, sizeof(buf),
+ "free: %s:%d:%s: %" UVxf "\n",
+ filename, linenumber, funcname,
+ PTR2UV(oldalloc));
+ break;
+ case MLT_NEW_SV:
+ case MLT_DEL_SV:
+ len = my_snprintf(buf, sizeof(buf),
+ "%s_SV: %s:%d:%s: %" UVxf SV_LOG_SERIAL_FMT "\n",
+ mlt == MLT_NEW_SV ? "new" : "del",
+ filename, linenumber, funcname,
+ PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv));
+ break;
+ default:
+ len = 0;
+ }
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
+#ifdef USE_C_BACKTRACE
+ if(strchr(pmlenv,'c') && (mlt == MLT_NEW_SV)) {
+ len = my_snprintf(buf, sizeof(buf),
+ " caller %s at %s line %" LINE_Tf "\n",
+ /* CopSTASHPV can crash early on startup; use CopFILE to check */
+ CopFILE(PL_curcop) ? CopSTASHPV(PL_curcop) : "<unknown>",
+ CopFILE(PL_curcop), CopLINE(PL_curcop));
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
+
+ Perl_c_backtrace *bt = Perl_get_c_backtrace(aTHX_ 3, 3);
+ Perl_c_backtrace_frame *frame;
+ UV i;
+ for (i = 0, frame = bt->frame_info;
+ i < bt->header.frame_count;
+ i++, frame++) {
+ len = my_snprintf(buf, sizeof(buf),
+ " frame[%" UVuf "]: %p %s at %s +0x%lx\n",
+ i,
+ frame->addr,
+ frame->symbol_name_size && frame->symbol_name_offset ? (char *)bt + frame->symbol_name_offset : "-",
+ frame->object_name_size && frame->object_name_offset ? (char *)bt + frame->object_name_offset : "?",
+ (char *)frame->addr - (char *)frame->object_base_addr);
+ PERL_UNUSED_RESULT(PerlLIO_write(fd, buf, len));
+ }
+ Perl_free_c_backtrace(bt);
+ }
+#endif /* USE_C_BACKTRACE */
+ }
}
}
#endif /* !PERL_MEM_LOG_NOIMPL */
Malloc_t
Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
- Malloc_t newalloc,
- const char *filename, const int linenumber,
- const char *funcname)
+ Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
PERL_ARGS_ASSERT_MEM_LOG_ALLOC;
mem_log_common_if(MLT_ALLOC, n, typesize, type_name,
- NULL, NULL, newalloc,
- filename, linenumber, funcname);
+ NULL, NULL, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
- Malloc_t oldalloc, Malloc_t newalloc,
- const char *filename, const int linenumber,
- const char *funcname)
+ Malloc_t oldalloc, Malloc_t newalloc,
+ const char *filename, const int linenumber,
+ const char *funcname)
{
PERL_ARGS_ASSERT_MEM_LOG_REALLOC;
mem_log_common_if(MLT_REALLOC, n, typesize, type_name,
- NULL, oldalloc, newalloc,
- filename, linenumber, funcname);
+ NULL, oldalloc, newalloc,
+ filename, linenumber, funcname);
return newalloc;
}
Malloc_t
Perl_mem_log_free(Malloc_t oldalloc,
- const char *filename, const int linenumber,
- const char *funcname)
+ const char *filename, const int linenumber,
+ const char *funcname)
{
PERL_ARGS_ASSERT_MEM_LOG_FREE;
mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
- filename, linenumber, funcname);
+ filename, linenumber, funcname);
return oldalloc;
}
void
Perl_mem_log_new_sv(const SV *sv,
- const char *filename, const int linenumber,
- const char *funcname)
+ const char *filename, const int linenumber,
+ const char *funcname)
{
+ PERL_ARGS_ASSERT_MEM_LOG_NEW_SV;
+
mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL,
- filename, linenumber, funcname);
+ filename, linenumber, funcname);
}
void
Perl_mem_log_del_sv(const SV *sv,
- const char *filename, const int linenumber,
- const char *funcname)
+ const char *filename, const int linenumber,
+ const char *funcname)
{
+ PERL_ARGS_ASSERT_MEM_LOG_DEL_SV;
+
mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL,
- filename, linenumber, funcname);
+ filename, linenumber, funcname);
}
#endif /* PERL_MEM_LOG */
/*
+=for apidoc_section $string
=for apidoc quadmath_format_valid
C<quadmath_snprintf()> is very strict about its C<format> string and will
=cut
*/
+
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
int retval = -1;
va_list ap;
+ dTHX;
+
PERL_ARGS_ASSERT_MY_SNPRINTF;
#ifndef HAS_VSNPRINTF
PERL_UNUSED_VAR(len);
#ifdef USE_QUADMATH
{
bool quadmath_valid = FALSE;
+
if (quadmath_format_valid(format)) {
/* If the format looked promising, use it as quadmath. */
- retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
+ );
if (retval == -1) {
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
}
}
#endif
- if (retval == -1)
+ if (retval == -1) {
+
#ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsnprintf(buffer, len, format, ap);
+ );
#else
- retval = vsprintf(buffer, format, ap);
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsprintf(buffer, format, ap);
+ );
#endif
+
+ }
+
va_end(ap);
/* vsprintf() shows failure with < 0 */
if (retval < 0
(len > 0 && (Size_t)retval >= len)
#endif
)
- Perl_croak_nocontext("panic: my_snprintf buffer overflow");
+ Perl_croak_nocontext("panic: my_snprintf buffer overflow");
return retval;
}
=cut
*/
+
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
return 0;
#else
int retval;
-#ifdef NEED_VA_COPY
+ dTHX;
+
+# ifdef NEED_VA_COPY
va_list apc;
PERL_ARGS_ASSERT_MY_VSNPRINTF;
Perl_va_copy(ap, apc);
-# ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, apc);
-# else
+# ifdef HAS_VSNPRINTF
+
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsnprintf(buffer, len, format, apc);
+ );
+# else
PERL_UNUSED_ARG(len);
- retval = vsprintf(buffer, format, apc);
-# endif
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsprintf(buffer, format, apc);
+ );
+# endif
+
va_end(apc);
-#else
-# ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
-# else
+# else
+# ifdef HAS_VSNPRINTF
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsnprintf(buffer, len, format, ap);
+ );
+# else
PERL_UNUSED_ARG(len);
- retval = vsprintf(buffer, format, ap);
-# endif
-#endif /* #ifdef NEED_VA_COPY */
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ retval = vsprintf(buffer, format, ap);
+ );
+# endif
+# endif /* #ifdef NEED_VA_COPY */
+
/* vsprintf() shows failure with < 0 */
if (retval < 0
-#ifdef HAS_VSNPRINTF
+# ifdef HAS_VSNPRINTF
/* vsnprintf() shows failure with >= len */
||
(len > 0 && (Size_t)retval >= len)
-#endif
+# endif
)
- Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
+ Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
+
return retval;
#endif
}
void
Perl_my_clearenv(pTHX)
{
-#if ! defined(PERL_MICRO)
# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
PerlEnv_clearenv();
# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
# if defined(USE_ITHREADS)
/* only the parent thread can clobber the process environment, so no need
* to use a mutex */
- if (PL_curinterp == aTHX)
+ if (PL_curinterp != aTHX)
+ return;
# endif /* USE_ITHREADS */
- {
-# if ! defined(PERL_USE_SAFE_PUTENV)
- if ( !PL_use_safe_putenv) {
- I32 i;
- if (environ == PL_origenviron)
- environ = (char**)safesysmalloc(sizeof(char*));
- else
- for (i = 0; environ[i]; i++)
- (void)safesysfree(environ[i]);
- }
- environ[0] = NULL;
-# else /* PERL_USE_SAFE_PUTENV */
-# if defined(HAS_CLEARENV)
- (void)clearenv();
-# elif defined(HAS_UNSETENV)
+# if defined(HAS_CLEARENV)
+ clearenv();
+# elif defined(HAS_UNSETENV)
int bsiz = 80; /* Most envvar names will be shorter than this. */
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(bsiz);
- }
- memcpy(buf, *environ, l);
- buf[l] = '\0';
- (void)unsetenv(buf);
- }
- (void)safesysfree(buf);
-# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
+ char *e = strchr(*environ, '=');
+ int l = e ? e - *environ : (int)strlen(*environ);
+ if (bsiz < l + 1) {
+ safesysfree(buf);
+ bsiz = l + 1; /* + 1 for the \0. */
+ buf = (char*)safesysmalloc(bsiz);
+ }
+ memcpy(buf, *environ, l);
+ buf[l] = '\0';
+ unsetenv(buf);
+ }
+ safesysfree(buf);
+# else /* ! HAS_CLEARENV && ! HAS_UNSETENV */
/* Just null environ and accept the leakage. */
*environ = NULL;
-# endif /* HAS_CLEARENV || HAS_UNSETENV */
-# endif /* ! PERL_USE_SAFE_PUTENV */
- }
+# endif /* HAS_CLEARENV || HAS_UNSETENV */
# endif /* USE_ENVIRON_ARRAY */
# endif /* PERL_IMPLICIT_SYS || WIN32 */
-#endif /* PERL_MICRO */
}
-#ifdef PERL_IMPLICIT_CONTEXT
+#ifdef MULTIPLICITY
+
+/*
+=for apidoc my_cxt_init
+
+Implements the L<perlxs/C<MY_CXT_INIT>> macro, which you should use instead.
+The first time a module is loaded, the global C<PL_my_cxt_index> is incremented,
+and that value is assigned to that module's static C<my_cxt_index> (whose
+address is passed as an arg). Then, for each interpreter this function is
+called for, it makes sure a C<void*> slot is available to hang the static data
+off, by allocating or extending the interpreter's C<PL_my_cxt_list> array
-/* Implements the MY_CXT_INIT macro. The first time a module is loaded,
-the global PL_my_cxt_index is incremented, and that value is assigned to
-that module's static my_cxt_index (who's address is passed as an arg).
-Then, for each interpreter this function is called for, it makes sure a
-void* slot is available to hang the static data off, by allocating or
-extending the interpreter's PL_my_cxt_list array */
+=cut
+*/
void *
Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
* other: already allocated by another thread
*/
if (index == -1) {
- MUTEX_LOCK(&PL_my_ctx_mutex);
+ MUTEX_LOCK(&PL_my_ctx_mutex);
/*now a stricter check with locking */
index = *indexp;
if (index == -1)
/* this module hasn't been allocated an index yet */
*indexp = PL_my_cxt_index++;
index = *indexp;
- MUTEX_UNLOCK(&PL_my_ctx_mutex);
+ MUTEX_UNLOCK(&PL_my_ctx_mutex);
}
/* make sure the array is big enough */
if (PL_my_cxt_size <= index) {
- if (PL_my_cxt_size) {
+ if (PL_my_cxt_size) {
IV new_size = PL_my_cxt_size;
- while (new_size <= index)
- new_size *= 2;
- Renew(PL_my_cxt_list, new_size, void *);
+ while (new_size <= index)
+ new_size *= 2;
+ Renew(PL_my_cxt_list, new_size, void *);
PL_my_cxt_size = new_size;
- }
- else {
- PL_my_cxt_size = 16;
- Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
- }
+ }
+ else {
+ PL_my_cxt_size = 16;
+ Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
+ }
}
/* newSV() allocates one more than needed */
p = (void*)SvPVX(newSV(size-1));
return p;
}
-#endif /* PERL_IMPLICIT_CONTEXT */
+#endif /* MULTIPLICITY */
/* Perl_xs_handshake():
'file' is the source filename of the caller.
*/
-I32
+Stack_off_t
Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
{
va_list args;
- U32 items, ax;
+ Stack_off_t items;
+ Stack_off_t ax;
void * got;
void * need;
-#ifdef PERL_IMPLICIT_CONTEXT
+ const char *stage = "first";
+#ifdef MULTIPLICITY
dTHX;
tTHX xs_interp;
#else
got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
if (UNLIKELY(got != need))
- goto bad_handshake;
+ 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
+#ifdef MULTIPLICITY
xs_interp = (tTHX)v_my_perl;
got = xs_interp;
need = my_perl;
got = xs_spp;
need = &PL_stack_sp;
#endif
+ stage = "second";
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);
+ bad_handshake:/* recycle branch and string from above */
+ if(got != (void *)HSf_NOCHK)
+ noperl_die("%s: loadable library and perl binaries are mismatched"
+ " (got %s handshake key %p, needed %p)\n",
+ file, stage, got, need);
}
if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
- SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
- PL_xsubfilename = file; /* so the old name must be restored for
- additional XSUBs to register themselves */
- /* XSUBs can't be perl lang/perl5db.pl debugged
- if (PERLDB_LINE_OR_SAVESRC)
- (void)gv_fetchfile(file); */
+ SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+ PL_xsubfilename = file; /* so the old name must be restored for
+ additional XSUBs to register themselves */
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
}
if(key & HSf_POPMARK) {
- ax = POPMARK;
- { SV **mark = PL_stack_base + ax++;
- { dSP;
- items = (I32)(SP - MARK);
- }
- }
+ ax = POPMARK;
+ { SV **mark = PL_stack_base + ax++;
+ { dSP;
+ items = (Stack_off_t)(SP - MARK);
+ }
+ }
} else {
- items = va_arg(args, U32);
- ax = va_arg(args, U32);
+ items = va_arg(args, Stack_off_t);
+ ax = va_arg(args, Stack_off_t);
}
+ assert(ax >= 0);
+ assert(items >= 0);
{
- 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 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);
+ U32 xsverlen = HS_GETXSVERLEN(key);
+ assert(xsverlen <= UCHAR_MAX && xsverlen <= HS_APIVERLEN_MAX);
+ if(xsverlen)
+ 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)
+S_xs_version_bootcheck(pTHX_ SSize_t items, SSize_t ax, const char *xs_p,
+ STRLEN xs_len)
{
SV *sv;
const char *vn = NULL;
PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
if (items >= 2) /* version supplied as bootstrap arg */
- sv = PL_stack_base[ax + 1];
+ sv = PL_stack_base[ax + 1];
else {
- /* XXX GV_ADDWARN */
- vn = "XS_VERSION";
- 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", SVfARG(module), vn), 0);
- }
+ /* XXX GV_ADDWARN */
+ vn = "XS_VERSION";
+ 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", SVfARG(module), vn), 0);
+ }
}
if (sv) {
- SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
- 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 ", SVfARG(module), SVfARG(string));
-
- SvREFCNT_dec(string);
- string = vstringify(pmsv);
-
- if (vn) {
- Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
- SVfARG(string));
- } else {
- Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
- }
- SvREFCNT_dec(string);
-
- Perl_sv_2mortal(aTHX_ xpt);
- Perl_croak_sv(aTHX_ xpt);
- }
- }
-}
-
-/*
-=for apidoc my_strlcat
-
-The C library C<strlcat> if available, or a Perl implementation of it.
-This operates on C C<NUL>-terminated strings.
-
-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).
-
-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>.
-
-The return value is the total length that C<dst> would have if C<size> is
-sufficiently large. Thus it is the initial length of C<dst> plus the length of
-C<src>. If C<size> is smaller than the return, the excess was not appended.
-
-=cut
-
-Description stolen from http://man.openbsd.org/strlcat.3
-*/
-#ifndef HAS_STRLCAT
-Size_t
-Perl_my_strlcat(char *dst, const char *src, Size_t size)
-{
- Size_t used, length, copy;
-
- used = strlen(dst);
- length = strlen(src);
- if (size > 0 && used < size - 1) {
- copy = (length >= size - used) ? size - used - 1 : length;
- memcpy(dst + used, src, copy);
- dst[used + copy] = '\0';
- }
- return used + length;
-}
-#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.
-
-The return value is the total length C<src> would be if the copy completely
-succeeded. If it is larger than C<size>, the excess was not copied.
-
-=cut
-
-Description stolen from http://man.openbsd.org/strlcpy.3
-*/
-#ifndef HAS_STRLCPY
-Size_t
-Perl_my_strlcpy(char *dst, const char *src, Size_t size)
-{
- Size_t length, copy;
+ SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
+ 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 ", SVfARG(module), SVfARG(string));
+
+ SvREFCNT_dec(string);
+ string = vstringify(pmsv);
+
+ if (vn) {
+ Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
+ SVfARG(string));
+ } else {
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
+ }
+ SvREFCNT_dec(string);
- length = strlen(src);
- if (size > 0) {
- copy = (length >= size) ? size - 1 : length;
- memcpy(dst, src, copy);
- dst[copy] = '\0';
+ Perl_sv_2mortal(aTHX_ xpt);
+ Perl_croak_sv(aTHX_ xpt);
+ }
}
- return length;
}
-#endif
-
-#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500)
-/* VC7 or 7.1, building with pre-VC7 runtime libraries. */
-long _ftol( double ); /* Defined by VC6 C libs. */
-long _ftol2( double dblSource ) { return _ftol( dblSource ); }
-#endif
PERL_STATIC_INLINE bool
S_gv_has_usable_name(pTHX_ GV *gv)
{
GV **gvp;
return GvSTASH(gv)
- && HvENAME(GvSTASH(gv))
- && (gvp = (GV **)hv_fetchhek(
- GvSTASH(gv), GvNAME_HEK(gv), 0
- ))
- && *gvp == gv;
+ && HvHasENAME(GvSTASH(gv))
+ && (gvp = (GV **)hv_fetchhek(
+ GvSTASH(gv), GvNAME_HEK(gv), 0
+ ))
+ && *gvp == gv;
}
void
TAINT_set(FALSE);
save_item(dbsv);
if (!PERLDB_SUB_NN) {
- GV *gv = CvGV(cv);
-
- if (!svp && !CvLEXICAL(cv)) {
- gv_efullname3(dbsv, gv, NULL);
- }
- else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
- || strEQ(GvNAME(gv), "END")
- || ( /* Could be imported, and old sub redefined. */
- (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
- &&
- !( (SvTYPE(*svp) == SVt_PVGV)
- && (GvCV((const GV *)*svp) == cv)
- /* Use GV from the stack as a fallback. */
- && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
- )
- )
- ) {
- /* GV is potentially non-unique, or contain different CV. */
- SV * const tmp = newRV(MUTABLE_SV(cv));
- sv_setsv(dbsv, tmp);
- SvREFCNT_dec(tmp);
- }
- else {
- sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
- sv_catpvs(dbsv, "::");
- sv_cathek(dbsv, GvNAME_HEK(gv));
- }
+ GV *gv = CvGV(cv);
+
+ if (!svp && !CvLEXICAL(cv)) {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || CvLEXICAL(cv)
+ || strEQ(GvNAME(gv), "END")
+ || ( /* Could be imported, and old sub redefined. */
+ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+ &&
+ !( (SvTYPE(*svp) == SVt_PVGV)
+ && (GvCV((const GV *)*svp) == cv)
+ /* Use GV from the stack as a fallback. */
+ && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp)
+ )
+ )
+ ) {
+ /* GV is potentially non-unique, or contain different CV. */
+ SV * const tmp = newRV(MUTABLE_SV(cv));
+ sv_setsv(dbsv, tmp);
+ SvREFCNT_dec(tmp);
+ }
+ else {
+ sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+ sv_catpvs(dbsv, "::");
+ sv_cathek(dbsv, GvNAME_HEK(gv));
+ }
}
else {
- const int type = SvTYPE(dbsv);
- if (type < SVt_PVIV && type != SVt_IV)
- sv_upgrade(dbsv, SVt_PVIV);
- (void)SvIOK_on(dbsv);
- SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
+ const int type = SvTYPE(dbsv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(dbsv, SVt_PVIV);
+ (void)SvIOK_on(dbsv);
+ SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
SvSETMAGIC(dbsv);
TAINT_IF(save_taint);
#endif
}
+/*
+=for apidoc_section $io
+=for apidoc my_dirfd
+
+The C library C<L<dirfd(3)>> if available, or a Perl implementation of it, or die
+if not easily emulatable.
+
+=cut
+*/
+
int
Perl_my_dirfd(DIR * dir) {
#endif
#ifndef HAS_MKOSTEMP
+
+/*
+=for apidoc my_mkostemp
+
+The C library C<L<mkostemp(3)>> if available, or a Perl implementation of it.
+
+=cut
+*/
+
int
Perl_my_mkostemp(char *templte, int flags)
{
#endif
#ifndef HAS_MKSTEMP
+
+/*
+=for apidoc my_mkstemp
+
+The C library C<L<mkstemp(3)>> if available, or a Perl implementation of it.
+
+=cut
+*/
+
int
Perl_my_mkstemp(char *templte)
{
if (SvMAGICAL(sv))
mg_get(sv);
if (SvROK(sv))
- sv = MUTABLE_SV(SvRV(sv));
+ sv = MUTABLE_SV(SvRV(sv));
if (SvTYPE(sv) == SVt_REGEXP)
return (REGEXP*) sv;
}
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. */
+ /* bfd_text is handle to 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,
return;
}
}
- cnt = snprintf(cmd, sizeof(cmd), ctx->format,
- ctx->fname, ctx->object_base_addr, raw_frame);
+
+ dTHX;
+ WITH_LC_NUMERIC_SET_TO_NEEDED(
+ 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
#endif /* #ifdef PERL_DARWIN */
/*
+=for apidoc_section $debugging
=for apidoc get_c_backtrace
Collects the backtrace (aka "stacktrace") into a single linear
/*
=for apidoc free_c_backtrace
-Deallocates a backtrace received from get_c_bracktrace.
+Deallocates a backtrace received from get_c_backtrace.
=cut
*/
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
-...
+ ...
+ 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
#endif /* #ifdef USE_C_BACKTRACE */
-#ifdef PERL_TSA_ACTIVE
+#if defined(USE_ITHREADS) && defined(I_PTHREAD)
/* pthread_mutex_t and perl_mutex are typedef equivalent
* so casting the pointers is fine. */
#endif
-
#ifdef USE_DTRACE
/* log a sub call or return */
PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
if (is_loading) {
- PERL_LOADING_FILE(name);
+ PERL_LOADING_FILE(name);
}
else {
- PERL_LOADED_FILE(name);
+ PERL_LOADED_FILE(name);
}
}
https://perl5.git.perl.org / perl5.git / blobdiff