abort();
}
#else
- ptr = (Malloc_t)PerlMem_malloc(size?size:1);
+ ptr = (Malloc_t)PerlMem_malloc(size);
#endif
PERL_ALLOC_CHECK(ptr);
if (ptr != NULL) {
return (char *)from;
}
-char *
-Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
-{
- PERL_ARGS_ASSERT_DELIMCPY;
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
-}
+/*
+=for apidoc delimcpy_no_escape
+
+Copy a source buffer to a destination buffer, stopping at (but not including)
+the first occurrence of the delimiter byte C<delim>, in the source. The source
+is the bytes between C<from> and C<fromend> inclusive. The dest is C<to>
+through C<toend>.
+
+Nothing is copied beyond what fits between C<to> through C<toend>. If C<delim>
+doesn't occur in the source buffer, as much of the source as will fit is copied
+to the destination.
+
+The actual number of bytes copied is written to C<*retlen>.
+If there is room in the destination available after the copy, an extra
+terminating safety NUL byte is written (not included in the returned length).
+
+=cut
+*/
char *
Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
const char *fromend, int delim, I32 *retlen)
{
+ const char * delim_pos;
+ Ptrdiff_t to_len = toend - to;
+
+ /* Only use the minimum of the available source/dest */
+ Ptrdiff_t copy_len = MIN(fromend - from, to_len);
+
PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
- return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0);
+ assert(copy_len >= 0);
+
+ /* Look for the first delimiter in the portion of the source we are allowed
+ * to look at (determined by the input bounds). */
+ delim_pos = (const char *) memchr(from, delim, copy_len);
+ if (delim_pos) {
+ copy_len = delim_pos - from;
+ } /* else didn't find it: copy all of the source permitted */
+
+ Copy(from, to, copy_len, char);
+
+ if (retlen) {
+ *retlen = copy_len;
+ }
+
+ /* If there is extra space available, add a trailing NUL */
+ if (copy_len < to_len) {
+ to[copy_len] = '\0';
+ }
+
+ return (char *) from + copy_len;
+}
+
+char *
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+{
+ PERL_ARGS_ASSERT_DELIMCPY;
+
+ return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1);
}
/*
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
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
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).
determined by C<strlen()>, which means it may not contain embedded C<NUL>
characters and must have a trailing C<NUL>. To prevent memory leaks, the
memory allocated for the new string needs to be freed when no longer needed.
-This can be done with the L</C<Safefree> function, or
-L<C<SAFEFREEPV>perlguts/SAFEFREEPV>.
+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
must explicitly copy the earlier strings away (and free the copies when you
are done).
+=for apidoc form_nocontext
+Like C<L</form>> but 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
*/
During global destruction a single SV may be shared between uses of
this function.
+=for apidoc mess_nocontext
+Like C<L</mess>> but 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
*/
STATIC bool
S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
{
- dVAR;
HV *stash;
GV *gv;
CV *cv;
It should be used only where the C<OP *> return type is required.
The function never actually returns.
+=for apidoc die_nocontext
+Like C<L</die>> but 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
*/
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>.
+=for apidoc croak_nocontext
+Like C<L</croak>> but 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
*/
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.
Unlike with L</croak>, C<pat> is not permitted to be null.
+=for apidoc warn_nocontext
+Like C<L</warn>> but 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
*/
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)) &&
* 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(__CYGWIN__)|| defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
# define MY_HAS_SETENV
# endif
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
- dVAR;
# ifdef __amigaos4__
amigaos4_obtain_environ(__FUNCTION__);
# endif
void
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
- dVAR;
char *envstr;
const Size_t nlen = strlen(nam);
Size_t vlen;
#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);
struct sigaction act, oact;
#ifdef USE_ITHREADS
- dVAR;
/* only "parent" interpreter can diddle signals */
if (PL_curinterp != aTHX)
return (Sighandler_t) SIG_ERR;
Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
{
#ifdef USE_ITHREADS
- dVAR;
#endif
struct sigaction act;
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);
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;
{
#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 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;
#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
#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
=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();
#ifdef PERL_IMPLICIT_CONTEXT
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
-
-/* rather than each module having a static var holding its index,
- * use a global array of name to index mappings
- */
-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;
-}
-# endif
-
-
/* 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).
extending the interpreter's PL_my_cxt_list array */
void *
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
-Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size)
-# else
Perl_my_cxt_init(pTHX_ int *indexp, size_t size)
-# endif
{
- dVAR;
void *p;
int index;
PERL_ARGS_ASSERT_MY_CXT_INIT;
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- index = Perl_my_cxt_index(aTHX_ my_cxt_key);
-# else
index = *indexp;
-# endif
/* do initial check without locking.
* -1: not allocated or another thread currently allocating
* other: already allocated by another thread
if (index == -1) {
MUTEX_LOCK(&PL_my_ctx_mutex);
/*now a stricter check with locking */
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- index = Perl_my_cxt_index(aTHX_ my_cxt_key);
-# else
index = *indexp;
-# endif
if (index == -1)
/* this module hasn't been allocated an index yet */
-# ifdef PERL_GLOBAL_STRUCT_PRIVATE
- index = PL_my_cxt_index++;
-
- /* Store the index in a global MY_CXT_KEY string to index mapping
- * table. This emulates the perl-module static my_cxt_index var on
- * builds which don't allow static vars */
- if (PL_my_cxt_keys_size <= index) {
- int old_size = PL_my_cxt_keys_size;
- int i;
- if (PL_my_cxt_keys_size) {
- IV new_size = PL_my_cxt_keys_size;
- while (new_size <= index)
- new_size *= 2;
- PL_my_cxt_keys = (const char **)PerlMemShared_realloc(
- PL_my_cxt_keys,
- new_size * sizeof(const char *));
- PL_my_cxt_keys_size = new_size;
- }
- else {
- PL_my_cxt_keys_size = 16;
- PL_my_cxt_keys = (const char **)PerlMemShared_malloc(
- PL_my_cxt_keys_size * sizeof(const char *));
- }
- for (i = old_size; i < PL_my_cxt_keys_size; i++) {
- PL_my_cxt_keys[i] = 0;
- }
- }
- PL_my_cxt_keys[index] = my_cxt_key;
-# else
*indexp = PL_my_cxt_index++;
index = *indexp;
-# endif
MUTEX_UNLOCK(&PL_my_ctx_mutex);
}
#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