return (char *)from;
}
-/* return ptr to little string in big string, NULL if not found */
-/* This routine was donated by Corey Satten. */
+/*
+=head1 Miscellaneous Functions
-char *
-Perl_instr(const char *big, const char *little)
-{
+=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end
- PERL_ARGS_ASSERT_INSTR;
+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).
- return strstr((char*)big, (char*)little);
-}
+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
-/* same as instr but allow embedded nulls. The end pointers point to 1 beyond
- * the final character desired to be checked */
+*/
char *
Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
{
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)
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
-/* 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;
/* 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;
}
#endif
-#if defined(OS2) || defined(__amigaos4__)
-# if defined(__amigaos4__) && defined(pclose)
-# undef pclose
-# endif
+#if defined(OS2)
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
while (deftypes ||
(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
{
+ Stat_t statbuf;
if (deftypes) {
deftypes = 0;
*tmpbuf = '\0';
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++) {
(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. */
{
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;
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 */
*source_name_size = source_name_end - p;
if (grok_atoUV(source_number_start, &uv, &source_line_end)
&& source_line_end == close_paren
- && uv <= MAX_STRLEN
+ && uv <= PERL_INT_MAX
) {
*source_line = (STRLEN)uv;
return p;
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 (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] =
#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
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff