(was Re: [PATCH] Re: Report /pro/3gl/CPAN/perl-5.7.1)

[p5sagit/p5-mst-13.2.git] / ext / Devel / DProf / DProf.xs

diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs
index 6e9cfb3..aba6de9 100644 (file)
--- a/ext/Devel/DProf/DProf.xs
+++ b/ext/Devel/DProf/DProf.xs
@@ -3,11 +3,6 @@
 #include "perl.h"
 #include "XSUB.h"
 
-/* For older Perls */
-#ifndef dTHR
-#  define dTHR int dummy_thr
-#endif /* dTHR */ 
-
 /*#define DBG_SUB 1      */
 /*#define DBG_TIMER 1    */
 
@@ -28,6 +23,7 @@
 #  define HZ ((I32)CLK_TCK)
 #  define DPROF_HZ HZ
 #  include <starlet.h>  /* prototype for sys$gettim() */
+#  include <lib$routines.h>
 #  define Times(ptr) (dprof_times(aTHX_ ptr))
 #else
 #  ifndef HZ
@@ -69,6 +65,7 @@ typedef union prof_any PROFANY;
 
 typedef struct {
     U32                dprof_ticks;
+    char*      out_file_name;  /* output file (defaults to tmon.out) */
     PerlIO*    fp;             /* pointer to tmon.out file */
     long       TIMES_LOCATION; /* Where in the file to store the time totals */
     int                SAVE_STACK;     /* How much data to buffer until end of run */
@@ -105,6 +102,7 @@ typedef struct {
 prof_state_t g_prof_state;
 
 #define g_dprof_ticks          g_prof_state.dprof_ticks
+#define g_out_file_name                g_prof_state.out_file_name
 #define g_fp                   g_prof_state.fp
 #define g_TIMES_LOCATION       g_prof_state.TIMES_LOCATION
 #define g_SAVE_STACK           g_prof_state.SAVE_STACK
@@ -141,20 +139,21 @@ dprof_times(pTHX_ struct tms *t)
 #ifdef OS2
     ULONG rc;
     QWORD cnt;
+    STRLEN n_a;
     
     if (!g_frequ) {
        if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
-           croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na));
+           croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),n_a));
        else
            g_frequ = g_frequ/DPROF_HZ; /* count per tick */
        if (CheckOSError(DosTmrQueryTime(&cnt)))
            croak("DosTmrQueryTime: %s",
-                 SvPV(perl_get_sv("!",TRUE),na));
+                 SvPV(perl_get_sv("!",TRUE), n_a));
        g_start_cnt = toLongLong(cnt);
     }
 
     if (CheckOSError(DosTmrQueryTime(&cnt)))
-           croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
+           croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE), n_a));
     t->tms_stime = 0;
     return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
 #else          /* !OS2 */
@@ -277,10 +276,6 @@ prof_mark(pTHX_ opcode ptype)
 {
     struct tms t;
     clock_t realtime, rdelta, udelta, sdelta;
-    char *name, *pv;
-    char *hvname;
-    STRLEN len;
-    SV *sv;
     U32 id;
     SV *Sub = GvSV(PL_DBsub);  /* name of current sub */
 
@@ -385,7 +380,6 @@ prof_mark(pTHX_ opcode ptype)
 static void
 test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
 {
-    dTHR;
     CV *cv = perl_get_cv("Devel::DProf::NONESUCH_noxs", FALSE);
     int i, j, k = 0;
     HV *oldstash = PL_curstash;
@@ -474,8 +468,6 @@ prof_record(pTHX)
     /* Now that we know the runtimes, fill them in at the recorded
        location -JH */
 
-    clock_t r, u, s;
-
     if (g_SAVE_STACK) {
        prof_dump_until(aTHX_ g_profstack_ix);
     }
@@ -499,7 +491,7 @@ prof_record(pTHX)
 static void
 check_depth(pTHX_ void *foo)
 {
-    U32 need_depth = (U32)foo;
+    U32 need_depth = PTR2UV(foo);
     if (need_depth != g_depth) {
        if (need_depth > g_depth) {
            warn("garbled call depth when profiling");
@@ -536,7 +528,7 @@ XS(XS_DB_sub)
     {
        HV *oldstash = PL_curstash;
 
-        DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na));
+        DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
 
        SAVEDESTRUCTOR_X(check_depth, (void*)g_depth);
        g_depth++;
@@ -544,6 +536,7 @@ XS(XS_DB_sub)
         prof_mark(aTHX_ OP_ENTERSUB);
         PUSHMARK(ORIGMARK);
         perl_call_sv(INT2PTR(SV*,SvIV(Sub)), GIMME | G_NODEBUG);
+        PL_curstash = oldstash;
         prof_mark(aTHX_ OP_LEAVESUB);
        g_depth--;
     }
@@ -575,7 +568,7 @@ XS(XS_DB_goto)
                 HV *oldstash = PL_curstash;
                SV *Sub = GvSV(PL_DBsub);       /* name of current sub */
                 /* SP -= items;  added by xsubpp */
-                DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV(Sub, na));
+                DBG_SUB_NOTIFY("XS DBsub(%s)\n", SvPV_nolen(Sub));
 
                 sv_setiv(PL_DBsingle, 0);      /* disable DB single-stepping */
 
@@ -663,10 +656,14 @@ BOOT:
            else {
                g_dprof_ticks = HZ;
            }
+
+           buffer = getenv("PERL_DPROF_OUT_FILE_NAME");
+           g_out_file_name = savepv(buffer ? buffer : "tmon.out");
        }
 
-        if ((g_fp = PerlIO_open("tmon.out", "w")) == NULL)
-           croak("DProf: unable to write tmon.out, errno = %d\n", errno);
+        if ((g_fp = PerlIO_open(g_out_file_name, "w")) == NULL)
+           croak("DProf: unable to write '%s', errno = %d\n",
+                 g_out_file_name, errno);
 
        g_default_perldb = PERLDBf_NONAME | PERLDBf_SUB | PERLDBf_GOTO;
        g_cv_hash = newHV();