X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6de23f80b0db931a33c28fa9eea3c74f533d772b..5fb413889777319544fb826f2cd3d8e78459b0a8:/util.c

diff --git a/util.c b/util.c
index 98e6be5..447a19f 100644
--- 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
 
@@ -5018,6 +5006,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);
@@ -5030,6 +5020,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);
@@ -5041,6 +5033,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;
@@ -6185,7 +6179,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;
@@ -6252,14 +6246,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);
@@ -6384,14 +6378,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] =
@@ -6652,6 +6647,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:
  */