dTHX;
#endif
Malloc_t ptr;
+ dSAVEDERRNO;
#ifdef USE_MDH
if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < 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) {
abort();
}
#else
- ptr = (Malloc_t)PerlMem_malloc(size?size:1);
+ ptr = (Malloc_t)PerlMem_malloc(size);
#endif
PERL_ALLOC_CHECK(ptr);
if (ptr != NULL) {
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.
+ */
+ RESTORE_ERRNO;
}
else {
#ifdef USE_MDH
ptr = safesysmalloc(size);
}
else {
+ dSAVE_ERRNO;
#ifdef USE_MDH
where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
maybe_protect_ro(header->prev);
#endif
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;
}
/* In particular, must do that fixup above before logging anything via
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 %zu x %zu = %zu bytes\n",PTR2UV(ptr),(long)PL_an++, count, size, total_size));
if (ptr != NULL) {
#ifdef USE_MDH
{
#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
+ * unquestioninly 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)
+/*
+=for apidoc_section $string
+=for apidoc delimcpy_no_escape
+
+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>.
+
+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_no_escape(char *to, const char *to_end,
+ const char *from, const char *from_end,
+ const int delim, I32 *retlen)
{
- I32 tolen;
+ 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;
+ PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
- 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;
+ 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;
}
- if (to < toend)
- *to = '\0';
- *retlen = tolen;
- return (char *)from;
+ 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 (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(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)
{
+ 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;
+ }
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
-}
+ /* Look for a backslash immediately before the delimiter */
+ backslash_pos = delim_pos - 1;
-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;
+ /* 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;
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
+ /* If there is extra space available, add a trailing NUL */
+ if (to < to_end) {
+ *to = '\0';
+ }
+
+ *retlen = to - orig_to;
+ }
+
+ return (char *) from + copy_len;
}
/*
-=head1 Miscellaneous Functions
-
-=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
+=for apidoc ninstr
Find the first (leftmost) occurrence of a sequence of bytes within another
sequence. This is the Perl version of C<strstr()>, extended to handle
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 Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end
+=for apidoc rninstr
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
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)
+ /* A non-existent needle trivially matches the rightmost possible position
+ * in the haystack */
+ if (UNLIKELY(little_len <= 0)) {
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);
}
- return NULL;
+
+ /* 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;
+ }
}
/* 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
-Analyses the string in order to make fast searches on it using C<fbm_instr()>
+Analyzes the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.
=cut
const U8 *s;
STRLEN i;
STRLEN len;
- U32 frequency = 256;
MAGIC *mg;
- PERL_DEB( STRLEN rarest = 0 );
PERL_ARGS_ASSERT_FBM_COMPILE;
}
}
- s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
- for (i = 0; i < len; i++) {
- if (PL_freq[s[i]] < frequency) {
- PERL_DEB( rarest = i );
- frequency = PL_freq[s[i]];
- }
- }
BmUSEFUL(sv) = 100; /* Initial value */
((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));
}
=cut
-If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
+If SvTAIL(littlestr) is true, a fake "\n" was appended 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).
}
}
+const char *
+Perl_cntrl_to_mnemonic(const U8 c)
+{
+ /* Returns the mnemonic string that represents character 'c', if one
+ * exists; NULL otherwise. The only ones that exist for the purposes of
+ * this routine are a few control characters */
+
+ switch (c) {
+ case '\a': return "\\a";
+ case '\b': return "\\b";
+ case ESC_NATIVE: return "\\e";
+ case '\f': return "\\f";
+ case '\n': return "\\n";
+ case '\r': return "\\r";
+ case '\t': return "\\t";
+ }
+
+ return NULL;
+}
+
/* copy a string to a safe spot */
/*
-=head1 Memory Management
-
+=for apidoc_section $string
=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>. The memory allocated for the new
-string can be freed with the C<Safefree()> function.
+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 C<L</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
*/
char *
-Perl_savepvn(pTHX_ const char *pv, I32 len)
+Perl_savepvn(pTHX_ const char *pv, Size_t len)
{
char *newaddr;
PERL_UNUSED_CONTEXT;
- assert(len >= 0);
-
Newx(newaddr,len+1,char);
/* Give a meaning to NULL pointer mainly for the use in sv_magic() */
if (pv) {
#endif /* PERL_IMPLICIT_CONTEXT */
/*
-=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
+They use 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).
+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 Am|SV *|mess|const char *pat|...
+=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
*/
}
/*
-=for apidoc Am|SV *|mess_sv|SV *basemsg|bool consume
+=for apidoc mess_sv
Expands a message, intended for the user, to include an indication of
the current location in the code, if the message does not already appear
}
/*
-=for apidoc Am|SV *|vmess|const char *pat|va_list *args
+=for apidoc vmess
C<pat> and C<args> are a sprintf-style format pattern and encapsulated
argument list, respectively. These are used to generate a string message. If
}
/*
-=head1 Warning and Dieing
+=for apidoc_section $warning
*/
/* Common code used in dieing and warning */
/* sv_2cv might call Perl_croak() or Perl_warner() */
SV * const oldhook = *hook;
- if (!oldhook)
+ if (!oldhook || oldhook == PERL_WARNHOOK_FATAL)
return FALSE;
ENTER;
}
/*
-=for apidoc Am|OP *|die_sv|SV *baseex
+=for apidoc die_sv
+=for apidoc_item die_nocontext
-Behaves the same as L</croak_sv>, except for the return type.
+These ehave 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.
+The functions 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
*/
-#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
+/* silence __declspec(noreturn) warnings */
+MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die_sv(pTHX_ SV *baseex)
{
/* NOTREACHED */
NORETURN_FUNCTION_END;
}
-#ifdef _MSC_VER
-# pragma warning( pop )
-#endif
+MSVC_DIAG_RESTORE
/*
-=for apidoc Am|OP *|die|const char *pat|...
+=for apidoc die
Behaves the same as L</croak>, except for the return type.
It should be used only where the C<OP *> return type is required.
*/
#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
+
+/* silence __declspec(noreturn) warnings */
+MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die_nocontext(const char* pat, ...)
{
va_end(args);
NORETURN_FUNCTION_END;
}
-#ifdef _MSC_VER
-# pragma warning( pop )
-#endif
+MSVC_DIAG_RESTORE
+
#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
+/* silence __declspec(noreturn) warnings */
+MSVC_DIAG_IGNORE(4646 4645)
OP *
Perl_die(pTHX_ const char* pat, ...)
{
va_end(args);
NORETURN_FUNCTION_END;
}
-#ifdef _MSC_VER
-# pragma warning( pop )
-#endif
+MSVC_DIAG_RESTORE
/*
-=for apidoc Am|void|croak_sv|SV *baseex
+=for apidoc croak_sv
This is an XS interface to Perl's C<die> function.
}
/*
-=for apidoc Am|void|vcroak|const char *pat|va_list *args
+=for apidoc vcroak
This is an XS interface to Perl's C<die> function.
}
/*
-=for apidoc Am|void|croak|const char *pat|...
+=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
*/
}
#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;
+
void
Perl_croak(pTHX_ const char *pat, ...)
{
}
/*
-=for apidoc Am|void|croak_no_modify
+=for apidoc croak_no_modify
+
+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").
-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.
+Less code used on exception code paths reduces CPU cache pressure.
=cut
*/
}
/*
-=for apidoc Am|void|warn_sv|SV *baseex
+=for apidoc warn_sv
This is an XS interface to Perl's C<warn> function.
}
/*
-=for apidoc Am|void|vwarn|const char *pat|va_list *args
+=for apidoc vwarn
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.
}
/*
-=for apidoc Am|void|warn|const char *pat|...
+=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
*/
va_end(args);
}
+/*
+=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.
+
+=cut
+*/
+
#if defined(PERL_IMPLICIT_CONTEXT)
void
Perl_warner_nocontext(U32 err, const char *pat, ...)
void
Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
{
- dVAR;
PERL_ARGS_ASSERT_VWARNER;
if (
(PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
Copy(val, s+(nlen+1), vlen, char); \
*(s+(nlen+1+vlen)) = '\0'
+
+
#ifdef USE_ENVIRON_ARRAY
- /* VMS' my_setenv() is in vms.c */
-#if !defined(WIN32) && !defined(NETWARE)
+/* 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
+static char *
+S_env_alloc(void *current, Size_t l1, Size_t l2, Size_t l3, Size_t size)
+{
+ void *p;
+ Size_t sl, l = l1 + l2;
+
+ if (l < l2)
+ goto panic;
+ l += l3;
+ if (l < l3)
+ goto panic;
+ sl = l * size;
+ if (sl < l)
+ goto panic;
+
+ p = current
+ ? safesysrealloc(current, sl)
+ : safesysmalloc(sl);
+ if (p)
+ return (char*)p;
+
+ panic:
+ croak_memory_wrap();
+}
+# 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
+version has desirable safeguards
+
+=cut
+*/
+
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
- dVAR;
-#ifdef __amigaos4__
+# ifdef __amigaos4__
amigaos4_obtain_environ(__FUNCTION__);
-#endif
-#ifdef USE_ITHREADS
- /* only parent thread can modify process environment */
+# endif
+
+# ifdef USE_ITHREADS
+ /* only parent thread can modify process environment, so no need to use a
+ * mutex */
if (PL_curinterp == aTHX)
-#endif
+# endif
{
-#ifndef PERL_USE_SAFE_PUTENV
+
+# ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- I32 i;
- const I32 len = strlen(nam);
- int nlen, vlen;
+ UV i;
+ Size_t vlen, nlen = strlen(nam);
/* where does it go? */
for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ if (strnEQ(environ[i], nam, nlen) && environ[i][nlen] == '=')
break;
}
if (environ == PL_origenviron) { /* need we copy environment? */
- I32 j;
- I32 max;
+ UV j, max;
char **tmpenv;
max = i;
while (environ[max])
max++;
- tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+
+ /* 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 int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ 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__
+# ifdef __amigaos4__
goto my_setenv_out;
-#else
+# else
return;
-#endif
+# endif
}
+
if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ 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]);
- nlen = strlen(nam);
+
vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ 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
- /* This next branch should only be called #if defined(HAS_SETENV), but
- Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
- were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
- */
-# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
-# if defined(HAS_UNSETENV)
+ }
+ else {
+
+# endif /* !PERL_USE_SAFE_PUTENV */
+
+# ifdef MY_HAS_SETENV
+# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
} else {
(void)setenv(nam, val, 1);
}
-# else /* ! HAS_UNSETENV */
+# else /* ! HAS_UNSETENV */
(void)setenv(nam, val, 1);
-# endif /* HAS_UNSETENV */
-# elif defined(HAS_UNSETENV)
+# endif /* HAS_UNSETENV */
+
+# elif defined(HAS_UNSETENV)
+
if (val == NULL) {
if (environ) /* old glibc can crash with null environ */
(void)unsetenv(nam);
} else {
- const int nlen = strlen(nam);
- const int vlen = strlen(val);
- char * const new_env =
- (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char));
+ 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);
}
-# else /* ! HAS_UNSETENV */
+
+# else /* ! HAS_UNSETENV */
+
char *new_env;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(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 /* __CYGWIN__ */
-#ifndef PERL_USE_SAFE_PUTENV
+
+# endif /* MY_HAS_SETENV */
+
+# ifndef PERL_USE_SAFE_PUTENV
}
-#endif
+# endif
}
-#ifdef __amigaos4__
+
+# ifdef __amigaos4__
my_setenv_out:
amigaos4_release_environ(__FUNCTION__);
-#endif
+# endif
}
-#else /* WIN32 || NETWARE */
+# else /* WIN32 || NETWARE */
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
- dVAR;
char *envstr;
- const int nlen = strlen(nam);
- int vlen;
+ const Size_t nlen = strlen(nam);
+ Size_t vlen;
if (!val) {
val = "";
}
vlen = strlen(val);
- Newx(envstr, nlen+vlen+2, char);
+ envstr = S_env_alloc(NULL, nlen, vlen, 2, 1);
my_setenv_format(envstr, nam, nlen, val, vlen);
(void)PerlEnv_putenv(envstr);
- Safefree(envstr);
+ safesysfree(envstr);
}
-#endif /* WIN32 || NETWARE */
+# endif /* WIN32 || NETWARE */
+
+#endif /* USE_ENVIRON_ARRAY */
+
+
-#endif /* !VMS */
#ifdef UNLINK_ALL_VERSIONS
I32
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
- if (PerlProc_pipe(p) < 0)
+ if (PerlProc_pipe_cloexec(p) < 0)
return NULL;
/* Try for another pipe pair for error return */
- if (PerlProc_pipe(pp) >= 0)
+ if (PerlProc_pipe_cloexec(pp) >= 0)
did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
if (errno != EAGAIN) {
#define THIS that
#define THAT This
/* Close parent's end of error status pipe (if any) */
- if (did_pipes) {
+ if (did_pipes)
PerlLIO_close(pp[0]);
-#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;
-#endif
- }
/* Now dup our end of _the_ pipe to right position */
if (p[THIS] != (*mode == 'r')) {
PerlLIO_dup2(p[THIS], *mode == 'r');
if (p[THAT] != (*mode == 'r')) /* if dup2() didn't close it */
PerlLIO_close(p[THAT]); /* close parent's end of _the_ pipe */
}
- else
+ 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 */
# ifndef NOFILE
#undef THAT
}
/* Parent */
- do_execfree(); /* free any memory malloced by child on fork */
if (did_pipes)
PerlLIO_close(pp[1]);
/* Keep the lower of the two fd numbers */
if (p[that] < p[This]) {
- PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_dup2_cloexec(p[This], p[that]);
PerlLIO_close(p[This]);
p[This] = p[that];
}
/* If we managed to get status pipe check for exec fail */
if (did_pipes && pid > 0) {
int errkid;
- unsigned n = 0;
+ unsigned read_total = 0;
- while (n < sizeof(int)) {
+ while (read_total < sizeof(int)) {
const SSize_t n1 = PerlLIO_read(pp[0],
- (void*)(((char*)&errkid)+n),
- (sizeof(int)) - n);
+ (void*)(((char*)&errkid)+read_total),
+ (sizeof(int)) - read_total);
if (n1 <= 0)
break;
- n += n1;
+ read_total += n1;
}
PerlLIO_close(pp[0]);
did_pipes = 0;
- if (n) { /* Error */
+ if (read_total) { /* Error */
int pid2, status;
PerlLIO_close(p[This]);
- if (n != sizeof(int))
- Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
+ 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);
taint_env();
taint_proper("Insecure %s%s", "EXEC");
}
- if (PerlProc_pipe(p) < 0)
+ if (PerlProc_pipe_cloexec(p) < 0)
return NULL;
- if (doexec && PerlProc_pipe(pp) >= 0)
+ if (doexec && PerlProc_pipe_cloexec(pp) >= 0)
did_pipes = 1;
while ((pid = PerlProc_fork()) < 0) {
if (errno != EAGAIN) {
#undef THAT
#define THIS that
#define THAT This
- if (did_pipes) {
+ if (did_pipes)
PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
- return NULL;
-#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
+ else {
+ setfd_cloexec_or_inhexec_by_sysfdness(p[THIS]);
PerlLIO_close(p[THAT]);
+ }
#ifndef OS2
if (doexec) {
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
#undef THIS
#undef THAT
}
- do_execfree(); /* free any memory malloced by child on vfork */
if (did_pipes)
PerlLIO_close(pp[1]);
if (p[that] < p[This]) {
- PerlLIO_dup2(p[This], p[that]);
+ PerlLIO_dup2_cloexec(p[This], p[that]);
PerlLIO_close(p[This]);
p[This] = p[that];
}
#endif
{
#if defined(USE_ITHREADS)
- dVAR;
/* locks must be held in locking order (if any) */
# ifdef USE_PERLIO
MUTEX_LOCK(&PL_perlio_mutex);
#endif
{
#if defined(USE_ITHREADS)
- dVAR;
/* locks must be released in same order as in atfork_lock() */
# ifdef USE_PERLIO
MUTEX_UNLOCK(&PL_perlio_mutex);
#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.
+
+=cut
+*/
+
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
struct sigaction act, oact;
#ifdef USE_ITHREADS
- dVAR;
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
return (Sighandler_t) SIG_ERR;
#endif
- act.sa_handler = (void(*)(int))handler;
+ act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
struct sigaction act;
return -1;
#endif
- act.sa_handler = (void(*)(int))handler;
+ act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
PERL_UNUSED_CONTEXT;
#ifdef USE_ITHREADS
static Signal_t
sig_trap(int signo)
{
- dVAR;
PL_sig_trapped++;
}
Sighandler_t
Perl_rsignal_state(pTHX_ int signo)
{
- dVAR;
Sighandler_t oldsig;
#if defined(USE_ITHREADS) && !defined(WIN32)
Perl_get_context(void)
{
#if defined(USE_ITHREADS)
- dVAR;
# ifdef OLD_PTHREADS_API
pthread_addr_t t;
- int error = pthread_getspecific(PL_thr_key, &t)
+ int error = pthread_getspecific(PL_thr_key, &t);
if (error)
Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
return (void*)t;
Perl_set_context(void *t)
{
#if defined(USE_ITHREADS)
- dVAR;
#endif
PERL_ARGS_ASSERT_SET_CONTEXT;
#if defined(USE_ITHREADS)
#endif /* !PERL_GET_CONTEXT_DEFINED */
-#if defined(PERL_GLOBAL_STRUCT) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
-struct perl_vars *
-Perl_GetVars(pTHX)
-{
- PERL_UNUSED_CONTEXT;
- return &PL_Vars;
-}
-#endif
-
char **
Perl_get_op_names(pTHX)
{
PPADDR_t*
Perl_get_ppaddr(pTHX)
{
- dVAR;
PERL_UNUSED_CONTEXT;
return (PPADDR_t*)PL_ppaddr;
}
PERL_UNUSED_CONTEXT;
PERL_ARGS_ASSERT_INIT_TM;
(void)time(&now);
+ ENV_LOCALE_READ_LOCK;
my_tm = localtime(&now);
if (my_tm)
Copy(my_tm, ptm, 1, struct tm);
+ ENV_LOCALE_READ_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)
{
#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 */
+/*
+=for apidoc_section $time
+=for apidoc my_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
+
+=cut
+ */
char *buf;
int buflen;
buflen = 64;
Newx(buf, buflen, char);
- GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
+ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
len = strftime(buf, buflen, fmt, &mytm);
- GCC_DIAG_RESTORE;
+ GCC_DIAG_RESTORE_STMT;
/*
** The following is needed to handle to the situation where
** If there is a better way to make it portable, go ahead by
** all means.
*/
- if ((len > 0 && len < buflen) || (len == 0 && *fmt == '\0'))
+ if (inRANGE(len, 1, buflen - 1) || (len == 0 && *fmt == '\0'))
return buf;
else {
/* Possibly buf overflowed - try again with a bigger buf */
Renew(buf, bufsize, char);
while (buf) {
- GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
+ GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
buflen = strftime(buf, bufsize, fmt, &mytm);
- GCC_DIAG_RESTORE;
+ GCC_DIAG_RESTORE_STMT;
- if (buflen > 0 && buflen < bufsize)
+ if (inRANGE(buflen, 1, bufsize - 1))
break;
/* heuristic to prevent out-of-memory errors */
if (bufsize > 100*fmtlen) {
(dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
/*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
=for apidoc getcwd_sv
return -1;
}
+#ifdef SOCK_CLOEXEC
+ type &= ~SOCK_CLOEXEC;
+#endif
+
#ifdef EMULATE_SOCKETPAIR_UDP
if (type == SOCK_DGRAM)
return S_socketpair_udp(fd);
#ifdef ECONNABORTED
errno = ECONNABORTED; /* This would be the standard thing to do. */
#elif defined(ECONNREFUSED)
- errno = ECONNREFUSED; /* E.g. Symbian does not have ECONNABORTED. */
+ errno = ECONNREFUSED; /* some OSes might not have ECONNABORTED. */
#else
errno = ETIMEDOUT; /* Desperation time. */
#endif
if (*p) {
if (isDIGIT(*p)) {
- const char* endptr;
+ const char* endptr = p + strlen(p);
UV uv;
if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
opt = (U32)uv;
# define PERL_RANDOM_DEVICE "/dev/urandom"
# endif
#endif
- fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
+ fd = PerlLIO_open_cloexec(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
if (PerlLIO_read(fd, (void*)&u, sizeof u) != sizeof u)
u = 0;
#endif
}
-#ifdef PERL_GLOBAL_STRUCT
-
-#define PERL_GLOBAL_STRUCT_INIT
-#include "opcode.h" /* the ppaddr and check */
-
-struct perl_vars *
-Perl_init_global_struct(pTHX)
-{
- struct perl_vars *plvarsp = NULL;
-# ifdef PERL_GLOBAL_STRUCT
- const IV nppaddr = C_ARRAY_LENGTH(Gppaddr);
- const IV ncheck = C_ARRAY_LENGTH(Gcheck);
- PERL_UNUSED_CONTEXT;
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- /* PerlMem_malloc() because can't use even safesysmalloc() this early. */
- plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars));
- if (!plvarsp)
- exit(1);
-# else
- plvarsp = PL_VarsPtr;
-# endif /* PERL_GLOBAL_STRUCT_PRIVATE */
-# undef PERLVAR
-# undef PERLVARA
-# undef PERLVARI
-# undef PERLVARIC
-# define PERLVAR(prefix,var,type) /**/
-# define PERLVARA(prefix,var,n,type) /**/
-# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init;
-# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init;
-# include "perlvars.h"
-# undef PERLVAR
-# undef PERLVARA
-# undef PERLVARI
-# undef PERLVARIC
-# ifdef PERL_GLOBAL_STRUCT
- plvarsp->Gppaddr =
- (Perl_ppaddr_t*)
- PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t));
- if (!plvarsp->Gppaddr)
- exit(1);
- plvarsp->Gcheck =
- (Perl_check_t*)
- PerlMem_malloc(ncheck * sizeof(Perl_check_t));
- if (!plvarsp->Gcheck)
- exit(1);
- Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t);
- Copy(Gcheck, plvarsp->Gcheck, ncheck, Perl_check_t);
-# endif
-# ifdef PERL_SET_VARS
- PERL_SET_VARS(plvarsp);
-# endif
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- plvarsp->Gsv_placeholder.sv_flags = 0;
- memset(plvarsp->Ghash_seed, 0, sizeof(plvarsp->Ghash_seed));
-# endif
-# undef PERL_GLOBAL_STRUCT_INIT
-# endif
- return plvarsp;
-}
-
-#endif /* PERL_GLOBAL_STRUCT */
-
-#ifdef PERL_GLOBAL_STRUCT
-
-void
-Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
-{
- int veto = plvarsp->Gveto_cleanup;
-
- PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT;
- PERL_UNUSED_CONTEXT;
-# ifdef PERL_GLOBAL_STRUCT
-# ifdef PERL_UNSET_VARS
- PERL_UNSET_VARS(plvarsp);
-# endif
- if (veto)
- return;
- free(plvarsp->Gppaddr);
- free(plvarsp->Gcheck);
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- free(plvarsp);
-# endif
-# endif
-}
-
-#endif /* PERL_GLOBAL_STRUCT */
-
#ifdef PERL_MEM_LOG
/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
* timeval. */
{
STRLEN len;
- const char* endptr;
+ const char* endptr = pmlenv + strlen(pmlenv);
int fd;
UV uv;
if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
#endif /* PERL_MEM_LOG */
/*
-=for apidoc quadmath_format_single
+=for apidoc_section $string
+=for apidoc quadmath_format_valid
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
+C<quadmath_format_valid()> 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.>
+Returns true if it is valid, false if not.
See also L</quadmath_format_needed>.
=cut
*/
#ifdef USE_QUADMATH
-const char*
-Perl_quadmath_format_single(const char* format)
+bool
+Perl_quadmath_format_valid(const char* format)
{
STRLEN len;
- PERL_ARGS_ASSERT_QUADMATH_FORMAT_SINGLE;
+ PERL_ARGS_ASSERT_QUADMATH_FORMAT_VALID;
if (format[0] != '%' || strchr(format + 1, '%'))
- return NULL;
+ return FALSE;
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;
+ if (len < 3 || memCHRs("efgaEFGA", format[len - 1]) == NULL)
+ return FALSE;
+ if (format[len - 2] != 'Q')
+ return FALSE;
+ return TRUE;
}
#endif
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
+format specifier (see L</quadmath_format_valid>), 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.
else
while (isDIGIT(*q)) q++;
}
- if (strchr("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
+ if (memCHRs("efgaEFGA", *q)) /* Would have needed 'Q' in front. */
return TRUE;
p = q + 1;
}
va_start(ap, format);
#ifdef USE_QUADMATH
{
- const char* qfmt = quadmath_format_single(format);
bool quadmath_valid = FALSE;
- if (qfmt) {
+ if (quadmath_format_valid(format)) {
/* If the format looked promising, use it as quadmath. */
- retval = quadmath_snprintf(buffer, len, qfmt, va_arg(ap, NV));
+ retval = quadmath_snprintf(buffer, len, format, va_arg(ap, NV));
if (retval == -1) {
- if (qfmt != format) {
- dTHX;
- SAVEFREEPV(qfmt);
- }
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", format);
}
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
=for apidoc my_vsnprintf
The C library C<vsnprintf> if available and standards-compliant.
-However, if if the C<vsnprintf> is not available, will unfortunately
+However, if the C<vsnprintf> is not available, will unfortunately
use the unsafe C<vsprintf> which can overrun the buffer (there is an
overrun check, but that may be too late). Consider using
C<sv_vcatpvf> instead, or getting C<vsnprintf>.
void
Perl_my_clearenv(pTHX)
{
- dVAR;
#if ! defined(PERL_MICRO)
# if defined(PERL_IMPLICIT_SYS) || defined(WIN32)
PerlEnv_clearenv();
# else /* ! (PERL_IMPLICIT_SYS || WIN32) */
# if defined(USE_ENVIRON_ARRAY)
# if defined(USE_ITHREADS)
- /* only the parent thread can clobber the process environment */
+ /* only the parent thread can clobber the process environment, so no need
+ * to use a mutex */
if (PL_curinterp == aTHX)
# endif /* USE_ITHREADS */
{
#ifdef PERL_IMPLICIT_CONTEXT
+
/* 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).
void* slot is available to hang the static data off, by allocating or
extending the interpreter's PL_my_cxt_list array */
-#ifndef PERL_GLOBAL_STRUCT_PRIVATE
void *
-Perl_my_cxt_init(pTHX_ int *index, size_t size)
+Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
{
- dVAR;
- void *p;
- PERL_ARGS_ASSERT_MY_CXT_INIT;
- if (*index == -1) {
- /* this module hasn't been allocated an index yet */
- MUTEX_LOCK(&PL_my_ctx_mutex);
- *index = PL_my_cxt_index++;
- MUTEX_UNLOCK(&PL_my_ctx_mutex);
- }
-
- /* make sure the array is big enough */
- if (PL_my_cxt_size <= *index) {
- 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 *);
- PL_my_cxt_size = new_size;
- }
- 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));
- PL_my_cxt_list[*index] = p;
- Zero(p, size, char);
- return p;
-}
-
-#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
-
-int
-Perl_my_cxt_index(pTHX_ const char *my_cxt_key)
-{
- dVAR;
- int index;
-
- PERL_ARGS_ASSERT_MY_CXT_INDEX;
-
- for (index = 0; index < PL_my_cxt_index; index++) {
- const char *key = PL_my_cxt_keys[index];
- /* try direct pointer compare first - there are chances to success,
- * and it's much faster.
- */
- if ((key == my_cxt_key) || strEQ(key, my_cxt_key))
- return index;
- }
- return -1;
-}
-
-void *
-Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
-{
- dVAR;
void *p;
int index;
PERL_ARGS_ASSERT_MY_CXT_INIT;
- index = Perl_my_cxt_index(aTHX_ my_cxt_key);
+ index = *indexp;
+ /* do initial check without locking.
+ * -1: not allocated or another thread currently allocating
+ * other: already allocated by another thread
+ */
if (index == -1) {
- /* this module hasn't been allocated an index yet */
MUTEX_LOCK(&PL_my_ctx_mutex);
- index = PL_my_cxt_index++;
+ /*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);
}
/* make sure the array is big enough */
if (PL_my_cxt_size <= index) {
- int old_size = PL_my_cxt_size;
- int i;
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 *);
- Renew(PL_my_cxt_keys, new_size, const char *);
PL_my_cxt_size = new_size;
}
else {
PL_my_cxt_size = 16;
Newx(PL_my_cxt_list, PL_my_cxt_size, void *);
- Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *);
- }
- for (i = old_size; i < PL_my_cxt_size; i++) {
- PL_my_cxt_keys[i] = 0;
- PL_my_cxt_list[i] = 0;
}
}
- PL_my_cxt_keys[index] = my_cxt_key;
/* newSV() allocates one more than needed */
p = (void*)SvPVX(newSV(size-1));
PL_my_cxt_list[index] = p;
Zero(p, size, char);
return p;
}
-#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */
+
#endif /* PERL_IMPLICIT_CONTEXT */
}
#endif
-/*
-=for apidoc my_strnlen
-
-The C library C<strnlen> if available, or a Perl implementation of it.
-
-C<my_strnlen()> computes the length of the string, up to C<maxlen>
-characters. It will will never attempt to address more than C<maxlen>
-characters, making it suitable for use with strings that are not
-guaranteed to be NUL-terminated.
-
-=cut
-
-Description stolen from http://man.openbsd.org/strnlen.3,
-implementation stolen from PostgreSQL.
-*/
-#ifndef HAS_STRNLEN
-Size_t
-Perl_my_strnlen(const char *str, Size_t maxlen)
-{
- const char *p = str;
-
- PERL_ARGS_ASSERT_MY_STRNLEN;
-
- while(maxlen-- && *p)
- p++;
-
- return p - str;
-}
-#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. */
#endif
}
-#ifndef HAS_MKSTEMP
+#if !defined(HAS_MKOSTEMP) || !defined(HAS_MKSTEMP)
#define TEMP_FILE_CH "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvxyz0123456789"
#define TEMP_FILE_CH_COUNT (sizeof(TEMP_FILE_CH)-1)
-int
-Perl_my_mkstemp(char *templte) {
+static int
+S_my_mkostemp(char *templte, int flags) {
dTHX;
STRLEN len = strlen(templte);
int fd;
int attempts = 0;
+#ifdef VMS
+ int delete_on_close = flags & O_VMS_DELETEONCLOSE;
- PERL_ARGS_ASSERT_MY_MKSTEMP;
+ flags &= ~O_VMS_DELETEONCLOSE;
+#endif
if (len < 6 ||
templte[len-1] != 'X' || templte[len-2] != 'X' || templte[len-3] != 'X' ||
templte[len-4] != 'X' || templte[len-5] != 'X' || templte[len-6] != 'X') {
- errno = EINVAL;
+ SETERRNO(EINVAL, LIB_INVARG);
return -1;
}
for (i = 1; i <= 6; ++i) {
templte[len-i] = TEMP_FILE_CH[(int)(Perl_internal_drand48() * TEMP_FILE_CH_COUNT)];
}
- fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL, 0600);
+#ifdef VMS
+ if (delete_on_close) {
+ fd = open(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600, "fop=dlt");
+ }
+ else
+#endif
+ {
+ fd = PerlLIO_open3(templte, O_RDWR | O_CREAT | O_EXCL | flags, 0600);
+ }
} while (fd == -1 && errno == EEXIST && ++attempts <= 100);
return fd;
#endif
+#ifndef HAS_MKOSTEMP
+int
+Perl_my_mkostemp(char *templte, int flags)
+{
+ PERL_ARGS_ASSERT_MY_MKOSTEMP;
+ return S_my_mkostemp(templte, flags);
+}
+#endif
+
+#ifndef HAS_MKSTEMP
+int
+Perl_my_mkstemp(char *templte)
+{
+ PERL_ARGS_ASSERT_MY_MKSTEMP;
+ return S_my_mkostemp(templte, 0);
+}
+#endif
+
REGEXP *
Perl_get_re_arg(pTHX_ SV *sv) {
* The matched regular expression is roughly "\(.*:\d+\)\s*$" */
const char* source_number_start;
const char* source_name_end;
- const char* source_line_end;
+ const char* source_line_end = start;
const char* close_paren;
UV uv;
#endif /* #ifdef PERL_DARWIN */
/*
+=for apidoc_section $debugging
=for apidoc get_c_backtrace
Collects the backtrace (aka "stacktrace") into a single linear
Safefree(raw_frames);
return bt;
#else
- PERL_UNUSED_ARGV(depth);
- PERL_UNUSED_ARGV(skip);
+ PERL_UNUSED_ARG(depth);
+ PERL_UNUSED_ARG(skip);
return NULL;
#endif
}
/*
=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 */
https://perl5.git.perl.org / perl5.git / blobdiff