This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Devel::DProf v19990108 from CPAN, as it was
authorGurusamy Sarathy <gsar@cpan.org>
Tue, 20 Jul 1999 05:39:11 +0000 (05:39 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Tue, 20 Jul 1999 05:39:11 +0000 (05:39 +0000)
p4raw-id: //depot/perl@3707

22 files changed:
MANIFEST
ext/DProf/Changes [new file with mode: 0644]
ext/DProf/DProf.pm [new file with mode: 0644]
ext/DProf/DProf.xs [new file with mode: 0644]
ext/DProf/Makefile.PL [new file with mode: 0644]
ext/DProf/Todo [new file with mode: 0644]
ext/DProf/dprofpp.PL [new file with mode: 0644]
ext/DProf/t/V.pm [new file with mode: 0644]
ext/DProf/t/test1.pl [new file with mode: 0644]
ext/DProf/t/test1.t [new file with mode: 0644]
ext/DProf/t/test1.v [new file with mode: 0644]
ext/DProf/t/test2.t [new file with mode: 0644]
ext/DProf/t/test2.v [new file with mode: 0644]
ext/DProf/t/test3.t [new file with mode: 0644]
ext/DProf/t/test3.v [new file with mode: 0644]
ext/DProf/t/test4.t [new file with mode: 0644]
ext/DProf/t/test4.v [new file with mode: 0644]
ext/DProf/t/test5.t [new file with mode: 0644]
ext/DProf/t/test5.v [new file with mode: 0644]
ext/DProf/t/test6.t [new file with mode: 0644]
ext/DProf/t/test6.v [new file with mode: 0644]
ext/DProf/test.pl [new file with mode: 0644]

index fccf79e..df8b64a 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -221,6 +221,26 @@ ext/Devel/Peek/Changes             Data debugging tool, changelog
 ext/Devel/Peek/Makefile.PL     Data debugging tool, makefile writer
 ext/Devel/Peek/Peek.pm         Data debugging tool, module and pod
 ext/Devel/Peek/Peek.xs         Data debugging tool, externals
+ext/DProf/Changes              Perl code profiler changelog
+ext/DProf/DProf.pm             Perl code profiler
+ext/DProf/DProf.xs             Perl code profiler
+ext/DProf/Makefile.PL          Perl code profiler makefile writer
+ext/DProf/Todo                 Perl code profiler todo list
+ext/DProf/dprofpp.PL           Perl code profile post-processor
+ext/DProf/t/test1.pl           Perl code profiler tests
+ext/DProf/t/test1.t            Perl code profiler tests
+ext/DProf/t/test1.v            Perl code profiler tests
+ext/DProf/t/test2.t            Perl code profiler tests
+ext/DProf/t/test2.v            Perl code profiler tests
+ext/DProf/t/test3.t            Perl code profiler tests
+ext/DProf/t/test3.v            Perl code profiler tests
+ext/DProf/t/test4.t            Perl code profiler tests
+ext/DProf/t/test4.v            Perl code profiler tests
+ext/DProf/t/test5.t            Perl code profiler tests
+ext/DProf/t/test5.v            Perl code profiler tests
+ext/DProf/t/test6.t            Perl code profiler tests
+ext/DProf/t/test6.v            Perl code profiler tests
+ext/DProf/test.pl              Perl code profiler testsuite driver
 ext/DynaLoader/DynaLoader_pm.PL        Dynamic Loader perl module
 ext/DynaLoader/Makefile.PL     Dynamic Loader makefile writer
 ext/DynaLoader/README          Dynamic Loader notes and intro
diff --git a/ext/DProf/Changes b/ext/DProf/Changes
new file mode 100644 (file)
index 0000000..216498b
--- /dev/null
@@ -0,0 +1,176 @@
+1999 Jan 8
+
+ Ilya Zakharevich:
+  Newer perls: Add PERL_POLLUTE and dTHR.
+
+1998 Nov 10 
+This version of DProf should work with older Perls too, but to get
+full benefits some patches to 5.004_55 are needed.  Patches take effect 
+after new version of Perl is installed, and DProf recompiled.
+
+Without these patches the overhead of DProf is too big, thus the statistic
+may be very skewed.
+
+Oct 98:
+ Ilya Zakharevich:
+  DProf.xs
+    - correct defstash to PL_defstash
+    - nonlocal exits work
+  dprofpp
+    - nonlocal exits work
+  DProf.pm
+    - documentation updated
+  t/test6.*
+    - added
+
+Nov-Dec 97:
+ Jason E. Holt and Ilya Zakharevich:
+  DProf.xs
+    - will not wait until completion to write the output, size of buffer
+      regulated by PERL_DPROF_BUFFER, default 2**14 words;
+
+ Ilya Zakharevich:
+  dprofpp
+    - smarter in fixing garbled profiles;
+    - subtracts DProf output overhead, and suggested profiler overhead;
+    - new options -A, -R, -g subroutine, -S;
+    - handles 'goto' too;
+  DProf.xs
+    - 7x denser output (time separated from name, ids for subs);
+    - outputs report-write overhead;
+    - optional higher-resolution (currently OS/2 only, cannot grok VMS code);
+    - outputs suggested profiler overhead;
+    - handles 'goto' too;
+    - handles PERL_DPROF_TICKS (on OS/2, VMS may be easily modified too)
+
+Jun 14, 97 andreas koenig adds the compatibility notes to the README
+and lets the Makefile.PL die on $] < 5.004.
+
+Jun 06, 97 andreas koenig applies a patch by gurusamy sarathy because
+Dean is not available for comments at that time. The patch is available
+from CPAN in the authors/id/GSAR directory for inspection.
+
+Sep 30, 96 dmr
+  DProf.xs
+  - added Ilya's patches to fix "&bar as &bar(@_)" bug.  This also fixes
+    the coredumps people have seen when using this with 5.003+.
+  DProf.pm
+  - updated manpage
+  t/bug.t
+  - moved to test5
+  Makefile.PL
+  - remove special case for bug.t
+
+Jun 26, 96 dmr
+  dprofpp.PL
+  - smarter r.e. to find VERSION in Makefile (for MM5.27).
+  DProf.pm
+  - updated manpage
+  DProf.xs
+  - keep pid of profiled process, if process forks then only the
+    parent is profiled.  Added test4 for this.
+
+Mar 2, 96 dmr
+  README
+  - updated
+  dprofpp
+  - updated manpage, point to DProf for raw profile description.
+  DProf.pm
+  - update manpage, update raw profile description with XS_VERSION.
+  - update manpage for AUTOLOAD changes.
+  DProf.xs
+  - smart handling of &AUTOLOAD--looks in $AUTOLOAD for the sub name.
+      this fixes one problem with corrupt profiles.
+
+Feb 5, 96 dmr 
+  dprofpp
+  - updated manpage
+  - added -E/-I for exclusive/inclusive times
+  - added DPROFPP_OPTS -- lazily
+  - added -p/-Q for profile-then-analyze
+  - added version check
+  dprofpp.PL
+  - pull dprofpp's version id from the makefile
+  DProf.pm
+  - added version to bootstrap
+  - updated doc
+  - updated doc, DProf and -w are now friendly to each other
+  DProf.xs
+  - using savepv
+  - added Tim's patch to check for DBsub, avoids -MDevel::DProf coredump
+  - turn off warnings during newXS("DB::sub")
+  tests
+  - added Tim's patch to ignore Loader::import in results
+  - added Tim's patch to aid readability of test?.v output
+
+
+-- from those days when I kept a unique changelog for each module --
+
+# Devel::DProf - a Perl code profiler
+#  31oct95
+#
+# changes/bugs fixed since 5apr95 version -dmr:
+#  -added VMS patches from CharlesB.
+#  -now open ./tmon.out in BOOT.
+# changes/bugs fixed since 2apr95 version -dmr:
+#  -now mallocing an extra byte for the \0 :)
+# changes/bugs fixed since 01mar95 version -dmr:
+#  -stringified code ref is used for name of anonymous sub.
+#  -include stash name with stringified code ref.
+#  -use perl.c's DBsingle and DBsub.
+#  -now using croak() and warn().
+#  -print "timer is on" before turning timer on.
+#  -use safefree() instead of free().
+#  -rely on PM to provide full path name to tmon.out.
+#  -print errno if unable to write tmon.out.
+# changes/bugs fixed since 03feb95 version -dmr:
+#  -comments
+# changes/bugs fixed since 31dec94 version -dmr:
+#  -added patches from AndyD.
+#
+
+# Devel::DProf - a Perl code profiler
+#  31oct95
+#
+# changes/bugs fixed since 05apr95 version -dmr:
+#  - VMS-related prob; now let tmon.out name be handled in XS.
+# changes/bugs fixed since 01mar95 version -dmr:
+#  - record $pwd and build pathname for tmon.out
+# changes/bugs fixed since 03feb95 version -dmr:
+#  - fixed some doc bugs
+#  - added require 5.000
+#  - added -w note to bugs section of pod
+# changes/bugs fixed since 31dec94 version -dmr:
+#  - podified
+#
+
+
+# dprofpp - display perl profile data
+#  31oct95
+#
+# changes/bugs fixed since 7oct95 version -dmr:
+#  - PL'd
+# changes/bugs fixed since 5apr95 version -dmr:
+#  - touch up handling of exit timestamps.
+#  - suggests -F when exit timestamps are missing.
+#  - added compressed execution tree patches from AchimB, put under -t.
+#      now -z is the default action; user+system time.
+#  - doc changes.
+# changes/bugs fixed since 10feb95 version -dmr:
+#  - summary info is printed by default, opt_c is gone.
+#  - fixed some doc bugs
+#  - changed name to dprofpp
+# changes/bugs fixed since 03feb95 version -dmr:
+#  - fixed division by zero.
+#  - replace many local()s with my().
+#  - now prints user+system times by default
+#     now -u prints user time, -U prints unsorted.
+#  - fixed documentation
+#  - fixed output, to clarify that times are given in seconds.
+#  - can now fake exit timestamps if the profile is garbled.
+# changes/bugs fixed since 17jun94 version -dmr:
+#  - podified.
+#  - correct old documentation flaws.
+#  - added AndyD's patches.
+#
diff --git a/ext/DProf/DProf.pm b/ext/DProf/DProf.pm
new file mode 100644 (file)
index 0000000..4c43f4d
--- /dev/null
@@ -0,0 +1,192 @@
+require 5.003;
+
+=head1 NAME
+
+Devel::DProf - a Perl code profiler
+
+=head1 SYNOPSIS
+
+       perl5 -d:DProf test.pl
+
+=head1 DESCRIPTION
+
+The Devel::DProf package is a Perl code profiler.  This will collect
+information on the execution time of a Perl script and of the subs in that
+script.  This information can be used to determine which subroutines are
+using the most time and which subroutines are being called most often.  This
+information can also be used to create an execution graph of the script,
+showing subroutine relationships.
+
+To profile a Perl script run the perl interpreter with the B<-d> debugging
+switch.  The profiler uses the debugging hooks.  So to profile script
+F<test.pl> the following command should be used:
+
+       perl5 -d:DProf test.pl
+
+When the script terminates (or when the output buffer is filled) the
+profiler will dump the profile information to a file called
+F<tmon.out>.  A tool like I<dprofpp> can be used to interpret the
+information which is in that profile.  The following command will
+print the top 15 subroutines which used the most time:
+
+       dprofpp
+
+To print an execution graph of the subroutines in the script use the
+following command:
+
+       dprofpp -T
+
+Consult L<dprofpp> for other options.
+
+=head1 PROFILE FORMAT
+
+The old profile is a text file which looks like this:
+
+       #fOrTyTwO
+       $hz=100;
+       $XS_VERSION='DProf 19970606';
+       # All values are given in HZ
+       $rrun_utime=2; $rrun_stime=0; $rrun_rtime=7
+       PART2
+       + 26 28 566822884 DynaLoader::import
+       - 26 28 566822884 DynaLoader::import
+       + 27 28 566822885 main::bar
+       - 27 28 566822886 main::bar
+       + 27 28 566822886 main::baz
+       + 27 28 566822887 main::bar
+       - 27 28 566822888 main::bar
+       [....]
+
+The first line is the magic number.  The second line is the hertz value, or
+clock ticks, of the machine where the profile was collected.  The third line
+is the name and version identifier of the tool which created the profile.
+The fourth line is a comment.  The fifth line contains three variables
+holding the user time, system time, and realtime of the process while it was
+being profiled.  The sixth line indicates the beginning of the sub
+entry/exit profile section.
+
+The columns in B<PART2> are:
+
+       sub entry(+)/exit(-) mark
+       app's user time at sub entry/exit mark, in ticks
+       app's system time at sub entry/exit mark, in ticks
+       app's realtime at sub entry/exit mark, in ticks
+       fully-qualified sub name, when possible
+
+With newer perls another format is used, which may look like this:
+
+        #fOrTyTwO
+        $hz=10000;
+        $XS_VERSION='DProf 19971213';
+        # All values are given in HZ
+        $over_utime=5917; $over_stime=0; $over_rtime=5917;
+        $over_tests=10000;
+        $rrun_utime=1284; $rrun_stime=0; $rrun_rtime=1284;
+        $total_marks=6;
+
+        PART2
+        @ 406 0 406
+        & 2 main bar
+        + 2
+        @ 456 0 456
+        - 2
+        @ 1 0 1
+        & 3 main baz
+        + 3
+        @ 141 0 141
+        + 2
+        @ 141 0 141
+        - 2
+        @ 1 0 1
+        & 4 main foo
+        + 4
+        @ 142 0 142
+        + & Devel::DProf::write
+        @ 5 0 5
+        - & Devel::DProf::write
+
+(with high value of $ENV{PERL_DPROF_TICKS}).  
+
+New C<$over_*> values show the measured overhead of making $over_tests
+calls to the profiler These values are used by the profiler to
+subtract the overhead from the runtimes.
+
+The lines starting with C<@> mark time passed from the previous C<@>
+line.  The lines starting with C<&> introduce new subroutine I<id> and
+show the package and the subroutine name of this id.  Lines starting
+with C<+>, C<-> and C<*> mark entering and exit of subroutines by
+I<id>s, and C<goto &subr>.
+
+The I<old-style> C<+>- and C<->-lines are used to mark the overhead
+related to writing to profiler-output file.
+
+=head1 AUTOLOAD
+
+When Devel::DProf finds a call to an C<&AUTOLOAD> subroutine it looks at the
+C<$AUTOLOAD> variable to find the real name of the sub being called.  See
+L<perlsub/"Autoloading">.
+
+=head1 ENVIRONMENT
+
+C<PERL_DPROF_BUFFER> sets size of output buffer in words.  Defaults to 2**14.
+
+C<PERL_DPROF_TICKS> sets number of ticks per second on some systems where
+a replacement for times() is used.  Defaults to the value of C<HZ> macro.
+
+=head1 BUGS
+
+Builtin functions cannot be measured by Devel::DProf.
+
+With a newer Perl DProf relies on the fact that the numeric slot of
+$DB::sub contains an address of a subroutine.  Excessive manipulation
+of this variable may overwrite this slot, as in
+
+  $DB::sub = 'current_sub';
+  ...
+  $addr = $DB::sub + 0;
+
+will set this numeric slot to numeric value of the string
+C<current_sub>, i.e., to C<0>.  This will cause a segfault on the exit
+from this subroutine.  Note that the first assignment above does not
+change the numeric slot (it will I<mark> it as invalid, but will not
+write over it).
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>.
+
+=head1 SEE ALSO
+
+L<perl>, L<dprofpp>, times(2)
+
+=cut
+
+# This sub is needed for calibration.
+package Devel::DProf;
+
+sub NONESUCH_noxs {
+       return $Devel::DProf::VERSION;
+}
+
+package DB;
+
+#
+# As of perl5.003_20, &DB::sub stub is not needed (some versions
+# even had problems if stub was redefined with XS version).
+#
+
+# disable DB single-stepping
+BEGIN { $single = 0; }
+
+# This sub is needed during startup.
+sub DB { 
+#      print "nonXS DBDB\n";
+}
+
+require DynaLoader;
+@Devel::DProf::ISA = 'DynaLoader';
+$Devel::DProf::VERSION = '19990108'; # this version not authorized by
+                                    # Dean Roehrich. See "Changes" file.
+
+bootstrap Devel::DProf $Devel::DProf::VERSION;
+
+1;
diff --git a/ext/DProf/DProf.xs b/ext/DProf/DProf.xs
new file mode 100644 (file)
index 0000000..946aee2
--- /dev/null
@@ -0,0 +1,703 @@
+#define PERL_POLLUTE
+
+#include "EXTERN.h"
+#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   /* */
+
+#ifdef DBG_SUB
+#  define DBG_SUB_NOTIFY(A,B) warn( A, B )
+#else
+#  define DBG_SUB_NOTIFY(A,B)  /* nothing */
+#endif
+
+#ifdef DBG_TIMER
+#  define DBG_TIMER_NOTIFY(A) warn( A )
+#else
+#  define DBG_TIMER_NOTIFY(A)  /* nothing */
+#endif
+
+static U32 dprof_ticks;
+
+/* HZ == clock ticks per second */
+#ifdef VMS
+#  define HZ CLK_TCK
+#  define DPROF_HZ HZ
+#  include <starlet.h>  /* prototype for sys$gettim() */
+   clock_t dprof_times(struct tms *bufptr) {
+        clock_t retval;
+        /* Get wall time and convert to 10 ms intervals to
+         * produce the return value dprof expects */
+#  if defined(__DECC) && defined (__ALPHA)
+#    include <ints.h>
+        uint64 vmstime;
+        _ckvmssts(sys$gettim(&vmstime));
+        vmstime /= 100000;
+        retval = vmstime & 0x7fffffff;
+#  else
+        /* (Older hw or ccs don't have an atomic 64-bit type, so we
+         * juggle 32-bit ints (and a float) to produce a time_t result
+         * with minimal loss of information.) */
+        long int vmstime[2],remainder,divisor = 100000;
+        _ckvmssts(sys$gettim((unsigned long int *)vmstime));
+        vmstime[1] &= 0x7fff;  /* prevent overflow in EDIV */
+        _ckvmssts(lib$ediv(&divisor,vmstime,(long int *)&retval,&remainder));
+#  endif
+        /* Fill in the struct tms using the CRTL routine . . .*/
+        times((tbuffer_t *)bufptr);
+        return (clock_t) retval;
+   }
+#  define Times(ptr) (dprof_times(ptr))
+#else
+#  ifndef HZ
+#    ifdef CLK_TCK
+#      define HZ CLK_TCK
+#    else
+#      define HZ 60
+#    endif
+#  endif
+#  ifdef OS2                           /* times() has significant overhead */
+#    define Times(ptr) (dprof_times(ptr))
+#    define INCL_DOSPROFILE
+#    define INCL_DOSERRORS
+#    include <os2.h>
+#    define toLongLong(arg) (*(long long*)&(arg))
+#    define DPROF_HZ dprof_ticks
+
+static ULONG frequ;
+static long long start_cnt;
+clock_t
+dprof_times(struct tms *t)
+{
+    ULONG rc;
+    QWORD cnt;
+    
+    if (!frequ) {
+       if (CheckOSError(DosTmrQueryFreq(&frequ)))
+           croak("DosTmrQueryFreq: %s", SvPV(perl_get_sv("!",TRUE),na));
+       else
+           frequ = frequ/DPROF_HZ;     /* count per tick */
+       if (CheckOSError(DosTmrQueryTime(&cnt)))
+           croak("DosTmrQueryTime: %s",
+                 SvPV(perl_get_sv("!",TRUE),na));
+       start_cnt = toLongLong(cnt);
+    }
+
+    if (CheckOSError(DosTmrQueryTime(&cnt)))
+           croak("DosTmrQueryTime: %s", SvPV(perl_get_sv("!",TRUE),na));
+    t->tms_stime = 0;
+    return (t->tms_utime = (toLongLong(cnt) - start_cnt)/frequ);
+}
+#  else
+#    define Times(ptr) (times(ptr))
+#    define DPROF_HZ HZ
+#  endif 
+#endif
+
+XS(XS_Devel__DProf_END);        /* used by prof_mark() */
+
+static SV * Sub;        /* pointer to $DB::sub */
+static PerlIO *fp;      /* pointer to tmon.out file */
+
+/* Added -JH */
+static long TIMES_LOCATION=42;/* Where in the file to store the time totals */
+static int SAVE_STACK = 1<<14;         /* How much data to buffer until */
+                                       /* end of run */
+
+static int prof_pid;    /* pid of profiled process */
+
+/* Everything is built on times(2).  See its manpage for a description
+ * of the timings.
+ */
+
+static
+struct tms      prof_start,
+                prof_end;
+
+static
+clock_t         rprof_start, /* elapsed real time, in ticks */
+                rprof_end,
+               wprof_u, wprof_s, wprof_r;
+
+union prof_any {
+        clock_t tms_utime;  /* cpu time spent in user space */
+        clock_t tms_stime;  /* cpu time spent in system */
+        clock_t realtime;   /* elapsed real time, in ticks */
+        char *name;
+        U32 id;
+        opcode ptype;
+};
+
+typedef union prof_any PROFANY;
+
+static PROFANY  *profstack;
+static int      profstack_max = 128;
+static int      profstack_ix = 0;
+
+static void
+prof_dump(opcode ptype, char *name)
+{
+    if(ptype == OP_LEAVESUB){
+       PerlIO_printf(fp,"- & %s\n", name );
+    } else if(ptype == OP_ENTERSUB) {
+       PerlIO_printf(fp,"+ & %s\n", name );
+    } else if(ptype == OP_DIE) {
+       PerlIO_printf(fp,"/ & %s\n", name );
+    } else {
+       PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype);
+    }
+    safefree(name);
+}   
+
+static void
+prof_dumpa(opcode ptype, U32 id)
+{
+    if(ptype == OP_LEAVESUB){
+       PerlIO_printf(fp,"- %lx\n", id );
+    } else if(ptype == OP_ENTERSUB) {
+       PerlIO_printf(fp,"+ %lx\n", id );
+    } else if(ptype == OP_GOTO) {
+       PerlIO_printf(fp,"* %lx\n", id );
+    } else if(ptype == OP_DIE) {
+       PerlIO_printf(fp,"/ %lx\n", id );
+    } else {
+       PerlIO_printf(fp,"Profiler unknown prof code %d\n", ptype);
+    }
+}   
+
+static void
+prof_dumps(U32 id, char *pname, char *gname)
+{
+    PerlIO_printf(fp,"& %lx %s %s\n", id, pname, gname);
+}   
+
+static clock_t otms_utime, otms_stime, orealtime;
+
+static void
+prof_dumpt(long tms_utime, long tms_stime, long realtime)
+{
+    PerlIO_printf(fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
+}   
+
+static void
+prof_dump_until(long ix)
+{
+    long base = 0;
+    struct tms t1, t2;
+    clock_t realtime1, realtime2;
+
+    realtime1 = Times(&t1);
+
+    while( base < ix ){
+       opcode ptype = profstack[base++].ptype;
+       if (ptype == OP_TIME) {
+           long tms_utime = profstack[base++].tms_utime;
+           long tms_stime = profstack[base++].tms_stime;
+           long realtime = profstack[base++].realtime;
+
+           prof_dumpt(tms_utime, tms_stime, realtime);
+       } else if (ptype == OP_GV) {
+           U32 id = profstack[base++].id;
+           char *pname = profstack[base++].name;
+           char *gname = profstack[base++].name;
+
+           prof_dumps(id, pname, gname);
+       } else {
+#ifdef PERLDBf_NONAME
+           U32 id = profstack[base++].id;
+           prof_dumpa(ptype, id);
+#else
+           char *name = profstack[base++].name;
+           prof_dump(ptype, name);
+#endif 
+       }
+    }
+    fflush(fp);
+    realtime2 = Times(&t2);
+    if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
+       || t1.tms_stime != t2.tms_stime) {
+       wprof_r += realtime2 - realtime1;
+       wprof_u += t2.tms_utime - t1.tms_utime;
+       wprof_s += t2.tms_stime - t1.tms_stime;
+
+       PerlIO_printf(fp,"+ & Devel::DProf::write\n" );
+       PerlIO_printf(fp,"@ %ld %ld %ld\n", 
+               t2.tms_utime - t1.tms_utime, t2.tms_stime - t1.tms_stime, 
+               realtime2 - realtime1);
+       PerlIO_printf(fp,"- & Devel::DProf::write\n" );
+       otms_utime = t2.tms_utime;
+       otms_stime = t2.tms_stime;
+       orealtime = realtime2;
+       fflush(fp);
+    }
+}
+
+static HV* cv_hash;
+static U32 total = 0;
+
+static void
+prof_mark( ptype )
+opcode ptype;
+{
+        struct tms t;
+        clock_t realtime, rdelta, udelta, sdelta;
+        char *name, *pv;
+        char *hvname;
+        STRLEN len;
+        SV *sv;
+       U32 id;
+
+        if( SAVE_STACK ){
+                if( profstack_ix + 5 > profstack_max ){
+                        profstack_max = profstack_max * 3 / 2;
+                        Renew( profstack, profstack_max, PROFANY );
+                }
+        }
+
+        realtime = Times(&t);
+       rdelta = realtime - orealtime;
+       udelta = t.tms_utime - otms_utime;
+       sdelta = t.tms_stime - otms_stime;
+       if (rdelta || udelta || sdelta) {
+           if (SAVE_STACK) {
+               profstack[profstack_ix++].ptype = OP_TIME;
+               profstack[profstack_ix++].tms_utime = udelta;
+               profstack[profstack_ix++].tms_stime = sdelta;
+               profstack[profstack_ix++].realtime = rdelta;
+           } else { /* Write it to disk now so's not to eat up core */
+               if (prof_pid == (int)getpid()) {
+                   prof_dumpt(udelta, sdelta, rdelta);
+                   fflush(fp);
+               }
+           }
+           orealtime = realtime;
+           otms_stime = t.tms_stime;
+           otms_utime = t.tms_utime;
+       }
+
+#ifdef PERLDBf_NONAME
+       {
+           SV **svp;
+           char *gname, *pname;
+           static U32 lastid;
+           CV *cv;
+
+           cv = (CV*)SvIVX(Sub);
+           svp = hv_fetch(cv_hash, (char*)&cv, sizeof(CV*), TRUE);
+           if (!SvOK(*svp)) {
+               GV *gv = CvGV(cv);
+                   
+               sv_setiv(*svp, id = ++lastid);
+               pname = ((GvSTASH(gv) && HvNAME(GvSTASH(gv))) 
+                        ? HvNAME(GvSTASH(gv)) 
+                        : "(null)");
+               gname = GvNAME(gv);
+               if (CvXSUB(cv) == XS_Devel__DProf_END)
+                   return;
+               if (SAVE_STACK) { /* Store it for later recording  -JH */
+                   profstack[profstack_ix++].ptype = OP_GV;
+                   profstack[profstack_ix++].id = id;
+                   profstack[profstack_ix++].name = pname;
+                   profstack[profstack_ix++].name = gname;
+               } else { /* Write it to disk now so's not to eat up core */
+
+                   /* Only record the parent's info */
+                   if (prof_pid == (int)getpid()) {
+                       prof_dumps(id, pname, gname);
+                       fflush(fp);
+                   } else
+                       perldb = 0;             /* Do not debug the kid. */
+               }
+           } else {
+               id = SvIV(*svp);
+           }
+       }
+#else
+       pv = SvPV( Sub, len );
+
+        if( SvROK(Sub) ){
+                /* Attempt to make CODE refs slightly identifiable by
+                 * including their package name.
+                 */
+                sv = (SV*)SvRV(Sub);
+                if( sv && SvTYPE(sv) == SVt_PVCV ){
+                        if( CvSTASH(sv) ){
+                                hvname = HvNAME(CvSTASH(sv));
+                        }
+                        else if( CvXSUB(sv) == &XS_Devel__DProf_END ){
+                                /*warn( "prof_mark() found dprof::end");*/
+                                return; /* don't profile Devel::DProf::END */
+                        }
+                        else{
+                    croak( "DProf prof_mark() lost on CODE ref %s\n", pv );
+                        }
+                        len += strlen( hvname ) + 2;  /* +2 for ::'s */
+
+                }
+                else{
+        croak( "DProf prof_mark() lost on supposed CODE ref %s.\n", pv );
+                }
+                name = (char *)safemalloc( len * sizeof(char) + 1 );
+                strcpy( name, hvname );
+                strcat( name, "::" );
+                strcat( name, pv );
+        }
+        else{
+                if( *(pv+len-1) == 'D' ){
+                        /* It could be an &AUTOLOAD. */
+
+                        /* I measured a bunch of *.pl and *.pm (from Perl
+                         * distribution and other misc things) and found
+                         * 780 fully-qualified names.  They averaged
+                         * about 19 chars each.  Only 1 of those names
+                         * ended with 'D' and wasn't an &AUTOLOAD--it
+                         * was &overload::OVERLOAD.
+                         *    --dmr 2/19/96
+                         */
+
+                        if( strcmp( pv+len-9, ":AUTOLOAD" ) == 0 ){
+                                /* The sub name is in $AUTOLOAD */
+                                sv = perl_get_sv( pv, 0 );
+                                if( sv == NULL ){
+                croak("DProf prof_mark() lost on AUTOLOAD (%s).\n", pv );
+                                }
+                                pv = SvPV( sv, na );
+                                DBG_SUB_NOTIFY( "  AUTOLOAD(%s)\n", pv );
+                        }
+                }
+                name = savepv( pv );
+        }
+#endif /* PERLDBf_NONAME */
+
+       total++;
+        if (SAVE_STACK) { /* Store it for later recording  -JH */
+           profstack[profstack_ix++].ptype = ptype;
+#ifdef PERLDBf_NONAME
+           profstack[profstack_ix++].id = id;
+#else
+           profstack[profstack_ix++].name = name;
+#endif 
+            /* Only record the parent's info */
+           if (SAVE_STACK < profstack_ix) {
+               if (prof_pid == (int)getpid())
+                   prof_dump_until(profstack_ix);
+               else
+                   perldb = 0;         /* Do not debug the kid. */
+               profstack_ix = 0;
+           }
+        } else { /* Write it to disk now so's not to eat up core */
+
+            /* Only record the parent's info */
+            if (prof_pid == (int)getpid()) {
+#ifdef PERLDBf_NONAME
+               prof_dumpa(ptype, id);
+#else
+               prof_dump(ptype, name);
+#endif 
+                fflush(fp);
+            } else
+               perldb = 0;             /* Do not debug the kid. */
+        }
+}
+
+static U32 default_perldb;
+
+#ifdef PL_NEEDED
+#  define defstash PL_defstash
+#endif
+
+/* Counts overhead of prof_mark and extra XS call. */
+static void
+test_time(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 = curstash;
+    struct tms t1, t2;
+    clock_t realtime1, realtime2;
+    U32 ototal = total;
+    U32 ostack = SAVE_STACK;
+    U32 operldb = perldb;
+
+    SAVE_STACK = 1000000;
+    realtime1 = Times(&t1);
+    
+    while (k < 2) {
+       i = 0;
+           /* Disable debugging of perl_call_sv on second pass: */
+       curstash = (k == 0 ? defstash : debstash);
+       perldb = default_perldb;
+       while (++i <= 100) {
+           j = 0;
+           profstack_ix = 0;           /* Do not let the stack grow */
+           while (++j <= 100) {
+/*             prof_mark( OP_ENTERSUB ); */
+
+               PUSHMARK( stack_sp );
+               perl_call_sv( (SV*)cv, G_SCALAR );
+               stack_sp--;
+/*             prof_mark( OP_LEAVESUB ); */
+           }
+       }
+       curstash = oldstash;
+       if (k == 0) {                   /* Put time with debugging */
+           realtime2 = Times(&t2);
+           *r = realtime2 - realtime1;
+           *u = t2.tms_utime - t1.tms_utime;
+           *s = t2.tms_stime - t1.tms_stime;
+       } else {                        /* Subtract time without debug */
+           realtime1 = Times(&t1);
+           *r -= realtime1 - realtime2;
+           *u -= t1.tms_utime - t2.tms_utime;
+           *s -= t1.tms_stime - t2.tms_stime;      
+       }
+       k++;
+    }
+    total = ototal;
+    SAVE_STACK = ostack;
+    perldb = operldb;
+}
+
+static void
+prof_recordheader()
+{
+       clock_t r, u, s;
+
+        /* fp is opened in the BOOT section */
+        PerlIO_printf(fp, "#fOrTyTwO\n" );
+        PerlIO_printf(fp, "$hz=%d;\n", DPROF_HZ );
+        PerlIO_printf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION );
+        PerlIO_printf(fp, "# All values are given in HZ\n" );
+       test_time(&r, &u, &s);
+        PerlIO_printf(fp, "$over_utime=%ld; $over_stime=%ld; $over_rtime=%ld;\n",
+                u, s, r);
+        PerlIO_printf(fp, "$over_tests=10000;\n");
+
+        TIMES_LOCATION = ftell(fp);
+
+        /* Pad with whitespace. */
+        /* This should be enough even for very large numbers. */
+        PerlIO_printf(fp, "%*s\n", 240 , "");
+
+        PerlIO_printf(fp, "\n");
+        PerlIO_printf(fp, "PART2\n" );
+
+        fflush(fp);
+}
+
+static void
+prof_record()
+{
+        /* fp is opened in the BOOT section */
+
+        /* Now that we know the runtimes, fill them in at the recorded
+           location -JH */
+
+       clock_t r, u, s;
+    
+        if(SAVE_STACK){
+           prof_dump_until(profstack_ix);
+        }
+        fseek(fp, TIMES_LOCATION, SEEK_SET);
+       /* Write into reserved 240 bytes: */
+        PerlIO_printf(fp, "$rrun_utime=%ld; $rrun_stime=%ld; $rrun_rtime=%ld;",
+                prof_end.tms_utime - prof_start.tms_utime - wprof_u,
+                prof_end.tms_stime - prof_start.tms_stime - wprof_s,
+                rprof_end - rprof_start - wprof_r );
+        PerlIO_printf(fp, "\n$total_marks=%ld;", total);
+       
+        fclose( fp );
+}
+
+#define NONESUCH()
+
+static U32 depth = 0;
+
+static void
+check_depth(void *foo)
+{
+    U32 need_depth = (U32)foo;
+    if (need_depth != depth) {
+       if (need_depth > depth) {
+           warn("garbled call depth when profiling");
+       } else {
+           I32 marks = depth - need_depth;
+
+/*         warn("Check_depth: got %d, expected %d\n", depth, need_depth); */
+           while (marks--) {
+               prof_mark( OP_DIE );
+           }
+           depth = need_depth;
+       }
+    }
+}
+
+#define for_real
+#ifdef for_real
+
+XS(XS_DB_sub)
+{
+        dXSARGS;
+        dORIGMARK;
+        HV *oldstash = curstash;
+
+        SP -= items;
+
+        DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
+
+#ifndef PERLDBf_NONAME                 /* Was needed on older Perls */
+        sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
+#endif 
+
+       SAVEDESTRUCTOR(check_depth, (void*)depth);
+       depth++;
+
+        prof_mark( OP_ENTERSUB );
+        PUSHMARK( ORIGMARK );
+
+#ifdef G_NODEBUG
+        perl_call_sv( (SV*)SvIV(Sub), GIMME | G_NODEBUG);
+#else
+        curstash = debstash;    /* To disable debugging of perl_call_sv */
+#ifdef PERLDBf_NONAME
+        perl_call_sv( (SV*)SvIV(Sub), GIMME );
+#else
+        perl_call_sv( Sub, GIMME );
+#endif 
+        curstash = oldstash;
+#endif 
+
+        prof_mark( OP_LEAVESUB );
+       depth--;
+
+        SPAGAIN;
+        PUTBACK;
+        return;
+}
+
+XS(XS_DB_goto)
+{
+        prof_mark( OP_GOTO );
+        return;
+}
+
+#endif /* for_real */
+
+#ifdef testing
+
+        MODULE = Devel::DProf           PACKAGE = DB
+
+        void
+        sub(...)
+                PPCODE:
+
+                dORIGMARK;
+                HV *oldstash = curstash;
+                /* SP -= items;  added by xsubpp */
+                DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
+
+                sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
+
+                prof_mark( OP_ENTERSUB );
+                PUSHMARK( ORIGMARK );
+
+                curstash = debstash;    /* To disable debugging of perl_call_sv
+*/
+                perl_call_sv( Sub, GIMME );
+                curstash = oldstash;
+
+                prof_mark( OP_LEAVESUB );
+                SPAGAIN;
+                /* PUTBACK;  added by xsubpp */
+
+#endif /* testing */
+
+MODULE = Devel::DProf           PACKAGE = Devel::DProf
+
+void
+END()
+        PPCODE:
+        if( DBsub ){
+                /* maybe the process forked--we want only
+                 * the parent's profile.
+                 */
+                if( prof_pid == (int)getpid() ){
+                        rprof_end = Times(&prof_end);
+                        DBG_TIMER_NOTIFY("Profiler timer is off.\n");
+                        prof_record();
+                }
+        }
+
+void
+NONESUCH()
+
+BOOT:
+        /* Before we go anywhere make sure we were invoked
+         * properly, else we'll dump core.
+         */
+        if( ! DBsub )
+                croak("DProf: run perl with -d to use DProf.\n");
+
+        /* When we hook up the XS DB::sub we'll be redefining
+         * the DB::sub from the PM file.  Turn off warnings
+         * while we do this.
+         */
+        {
+                I32 warn_tmp = dowarn;
+                dowarn = 0;
+                newXS("DB::sub", XS_DB_sub, file);
+                newXS("DB::goto", XS_DB_goto, file);
+                dowarn = warn_tmp;
+        }
+
+        Sub = GvSV(DBsub);       /* name of current sub */
+        sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
+
+       {
+           char *buffer = getenv("PERL_DPROF_BUFFER");
+
+           if (buffer) {
+               SAVE_STACK = atoi(buffer);
+           }
+
+           buffer = getenv("PERL_DPROF_TICKS");
+
+           if (buffer) {
+               dprof_ticks = atoi(buffer); /* Used under OS/2 only */
+           } else {
+               dprof_ticks = HZ;
+           }
+       }
+
+        if( (fp = fopen( "tmon.out", "w" )) == NULL )
+                croak("DProf: unable to write tmon.out, errno = %d\n", errno );
+#ifdef PERLDBf_NONAME
+       default_perldb = PERLDBf_NONAME | PERLDBf_SUB; /* no name needed. */
+#ifdef PERLDBf_GOTO
+       default_perldb = default_perldb | PERLDBf_GOTO;
+#endif 
+       cv_hash = newHV();
+#else
+#  ifdef PERLDBf_SUB
+       default_perldb = PERLDBf_SUB;           /* debug subroutines only. */
+#  endif
+#endif
+        prof_pid = (int)getpid();
+
+       New( 0, profstack, profstack_max, PROFANY );
+
+        prof_recordheader();
+
+        DBG_TIMER_NOTIFY("Profiler timer is on.\n");
+        orealtime = rprof_start = Times(&prof_start);
+       otms_utime = prof_start.tms_utime;
+       otms_stime = prof_start.tms_stime;
+       perldb = default_perldb;
diff --git a/ext/DProf/Makefile.PL b/ext/DProf/Makefile.PL
new file mode 100644 (file)
index 0000000..ec23edb
--- /dev/null
@@ -0,0 +1,55 @@
+use ExtUtils::MakeMaker;
+require 5.003;
+die qq{
+
+Your perl is too old for this version of DProf. The last version of
+DProf that works for perls older than 5.004 is DProf-19960930 and
+should be available from Dean Roehrich\'s directory on CPAN:
+
+    CPAN/authors/id/DMR/
+
+Please either upgrade your perl or get that older DProf from CPAN.
+
+} if $] < 5.004;
+
+if ($] < 5.005) {
+  $defines = '';
+} else {
+  $defines = '-DPERLDBf_NONAME=0x40 -DPERLDBf_GOTO=0x80 -DG_NODEBUG=32 -DPL_NEEDED';
+}
+
+$Verbose = 1;
+WriteMakefile(
+       'NAME'          => 'Devel::DProf',
+       'DISTNAME'      => 'DProf',
+       'VERSION_FROM'  => 'DProf.pm',
+       'clean'         => {'FILES' => 'tmon.out t/tmon.out t/err dprofpp T/tmon.out'},
+       'EXE_FILES'     => ['dprofpp'],
+       'PL_FILES'      => {'dprofpp.PL' => 'dprofpp'},
+       'XSPROTOARG'    => '-noprototypes',
+       'DEFINE'        => $defines,
+       'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz' },
+);
+
+sub MY::test_via_harness { "" }
+#sub MY::test_via_harness {
+#      my( $self, $perl, $tests ) = @_;
+#      my $t = quotemeta( $tests );
+#      my $res;
+#
+#      $res = $self->MM::test_via_harness( $perl, $tests );
+#      $res =~ s/^(\s+)/$1-/;
+#      $res =~ s/(&runtests)/\$\$switches $1/;
+#      $res =~ s/(; runtests)/; \$\$switches=q{-d:DProf}$1/;
+#      $res =~ s,$t,t/bug.t,;
+#      $res;
+#}
+
+sub MY::test_via_script {
+       my( $self, $perl, $script ) = @_;
+       my $res;
+
+       $res = $self->MM::test_via_script( $perl, $script );
+       $res =~ s/(test.pl)/$1 -p $perl/;
+       $res;
+}
diff --git a/ext/DProf/Todo b/ext/DProf/Todo
new file mode 100644 (file)
index 0000000..0e00347
--- /dev/null
@@ -0,0 +1,13 @@
+- work on test suite.
+- localize the depth to guard against non-local exits.
+Current overhead (with PERLDBf_NONAME) wrt non-debugging run (estimates):
+        8% extra call frame on DB::sub
+        7% output of subroutine data
+       70% output of timing data (on OS/2, 35% with custom dprof_times())
+(Additional 17% are spent to write the output, but they are counted
+ and subtracted.)  
+
+With compensation for DProf overhead all but some odd 12% are subtracted ?!
+
+- Calculate overhead/count for XS calls and Perl calls separately.
+- goto &XSUB in pp_ctl.c;
diff --git a/ext/DProf/dprofpp.PL b/ext/DProf/dprofpp.PL
new file mode 100644 (file)
index 0000000..c513062
--- /dev/null
@@ -0,0 +1,800 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+
+# List explicitly here the variables you want Configure to
+# generate.  Metaconfig only looks for shell variables, so you
+# have to mention them as if they were shell variables, not
+# %Config entries.  Thus you write
+#  $startperl
+# to ensure Configure will look for $Config{startperl}.
+
+# This forces PL files to create target in same directory as PL file.
+# This is so that make depend always knows where to find PL derivatives.
+chdir(dirname($0));
+($file = basename($0)) =~ s/\.PL$//;
+$file =~ s/\.pl$//
+       if ($Config{'osname'} eq 'VMS' or
+           $Config{'osname'} eq 'OS2');  # "case-forgiving"
+
+print "Pulling version from Makefile for dprofpp...\n";
+my $VERSION = 0;
+open( MK, "<Makefile" ) || die "Can't open Makefile: $!";
+while(<MK>){
+       if( /^VERSION\s*=\s*(\d+)/ ){
+               $VERSION = $1;
+               last;
+       }
+}
+close MK;
+if( $VERSION == 0 ){
+       die "Did not find VERSION in Makefile";
+}
+print "   version is ($VERSION).\n";
+
+open OUT,">$file" or die "Can't create $file: $!";
+
+print "Extracting $file (with variable substitutions)\n";
+
+# In this section, perl variables will be expanded during extraction.
+# You can use $Config{...} to use Configure variables.
+
+print OUT <<"!GROK!THIS!";
+$Config{'startperl'}
+    eval 'exec perl -S \$0 "\$@"'
+       if 0;
+
+require 5.003;
+
+my \$VERSION = $VERSION;
+
+!GROK!THIS!
+
+# In the following, perl variables are not expanded during extraction.
+
+print OUT <<'!NO!SUBS!';
+=head1 NAME
+
+dprofpp - display perl profile data
+
+=head1 SYNOPSIS
+
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-s>|B<-r>|B<-u>] [B<-q>] [B<-F>] [B<-I|-E>] [B<-O cnt>] [B<-A>] [B<-R>] [B<-S>] [B<-g subroutine>] [profile]
+
+dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-p script> [B<-Q>] [other opts]
+
+dprofpp B<-V> [profile]
+
+=head1 DESCRIPTION
+
+The I<dprofpp> command interprets profile data produced by a profiler, such
+as the Devel::DProf profiler.  Dprofpp will read the file F<tmon.out> and
+will display the 15 subroutines which are using the most time.  By default
+the times for each subroutine are given exclusive of the times of their
+child subroutines.
+
+To profile a Perl script run the perl interpreter with the B<-d> switch.  So
+to profile script F<test.pl> with Devel::DProf the following command should
+be used.
+
+       $ perl5 -d:DProf test.pl
+
+Then run dprofpp to analyze the profile.
+
+       $ dprofpp -u
+       Total Elapsed Time =    1.67 Seconds
+                User Time =    0.61 Seconds
+       Exclusive Times
+       %Time Seconds     #Calls sec/call Name
+        52.4   0.320          2   0.1600 main::foo
+        45.9   0.280        200   0.0014 main::bar
+        0.00   0.000          1   0.0000 DynaLoader::import
+        0.00   0.000          1   0.0000 main::baz
+
+The dprofpp tool can also run the profiler before analyzing the profile
+data.  The above two commands can be executed with one dprofpp command.
+
+       $ dprofpp -u -p test.pl
+
+Consult L<Devel::DProf/"PROFILE FORMAT"> for a description of the raw profile.
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-a>
+
+Sort alphabetically by subroutine names.
+
+=item B<-A>
+
+Count timing for autoloaded subroutine as timing for C<*::AUTOLOAD>.
+Otherwise the time to autoload it is counted as time of the subroutine
+itself (there is no way to separate autoload time from run time).
+
+This is going to be irrelevant with newer Perls.  They will inform
+C<Devel::DProf> I<when> the C<AUTOLOAD> switches to actual subroutine,
+so a separate statistics for C<AUTOLOAD> will be collected no matter
+whether this option is set.
+
+=item B<-R>
+
+Count anonymous subroutines defined in the same package separately.
+
+=item B<-E>
+
+(default)  Display all subroutine times exclusive of child subroutine times.
+
+=item B<-F>
+
+Force the generation of fake exit timestamps if dprofpp reports that the
+profile is garbled.  This is only useful if dprofpp determines that the
+profile is garbled due to missing exit timestamps.  You're on your own if
+you do this.  Consult the BUGS section.
+
+=item B<-I>
+
+Display all subroutine times inclusive of child subroutine times.
+
+=item B<-l>
+
+Sort by number of calls to the subroutines.  This may help identify
+candidates for inlining.
+
+=item B<-O cnt>
+
+Show only I<cnt> subroutines.  The default is 15.
+
+=item B<-p script>
+
+Tells dprofpp that it should profile the given script and then interpret its
+profile data.  See B<-Q>.
+
+=item B<-Q>
+
+Used with B<-p> to tell dprofpp to quit after profiling the script, without
+interpreting the data.
+
+=item B<-q>
+
+Do not display column headers.
+
+=item B<-r>
+
+Display elapsed real times rather than user+system times.
+
+=item B<-s>
+
+Display system times rather than user+system times.
+
+=item B<-T>
+
+Display subroutine call tree to stdout.  Subroutine statistics are
+not displayed.
+
+=item B<-t>
+
+Display subroutine call tree to stdout.  Subroutine statistics are not
+displayed.  When a function is called multiple consecutive times at the same
+calling level then it is displayed once with a repeat count.
+
+=item B<-S>
+
+Display I<merged> subroutine call tree to stdout.  Statistics is
+displayed for each branch of the tree.  
+
+When a function is called multiple (I<not necessarily consecutive>)
+times in the same branch then all these calls go into one branch of
+the next level.  A repeat count is output together with combined
+inclusive, exclusive and kids time.
+
+Branches are sorted w.r.t. inclusive time.
+
+=item B<-U>
+
+Do not sort.  Display in the order found in the raw profile.
+
+=item B<-u>
+
+Display user times rather than user+system times.
+
+=item B<-V>
+
+Print dprofpp's version number and exit.  If a raw profile is found then its
+XS_VERSION variable will be displayed, too.
+
+=item B<-v>
+
+Sort by average time spent in subroutines during each call.  This may help
+identify candidates for inlining. 
+
+=item B<-z>
+
+(default) Sort by amount of user+system time used.  The first few lines
+should show you which subroutines are using the most time.
+
+=item B<-g> C<subroutine>
+
+Ignore subroutines except C<subroutine> and whatever is called from it.
+
+=back
+
+=head1 ENVIRONMENT
+
+The environment variable B<DPROFPP_OPTS> can be set to a string containing
+options for dprofpp.  You might use this if you prefer B<-I> over B<-E> or
+if you want B<-F> on all the time.
+
+This was added fairly lazily, so there are some undesirable side effects.
+Options on the commandline should override options in DPROFPP_OPTS--but
+don't count on that in this version.
+
+=head1 BUGS
+
+Applications which call _exit() or exec() from within a subroutine
+will leave an incomplete profile.  See the B<-F> option.
+
+Any bugs in Devel::DProf, or any profiler generating the profile data, could
+be visible here.  See L<Devel::DProf/BUGS>.
+
+Mail bug reports and feature requests to the perl5-porters mailing list at
+F<E<lt>perl5-porters@perl.orgE<gt>>.  Bug reports should include the
+output of the B<-V> option.
+
+=head1 FILES
+
+       dprofpp         - profile processor
+       tmon.out        - raw profile
+
+=head1 SEE ALSO
+
+L<perl>, L<Devel::DProf>, times(2)
+
+=cut
+
+use Getopt::Std 'getopts';
+use Config '%Config';
+
+Setup: {
+       my $options = 'O:g:lzaAvuTtqrRsUFEIp:QVS';
+
+       $Monfile = 'tmon.out';
+       if( exists $ENV{DPROFPP_OPTS} ){
+               my @tmpargv = @ARGV;
+               @ARGV = split( ' ', $ENV{DPROFPP_OPTS} );
+               getopts( $options );
+               if( @ARGV ){
+                       # there was a filename.
+                       $Monfile = shift;
+               }
+               @ARGV = @tmpargv;
+       }
+
+       getopts( $options );
+       if( @ARGV ){
+               # there was a filename, it overrides any earlier name.
+               $Monfile = shift;
+       }
+
+# -O cnt       Specifies maximum number of subroutines to display.
+# -a           Sort by alphabetic name of subroutines.
+# -z           Sort by user+system time spent in subroutines. (default)
+# -l           Sort by number of calls to subroutines.
+# -v           Sort by average amount of time spent in subroutines.
+# -T           Show call tree.
+# -t           Show call tree, compressed.
+# -q           Do not print column headers.
+# -u           Use user time rather than user+system time.
+# -s           Use system time rather than user+system time.
+# -r           Use real elapsed time rather than user+system time.
+# -U           Do not sort subroutines.
+# -E           Sub times are reported exclusive of child times. (default)
+# -I           Sub times are reported inclusive of child times.
+# -V           Print dprofpp's version.
+# -p script    Specifies name of script to be profiled.
+# -Q           Used with -p to indicate the dprofpp should quit after
+#              profiling the script, without interpreting the data.
+# -A           count autoloaded to *AUTOLOAD
+# -R           count anonyms separately even if from the same package
+# -g subr      count only those who are SUBR or called from SUBR
+# -S           Create statistics for all the depths
+
+       if( defined $opt_V ){
+               my $fh = 'main::fh';
+               print "$0 version: $VERSION\n";
+               open( $fh, "<$Monfile" ) && do {
+                       local $XS_VERSION = 'early';
+                       header($fh);
+                       close( $fh );
+                       print "XS_VERSION: $XS_VERSION\n";
+               };
+               exit(0);
+       }
+       $cnt = $opt_O || 15;
+       $sort = 'by_time';
+       $sort = 'by_ctime' if defined $opt_I;
+       $sort = 'by_calls' if defined $opt_l;
+       $sort = 'by_alpha' if defined $opt_a;
+       $sort = 'by_avgcpu' if defined $opt_v;
+       $incl_excl = 'Exclusive';
+       $incl_excl = 'Inclusive' if defined $opt_I;
+       $whichtime = 'User+System';
+       $whichtime = 'System' if defined $opt_s;
+       $whichtime = 'Real' if defined $opt_r;
+       $whichtime = 'User' if defined $opt_u;
+
+       if( defined $opt_p ){
+               my $prof = 'DProf';
+               my $startperl = $Config{'startperl'};
+
+               $startperl =~ s/^#!//; # remove shebang
+               run_profiler( $opt_p, $prof, $startperl );
+               $Monfile = 'tmon.out';  # because that's where it is
+               exit(0) if defined $opt_Q;
+       }
+       elsif( defined $opt_Q ){
+               die "-Q is meaningful only when used with -p\n";
+       }
+}
+
+Main: {
+       my $monout = $Monfile;
+       my $fh = 'main::fh';
+       local $names = {};
+       local $times = {};   # times in hz
+       local $ctimes = {};  # Cumulative times in hz
+       local $calls = {};
+       local $persecs = {}; # times in seconds
+       local $idkeys = [];
+       local $runtime; # runtime in seconds
+       my @a = ();
+       my $a;
+       local $rrun_utime = 0;  # user time in hz
+       local $rrun_stime = 0;  # system time in hz
+       local $rrun_rtime = 0;  # elapsed run time in hz
+       local $rrun_ustime = 0; # user+system time in hz
+       local $hz = 0;
+       local $deep_times = {count => 0 , kids => {}, incl_time => 0};
+       local $time_precision = 2;
+       local $overhead = 0;
+
+       open( $fh, "<$monout" ) || die "Unable to open $monout\n";
+
+       header($fh);
+
+       $rrun_ustime = $rrun_utime + $rrun_stime;
+
+       $~ = 'STAT';
+       if( ! $opt_q ){
+               $^ = 'CSTAT_top';
+       }
+
+       parsestack( $fh, $names, $calls, $times, $ctimes, $idkeys );
+
+       settime( \$runtime, $hz ) unless $opt_g;
+
+       exit(0) if $opt_T || $opt_t;
+
+       if( $opt_v ){
+               percalc( $calls, ($opt_I ? $ctimes : $times), $persecs, $idkeys );
+       }
+       if( ! $opt_U ){
+               @a = sort $sort @$idkeys;
+               $a = \@a;
+       }
+       else {
+               $a = $idkeys;
+       }
+       display( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, $a,
+                $deep_times);
+}
+
+
+# Sets $runtime to user, system, real, or user+system time.  The
+# result is given in seconds.
+#
+sub settime {
+  my( $runtime, $hz ) = @_;
+  
+  if( $opt_r ){
+    $$runtime = ($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2)/$hz;
+  }
+  elsif( $opt_s ){
+    $$runtime = ($rrun_stime - $overhead - $over_stime * $total_marks/$over_tests/2)/$hz;
+  }
+  elsif( $opt_u ){
+    $$runtime = ($rrun_utime - $overhead - $over_utime * $total_marks/$over_tests/2)/$hz;
+  }
+  else{
+    $$runtime = ($rrun_ustime - $overhead - ($over_utime + $over_stime) * $total_marks/$over_tests/2)/$hz;
+  }
+  $$runtime = 0 unless $$runtime > 0;
+}
+
+sub exclusives_in_tree {
+  my( $deep_times ) = @_;
+  my $kids_time = 0;
+  my $kid;
+  # When summing, take into account non-rounded-up kids time.
+  for $kid (keys %{$deep_times->{kids}}) {
+    $kids_time += $deep_times->{kids}{$kid}{incl_time};
+  }
+  $kids_time = 0 unless $kids_time >= 0;
+  $deep_times->{excl_time} = $deep_times->{incl_time} - $kids_time;
+  $deep_times->{excl_time} = 0 unless $deep_times->{excl_time} >= 0;
+  for $kid (keys %{$deep_times->{kids}}) {
+    exclusives_in_tree($deep_times->{kids}{$kid});
+  }
+  $deep_times->{incl_time} = 0 unless $deep_times->{incl_time} >= 0;
+  $deep_times->{kids_time} = $kids_time;
+}
+
+sub kids_by_incl { $kids{$b}{incl_time} <=> $kids{$a}{excl_time} 
+                  or $a cmp $b }
+
+sub display_tree {
+  my( $deep_times, $name, $level ) = @_;
+  exclusives_in_tree($deep_times);
+  
+  my $kid;
+  local *kids = $deep_times->{kids}; # %kids
+
+  my $time;
+  if (%kids) {
+    $time = sprintf '%.*fs = (%.*f + %.*f)', 
+      $time_precision, $deep_times->{incl_time}/$hz,
+        $time_precision, $deep_times->{excl_time}/$hz,
+          $time_precision, $deep_times->{kids_time}/$hz;
+  } else {
+    $time = sprintf '%.*f', $time_precision, $deep_times->{incl_time}/$hz;
+  }
+  print ' ' x (2*$level), "$name x $deep_times->{count}  \t${time}s\n"
+    if $deep_times->{count};
+
+  for $kid (sort kids_by_incl keys %kids) {
+    display_tree( $deep_times->{kids}{$kid}, $kid, $level + 1 );
+  }  
+}
+
+# Report the times in seconds.
+sub display {
+       my( $runtime, $hz, $names, $calls, $times, $ctimes, $cnt, 
+           $idkeys, $deep_times ) = @_;
+       my( $x, $key, $s, $cs );
+       #format: $ncalls, $name, $secs, $percall, $pcnt
+
+       if ($opt_S) {
+         display_tree( $deep_times, 'toplevel', -1 )
+       } else {
+         for( $x = 0; $x < @$idkeys; ++$x ){
+           $key = $idkeys->[$x];
+           $ncalls = $calls->{$key};
+           $name = $names->{$key};
+           $s = $times->{$key}/$hz;
+           $secs = sprintf("%.3f", $s );
+           $cs = $ctimes->{$key}/$hz;
+           $csecs = sprintf("%.3f", $cs );
+           $percall = sprintf("%.4f", $s/$ncalls );
+           $cpercall = sprintf("%.4f", $cs/$ncalls );
+           $pcnt = sprintf("%.2f",
+                           $runtime? ((($opt_I ? $csecs : $secs) / $runtime) * 100.0): 0 );
+           write;
+           $pcnt = $secs = $ncalls = $percall = "";
+           write while( length $name );
+           last unless --$cnt;
+         }       
+       }
+}
+
+sub move_keys {
+  my ($source, $dest) = @_;
+  my $kid;
+  
+  for $kid (keys %$source) {
+    if (exists $dest->{$kid}) {
+      $dest->{count} += $source->{count};
+      $dest->{incl_time} += $source->{incl_time};
+      move_keys($source->{kids},$dest->{kids});
+    } else {
+      $dest->{$kid} = delete $source->{$kid};
+    }
+  }
+}
+
+sub add_to_tree {
+  my ($curdeep_times, $name, $t) = @_;
+  if ($name ne $curdeep_times->[-1]{name} and $opt_A) {
+    $name = $curdeep_times->[-1]{name};
+  }
+  die "Shorted?!" unless @$curdeep_times >= 2;
+  $curdeep_times->[-2]{kids}{$name} = { count => 0 , kids => {}, 
+                                       incl_time => 0,
+                                     } 
+    unless exists $curdeep_times->[-2]{kids}{$name};
+  my $entry = $curdeep_times->[-2]{kids}{$name};
+  # Now transfer to the new node (could not do earlier, since name can change)
+  $entry->{count}++;
+  $entry->{incl_time} += $t - $curdeep_times->[-1]{enter_stamp};
+  # Merge the kids?
+  move_keys($curdeep_times->[-1]->{kids},$entry->{kids});
+  pop @$curdeep_times;
+}
+
+sub parsestack {
+       my( $fh, $names, $calls, $times, $ctimes, $idkeys ) = @_;
+       my( $dir, $name );
+       my( $t, $syst, $realt, $usert );
+       my( $x, $z, $c, $id, $pack );
+       my @stack = ();
+       my @tstack = ();
+       my $tab = 3;
+       my $in = 0;
+
+       # remember last call depth and function name
+       my $l_in = $in;
+       my $l_name = '';
+       my $repcnt = 0;
+       my $repstr = '';
+       my $dprof_t = 0;
+       my $dprof_stamp;
+       my %cv_hash;
+       my $in_level = not defined $opt_g; # Level deep in report grouping
+       my $curdeep_times = [$deep_times];
+
+       my $over_per_call;
+       if   ( $opt_u ) {       $over_per_call = $over_utime            }
+       elsif( $opt_s ) {       $over_per_call = $over_stime            }
+       elsif( $opt_r ) {       $over_per_call = $over_rtime            }
+       else            {       $over_per_call = $over_utime + $over_stime }
+       $over_per_call /= 2*$over_tests; # distribute over entry and exit
+
+       while(<$fh>){
+               next if /^#/;
+               last if /^PART/;
+
+               chop;
+               if (/^&/) {
+                 ($dir, $id, $pack, $name) = split;
+                 if ($opt_R and ($name =~ /::(__ANON_|END)$/)) {
+                   $name .= "($id)";
+                 }
+                 $cv_hash{$id} = "$pack\::$name";
+                 next;
+               }
+               ($dir, $usert, $syst, $realt, $name) = split;
+
+               my $ot = $t;
+               if ( $dir eq '/' ) {
+                 $syst = $stack[-1][0];
+                 $usert = '&';
+                 $dir = '-';
+                 #warn("Inserted exit for $stack[-1][0].\n")
+               }
+               if (defined $realt) { # '+ times nam' '- times nam' or '@ incr'
+                 if   ( $opt_u )       {       $t = $usert             }
+                 elsif( $opt_s )       {       $t = $syst              }
+                 elsif( $opt_r )       {       $t = $realt             }
+                 else                  {       $t = $usert + $syst     }
+                 $t += $ot, next if $dir eq '@'; # Increments there
+               } else {
+                 # "- id" or "- & name"
+                 $name = defined $syst ? $syst : $cv_hash{$usert};
+               }
+
+               next unless $in_level or $name eq $opt_g or $dir eq '*';
+               if ( $dir eq '-' or $dir eq '*' ) {
+                       my $ename = $dir eq '*' ? $stack[-1][0]  : $name;
+                       $overhead += $over_per_call;
+                       if ($name eq "Devel::DProf::write") {
+                         $dprof_t += $t - $dprof_stamp;
+                         next;
+                       } elsif (defined $opt_g and $ename eq $opt_g) {
+                         $in_level--;
+                       }
+                       add_to_tree($curdeep_times, $ename,
+                                   $t - $dprof_t - $overhead) if $opt_S;
+                       exitstamp( \@stack, \@tstack, 
+                                  $t - $dprof_t - $overhead, 
+                                  $times, $ctimes, $ename, \$in, $tab, 
+                                  $curdeep_times );
+               } 
+               next unless $in_level or $name eq $opt_g;
+               if( $dir eq '+' or $dir eq '*' ){
+                       if ($name eq "Devel::DProf::write") {
+                         $dprof_stamp = $t;
+                         next;
+                       } elsif (defined $opt_g and $name eq $opt_g) {
+                         $in_level++;
+                       }
+                       $overhead += $over_per_call;
+                       if( $opt_T ){
+                               print ' ' x $in, "$name\n";
+                               $in += $tab;
+                       }
+                       elsif( $opt_t ){
+                               # suppress output on same function if the
+                               # same calling level is called.
+                               if ($l_in == $in and $l_name eq $name) {
+                                       $repcnt++;
+                               } else {
+                                       $repstr = ' ('.++$repcnt.'x)'
+                                                if $repcnt;
+                                       print ' ' x $l_in, "$l_name$repstr\n"
+                                               if $l_name ne '';
+                                       $repstr = '';
+                                       $repcnt = 0;
+                                       $l_in = $in;
+                                       $l_name = $name;
+                               }
+                               $in += $tab;
+                       }
+                       if( ! defined $names->{$name} ){
+                               $names->{$name} = $name;
+                               $times->{$name} = 0;
+                               $ctimes->{$name} = 0;
+                               push( @$idkeys, $name );
+                       }
+                       $calls->{$name}++;
+                       push @$curdeep_times, { kids => {}, 
+                                               name => $name, 
+                                               enter_stamp => $t - $dprof_t - $overhead,
+                                             } if $opt_S;
+                       $x = [ $name, $t - $dprof_t - $overhead ];
+                       push( @stack, $x );
+
+                       # my children will put their time here
+                       push( @tstack, 0 );
+               } elsif ($dir ne '-'){
+                   die "Bad profile: $_";
+               }
+       }
+       if( $opt_t ){
+               $repstr = ' ('.++$repcnt.'x)' if $repcnt;
+               print ' ' x $l_in, "$l_name$repstr\n";
+       }
+
+       if( @stack ){
+               if( ! $opt_F ){
+                       warn "Garbled profile is missing some exit time stamps:\n";
+                       foreach $x (@stack) {
+                               print $x->[0],"\n";
+                       }
+                       die "Try rerunning dprofpp with -F.\n";
+                       # I don't want -F to be default behavior--yet
+                       #  9/18/95 dmr
+               }
+               else{
+                       warn( "Faking " . scalar( @stack ) . " exit timestamp(s).\n");
+                       foreach $x ( reverse @stack ){
+                               $name = $x->[0];
+                               exitstamp( \@stack, \@tstack, 
+                                          $t - $dprof_t - $overhead, $times, 
+                                          $ctimes, $name, \$in, $tab, 
+                                          $curdeep_times );
+                               add_to_tree($curdeep_times, $name,
+                                           $t - $dprof_t - $overhead)
+                                 if $opt_S;
+                       }
+               }
+       }
+       if (defined $opt_g) {
+         $runtime = $ctimes->{$opt_g}/$hz;
+         $runtime = 0 unless $runtime > 0;
+       }
+}
+
+sub exitstamp {
+       my($stack, $tstack, $t, $times, $ctimes, $name, $in, $tab, $deep) = @_;
+       my( $x, $c, $z );
+
+       $x = pop( @$stack );
+       if( ! defined $x ){
+               die "Garbled profile, missing an enter time stamp";
+       }
+       if( $x->[0] ne $name ){
+         if ($x->[0] =~ /::AUTOLOAD$/) {
+           if ($opt_A) {
+             $name = $x->[0];
+           }
+         } elsif ( $opt_F ) {
+           warn( "Garbled profile, faking exit timestamp:\n\t$name => $x->[0].\n");
+           $name = $x->[0];
+         } else {
+           foreach $z (@stack, $x) {
+             print $z->[0],"\n";
+           }
+           die "Garbled profile, unexpected exit time stamp";
+         }
+       }
+       if( $opt_T || $opt_t ){
+               $$in -= $tab;
+       }
+       # collect childtime
+       $c = pop( @$tstack );
+       # total time this func has been active
+       $z = $t - $x->[1];
+       $ctimes->{$name} += $z;
+       $times->{$name} += ($z > $c)? $z - $c: 0;
+       # pass my time to my parent
+       if( @$tstack ){
+               $c = pop( @$tstack );
+               push( @$tstack, $c + $z );
+       }
+}
+
+
+sub header {
+       my $fh = shift;
+       chop($_ = <$fh>);
+       if( ! /^#fOrTyTwO$/ ){
+               die "Not a perl profile";
+       }
+       while(<$fh>){
+               next if /^#/;
+               last if /^PART/;
+               eval;
+       }
+       $over_tests = 1 unless $over_tests;
+       $time_precision = length int ($hz - 1); # log ;-)
+}
+
+
+# Report avg time-per-function in seconds
+sub percalc {
+       my( $calls, $times, $persecs, $idkeys ) = @_;
+       my( $x, $t, $n, $key );
+
+       for( $x = 0; $x < @$idkeys; ++$x ){
+               $key = $idkeys->[$x];
+               $n = $calls->{$key};
+               $t = $times->{$key} / $hz;
+               $persecs->{$key} = $t ? $t / $n : 0;
+       }
+}
+
+
+# Runs the given script with the given profiler and the given perl.
+sub run_profiler {
+       my $script = shift;
+       my $profiler = shift;
+       my $startperl = shift;
+
+       system $startperl, "-d:$profiler", $script;
+       if( $? / 256 > 0 ){
+               die "Failed: $startperl -d:$profiler $script: $!";
+       }
+}
+
+
+sub by_time { $times->{$b} <=> $times->{$a} }
+sub by_ctime { $ctimes->{$b} <=> $ctimes->{$a} }
+sub by_calls { $calls->{$b} <=> $calls->{$a} }
+sub by_alpha { $names->{$a} cmp $names->{$b} }
+sub by_avgcpu { $persecs->{$b} <=> $persecs->{$a} }
+
+
+format CSTAT_top =
+Total Elapsed Time = @>>>>>>> Seconds
+(($rrun_rtime - $overhead - $over_rtime * $total_marks/$over_tests/2) / $hz)
+  @>>>>>>>>>> Time = @>>>>>>> Seconds
+$whichtime, $runtime
+@<<<<<<<< Times
+$incl_excl
+%Time ExclSec CumulS #Calls sec/call Csec/c  Name
+.
+
+format STAT =
+ ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.
+
+!NO!SUBS!
+
+close OUT or die "Can't close $file: $!";
+chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
diff --git a/ext/DProf/t/V.pm b/ext/DProf/t/V.pm
new file mode 100644 (file)
index 0000000..e8d59a8
--- /dev/null
@@ -0,0 +1,65 @@
+package V;
+
+use Getopt::Std 'getopts';
+getopts('vp:');
+
+require Exporter;
+@ISA = 'Exporter';
+
+@EXPORT = qw( dprofpp $opt_v $results $expected report @results );
+@EXPORT_OK = qw( notok ok $num );
+
+my $out = 0;
+$num = 0;
+$results = $expected = '';
+$perl = $opt_p || $^X;
+
+print "\nperl: $perl\n" if $opt_v;
+if( ! -f $perl ){ die "Where's Perl?" }
+
+sub dprofpp {
+       my $switches = shift;
+
+       open( D, "$perl ../dprofpp $switches 2> err |" ) || warn "$0: Can't run. $!\n";
+       @results = <D>;
+       close D;
+
+       open( D, "<err" ) || warn "$0: Can't open: $!\n";
+       @err = <D>;
+       close D;
+       push( @results, @err ) if @err;
+
+       $results = qq{@results};
+       # ignore Loader (Dyna/Auto etc), leave newline
+       $results =~ s/^\w+Loader::import//;
+       $results =~ s/\n /\n/gm;
+       $results;
+}
+
+sub report {
+       $num = shift;
+       my $sub = shift;
+       my $x;
+
+       $x = &$sub;
+       $x ? &ok : &notok;
+}
+
+sub ok {
+       ++$out;
+       print "ok $num, ";
+}
+
+sub notok {
+       ++$out;
+       print "not ok $num, ";
+       if( $opt_v ){
+               print "\nResult\n{$results}\n";
+               print "Expected\n{$expected}\n";
+       }
+}
+
+END { print "\n" if $out }
+
+
+1;
diff --git a/ext/DProf/t/test1.pl b/ext/DProf/t/test1.pl
new file mode 100644 (file)
index 0000000..af792ed
--- /dev/null
@@ -0,0 +1,32 @@
+END { print "main:: the end\n" }
+sub FOO::END { print "foo:: the end\n" }
+
+
+sub foo {
+       my $x;
+       my $y;
+       print "in sub foo\n";
+       for( $x = 1; $x < 100; ++$x ){
+               bar();
+               for( $y = 1; $y < 100; ++$y ){
+               }
+       }
+}
+
+sub bar {
+       my $x;
+       print "in sub bar\n";
+       for( $x = 1; $x < 100; ++$x ){
+       }
+}
+
+sub baz {
+       print "in sub baz\n";
+       bar();
+       foo();
+}
+
+bar();
+baz();
+foo();
+
diff --git a/ext/DProf/t/test1.t b/ext/DProf/t/test1.t
new file mode 100644 (file)
index 0000000..d504cd5
--- /dev/null
@@ -0,0 +1,18 @@
+sub foo {
+       print "in sub foo\n";
+       bar();
+}
+
+sub bar {
+       print "in sub bar\n";
+}
+
+sub baz {
+       print "in sub baz\n";
+       bar();
+       foo();
+}
+
+bar();
+baz();
+foo();
diff --git a/ext/DProf/t/test1.v b/ext/DProf/t/test1.v
new file mode 100644 (file)
index 0000000..542a503
--- /dev/null
@@ -0,0 +1,24 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected = 
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 1, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 2, sub { $expected eq $results };
+
+dprofpp( '-t' );
+report 3, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 4, sub { $expected eq $results };
diff --git a/ext/DProf/t/test2.t b/ext/DProf/t/test2.t
new file mode 100644 (file)
index 0000000..edc46c5
--- /dev/null
@@ -0,0 +1,21 @@
+sub foo {
+       print "in sub foo\n";
+       bar();
+}
+
+sub bar {
+       print "in sub bar\n";
+}
+
+sub baz {
+       print "in sub baz\n";
+       bar();
+       bar();
+       bar();
+       foo();
+}
+
+bar();
+bar();
+baz();
+foo();
diff --git a/ext/DProf/t/test2.v b/ext/DProf/t/test2.v
new file mode 100644 (file)
index 0000000..3e9b183
--- /dev/null
@@ -0,0 +1,36 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::bar
+main::baz
+   main::bar
+   main::bar
+   main::bar
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 1, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 2, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected =
+qq{main::bar (2x)
+main::baz
+   main::bar (3x)
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 3, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 4, sub { $expected eq $results };
diff --git a/ext/DProf/t/test3.t b/ext/DProf/t/test3.t
new file mode 100644 (file)
index 0000000..a5327f4
--- /dev/null
@@ -0,0 +1,19 @@
+sub foo {
+       print "in sub foo\n";
+       exit(0);
+       bar();
+}
+
+sub bar {
+       print "in sub bar\n";
+}
+
+sub baz {
+       print "in sub baz\n";
+       bar();
+       foo();
+}
+
+bar();
+baz();
+foo();
diff --git a/ext/DProf/t/test3.v b/ext/DProf/t/test3.v
new file mode 100644 (file)
index 0000000..31211c1
--- /dev/null
@@ -0,0 +1,29 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$e1 = $expected =
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+};
+report 1, sub { $expected eq $results };
+
+dprofpp('-TF');
+$e2 = $expected =
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+};
+report 2, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected = $e1;
+report 3, sub { 1 };
+
+dprofpp('-tF');
+$expected = $e2;
+report 4, sub { $expected eq $results };
diff --git a/ext/DProf/t/test4.t b/ext/DProf/t/test4.t
new file mode 100644 (file)
index 0000000..7d5a356
--- /dev/null
@@ -0,0 +1,24 @@
+sub foo {
+       print "in sub foo\n";
+       bar();
+}
+
+sub bar {
+       print "in sub bar\n";
+}
+
+sub baz {
+       print "in sub baz\n";
+       bar();
+       bar();
+       bar();
+       foo();
+}
+
+bar();
+
+fork;
+
+bar();
+baz();
+foo();
diff --git a/ext/DProf/t/test4.v b/ext/DProf/t/test4.v
new file mode 100644 (file)
index 0000000..3e9b183
--- /dev/null
@@ -0,0 +1,36 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::bar
+main::baz
+   main::bar
+   main::bar
+   main::bar
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 1, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 2, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected =
+qq{main::bar (2x)
+main::baz
+   main::bar (3x)
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 3, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 4, sub { $expected eq $results };
diff --git a/ext/DProf/t/test5.t b/ext/DProf/t/test5.t
new file mode 100644 (file)
index 0000000..0b11137
--- /dev/null
@@ -0,0 +1,25 @@
+# Test that dprof doesn't break
+#    &bar;  used as &bar(@_);
+
+sub foo1 {
+       print "in foo1(@_)\n";
+       bar(@_);
+}
+sub foo2 {
+       print "in foo2(@_)\n";
+       &bar;
+}
+sub bar {
+       print "in bar(@_)\n";
+       if( @_ > 0 ){
+               &yeppers;
+       }
+}
+sub yeppers {
+       print "rest easy\n";
+}
+
+
+&foo1( A );
+&foo2( B );
+
diff --git a/ext/DProf/t/test5.v b/ext/DProf/t/test5.v
new file mode 100644 (file)
index 0000000..8f90252
--- /dev/null
@@ -0,0 +1,15 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::foo1
+   main::bar
+      main::yeppers
+main::foo2
+   main::bar
+      main::yeppers
+};
+report 1, sub { $expected eq $results };
+
diff --git a/ext/DProf/t/test6.t b/ext/DProf/t/test6.t
new file mode 100644 (file)
index 0000000..7b8bf4a
--- /dev/null
@@ -0,0 +1,29 @@
+sub foo {
+       my $x;
+       my $y;
+       print "in sub foo\n";
+       for( $x = 1; $x < 100; ++$x ){
+               bar();
+               for( $y = 1; $y < 100; ++$y ){
+               }
+       }
+}
+
+sub bar {
+       my $x;
+       print "in sub bar\n";
+       for( $x = 1; $x < 100; ++$x ){
+       }
+       die "bar exiting";
+}
+
+sub baz {
+       print "in sub baz\n";
+       eval { bar(); };
+       eval { foo(); };
+}
+
+eval { bar(); };
+baz();
+eval { foo(); };
+
diff --git a/ext/DProf/t/test6.v b/ext/DProf/t/test6.v
new file mode 100644 (file)
index 0000000..1236285
--- /dev/null
@@ -0,0 +1,16 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+      main::bar
+main::foo
+   main::bar
+};
+report 1, sub { $expected eq $results };
+
diff --git a/ext/DProf/test.pl b/ext/DProf/test.pl
new file mode 100644 (file)
index 0000000..a889fec
--- /dev/null
@@ -0,0 +1,79 @@
+# perl
+
+require 5.003;
+
+use Benchmark qw( timediff timestr );
+use Getopt::Std 'getopts';
+use Config '%Config';
+getopts('vI:p:');
+
+# -v   Verbose
+# -I   Add to @INC
+# -p   Name of perl binary
+
+unless (-r 'dprofpp' and -M 'dprofpp' <= -M 'dprofpp.PL') {
+  print STDERR "dprofpp out of date, extracting...\n";
+  system 'perl', 'dprofpp.PL' and die 'perl dprofpp.PL: exit code $?, $!';
+}
+die "Need dprofpp, could not make it" unless -r 'dprofpp';
+
+chdir( 't' ) if -d 't';
+@tests = @ARGV ? @ARGV : sort <*.t *.v>;  # glob-sort, for OS/2
+
+$path_sep = $Config{path_sep} || ':';
+if( -d '../blib' ){
+       unshift @INC, '../blib/arch', '../blib/lib';
+}
+$perl5lib = $opt_I || join( $path_sep, @INC );
+$perl = $opt_p || $^X;
+
+if( $opt_v ){
+       print "tests: @tests\n";
+       print "perl: $perl\n";
+       print "perl5lib: $perl5lib\n";
+}
+if( $perl =~ m|^\./| ){
+       # turn ./perl into ../perl, because of chdir(t) above.
+       $perl = ".$perl";
+}
+if( ! -f $perl ){ die "Where's Perl?" }
+
+sub profile {
+       my $test = shift;
+       my @results;
+       local $ENV{PERL5LIB} = $perl5lib;
+       my $opt_d = '-d:DProf';
+
+       my $t_start = new Benchmark;
+       open( R, "$perl $opt_d $test |" ) || warn "$0: Can't run. $!\n";
+       @results = <R>;
+       close R;
+       my $t_total = timediff( new Benchmark, $t_start );
+
+       if( $opt_v ){
+               print "\n";
+               print @results
+       }
+
+       print timestr( $t_total, 'nop' ), "\n";
+}
+
+
+sub verify {
+       my $test = shift;
+
+       system $perl, '-I.', $test, $opt_v?'-v':'', '-p', $perl;
+}
+
+
+$| = 1;
+while( @tests ){
+       $test = shift @tests;
+       print $test . '.' x (20 - length $test);
+       if( $test =~ /t$/ ){
+               profile $test;
+       }
+       else{
+               verify $test;
+       }
+}