int putenv(char *);
#endif
+#ifdef __amigaos__
+# include "amigaos4/amigaio.h"
+#endif
+
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
dTHX;
#endif
Malloc_t ptr;
+
+#ifdef USE_MDH
+ if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
+ goto out_of_memory;
size += PERL_MEMORY_DEBUG_HEADER_SIZE;
+#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
+ Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size);
#endif
if (!size) size = 1; /* malloc(0) is NASTY on our system */
#ifdef PERL_DEBUG_READONLY_COW
#ifdef MDH_HAS_SIZE
header->size = size;
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
- return ptr;
-}
+ 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));
+
+ }
else {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- else {
- croak_no_mem();
- }
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
- /*NOTREACHED*/
+ return ptr;
}
/* paranoid version of system's realloc() */
if (!size) {
safesysfree(where);
- return NULL;
+ ptr = NULL;
}
-
- if (!where)
- return safesysmalloc(size);
+ else if (!where) {
+ ptr = safesysmalloc(size);
+ }
+ else {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
- size += PERL_MEMORY_DEBUG_HEADER_SIZE;
- {
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
+ goto out_of_memory;
+ size += PERL_MEMORY_DEBUG_HEADER_SIZE;
+ {
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)where;
# ifdef PERL_TRACK_MEMPOOL
- if (header->interpreter != aTHX) {
- Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
- header->interpreter, aTHX);
- }
- assert(header->next->prev == header);
- assert(header->prev->next == header);
+ if (header->interpreter != aTHX) {
+ Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+ header->interpreter, aTHX);
+ }
+ assert(header->next->prev == header);
+ assert(header->prev->next == header);
# ifdef PERL_POISON
- if (header->size > size) {
- const MEM_SIZE freed_up = header->size - size;
- char *start_of_freed = ((char *)where) + size;
- PoisonFree(start_of_freed, freed_up, char);
- }
+ if (header->size > size) {
+ const MEM_SIZE freed_up = header->size - size;
+ char *start_of_freed = ((char *)where) + size;
+ PoisonFree(start_of_freed, freed_up, char);
+ }
# endif
# endif
# ifdef MDH_HAS_SIZE
- header->size = size;
+ header->size = size;
# endif
- }
+ }
#endif
#ifdef DEBUGGING
- if ((SSize_t)size < 0)
- Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
+ if ((SSize_t)size < 0)
+ Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size);
#endif
#ifdef PERL_DEBUG_READONLY_COW
- if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
- MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
- perror("mmap failed");
- abort();
- }
- Copy(where,ptr,oldsize < size ? oldsize : size,char);
- if (munmap(where, oldsize)) {
- perror("munmap failed");
- abort();
- }
+ if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ Copy(where,ptr,oldsize < size ? oldsize : size,char);
+ if (munmap(where, oldsize)) {
+ perror("munmap failed");
+ abort();
+ }
#else
- ptr = (Malloc_t)PerlMem_realloc(where,size);
+ ptr = (Malloc_t)PerlMem_realloc(where,size);
#endif
- PERL_ALLOC_CHECK(ptr);
+ PERL_ALLOC_CHECK(ptr);
/* MUST do this fixup first, before doing ANYTHING else, as anything else
might allocate memory/free/move memory, and until we do the fixup, it
may well be chasing (and writing to) free memory. */
- if (ptr != NULL) {
+ if (ptr != NULL) {
#ifdef PERL_TRACK_MEMPOOL
- struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)ptr;
+ struct perl_memory_debug_header *const header
+ = (struct perl_memory_debug_header *)ptr;
# ifdef PERL_POISON
- if (header->size < size) {
- const MEM_SIZE fresh = size - header->size;
- char *start_of_fresh = ((char *)ptr) + size;
- PoisonNew(start_of_fresh, fresh, char);
- }
+ if (header->size < size) {
+ const MEM_SIZE fresh = size - header->size;
+ char *start_of_fresh = ((char *)ptr) + size;
+ PoisonNew(start_of_fresh, fresh, char);
+ }
# endif
- maybe_protect_rw(header->next);
- header->next->prev = header;
- maybe_protect_ro(header->next);
- maybe_protect_rw(header->prev);
- header->prev->next = header;
- maybe_protect_ro(header->prev);
+ maybe_protect_rw(header->next);
+ header->next->prev = header;
+ maybe_protect_ro(header->next);
+ maybe_protect_rw(header->prev);
+ header->prev->next = header;
+ maybe_protect_ro(header->prev);
#endif
- ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
- }
+ ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE);
+ }
/* In particular, must do that fixup above before logging anything via
*printf(), as it can reallocate memory, which can cause SEGVs. */
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
-
- if (ptr != NULL) {
- return ptr;
- }
- else {
+ if (ptr == NULL) {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- return NULL;
- else {
- croak_no_mem();
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
}
- /*NOTREACHED*/
+ return ptr;
}
/* safe version of system's free() */
#ifdef ALWAYS_NEED_THX
dTHX;
#endif
- DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
#ifdef USE_MDH
- where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
{
struct perl_memory_debug_header *const header
- = (struct perl_memory_debug_header *)where;
+ = (struct perl_memory_debug_header *)where_intrn;
# ifdef MDH_HAS_SIZE
const MEM_SIZE size = header->size;
maybe_protect_ro(header->prev);
maybe_protect_rw(header);
# ifdef PERL_POISON
- PoisonNew(where, size, char);
+ PoisonNew(where_intrn, size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
# endif
# ifdef PERL_DEBUG_READONLY_COW
- if (munmap(where, size)) {
+ if (munmap(where_intrn, size)) {
perror("munmap failed");
abort();
}
# endif
}
-#endif
+#else
+ Malloc_t where_intrn = where;
+#endif /* USE_MDH */
#ifndef PERL_DEBUG_READONLY_COW
- PerlMem_free(where);
+ PerlMem_free(where_intrn);
#endif
}
}
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
- Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+ Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf,
(UV)size, (UV)count);
#endif
#ifdef PERL_DEBUG_READONLY_COW
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 %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
if (ptr != NULL) {
#ifdef USE_MDH
{
#endif
-/* copy a string up to some (non-backslashed) delimiter, if any */
+/* 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.
+ */
-char *
-Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+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;
PERL_ARGS_ASSERT_DELIMCPY;
for (tolen = 0; from < fromend; from++, tolen++) {
- if (*from == '\\') {
+ if (allow_escape && *from == '\\' && from + 1 < fromend) {
if (from[1] != delim) {
if (to < toend)
*to++ = *from;
return (char *)from;
}
-/* return ptr to little string in big string, NULL if not found */
-/* This routine was donated by Corey Satten. */
-
char *
-Perl_instr(const char *big, const char *little)
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
{
+ PERL_ARGS_ASSERT_DELIMCPY;
- PERL_ARGS_ASSERT_INSTR;
+ return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
+}
- /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
- * 'little' */
- if (!little)
- return (char*)big;
- return strstr((char*)big, (char*)little);
+char *
+Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
+ const char *fromend, int delim, I32 *retlen)
+{
+ PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
+
+ return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
}
-/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
- * the final character desired to be checked */
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
+
+Find the first (leftmost) occurrence of a sequence of bytes within another
+sequence. This is the Perl version of C<strstr()>, extended to handle
+arbitrary sequences, potentially containing embedded C<NUL> characters (C<NUL>
+is what the initial C<n> in the function name stands for; some systems have an
+equivalent, C<memmem()>, but with a somewhat different API).
+
+Another way of thinking about this function is finding a needle in a haystack.
+C<big> points to the first byte in the haystack. C<big_end> points to one byte
+beyond the final byte in the haystack. C<little> points to the first byte in
+the needle. C<little_end> points to one byte beyond the final byte in the
+needle. All the parameters must be non-C<NULL>.
+
+The function returns C<NULL> if there is no occurrence of C<little> within
+C<big>. If C<little> is the empty string, C<big> is returned.
+
+Because this function operates at the byte level, and because of the inherent
+characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the
+needle and the haystack are strings with the same UTF-8ness, but not if the
+UTF-8ness differs.
+
+=cut
+
+*/
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
PERL_ARGS_ASSERT_NINSTR;
+
+#ifdef HAS_MEMMEM
+ return ninstr(big, bigend, little, lend);
+#else
+
if (little >= lend)
return (char*)big;
{
}
}
return NULL;
+
+#endif
+
}
-/* reverse of the above--find last substring */
+/*
+=head1 Miscellaneous Functions
+
+=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
+
+Like C<L</ninstr>>, but instead finds the final (rightmost) occurrence of a
+sequence of bytes within another sequence, returning C<NULL> if there is no
+such occurrence.
+
+=cut
+
+*/
char *
Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend)
=for apidoc fbm_compile
-Analyses the string in order to make fast searches on it using fbm_instr()
+Analyses the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.
=cut
SvUPGRADE(sv, SVt_PVMG);
SvIOK_off(sv);
SvNOK_off(sv);
- SvVALID_on(sv);
-
- /* "deep magic", the comment used to add. The use of MAGIC itself isn't
- really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2)
- to call SvVALID_off() if the scalar was assigned to.
-
- The comment itself (and "deeper magic" below) date back to
- 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on
- str->str_pok |= 2;
- where the magic (presumably) was that the scalar had a BM table hidden
- inside itself.
- As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store
- the table instead of the previous (somewhat hacky) approach of co-opting
- the string buffer and storing it after the string. */
+ /* add PERL_MAGIC_bm magic holding the FBM lookup table */
assert(!mg_find(sv, PERL_MAGIC_bm));
mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0);
}
}
BmUSEFUL(sv) = 100; /* Initial value */
- if (flags & FBMcf_TAIL)
- SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n",
+ ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL);
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n",
s[rarest], (UV)rarest));
}
-/* If SvTAIL(littlestr), it has a fake '\n' at end. */
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if multiline */
/*
=for apidoc fbm_instr
Returns the location of the SV in the string delimited by C<big> and
-C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
-does not have to be fbm_compiled, but the search will not be as fast
+C<bigend> (C<bigend>) is the char following the last char).
+It returns C<NULL> if the string can't be found. The C<sv>
+does not have to be C<fbm_compiled>, but the search will not be as fast
then.
=cut
+
+If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
+during FBM compilation due to FBMcf_TAIL in flags. It indicates that
+the littlestr must be anchored to the end of bigstr (or to any \n if
+FBMrf_MULTILINE).
+
+E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
+while /abc$/ compiles to "abc\n" with SvTAIL() true.
+
+A littlestr of "abc", !SvTAIL matches as /abc/;
+a littlestr of "ab\n", SvTAIL matches as:
+ without FBMrf_MULTILINE: /ab\n?\z/
+ with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
+
+(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
+ "If SvTAIL is actually due to \Z or \z, this gives false positives
+ if multiline".
*/
+
char *
Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
{
const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l);
STRLEN littlelen = l;
const I32 multiline = flags & FBMrf_MULTILINE;
+ bool valid = SvVALID(littlestr);
+ bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE;
PERL_ARGS_ASSERT_FBM_INSTR;
if ((STRLEN)(bigend - big) < littlelen) {
- if ( SvTAIL(littlestr)
+ if ( tail
&& ((STRLEN)(bigend - big) == littlelen - 1)
&& (littlelen == 1
|| (*big == *little &&
switch (littlelen) { /* Special cases for 0, 1 and 2 */
case 0:
return (char*)big; /* Cannot be SvTAIL! */
+
case 1:
- if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
- /* Know that bigend != big. */
- if (bigend[-1] == '\n')
- return (char *)(bigend - 1);
- return (char *) bigend;
- }
- s = big;
- while (s < bigend) {
- if (*s == *little)
- return (char *)s;
- s++;
- }
- if (SvTAIL(littlestr))
+ 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);
+ if (s)
+ return (char *)s;
+ if (tail)
return (char *) bigend;
return NULL;
+
case 2:
- if (SvTAIL(littlestr) && !multiline) {
- if (bigend[-1] == '\n' && bigend[-2] == *little)
+ 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;
}
+
{
- /* This should be better than FBM if c1 == c2, and almost
- as good otherwise: maybe better since we do less indirection.
- And we save a lot of memory by caching no table. */
- const unsigned char c1 = little[0];
- const unsigned char c2 = little[1];
-
- s = big + 1;
- bigend--;
- if (c1 != c2) {
- while (s <= bigend) {
- if (s[0] == c2) {
- if (s[-1] == c1)
- return (char*)s - 1;
- s += 2;
- continue;
- }
- next_chars:
- if (s[0] == c1) {
- if (s == bigend)
- goto check_1char_anchor;
- if (s[1] == c2)
- return (char*)s;
- else {
- s++;
- goto next_chars;
- }
- }
- else
- s += 2;
- }
- goto check_1char_anchor;
- }
- /* Now c1 == c2 */
- while (s <= bigend) {
- if (s[0] == c1) {
- if (s[-1] == c1)
- return (char*)s - 1;
- if (s == bigend)
- goto check_1char_anchor;
- if (s[1] == c1)
- return (char*)s;
- s += 3;
- }
- else
- s += 2;
- }
- }
- check_1char_anchor: /* One char and anchor! */
- if (SvTAIL(littlestr) && (*bigend == *little))
- return (char *)bigend; /* bigend is already decremented. */
- return NULL;
+ /* memchr() is likely to be very fast, possibly using whatever
+ * hardware support is available, such as checking a whole
+ * cache line in one instruction.
+ * So for a 2 char pattern, calling memchr() is likely to be
+ * faster than running FBM, or rolling our own. The previous
+ * version of this code was roll-your-own which typically
+ * only needed to read every 2nd char, which was good back in
+ * the day, but no longer.
+ */
+ unsigned char c1 = little[0];
+ unsigned char c2 = little[1];
+
+ /* *** for all this case, bigend points to the last char,
+ * not the trailing \0: this makes the conditions slightly
+ * simpler */
+ bigend--;
+ s = big;
+ if (c1 != c2) {
+ while (s < bigend) {
+ /* do a quick test for c1 before calling memchr();
+ * this avoids the expensive fn call overhead when
+ * there are lots of c1's */
+ if (LIKELY(*s != c1)) {
+ s++;
+ s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+ if (!s)
+ break;
+ }
+ if (s[1] == c2)
+ return (char*)s;
+
+ /* failed; try searching for c2 this time; that way
+ * we don't go pathologically slow when the string
+ * consists mostly of c1's or vice versa.
+ */
+ s += 2;
+ if (s > bigend)
+ break;
+ s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
+ if (!s)
+ break;
+ if (s[-1] == c1)
+ return (char*)s - 1;
+ }
+ }
+ else {
+ /* c1, c2 the same */
+ while (s < bigend) {
+ if (s[0] == c1) {
+ got_1char:
+ if (s[1] == c1)
+ return (char*)s;
+ s += 2;
+ }
+ else {
+ s++;
+ s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+ if (!s || s >= bigend)
+ break;
+ goto got_1char;
+ }
+ }
+ }
+
+ /* failed to find 2 chars; try anchored match at end without
+ * the \n */
+ if (tail && bigend[0] == little[0])
+ return (char *)bigend;
+ return NULL;
+ }
+
default:
break; /* Only lengths 0 1 and 2 have special-case code. */
}
- if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
+ if (tail && !multiline) { /* tail anchored? */
s = bigend - littlelen;
if (s >= big && bigend[-1] == '\n' && *s == *little
/* Automatically of length > 2 */
}
return NULL;
}
- if (!SvVALID(littlestr)) {
+
+ if (!valid) {
+ /* not compiled; use Perl_ninstr() instead */
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
- if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */
- /* Chop \n from littlestr: */
- s = bigend - littlelen + 1;
- if (*s == *little
- && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
- {
- return (char*)s;
- }
- return NULL;
- }
+ assert(!tail); /* valid => FBM; tail only set on SvVALID SVs */
return b;
}
oldlittle = little;
if (s < bigend) {
const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+ const unsigned char lastc = *little;
I32 tmp;
top2:
if ((tmp = table[*s])) {
- if ((s += tmp) < bigend)
- goto top2;
- goto check_end;
+ /* *s != lastc; earliest position it could match now is
+ * tmp slots further on */
+ if ((s += tmp) >= bigend)
+ goto check_end;
+ if (LIKELY(*s != lastc)) {
+ s++;
+ s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
+ if (!s) {
+ s = bigend;
+ goto check_end;
+ }
+ goto top2;
+ }
}
- else { /* less expensive than calling strncmp() */
+
+
+ /* hand-rolled strncmp(): less expensive than calling the
+ * real function (maybe???) */
+ {
unsigned char * const olds = s;
tmp = littlelen;
}
check_end:
if ( s == bigend
- && SvTAIL(littlestr)
+ && tail
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
}
}
-char *
-Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
-{
- PERL_ARGS_ASSERT_SCREAMINSTR;
- PERL_UNUSED_ARG(bigstr);
- PERL_UNUSED_ARG(littlestr);
- PERL_UNUSED_ARG(start_shift);
- PERL_UNUSED_ARG(end_shift);
- PERL_UNUSED_ARG(old_posp);
- PERL_UNUSED_ARG(last);
-
- /* This function must only ever be called on a scalar with study magic,
- but those do not happen any more. */
- Perl_croak(aTHX_ "panic: screaminstr");
- NORETURN_FUNCTION_END;
-}
/*
=for apidoc foldEQ
-Returns true if the leading len bytes of the strings s1 and s2 are the same
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same
case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
match themselves and their opposite case counterparts. Non-cased and non-ASCII
range bytes match only themselves.
/*
=for apidoc foldEQ_locale
-Returns true if the leading len bytes of the strings s1 and s2 are the same
-case-insensitively in the current locale; false otherwise.
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same case-insensitively in the current locale; false otherwise.
=cut
*/
=for apidoc savesharedpvn
A version of C<savepvn()> which allocates the duplicate string in memory
-which is shared between threads. (With the specific difference that a NULL
+which is shared between threads. (With the specific difference that a C<NULL>
pointer is not acceptable)
=cut
if (o->op_flags & OPf_KIDS) {
const OP *kid;
- for (kid = cUNOPo->op_first; kid; kid = OP_SIBLING(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
#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
{
char *ws;
- int wi;
+ UV wi;
/* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
- if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) &&
- (wi = grok_atou(ws, NULL)) > 0) {
- Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1);
+ if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
+ && grok_atoUV(ws, &wi, NULL)
+ && wi <= PERL_INT_MAX
+ ) {
+ Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
}
}
#endif
* from the sibling of PL_curcop.
*/
- const COP *cop =
- closest_cop(PL_curcop, OP_SIBLING(PL_curcop), PL_op, FALSE);
- if (!cop)
- cop = PL_curcop;
+ if (PL_curcop) {
+ const COP *cop =
+ closest_cop(PL_curcop, OpSIBLING(PL_curcop), PL_op, FALSE);
+ if (!cop)
+ cop = PL_curcop;
+
+ if (CopLINE(cop))
+ Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf,
+ OutCopFILE(cop), (IV)CopLINE(cop));
+ }
- if (CopLINE(cop))
- Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
- OutCopFILE(cop), (IV)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,
+ 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)))),
=for apidoc Am|SV *|vmess|const char *pat|va_list *args
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
+argument list, respectively. These are used to generate a string message. If
+the
message does not end with a newline, then it will be extended with
some indication of the current location in the code, as described for
L</mess_sv>.
=cut
*/
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
PERL_ARGS_ASSERT_DIE_SV;
croak_sv(baseex);
- assert(0); /* NOTREACHED */
+ /* NOTREACHED */
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|OP *|die|const char *pat|...
*/
#if defined(PERL_IMPLICIT_CONTEXT)
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die_nocontext(const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
#endif /* PERL_IMPLICIT_CONTEXT */
+#ifdef _MSC_VER
+# pragma warning( push )
+# pragma warning( disable : 4646 ) /* warning C4646: function declared with
+ __declspec(noreturn) has non-void return type */
+# pragma warning( disable : 4645 ) /* warning C4645: function declared with
+__declspec(noreturn) has a return statement */
+#endif
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
NORETURN_FUNCTION_END;
}
+#ifdef _MSC_VER
+# pragma warning( pop )
+#endif
/*
=for apidoc Am|void|croak_sv|SV *baseex
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
#endif /* PERL_IMPLICIT_CONTEXT */
va_list args;
va_start(args, pat);
vcroak(pat, &args);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
va_end(args);
}
{
dVAR;
PERL_ARGS_ASSERT_VWARNER;
- if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
+ if (
+ (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
+ !(PL_in_eval & EVAL_KEEPERR)
+ ) {
SV * const msv = vmess(pat, args);
- invoke_exception_hook(msv, FALSE);
- die_unwind(msv);
+ if (PL_parser && PL_parser->error_count) {
+ qerror(msv);
+ }
+ else {
+ invoke_exception_hook(msv, FALSE);
+ die_unwind(msv);
+ }
}
else {
Perl_vwarn(aTHX_ pat, args);
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
+#ifdef __amigaos4__
+ amigaos4_obtain_environ(__FUNCTION__);
+#endif
#ifdef USE_ITHREADS
/* only parent thread can modify process environment */
if (PL_curinterp == aTHX)
environ[i] = environ[i+1];
i++;
}
+#ifdef __amigaos4__
+ goto my_setenv_out;
+#else
return;
+#endif
}
if (!environ[i]) { /* does not exist yet */
environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
*/
-# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
}
#endif
}
+#ifdef __amigaos4__
+my_setenv_out:
+ amigaos4_release_environ(__FUNCTION__);
+#endif
}
#else /* WIN32 || NETWARE */
}
#endif
-/* this is a drop-in replacement for bcopy() */
-#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
-char *
-Perl_my_bcopy(const char *from, char *to, I32 len)
+/* this is a drop-in replacement for bcopy(), except for the return
+ * value, which we need to be able to emulate memcpy() */
+#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY))
+void *
+Perl_my_bcopy(const void *vfrom, void *vto, size_t len)
{
- char * const retval = to;
+#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
+ bcopy(vfrom, vto, len);
+#else
+ const unsigned char *from = (const unsigned char *)vfrom;
+ unsigned char *to = (unsigned char *)vto;
PERL_ARGS_ASSERT_MY_BCOPY;
- assert(len >= 0);
-
if (from - to >= 0) {
while (len--)
*to++ = *from++;
while (len--)
*(--to) = *(--from);
}
- return retval;
+#endif
+
+ return vto;
}
#endif
/* this is a drop-in replacement for memset() */
#ifndef HAS_MEMSET
void *
-Perl_my_memset(char *loc, I32 ch, I32 len)
+Perl_my_memset(void *vloc, int ch, size_t len)
{
- char * const retval = loc;
+ unsigned char *loc = (unsigned char *)vloc;
PERL_ARGS_ASSERT_MY_MEMSET;
- assert(len >= 0);
-
while (len--)
*loc++ = ch;
- return retval;
+ return vloc;
}
#endif
/* this is a drop-in replacement for bzero() */
#if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
-char *
-Perl_my_bzero(char *loc, I32 len)
+void *
+Perl_my_bzero(void *vloc, size_t len)
{
- char * const retval = loc;
+ unsigned char *loc = (unsigned char *)vloc;
PERL_ARGS_ASSERT_MY_BZERO;
- assert(len >= 0);
-
while (len--)
*loc++ = 0;
- return retval;
+ return vloc;
}
#endif
/* this is a drop-in replacement for memcmp() */
#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
-I32
-Perl_my_memcmp(const char *s1, const char *s2, I32 len)
+int
+Perl_my_memcmp(const void *vs1, const void *vs2, size_t len)
{
- const U8 *a = (const U8 *)s1;
- const U8 *b = (const U8 *)s2;
- I32 tmp;
+ const U8 *a = (const U8 *)vs1;
+ const U8 *b = (const U8 *)vs2;
+ int tmp;
PERL_ARGS_ASSERT_MY_MEMCMP;
- assert(len >= 0);
-
while (len--) {
if ((tmp = *a++ - *b++))
return tmp;
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
int p[2];
I32 This, that;
Pid_t pid;
/* Close parent's end of error status pipe (if any) */
if (did_pipes) {
PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
/* Close error pipe automatically if exec works */
if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
return NULL;
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
-# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+# if defined(OS2) /* Same, without fork()ing and all extra overhead... */
return my_syspopen4(aTHX_ NULL, mode, n, args);
+# elif defined(WIN32)
+ return win32_popenlist(mode, n, args);
# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
#endif
}
- /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+ /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
/* this is called in parent before the fork() */
void
Perl_atfork_lock(void)
+#if defined(USE_ITHREADS)
+# ifdef USE_PERLIO
+ PERL_TSA_ACQUIRE(PL_perlio_mutex)
+# endif
+# ifdef MYMALLOC
+ PERL_TSA_ACQUIRE(PL_malloc_mutex)
+# endif
+ PERL_TSA_ACQUIRE(PL_op_mutex)
+#endif
{
#if defined(USE_ITHREADS)
dVAR;
/* this is called in both parent and child after the fork() */
void
Perl_atfork_unlock(void)
+#if defined(USE_ITHREADS)
+# ifdef USE_PERLIO
+ PERL_TSA_RELEASE(PL_perlio_mutex)
+# endif
+# ifdef MYMALLOC
+ PERL_TSA_RELEASE(PL_malloc_mutex)
+# endif
+ PERL_TSA_RELEASE(PL_op_mutex)
+#endif
{
#if defined(USE_ITHREADS)
dVAR;
pid = fork();
#endif
return pid;
+#elif defined(__amigaos4__)
+ return amigaos_fork();
#else
/* this "canna happen" since nothing should be calling here if !HAS_FORK */
Perl_croak_nocontext("fork() not available");
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
*statusp = SvIVX(sv);
/* The hash iterator is currently on this entry, so simply
calling hv_delete would trigger the lazy delete, which on
- aggregate does more work, beacuse next call to hv_iterinit()
+ aggregate does more work, because next call to hv_iterinit()
would spot the flag, and have to call the delete routine,
while in the meantime any new entries can't re-use that
memory. */
while (deftypes ||
(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
{
+ Stat_t statbuf;
if (deftypes) {
deftypes = 0;
*tmpbuf = '\0';
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (PerlLIO_stat(cur,&PL_statbuf) >= 0
- && !S_ISDIR(PL_statbuf.st_mode)) {
- dosearch = 0;
- scriptname = cur;
+ {
+ Stat_t statbuf;
+ if (PerlLIO_stat(cur,&statbuf) >= 0
+ && !S_ISDIR(statbuf.st_mode)) {
+ dosearch = 0;
+ scriptname = cur;
#ifdef SEARCH_EXTS
- break;
+ break;
#endif
+ }
}
#ifdef SEARCH_EXTS
if (cur == scriptname) {
bufend = s + strlen(s);
while (s < bufend) {
+ Stat_t statbuf;
# ifdef DOSISH
for (len = 0; *s
&& *s != ';'; len++, s++) {
do {
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
- retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
- if (S_ISDIR(PL_statbuf.st_mode)) {
+ retval = PerlLIO_stat(tmpbuf,&statbuf);
+ if (S_ISDIR(statbuf.st_mode)) {
retval = -1;
}
#ifdef SEARCH_EXTS
#endif
if (retval < 0)
continue;
- if (S_ISREG(PL_statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&PL_statbuf)
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf)
#if !defined(DOSISH)
- && cando(S_IXUSR,TRUE,&PL_statbuf)
+ && cando(S_IXUSR,TRUE,&statbuf)
#endif
)
{
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed &&
- (PerlLIO_stat(scriptname,&PL_statbuf) < 0
- || S_ISDIR(PL_statbuf.st_mode)))
+ {
+ Stat_t statbuf;
+ if (!xfound && !seen_dot && !xfailed &&
+ (PerlLIO_stat(scriptname,&statbuf) < 0
+ || S_ISDIR(statbuf.st_mode)))
+#endif
+ seen_dot = 1; /* Disable message. */
+#ifndef DOSISH
+ }
#endif
- seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
/* diag_listed_as: Can't execute %s */
if (name && HEK_LEN(name))
Perl_warner(aTHX_ packWARN(WARN_IO),
- "Filehandle %"HEKf" opened only for %sput",
+ "Filehandle %" HEKf " opened only for %sput",
HEKfARG(name), direction);
else
Perl_warner(aTHX_ packWARN(WARN_IO),
? "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,
+ "%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",
+ "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n",
func, pars, have_name ? " " : "",
SVfARG(have_name ? name : &PL_sv_no)
);
#define SV_CWD_RETURN_UNDEF \
-sv_setsv(sv, &PL_sv_undef); \
-return FALSE
+ sv_set_undef(sv); \
+ return FALSE
#define SV_CWD_ISDOT(dp) \
(dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
=for apidoc getcwd_sv
-Fill the sv with current working directory
+Fill C<sv> with current working directory
=cut
*/
/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
* rewritten again by dougm, optimized for use with xs TARG, and to prefer
* getcwd(3) if available
- * Comments from the orignal:
+ * Comments from the original:
* This is a faster version of getcwd. It's also more dangerous
* because you might chdir out of a directory that you can't chdir
* back into. */
return TRUE;
}
else {
- sv_setsv(sv, &PL_sv_undef);
- return FALSE;
+ SV_CWD_RETURN_UNDEF;
}
}
Dummy routine which "shares" an SV when there is no sharing module present.
Or "locks" it. Or "unlocks" it. In other
words, ignores its single SV argument.
-Exists to avoid test for a NULL function pointer and because it could
+Exists to avoid test for a C<NULL> function pointer and because it could
potentially warn under some level of strict-ness.
=cut
Dummy routine which reports that object can be destroyed when there is no
sharing module present. It ignores its single SV argument, and returns
-'true'. Exists to avoid test for a NULL function pointer and because it
+'true'. Exists to avoid test for a C<NULL> function pointer and because it
could potentially warn under some level of strict-ness.
=cut
if (*p) {
if (isDIGIT(*p)) {
const char* endptr;
- opt = (U32) grok_atou(p, &endptr);
- p = endptr;
- if (*p && *p != '\n' && *p != '\r') {
- if(isSPACE(*p)) goto the_end_of_the_opts_parser;
- else
- Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
- }
- }
- else {
+ UV uv;
+ if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
+ opt = (U32)uv;
+ p = endptr;
+ if (p && *p && *p != '\n' && *p != '\r') {
+ if (isSPACE(*p))
+ goto the_end_of_the_opts_parser;
+ else
+ Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
+ }
+ else {
+ Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
+ }
+ }
+ else {
for (; *p; p++) {
switch (*p) {
case PERL_UNICODE_STDIN:
the_end_of_the_opts_parser:
if (opt & ~PERL_UNICODE_ALL_FLAGS)
- Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
+ Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf,
(UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
*popt = p;
int fd;
#endif
U32 u;
-#ifdef VMS
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
struct timeval when;
-# else
+#else
Time_t when;
-# endif
#endif
/* This test is an escape hatch, this symbol isn't set by Configure. */
* if there isn't enough entropy available. You can compile with
* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
* is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
+# ifdef __amigaos4__
+# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
+# else
+# define PERL_RANDOM_DEVICE "/dev/urandom"
+# endif
#endif
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
}
#endif
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
PerlProc_gettimeofday(&when,NULL);
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
+#else
(void)time(&when);
u = (U32)SEED_C1 * when;
-# endif
#endif
u += SEED_C3 * (U32)PerlProc_getpid();
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
void
Perl_get_hash_seed(pTHX_ unsigned char * const seed_buffer)
{
+#ifndef NO_PERL_HASH_ENV
const char *env_pv;
+#endif
unsigned long i;
PERL_ARGS_ASSERT_GET_HASH_SEED;
+#ifndef NO_PERL_HASH_ENV
env_pv= PerlEnv_getenv("PERL_HASH_SEED");
if ( env_pv )
-#ifndef USE_HASH_SEED_EXPLICIT
+# ifndef USE_HASH_SEED_EXPLICIT
{
/* ignore leading spaces */
while (isSPACE(*env_pv))
env_pv++;
-#ifdef USE_PERL_PERTURB_KEYS
+# ifdef USE_PERL_PERTURB_KEYS
/* if they set it to "0" we disable key traversal randomization completely */
if (strEQ(env_pv,"0")) {
PL_hash_rand_bits_enabled= 0;
/* otherwise switch to deterministic mode */
PL_hash_rand_bits_enabled= 2;
}
-#endif
+# endif
/* ignore a leading 0x... if it is there */
if (env_pv[0] == '0' && env_pv[1] == 'x')
env_pv += 2;
/* should we warn about insufficient hex? */
}
else
+# endif
#endif
{
(void)seedDrand01((Rand_seed_t)seed());
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 (strEQ(env_pv,"0") || strEQ(env_pv,"NO")) {
Perl_warn(aTHX_ "perl: warning: strange setting in '$ENV{PERL_PERTURB_KEYS}': '%s'\n", env_pv);
}
}
+# endif
#endif
}
#ifdef PERL_MEM_LOG
-/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
* the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
* given, and you supply your own implementation.
*
* The default implementation reads a single env var, PERL_MEM_LOG,
* expecting one or more of the following:
*
- * \d+ - fd fd to write to : must be 1st (grok_atou)
+ * \d+ - fd fd to write to : must be 1st (grok_atoUV)
* 'm' - memlog was PERL_MEM_LOG=1
* 's' - svlog was PERL_SV_LOG=1
* 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
(void)time(&when);
# endif
/* If there are other OS specific ways of hires time than
- * gettimeofday() (see ext/Time-HiRes), the easiest way is
+ * gettimeofday() (see dist/Time-HiRes), the easiest way is
* probably that they would be used to fill in the struct
* timeval. */
{
STRLEN len;
const char* endptr;
- int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */
- if (!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;
+ }
if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
switch (mlt) {
case MLT_ALLOC:
len = my_snprintf(buf, sizeof(buf),
- "alloc: %s:%d:%s: %"IVdf" %"UVuf
- " %s = %"IVdf": %"UVxf"\n",
+ "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",
+ "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",
+ "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",
+ "%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));
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);
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);
const char *filename, const int linenumber,
const char *funcname)
{
+ PERL_ARGS_ASSERT_MEM_LOG_FREE;
+
mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL,
filename, linenumber, funcname);
return oldalloc;
#endif
/*
+=for apidoc quadmath_format_single
+
+C<quadmath_snprintf()> is very strict about its C<format> string and will
+fail, returning -1, if the format is invalid. It accepts exactly
+one format spec.
+
+C<quadmath_format_single()> checks that the intended single spec looks
+sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
+and has C<Q> before it. This is not a full "printf syntax check",
+just the basics.
+
+Returns the format if it is valid, NULL if not.
+
+C<quadmath_format_single()> can and will actually patch in the missing
+C<Q>, if necessary. In this case it will return the modified copy of
+the format, B<which the caller will need to free.>
+
+See also L</quadmath_format_needed>.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+const char*
+Perl_quadmath_format_single(const char* format)
+{
+ STRLEN len;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+
+ if (format[0] != '%' || strchr(format + 1, '%'))
+ return NULL;
+ len = strlen(format);
+ /* minimum length three: %Qg */
+ if (len < 3 || strchr("efgaEFGA", format[len - 1]) == NULL)
+ return NULL;
+ if (format[len - 2] != 'Q') {
+ char* fixed;
+ Newx(fixed, len + 1, char);
+ memcpy(fixed, format, len - 1);
+ fixed[len - 1] = 'Q';
+ fixed[len ] = format[len - 1];
+ fixed[len + 1] = 0;
+ return (const char*)fixed;
+ }
+ return format;
+}
+#endif
+
+/*
+=for apidoc quadmath_format_needed
+
+C<quadmath_format_needed()> returns true if the C<format> string seems to
+contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
+or returns false otherwise.
+
+The format specifier detection is not complete printf-syntax detection,
+but it should catch most common cases.
+
+If true is returned, those arguments B<should> in theory be processed
+with C<quadmath_snprintf()>, but in case there is more than one such
+format specifier (see L</quadmath_format_single>), and if there is
+anything else beyond that one (even just a single byte), they
+B<cannot> be processed because C<quadmath_snprintf()> is very strict,
+accepting only one format spec, and nothing else.
+In this case, the code should probably fail.
+
+=cut
+*/
+#ifdef USE_QUADMATH
+bool
+Perl_quadmath_format_needed(const char* format)
+{
+ const char *p = format;
+ const char *q;
+
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_NEEDED;
+
+ while ((q = strchr(p, '%'))) {
+ q++;
+ if (*q == '+') /* plus */
+ q++;
+ if (*q == '#') /* alt */
+ q++;
+ if (*q == '*') /* width */
+ q++;
+ else {
+ if (isDIGIT(*q)) {
+ while (isDIGIT(*q)) q++;
+ }
+ }
+ if (*q == '.' && (q[1] == '*' || isDIGIT(q[1]))) { /* prec */
+ q++;
+ if (*q == '*')
+ q++;
+ else
+ while (isDIGIT(*q)) q++;
+ }
+ if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ return TRUE;
+ p = q + 1;
+ }
+ return FALSE;
+}
+#endif
+
+/*
=for apidoc my_snprintf
The C library C<snprintf> functionality, if available and
int
Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...)
{
- int retval;
+ int retval = -1;
va_list ap;
PERL_ARGS_ASSERT_MY_SNPRINTF;
#ifndef HAS_VSNPRINTF
PERL_UNUSED_VAR(len);
#endif
va_start(ap, format);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(format);
+ bool quadmath_valid = FALSE;
+ if (qfmt) {
+ /* If the format looked promising, use it as quadmath. */
+ retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ if (retval == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ quadmath_valid = TRUE;
+ if (qfmt != format)
+ Safefree(qfmt);
+ qfmt = NULL;
+ }
+ assert(qfmt == NULL);
+ /* quadmath_format_single() will return false for example for
+ * "foo = %g", or simply "%g". We could handle the %g by
+ * using quadmath for the NV args. More complex cases of
+ * course exist: "foo = %g, bar = %g", or "foo=%Qg" (otherwise
+ * quadmath-valid but has stuff in front).
+ *
+ * Handling the "Q-less" cases right would require walking
+ * through the va_list and rewriting the format, calling
+ * quadmath for the NVs, building a new va_list, and then
+ * letting vsnprintf/vsprintf to take care of the other
+ * arguments. This may be doable.
+ *
+ * We do not attempt that now. But for paranoia, we here try
+ * to detect some common (but not all) cases where the
+ * "Q-less" %[efgaEFGA] formats are present, and die if
+ * detected. This doesn't fix the problem, but it stops the
+ * vsnprintf/vsprintf pulling doubles off the va_list when
+ * __float128 NVs should be pulled off instead.
+ *
+ * If quadmath_format_needed() returns false, we are reasonably
+ * certain that we can call vnsprintf() or vsprintf() safely. */
+ if (!quadmath_valid && quadmath_format_needed(format))
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
+
+ }
+#endif
+ if (retval == -1)
#ifdef HAS_VSNPRINTF
- retval = vsnprintf(buffer, len, format, ap);
+ retval = vsnprintf(buffer, len, format, ap);
#else
- retval = vsprintf(buffer, format, ap);
+ retval = vsprintf(buffer, format, ap);
#endif
va_end(ap);
/* vsprintf() shows failure with < 0 */
int
Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap)
{
+#ifdef USE_QUADMATH
+ PERL_UNUSED_ARG(buffer);
+ PERL_UNUSED_ARG(len);
+ PERL_UNUSED_ARG(format);
+ /* the cast is to avoid gcc -Wsizeof-array-argument complaining */
+ PERL_UNUSED_ARG((void*)ap);
+ Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath");
+ return 0;
+#else
int retval;
#ifdef NEED_VA_COPY
va_list apc;
PERL_ARGS_ASSERT_MY_VSNPRINTF;
-#ifndef HAS_VSNPRINTF
- PERL_UNUSED_VAR(len);
-#endif
Perl_va_copy(ap, apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, apc);
# else
+ PERL_UNUSED_ARG(len);
retval = vsprintf(buffer, format, apc);
# endif
va_end(apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
# else
+ PERL_UNUSED_ARG(len);
retval = vsprintf(buffer, format, ap);
# endif
#endif /* #ifdef NEED_VA_COPY */
)
Perl_croak_nocontext("panic: my_vsnprintf buffer overflow");
return retval;
+#endif
}
void
#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
#endif /* PERL_IMPLICIT_CONTEXT */
-void
-Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
+
+/* Perl_xs_handshake():
+ implement the various XS_*_BOOTCHECK macros, which are added to .c
+ files by ExtUtils::ParseXS, to check that the perl the module was built
+ with is binary compatible with the running perl.
+
+ usage:
+ Perl_xs_handshake(U32 key, void * v_my_perl, const char * file,
+ [U32 items, U32 ax], [char * api_version], [char * xs_version])
+
+ The meaning of the varargs is determined the U32 key arg (which is not
+ a format string). The fields of key are assembled by using HS_KEY().
+
+ Under PERL_IMPLICIT_CONTEX, the v_my_perl arg is of type
+ "PerlInterpreter *" and represents the callers context; otherwise it is
+ of type "CV *", and is the boot xsub's CV.
+
+ v_my_perl will catch where a threaded future perl526.dll calling IO.dll
+ for example, and IO.dll was linked with threaded perl524.dll, and both
+ perl526.dll and perl524.dll are in %PATH and the Win32 DLL loader
+ successfully can load IO.dll into the process but simultaneously it
+ loaded an interpreter of a different version into the process, and XS
+ code will naturally pass SV*s created by perl524.dll for perl526.dll to
+ use through perl526.dll's my_perl->Istack_base.
+
+ v_my_perl cannot be the first arg, since then 'key' will be out of
+ place in a threaded vs non-threaded mixup; and analyzing the key
+ number's bitfields won't reveal the problem, since it will be a valid
+ key (unthreaded perl) on interp side, but croak will report the XS mod's
+ key as gibberish (it is really a my_perl ptr) (threaded XS mod); or if
+ it's a threaded perl and an unthreaded XS module, threaded perl will
+ look at an uninit C stack or an uninit register to get 'key'
+ (remember that it assumes that the 1st arg is the interp cxt).
+
+ 'file' is the source filename of the caller.
+*/
+
+I32
+Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...)
+{
+ va_list args;
+ U32 items, ax;
+ void * got;
+ void * need;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dTHX;
+ tTHX xs_interp;
+#else
+ CV* cv;
+ SV *** xs_spp;
+#endif
+ PERL_ARGS_ASSERT_XS_HANDSHAKE;
+ va_start(args, file);
+
+ got = INT2PTR(void*, (UV)(key & HSm_KEY_MATCH));
+ need = (void *)(HS_KEY(FALSE, FALSE, "", "") & HSm_KEY_MATCH);
+ if (UNLIKELY(got != need))
+ goto bad_handshake;
+/* try to catch where a 2nd threaded perl interp DLL is loaded into a process
+ by a XS DLL compiled against the wrong interl DLL b/c of bad @INC, and the
+ 2nd threaded perl interp DLL never initialized its TLS/PERL_SYS_INIT3 so
+ dTHX call from 2nd interp DLL can't return the my_perl that pp_entersub
+ passed to the XS DLL */
+#ifdef PERL_IMPLICIT_CONTEXT
+ xs_interp = (tTHX)v_my_perl;
+ got = xs_interp;
+ need = my_perl;
+#else
+/* try to catch where an unthreaded perl interp DLL (for ex. perl522.dll) is
+ loaded into a process by a XS DLL built by an unthreaded perl522.dll perl,
+ but the DynaLoder/Perl that started the process and loaded the XS DLL is
+ unthreaded perl524.dll, since unthreadeds don't pass my_perl (a unique *)
+ through pp_entersub, use a unique value (which is a pointer to PL_stack_sp's
+ location in the unthreaded perl binary) stored in CV * to figure out if this
+ Perl_xs_handshake was called by the same pp_entersub */
+ cv = (CV*)v_my_perl;
+ xs_spp = (SV***)CvHSCXT(cv);
+ got = xs_spp;
+ need = &PL_stack_sp;
+#endif
+ if(UNLIKELY(got != need)) {
+ bad_handshake:/* recycle branch and string from above */
+ if(got != (void *)HSf_NOCHK)
+ noperl_die("%s: loadable library and perl binaries are mismatched"
+ " (got handshake key %p, needed %p)\n",
+ file, got, need);
+ }
+
+ if(key & HSf_SETXSUBFN) { /* this might be called from a module bootstrap */
+ SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
+ PL_xsubfilename = file; /* so the old name must be restored for
+ additional XSUBs to register themselves */
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
+ }
+
+ if(key & HSf_POPMARK) {
+ ax = POPMARK;
+ { SV **mark = PL_stack_base + ax++;
+ { dSP;
+ items = (I32)(SP - MARK);
+ }
+ }
+ } else {
+ items = va_arg(args, U32);
+ ax = va_arg(args, U32);
+ }
+ {
+ U32 apiverlen;
+ assert(HS_GETAPIVERLEN(key) <= UCHAR_MAX);
+ if((apiverlen = HS_GETAPIVERLEN(key))) {
+ char * api_p = va_arg(args, char*);
+ if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1
+ || memNE(api_p, "v" PERL_API_VERSION_STRING,
+ sizeof("v" PERL_API_VERSION_STRING)-1))
+ Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s",
+ api_p, SVfARG(PL_stack_base[ax + 0]),
+ "v" PERL_API_VERSION_STRING);
+ }
+ }
+ {
+ U32 xsverlen;
+ assert(HS_GETXSVERLEN(key) <= UCHAR_MAX && HS_GETXSVERLEN(key) <= HS_APIVERLEN_MAX);
+ if((xsverlen = HS_GETXSVERLEN(key)))
+ S_xs_version_bootcheck(aTHX_
+ items, ax, va_arg(args, char*), xsverlen);
+ }
+ va_end(args);
+ return ax;
+}
+
+
+STATIC void
+S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
STRLEN xs_len)
{
SV *sv;
else {
/* XXX GV_ADDWARN */
vn = "XS_VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
if (!sv || !SvOK(sv)) {
vn = "VERSION";
- sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0);
+ sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0);
}
}
if (sv) {
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
SV *string = vstringify(xssv);
- SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+ 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,
+ Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn,
SVfARG(string));
} else {
- Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string));
+ Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string));
}
SvREFCNT_dec(string);
}
}
-void
-Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
- STRLEN api_len)
-{
- SV *xpt = NULL;
- SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
- SV *runver;
-
- PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
-
- /* This might croak */
- compver = upg_version(compver, 0);
- /* This should never croak */
- runver = new_version(PL_apiversion);
- if (vcmp(compver, runver)) {
- SV *compver_string = vstringify(compver);
- SV *runver_string = vstringify(runver);
- xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
- " of %"SVf" does not match %"SVf,
- SVfARG(compver_string), SVfARG(module),
- SVfARG(runver_string));
- Perl_sv_2mortal(aTHX_ xpt);
-
- SvREFCNT_dec(compver_string);
- SvREFCNT_dec(runver_string);
- }
- SvREFCNT_dec(runver);
- if (xpt)
- Perl_croak_sv(aTHX_ xpt);
-}
-
/*
=for apidoc my_strlcat
the 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://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
+Description stolen from http://man.openbsd.org/strlcat.3
*/
#ifndef HAS_STRLCAT
Size_t
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://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
+Description stolen from http://man.openbsd.org/strlcpy.3
*/
#ifndef HAS_STRLCPY
Size_t
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- if (gv && !svp) {
+ if (!svp && !CvLEXICAL(cv)) {
gv_efullname3(dbsv, gv, NULL);
}
- else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || !gv
+ 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))
else {
sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
sv_catpvs(dbsv, "::");
- sv_catpvn_flags(
- dbsv, GvNAME(gv), GvNAMELEN(gv),
- GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
- );
+ sv_cathek(dbsv, GvNAME_HEK(gv));
}
}
else {
return dir->dd_fd;
#else
Perl_croak_nocontext(PL_no_func, "dirfd");
- assert(0); /* NOT REACHED */
+ NOT_REACHED; /* NOTREACHED */
return 0;
#endif
}
PERL_ARGS_ASSERT_DRAND48_INIT_R;
#ifdef PERL_DRAND48_QUAD
- *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
+ *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
#else
random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
random_state->seed[1] = (U16) seed;
/* BFD open and scan only if the filename changed. */
if (ctx->fname_prev == NULL ||
strNE(dl_info->dli_fname, ctx->fname_prev)) {
+ if (ctx->abfd) {
+ bfd_close(ctx->abfd);
+ }
ctx->abfd = bfd_openr(dl_info->dli_fname, 0);
if (ctx->abfd) {
if (bfd_check_format(ctx->abfd, bfd_object)) {
const char* source_name_end;
const char* source_line_end;
const char* close_paren;
+ UV uv;
+
/* Skip trailing whitespace. */
while (p > start && isspace(*p)) p--;
/* Now we should be at the close paren. */
return NULL;
p++;
*source_name_size = source_name_end - p;
- *source_line = grok_atou(source_number_start, &source_line_end);
- if (source_line_end != close_paren)
- return NULL;
- return p;
+ if (grok_atoUV(source_number_start, &uv, &source_line_end)
+ && source_line_end == close_paren
+ && uv <= PERL_INT_MAX
+ ) {
+ *source_line = (STRLEN)uv;
+ return p;
+ }
+ return NULL;
}
/* Given a raw frame, read a pipe from the symbolicator (that's the
char out[1024];
UV cnt = fread(out, 1, sizeof(out), fp);
if (cnt < sizeof(out)) {
- const char* p = atos_parse(out + cnt, out,
+ const char* p = atos_parse(out + cnt - 1, out,
source_name_size,
source_line);
if (p) {
Newx(*source_name,
- *source_name_size + 1, char);
+ *source_name_size, char);
Copy(p, *source_name,
- *source_name_size + 1, char);
+ *source_name_size, char);
}
}
pclose(fp);
=for apidoc get_c_backtrace
Collects the backtrace (aka "stacktrace") into a single linear
-malloced buffer, which the caller B<must> Perl_free_c_backtrace().
+malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
-Scans the frames back by depth + skip, then drops the skip innermost,
-returning at most depth frames.
+Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
+returning at most C<depth> frames.
=cut
*/
for (i = skip; i < try_depth; i++) {
Dl_info* dl_info = &dl_infos[i];
- total_bytes += sizeof(Perl_c_backtrace_frame);
-
+ object_name_sizes[i] = 0;
source_names[i] = NULL;
source_name_sizes[i] = 0;
source_lines[i] = 0;
/* Yes, zero from dladdr() is failure. */
if (dladdr(raw_frames[i], dl_info)) {
+ total_bytes += sizeof(Perl_c_backtrace_frame);
+
object_name_sizes[i] =
dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0;
symbol_name_sizes[i] =
}
#ifdef USE_BFD
Safefree(symbol_names);
+ if (bfd_ctx.abfd) {
+ bfd_close(bfd_ctx.abfd);
+ }
#endif
Safefree(source_lines);
Safefree(source_name_sizes);
/*
=for apidoc get_c_backtrace_dump
-Returns a SV a dump of |depth| frames of the call stack, skipping
-the |skip| innermost ones. depth of 20 is usually enough.
+Returns a SV containing a dump of C<depth> frames of the call stack, skipping
+the C<skip> innermost ones. C<depth> of 20 is usually enough.
The appended output looks like:
The fields are tab-separated. The first column is the depth (zero
being the innermost non-skipped frame). In the hex:offset, the hex is
-where the program counter was in S_parse_body, and the :offset (might
-be missing) tells how much inside the S_parse_body the program counter was.
+where the program counter was in C<S_parse_body>, and the :offset (might
+be missing) tells how much inside the C<S_parse_body> the program counter was.
-The util.c:1716 is the source code file and line number.
+The C<util.c:1716> is the source code file and line number.
-The /usr/bin/perl is obvious (hopefully).
+The F</usr/bin/perl> is obvious (hopefully).
Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
if the platform doesn't support retrieving the information;
if (frame->source_name_size &&
frame->source_name_offset &&
frame->source_line_number) {
- Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf,
+ Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf,
(char*)bt + frame->source_name_offset,
(UV)frame->source_line_number);
} else {
sv_catpvs(dsv, "\n");
}
- Perl_free_c_backtrace(aTHX_ bt);
+ Perl_free_c_backtrace(bt);
return dsv;
}
/*
=for apidoc dump_c_backtrace
-Dumps the C backtrace to the given fp.
+Dumps the C backtrace to the given C<fp>.
Returns true if a backtrace could be retrieved, false if not.
#endif /* #ifdef USE_C_BACKTRACE */
+#ifdef PERL_TSA_ACTIVE
+
+/* pthread_mutex_t and perl_mutex are typedef equivalent
+ * so casting the pointers is fine. */
+
+int perl_tsa_mutex_lock(perl_mutex* mutex)
+{
+ return pthread_mutex_lock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_unlock(perl_mutex* mutex)
+{
+ return pthread_mutex_unlock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_destroy(perl_mutex* mutex)
+{
+ return pthread_mutex_destroy((pthread_mutex_t *) mutex);
+}
+
+#endif
+
+
+#ifdef USE_DTRACE
+
+/* log a sub call or return */
+
+void
+Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call)
+{
+ const char *func;
+ const char *file;
+ const char *stash;
+ const COP *start;
+ line_t line;
+
+ PERL_ARGS_ASSERT_DTRACE_PROBE_CALL;
+
+ if (CvNAMED(cv)) {
+ HEK *hek = CvNAME_HEK(cv);
+ func = HEK_KEY(hek);
+ }
+ else {
+ GV *gv = CvGV(cv);
+ func = GvENAME(gv);
+ }
+ start = (const COP *)CvSTART(cv);
+ file = CopFILE(start);
+ line = CopLINE(start);
+ stash = CopSTASHPV(start);
+
+ if (is_call) {
+ PERL_SUB_ENTRY(func, file, line, stash);
+ }
+ else {
+ PERL_SUB_RETURN(func, file, line, stash);
+ }
+}
+
+
+/* log a require file loading/loaded */
+
+void
+Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading)
+{
+ PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD;
+
+ if (is_loading) {
+ PERL_LOADING_FILE(name);
+ }
+ else {
+ PERL_LOADED_FILE(name);
+ }
+}
+
+
+/* log an op execution */
+
+void
+Perl_dtrace_probe_op(pTHX_ const OP *op)
+{
+ PERL_ARGS_ASSERT_DTRACE_PROBE_OP;
+
+ PERL_OP_ENTRY(OP_NAME(op));
+}
+
+
+/* log a compile/run phase change */
+
+void
+Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase)
+{
+ const char *ph_old = PL_phase_names[PL_phase];
+ const char *ph_new = PL_phase_names[phase];
+
+ PERL_PHASE_CHANGE(ph_new, ph_old);
+}
+
+#endif
+
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff