Add perldelta entries for my 5.25.1 changes

[perl5.git] / util.c

diff --git a/util.c b/util.c
index c18555c..2f78825 100644 (file)
--- a/util.c
+++ b/util.c
@@ -551,18 +551,6 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend
     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_ARGS_ASSERT_INSTR;
-
-    return strstr((char*)big, (char*)little);
-}
-
 /*
 =head1 Miscellaneous Functions
 
@@ -596,6 +584,11 @@ 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;
     {
@@ -614,6 +607,9 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char
         }
     }
     return NULL;
+
+#endif
+
 }
 
 /*
@@ -3175,10 +3171,7 @@ S_pidgone(pTHX_ Pid_t pid, int status)
 }
 #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
@@ -5021,6 +5014,8 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name,
                   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);
@@ -5033,6 +5028,8 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name,
                     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);
@@ -5044,6 +5041,8 @@ Perl_mem_log_free(Malloc_t oldalloc,
                  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;
@@ -6188,7 +6187,7 @@ static const char* atos_parse(const char* p,
     *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;
@@ -6255,14 +6254,14 @@ static void atos_symbolize(atos_context* ctx,
             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);
@@ -6387,14 +6386,15 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip)
         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] =
@@ -6655,6 +6655,84 @@ int perl_tsa_mutex_destroy(perl_mutex* 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:
  */