Dual-life Devel::DProf

It's not actually on CPAN yet, but it will be in the next couple of days.

24 files changed, 2705 insertions, 0 deletions

diff --git a/cpan/Devel-DProf/Changes b/cpan/Devel-DProf/Changes
new file mode 100644
index 0000000000..1d1ba0e7b9
--- /dev/null
+++ b/cpan/Devel-DProf/Changes
@@ -0,0 +1,204 @@
+2003 Aug 1
+ Radu Greab:
+  DProf.xs:
+    - do not assume that $^P stays unchanged inside the profiled subroutine
+  DProf.pm:
+    - increase VERSION
+
+2003 Jul 6
+
+ Radu Greab:
+  DProf.xs:
+    - improved the mapping between subroutines and identifiers
+    - do not assume that $^P stays unchanged during the lifetime of the script
+    - panic when the profiled subroutine is leaved with goto/last/next
+  DProf.pm:
+    - document the problem with the subroutines exited with goto/last/next
+  t/test{7,8}*
+    - added
+
+2003 Jan 8
+
+ Blair Zajac:
+  DProf.xs:
+    - To avoid core dumps, increase stack size by 10 instead of 5.
+    - Assert that g_profstack is large enough when DEBUGGING is defined
+  DProf.pm:
+    - Bump VERSION.
+
+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/cpan/Devel-DProf/DProf.pm b/cpan/Devel-DProf/DProf.pm
new file mode 100644
index 0000000000..8b4788aad7
--- /dev/null
+++ b/cpan/Devel-DProf/DProf.pm
@@ -0,0 +1,250 @@
+use 5.006_001;
+
+=head1 NAME
+
+Devel::DProf - a B<DEPRECATED> Perl code profiler
+
+=head1 SYNOPSIS
+
+	perl -d:DProf test.pl
+
+=head1 ACHTUNG!
+
+C<Devel::DProf> is B<DEPRECATED> and will be removed from a future version of
+Perl. We strongly recommend that you install and use L<Devel::NYTProf> instead,
+as it offers significantly improved profiling and reporting.
+
+=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:
+
+	perl -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.
+
+Lines starting with C<@> mark the amount of time passed since the
+previous C<@> line.  The numbers following the C<@> are integer tick
+counts representing user, system, and real time.  Divide these numbers
+by the $hz value in the header to get seconds.
+
+Lines starting with C<&> map subroutine identifiers (an integer) to
+subroutine packages and names.  These should only occur once per
+subroutine.
+
+Lines starting with C<+> or C<-> mark normal entering and exit of
+subroutines.  The number following is a reference to a subroutine
+identifier.
+
+Lines starting with C<*> mark where subroutines are entered by C<goto
+&subr>, but note that the return will still be marked as coming from
+the original sub.  The sequence might look like this:
+
+	+ 5
+	* 6
+	- 5
+
+Lines starting with C</> is like C<-> but mark where subroutines are
+exited by dying.  Example:
+
+	+ 5
+	+ 6
+	/ 6
+	/ 5
+
+Finally you might find C<@> time stamp marks surrounded by C<+ &
+Devel::DProf::write> and C<- & Devel::DProf::write> lines.  These 3
+lines are outputted when printing of the mark above actually consumed
+measurable time.
+
+=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.
+
+C<PERL_DPROF_OUT_FILE_NAME> sets the name of the output file.  If not set,
+defaults to tmon.out.
+
+=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).
+
+Another problem is that if a subroutine exits using goto(LABEL),
+last(LABEL) or next(LABEL) then perl may crash or Devel::DProf will die
+with the error:
+
+   panic: Devel::DProf inconsistent subroutine return
+
+For example, this code will break under Devel::DProf:
+
+   sub foo {
+     last FOO;
+   }
+   FOO: {
+     foo();
+   }
+
+A pattern like this is used by Test::More's skip() function, for
+example.  See L<perldiag> for more details.
+
+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";
+    }
+}
+
+use XSLoader ();
+
+$Devel::DProf::VERSION = '20110217.00';  # this version not authorized by
+				         # Dean Roehrich. See "Changes" file.
+
+use if $] >= 5.013, 'deprecate';
+
+sub import {
+    XSLoader::load 'Devel::DProf', $Devel::DProf::VERSION;
+}
+
+1;
diff --git a/cpan/Devel-DProf/DProf.xs b/cpan/Devel-DProf/DProf.xs
new file mode 100644
index 0000000000..4eef0bc289
--- /dev/null
+++ b/cpan/Devel-DProf/DProf.xs
@@ -0,0 +1,785 @@
+#define PERL_NO_GET_CONTEXT
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* define DBG_SUB to cause a warning on each subroutine entry. */
+/*#define DBG_SUB 1      */
+
+/* define DBG_TIMER to cause a warning when the timer is turned on and off. */
+/*#define DBG_TIMER 1  */
+
+#ifdef DEBUGGING
+#define ASSERT(x) assert(x)
+#else
+#define ASSERT(x)
+#endif
+
+static CV *
+db_get_cv(pTHX_ SV *sv)
+{
+	CV *cv;
+
+	if (SvIOK(sv)) {			/* if (PERLDB_SUB_NN) { */
+	    cv = INT2PTR(CV*,SvIVX(sv));
+	} else {
+	    if (SvPOK(sv)) {
+		STRLEN len;
+		const char *const name = SvPV(sv, len);
+		cv = get_cvn_flags(name, len, GV_ADD | SvUTF8(sv));
+	    } else if (SvROK(sv)) {
+		cv = (CV*)SvRV(sv);
+	    } else {
+		croak("DProf: don't know what subroutine to profile");
+	    }
+	}
+	return cv;
+}
+
+#ifdef DBG_SUB
+#  define DBG_SUB_NOTIFY(A) dprof_dbg_sub_notify(aTHX_ A)
+void
+dprof_dbg_sub_notify(pTHX_ SV *Sub) {
+    CV * const cv = db_get_cv(aTHX_ Sub);
+    GV * const gv = cv ? CvGV(cv) : NULL;
+    if (cv && gv) {
+	warn("XS DBsub(%s::%s)\n",
+	     ((GvSTASH(gv) && HvNAME_get(GvSTASH(gv))) ?
+	      HvNAME_get(GvSTASH(gv)) : "(null)"),
+	     GvNAME(gv));
+    } else {
+	warn("XS DBsub(unknown) at %x", Sub);
+    }
+}
+#else
+#  define DBG_SUB_NOTIFY(A)  /* nothing */
+#endif
+
+
+#ifdef DBG_TIMER
+#  define DBG_TIMER_NOTIFY(A) warn(A)
+#else
+#  define DBG_TIMER_NOTIFY(A)  /* nothing */
+#endif
+
+/* HZ == clock ticks per second */
+#ifdef VMS
+#  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))
+#  define NEEDS_DPROF_TIMES
+#else
+#  ifdef BSDish
+#    define Times(ptr) (dprof_times(aTHX_ ptr))
+#    define NEEDS_DPROF_TIMES
+#    define HZ 1000000
+#    define DPROF_HZ HZ
+#  else
+#    ifndef HZ
+#      ifdef CLK_TCK
+#        define HZ ((I32)CLK_TCK)
+#      else
+#        define HZ 60
+#      endif
+#    endif
+#    ifdef OS2				/* times() has significant overhead */
+#      define Times(ptr) (dprof_times(aTHX_ ptr))
+#      define NEEDS_DPROF_TIMES
+#      define INCL_DOSPROFILE
+#      define INCL_DOSERRORS
+#      include <os2.h>
+#      define toLongLong(arg) (*(long long*)&(arg))
+#      define DPROF_HZ g_dprof_ticks
+#    else
+#      define Times(ptr) (times(ptr))
+#      define DPROF_HZ HZ
+#    endif 
+#  endif
+#endif
+
+XS(XS_Devel__DProf_END);        /* used by prof_mark() */
+
+/* Everything is built on times(2).  See its manpage for a description
+ * of the timings.
+ */
+
+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 */
+        const char *name;
+        U32 id;
+        opcode ptype;
+};
+
+typedef union prof_any PROFANY;
+
+typedef struct {
+    U32		dprof_ticks;
+    const char*	out_file_name;	/* output file (defaults to tmon.out) */
+    PerlIO*	fp;		/* pointer to tmon.out file */
+    Off_t	TIMES_LOCATION;	/* Where in the file to store the time totals */
+    int		SAVE_STACK;	/* How much data to buffer until end of run */
+    int		prof_pid;	/* pid of profiled process */
+    struct tms	prof_start;
+    struct tms	prof_end;
+    clock_t	rprof_start;	/* elapsed real time ticks */
+    clock_t	rprof_end;
+    clock_t	wprof_u;
+    clock_t	wprof_s;
+    clock_t	wprof_r;
+    clock_t	otms_utime;
+    clock_t	otms_stime;
+    clock_t	orealtime;
+    PROFANY*	profstack;
+    int		profstack_max;
+    int		profstack_ix;
+    HV*		cv_hash;	/* cache of CV to identifier mappings */
+    SV*		key_hash;	/* key for cv_hash */
+    U32		total;
+    U32		lastid;
+    U32		default_perldb;
+    UV		depth;
+#ifdef OS2
+    ULONG	frequ;
+    long long	start_cnt;
+#endif
+#ifdef PERL_IMPLICIT_CONTEXT
+    PerlInterpreter *my_perl;
+#endif
+} prof_state_t;
+
+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
+#define g_prof_pid		g_prof_state.prof_pid
+#define g_prof_start		g_prof_state.prof_start
+#define g_prof_end		g_prof_state.prof_end
+#define g_rprof_start		g_prof_state.rprof_start
+#define g_rprof_end		g_prof_state.rprof_end
+#define g_wprof_u		g_prof_state.wprof_u
+#define g_wprof_s		g_prof_state.wprof_s
+#define g_wprof_r		g_prof_state.wprof_r
+#define g_otms_utime		g_prof_state.otms_utime
+#define g_otms_stime		g_prof_state.otms_stime
+#define g_orealtime		g_prof_state.orealtime
+#define g_profstack		g_prof_state.profstack
+#define g_profstack_max		g_prof_state.profstack_max
+#define g_profstack_ix		g_prof_state.profstack_ix
+#define g_cv_hash		g_prof_state.cv_hash
+#define g_key_hash		g_prof_state.key_hash
+#define g_total			g_prof_state.total
+#define g_lastid		g_prof_state.lastid
+#define g_default_perldb	g_prof_state.default_perldb
+#define g_depth			g_prof_state.depth
+#ifdef PERL_IMPLICIT_CONTEXT
+#  define g_THX			g_prof_state.my_perl
+#endif
+#ifdef OS2
+#  define g_frequ		g_prof_state.frequ
+#  define g_start_cnt		g_prof_state.start_cnt
+#endif
+
+#ifdef NEEDS_DPROF_TIMES
+static clock_t
+dprof_times(pTHX_ struct tms *t)
+{
+#ifdef OS2
+    ULONG rc;
+    QWORD cnt;
+    
+    if (!g_frequ) {
+	if (CheckOSError(DosTmrQueryFreq(&g_frequ)))
+	    croak("DosTmrQueryFreq: %s", SvPV_nolen(perl_get_sv("!",GV_ADD)));
+	else
+	    g_frequ = g_frequ/DPROF_HZ;	/* count per tick */
+	if (CheckOSError(DosTmrQueryTime(&cnt)))
+	    croak("DosTmrQueryTime: %s",
+		  SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
+	g_start_cnt = toLongLong(cnt);
+    }
+
+    if (CheckOSError(DosTmrQueryTime(&cnt)))
+	    croak("DosTmrQueryTime: %s", SvPV_nolen(perl_get_sv("!",GV_ADD)));
+    t->tms_stime = 0;
+    return (t->tms_utime = (toLongLong(cnt) - g_start_cnt)/g_frequ);
+#else		/* !OS2 */
+#  ifdef VMS
+    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 *)t);
+    return (clock_t) retval;
+#  else		/* !VMS && !OS2 */
+#    ifdef BSDish
+#      include <sys/resource.h>
+    struct rusage ru;
+    struct timeval tv;
+    /* Measure offset from start time to avoid overflow  */
+    static struct timeval tv0 = { 0, 0 };
+
+    if (!tv0.tv_sec)
+        if (gettimeofday(&tv0, NULL) < 0)
+            croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
+    
+    if (getrusage(0, &ru) < 0)
+        croak("getrusage: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
+
+    if (gettimeofday(&tv, NULL) < 0)
+        croak("gettimeofday: %s", SvPV_nolen_const(perl_get_sv("!",GV_ADD)));
+
+    t->tms_stime = DPROF_HZ * ru.ru_stime.tv_sec + ru.ru_stime.tv_usec;
+    t->tms_utime = DPROF_HZ * ru.ru_utime.tv_sec + ru.ru_utime.tv_usec;
+
+    if (tv.tv_usec < tv0.tv_usec)
+        tv.tv_sec--, tv.tv_usec += DPROF_HZ;
+
+    return DPROF_HZ * (tv.tv_sec - tv0.tv_sec) + tv.tv_usec - tv0.tv_usec;
+#    else  /* !VMS && !OS2 && !BSD! */
+    return times(t);
+#    endif
+#  endif
+#endif
+}
+#endif
+
+static void
+prof_dumpa(pTHX_ opcode ptype, U32 id)
+{
+    if (ptype == OP_LEAVESUB) {
+	PerlIO_printf(g_fp,"- %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_ENTERSUB) {
+	PerlIO_printf(g_fp,"+ %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_GOTO) {
+	PerlIO_printf(g_fp,"* %"UVxf"\n", (UV)id);
+    }
+    else if(ptype == OP_DIE) {
+	PerlIO_printf(g_fp,"/ %"UVxf"\n", (UV)id);
+    }
+    else {
+	PerlIO_printf(g_fp,"Profiler unknown prof code %d\n", ptype);
+    }
+}   
+
+static void
+prof_dumps(pTHX_ U32 id, const char *pname, const char *gname)
+{
+    PerlIO_printf(g_fp,"& %"UVxf" %s %s\n", (UV)id, pname, gname);
+}   
+
+static void
+prof_dumpt(pTHX_ long tms_utime, long tms_stime, long realtime)
+{
+    PerlIO_printf(g_fp,"@ %ld %ld %ld\n", tms_utime, tms_stime, realtime);
+}   
+
+static void
+prof_dump_until(pTHX_ long ix)
+{
+    long base = 0;
+    struct tms t1, t2;
+    clock_t realtime2;
+
+    const clock_t realtime1 = Times(&t1);
+
+    while (base < ix) {
+	const opcode ptype = g_profstack[base++].ptype;
+	if (ptype == OP_TIME) {
+	    const long tms_utime = g_profstack[base++].tms_utime;
+	    const long tms_stime = g_profstack[base++].tms_stime;
+	    const long realtime = g_profstack[base++].realtime;
+
+	    prof_dumpt(aTHX_ tms_utime, tms_stime, realtime);
+	}
+	else if (ptype == OP_GV) {
+	    const U32 id = g_profstack[base++].id;
+	    const char * const pname = g_profstack[base++].name;
+	    const char * const gname = g_profstack[base++].name;
+
+	    prof_dumps(aTHX_ id, pname, gname);
+	}
+	else {
+	    const U32 id = g_profstack[base++].id;
+	    prof_dumpa(aTHX_ ptype, id);
+	}
+    }
+    PerlIO_flush(g_fp);
+    realtime2 = Times(&t2);
+    if (realtime2 != realtime1 || t1.tms_utime != t2.tms_utime
+	|| t1.tms_stime != t2.tms_stime) {
+	g_wprof_r += realtime2 - realtime1;
+	g_wprof_u += t2.tms_utime - t1.tms_utime;
+	g_wprof_s += t2.tms_stime - t1.tms_stime;
+
+	PerlIO_printf(g_fp,"+ & Devel::DProf::write\n");
+	PerlIO_printf(g_fp,"@ %"IVdf" %"IVdf" %"IVdf"\n", 
+		      /* The (IV) casts are one possibility:
+		       * the Painfully Correct Way would be to
+		       * have Clock_t_f. */
+		      (IV)(t2.tms_utime - t1.tms_utime),
+		      (IV)(t2.tms_stime - t1.tms_stime), 
+		      (IV)(realtime2 - realtime1));
+	PerlIO_printf(g_fp,"- & Devel::DProf::write\n");
+	g_otms_utime = t2.tms_utime;
+	g_otms_stime = t2.tms_stime;
+	g_orealtime = realtime2;
+	PerlIO_flush(g_fp);
+    }
+}
+
+static void
+set_cv_key(pTHX_ CV *cv, const char *pname, const char *gname)
+{
+	SvGROW(g_key_hash, sizeof(CV**) + strlen(pname) + strlen(gname) + 3);
+	sv_setpvn(g_key_hash, (char*)&cv, sizeof(CV**));
+	sv_catpv(g_key_hash, pname);
+	sv_catpv(g_key_hash, "::");
+	sv_catpv(g_key_hash, gname);
+}
+
+static void
+prof_mark(pTHX_ opcode ptype)
+{
+    struct tms t;
+    clock_t realtime, rdelta, udelta, sdelta;
+    U32 id;
+    SV * const Sub = GvSV(PL_DBsub);	/* name of current sub */
+
+    if (g_SAVE_STACK) {
+	if (g_profstack_ix + 10 > g_profstack_max) {
+		g_profstack_max = g_profstack_max * 3 / 2;
+		Renew(g_profstack, g_profstack_max, PROFANY);
+	}
+    }
+
+    realtime = Times(&t);
+    rdelta = realtime - g_orealtime;
+    udelta = t.tms_utime - g_otms_utime;
+    sdelta = t.tms_stime - g_otms_stime;
+    if (rdelta || udelta || sdelta) {
+	if (g_SAVE_STACK) {
+	    ASSERT(g_profstack_ix + 4 <= g_profstack_max);
+	    g_profstack[g_profstack_ix++].ptype = OP_TIME;
+	    g_profstack[g_profstack_ix++].tms_utime = udelta;
+	    g_profstack[g_profstack_ix++].tms_stime = sdelta;
+	    g_profstack[g_profstack_ix++].realtime = rdelta;
+	}
+	else { /* Write it to disk now so's not to eat up core */
+	    if (g_prof_pid == (int)getpid()) {
+		prof_dumpt(aTHX_ udelta, sdelta, rdelta);
+		PerlIO_flush(g_fp);
+	    }
+	}
+	g_orealtime = realtime;
+	g_otms_stime = t.tms_stime;
+	g_otms_utime = t.tms_utime;
+    }
+
+    {
+	SV **svp;
+	char *gname, *pname;
+
+	CV * const cv = db_get_cv(aTHX_ Sub);
+	GV * const gv = CvGV(cv);
+	if (isGV_with_GP(gv)) {
+	    pname = GvSTASH(gv) ? HvNAME_get(GvSTASH(gv)) : NULL;
+	    pname = pname ? pname : (char *) "(null)";
+	    gname = GvNAME(gv);
+	} else {
+	    gname = pname = (char *) "(null)";
+	}
+
+	set_cv_key(aTHX_ cv, pname, gname);
+	svp = hv_fetch(g_cv_hash, SvPVX_const(g_key_hash), SvCUR(g_key_hash), TRUE);
+	if (!SvOK(*svp)) {
+	    sv_setiv(*svp, id = ++g_lastid);
+	    if (CvXSUB(cv) == XS_Devel__DProf_END)
+		return;
+	    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
+		ASSERT(g_profstack_ix + 4 <= g_profstack_max);
+		g_profstack[g_profstack_ix++].ptype = OP_GV;
+		g_profstack[g_profstack_ix++].id = id;
+		g_profstack[g_profstack_ix++].name = pname;
+		g_profstack[g_profstack_ix++].name = gname;
+	    }
+	    else { /* Write it to disk now so's not to eat up core */
+		/* Only record the parent's info */
+		if (g_prof_pid == (int)getpid()) {
+		    prof_dumps(aTHX_ id, pname, gname);
+		    PerlIO_flush(g_fp);
+		}
+		else
+		    PL_perldb = 0;		/* Do not debug the kid. */
+	    }
+	}
+	else {
+	    id = SvIV(*svp);
+	}
+    }
+
+    g_total++;
+    if (g_SAVE_STACK) { /* Store it for later recording  -JH */
+	ASSERT(g_profstack_ix + 2 <= g_profstack_max);
+	g_profstack[g_profstack_ix++].ptype = ptype;
+	g_profstack[g_profstack_ix++].id = id;
+
+	/* Only record the parent's info */
+	if (g_SAVE_STACK < g_profstack_ix) {
+	    if (g_prof_pid == (int)getpid())
+		prof_dump_until(aTHX_ g_profstack_ix);
+	    else
+		PL_perldb = 0;		/* Do not debug the kid. */
+	    g_profstack_ix = 0;
+	}
+    }
+    else { /* Write it to disk now so's not to eat up core */
+
+	/* Only record the parent's info */
+	if (g_prof_pid == (int)getpid()) {
+	    prof_dumpa(aTHX_ ptype, id);
+	    PerlIO_flush(g_fp);
+	}
+	else
+	    PL_perldb = 0;		/* Do not debug the kid. */
+    }
+}
+
+/* Counts overhead of prof_mark and extra XS call. */
+static void
+test_time(pTHX_ clock_t *r, clock_t *u, clock_t *s)
+{
+    CV * const cv = get_cvs("Devel::DProf::NONESUCH_noxs", 0);
+    HV * const oldstash = PL_curstash;
+    struct tms t1, t2;
+    const U32 ototal = g_total;
+    const U32 ostack = g_SAVE_STACK;
+    const U32 operldb = PL_perldb;
+    int k = 0;
+
+    clock_t realtime1 = Times(&t1);
+    clock_t realtime2 = 0;
+
+    g_SAVE_STACK = 1000000;
+
+    while (k < 2) {
+	int i = 0;
+	    /* Disable debugging of perl_call_sv on second pass: */
+	PL_curstash = (k == 0 ? PL_defstash : PL_debstash);
+	PL_perldb = g_default_perldb;
+	while (++i <= 100) {
+	    int j = 0;
+	    g_profstack_ix = 0;		/* Do not let the stack grow */
+	    while (++j <= 100) {
+/* 		prof_mark(aTHX_ OP_ENTERSUB); */
+
+		PUSHMARK(PL_stack_sp);
+		perl_call_sv((SV*)cv, G_SCALAR);
+		PL_stack_sp--;
+/* 		prof_mark(aTHX_ OP_LEAVESUB); */
+	    }
+	}
+	PL_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++;
+    }
+    g_total = ototal;
+    g_SAVE_STACK = ostack;
+    PL_perldb = operldb;
+}
+
+static void
+prof_recordheader(pTHX)
+{
+    clock_t r, u, s;
+
+    /* g_fp is opened in the BOOT section */
+    PerlIO_printf(g_fp, "#fOrTyTwO\n");
+    PerlIO_printf(g_fp, "$hz=%"IVdf";\n", (IV)DPROF_HZ);
+    PerlIO_printf(g_fp, "$XS_VERSION='DProf %s';\n", XS_VERSION);
+    PerlIO_printf(g_fp, "# All values are given in HZ\n");
+    test_time(aTHX_ &r, &u, &s);
+    PerlIO_printf(g_fp,
+		  "$over_utime=%"IVdf"; $over_stime=%"IVdf"; $over_rtime=%"IVdf";\n",
+		  /* The (IV) casts are one possibility:
+		   * the Painfully Correct Way would be to
+		   * have Clock_t_f. */
+		  (IV)u, (IV)s, (IV)r);
+    PerlIO_printf(g_fp, "$over_tests=10000;\n");
+
+    g_TIMES_LOCATION = PerlIO_tell(g_fp);
+
+    /* Pad with whitespace. */
+    /* This should be enough even for very large numbers. */
+    PerlIO_printf(g_fp, "%*s\n", 240 , "");
+
+    PerlIO_printf(g_fp, "\n");
+    PerlIO_printf(g_fp, "PART2\n");
+
+    PerlIO_flush(g_fp);
+}
+
+static void
+prof_record(pTHX)
+{
+    /* g_fp is opened in the BOOT section */
+
+    /* Now that we know the runtimes, fill them in at the recorded
+       location -JH */
+
+    if (g_SAVE_STACK) {
+	prof_dump_until(aTHX_ g_profstack_ix);
+    }
+    PerlIO_seek(g_fp, g_TIMES_LOCATION, SEEK_SET);
+    /* Write into reserved 240 bytes: */
+    PerlIO_printf(g_fp,
+		  "$rrun_utime=%"IVdf"; $rrun_stime=%"IVdf"; $rrun_rtime=%"IVdf";",
+		  /* The (IV) casts are one possibility:
+		   * the Painfully Correct Way would be to
+		   * have Clock_t_f. */
+		  (IV)(g_prof_end.tms_utime-g_prof_start.tms_utime-g_wprof_u),
+		  (IV)(g_prof_end.tms_stime-g_prof_start.tms_stime-g_wprof_s),
+		  (IV)(g_rprof_end-g_rprof_start-g_wprof_r));
+    PerlIO_printf(g_fp, "\n$total_marks=%"IVdf, (IV)g_total);
+    
+    PerlIO_close(g_fp);
+}
+
+#define NONESUCH()
+
+static void
+check_depth(pTHX_ void *foo)
+{
+    const U32 need_depth = PTR2UV(foo);
+    if (need_depth != g_depth) {
+	if (need_depth > g_depth) {
+	    warn("garbled call depth when profiling");
+	}
+	else {
+	    IV marks = g_depth - need_depth;
+
+/* 	    warn("Check_depth: got %d, expected %d\n", g_depth, need_depth); */
+	    while (marks--) {
+		prof_mark(aTHX_ OP_DIE);
+	    }
+	    g_depth = need_depth;
+	}
+    }
+}
+
+#define for_real
+#ifdef for_real
+
+XS(XS_DB_sub);
+XS(XS_DB_sub)
+{
+    dMARK;
+    dORIGMARK;
+    SV * const Sub = GvSV(PL_DBsub);		/* name of current sub */
+
+#ifdef PERL_IMPLICIT_CONTEXT
+    /* profile only the interpreter that loaded us */
+    if (g_THX != aTHX) {
+        PUSHMARK(ORIGMARK);
+        perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
+    }
+    else
+#endif
+    {
+	HV * const oldstash = PL_curstash;
+	const I32 old_scopestack_ix = PL_scopestack_ix;
+	const I32 old_cxstack_ix = cxstack_ix;
+
+        DBG_SUB_NOTIFY(Sub);
+
+	SAVEDESTRUCTOR_X(check_depth, INT2PTR(void*,g_depth));
+	g_depth++;
+
+        prof_mark(aTHX_ OP_ENTERSUB);
+        PUSHMARK(ORIGMARK);
+        perl_call_sv((SV*)db_get_cv(aTHX_ Sub), GIMME_V | G_NODEBUG);
+        PL_curstash = oldstash;
+
+	/* Make sure we are on the same context and scope as before the call
+	 * to the sub. If the called sub was exited via a goto, next or
+	 * last then this will try to croak(), however perl may still crash
+	 * with a segfault. */
+	if (PL_scopestack_ix != old_scopestack_ix || cxstack_ix != old_cxstack_ix)
+	    croak("panic: Devel::DProf inconsistent subroutine return");
+
+        prof_mark(aTHX_ OP_LEAVESUB);
+	g_depth--;
+    }
+    return;
+}
+
+XS(XS_DB_goto);
+XS(XS_DB_goto)
+{
+#ifdef PERL_IMPLICIT_CONTEXT
+    if (g_THX == aTHX)
+#endif
+    {
+        prof_mark(aTHX_ OP_GOTO);
+        return;
+    }
+}
+
+#endif /* for_real */
+
+#ifdef testing
+
+        MODULE = Devel::DProf           PACKAGE = DB
+
+        void
+        sub(...)
+	PPCODE:
+	    {
+                dORIGMARK;
+		HV * const oldstash = PL_curstash;
+		SV * const Sub = GvSV(PL_DBsub);	/* name of current sub */
+                /* SP -= items;  added by xsubpp */
+                DBG_SUB_NOTIFY(Sub);
+
+                sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */
+
+                prof_mark(aTHX_ OP_ENTERSUB);
+                PUSHMARK(ORIGMARK);
+
+                PL_curstash = PL_debstash;	/* To disable debugging of perl_call_sv */
+                perl_call_sv(Sub, GIMME_V);
+                PL_curstash = oldstash;
+
+                prof_mark(aTHX_ OP_LEAVESUB);
+                SPAGAIN;
+                /* PUTBACK;  added by xsubpp */
+	    }
+
+#endif /* testing */
+
+MODULE = Devel::DProf           PACKAGE = Devel::DProf
+
+void
+END()
+PPCODE:
+    {
+        if (PL_DBsub) {
+	    /* maybe the process forked--we want only
+	     * the parent's profile.
+	     */
+	    if (
+#ifdef PERL_IMPLICIT_CONTEXT
+		g_THX == aTHX &&
+#endif
+		g_prof_pid == (int)getpid())
+	    {
+		g_rprof_end = Times(&g_prof_end);
+		DBG_TIMER_NOTIFY("Profiler timer is off.\n");
+		prof_record(aTHX);
+	    }
+	}
+    }
+
+void
+NONESUCH()
+
+BOOT:
+    {
+	g_TIMES_LOCATION = 42;
+	g_SAVE_STACK = 1<<14;
+    	g_profstack_max = 128;
+#ifdef PERL_IMPLICIT_CONTEXT
+	g_THX = aTHX;
+#endif
+
+        /* Before we go anywhere make sure we were invoked
+         * properly, else we'll dump core.
+         */
+        if (!PL_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.
+         */
+        {
+	    const bool warn_tmp = PL_dowarn;
+	    PL_dowarn = 0;
+	    newXS("DB::sub", XS_DB_sub, file);
+	    newXS("DB::goto", XS_DB_goto, file);
+	    PL_dowarn = warn_tmp;
+        }
+
+        sv_setiv(PL_DBsingle, 0);	/* disable DB single-stepping */
+
+	{
+	    const char *buffer = getenv("PERL_DPROF_BUFFER");
+
+	    if (buffer) {
+		g_SAVE_STACK = atoi(buffer);
+	    }
+
+	    buffer = getenv("PERL_DPROF_TICKS");
+
+	    if (buffer) {
+		g_dprof_ticks = atoi(buffer); /* Used under OS/2 only */
+	    }
+	    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(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();
+	g_key_hash = newSV(256);
+        g_prof_pid = (int)getpid();
+
+	Newx(g_profstack, g_profstack_max, PROFANY);
+        prof_recordheader(aTHX);
+        DBG_TIMER_NOTIFY("Profiler timer is on.\n");
+	g_orealtime = g_rprof_start = Times(&g_prof_start);
+	g_otms_utime = g_prof_start.tms_utime;
+	g_otms_stime = g_prof_start.tms_stime;
+	PL_perldb = g_default_perldb;
+    }
diff --git a/cpan/Devel-DProf/Makefile.PL b/cpan/Devel-DProf/Makefile.PL
new file mode 100644
index 0000000000..5bb00128d0
--- /dev/null
+++ b/cpan/Devel-DProf/Makefile.PL
@@ -0,0 +1,18 @@
+BEGIN {
+	require 5.006;
+}
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+	NAME		=> 'Devel::DProf',
+	DISTNAME	=> 'DProf',
+	VERSION_FROM	=> 'DProf.pm',
+	clean		=> { 'FILES' => 'tmon.out t/tmon.out t/err'},
+	XSPROTOARG	=> '-noprototypes',
+	dist		=> {
+			     COMPRESS => 'gzip -9f',
+			     SUFFIX => 'gz',
+			     DIST_DEFAULT => 'all tardist',
+			   },
+);
diff --git a/cpan/Devel-DProf/Todo b/cpan/Devel-DProf/Todo
new file mode 100644
index 0000000000..0e003471d6
--- /dev/null
+++ b/cpan/Devel-DProf/Todo
@@ -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/cpan/Devel-DProf/bin/dprofpp b/cpan/Devel-DProf/bin/dprofpp
new file mode 100644
index 0000000000..51d0ed9d9b
--- /dev/null
+++ b/cpan/Devel-DProf/bin/dprofpp
@@ -0,0 +1,942 @@
+#!/usr/bin/perl
+
+require 5.003;
+
+my $stty;
+BEGIN {
+    foreach my $s (qw(/bin/stty /usr/bin/stty)) {
+	if (-x $s) {
+	    $stty = $s;
+	    last;
+	}
+    }
+}
+
+require Devel::DProf;
+require deprecate;
+
+if($] > 5.013009 && deprecate::__loaded_from_core('Devel::DProf', $INC{'Devel/DProf.pm'},
+						  'Devel/DProf.pm')) {
+    warn "dprofpp will be removed from the Perl core distribution in the next major release. Please install Devel::DProf from CPAN.\n";
+}
+
+=head1 NAME
+
+dprofpp - display perl profile data
+
+=head1 SYNOPSIS
+
+dprofpp [B<-a>|B<-z>|B<-l>|B<-v>|B<-U>] [B<-d>] [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>] [B<-G> <regexp> [B<-P>]] [B<-f> <regexp>] [profile]
+
+dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile]
+
+dprofpp B<-G> <regexp> [B<-P>] [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
+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 use the following:
+
+	$ perl5 -d:DProf test.pl
+
+Then run dprofpp to analyze the profile.  The output of dprofpp depends
+on the flags to the program and the version of Perl you're using.
+
+	$ 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 OUTPUT
+
+Columns are:
+
+=over 4
+
+=item %Time
+
+Percentage of time spent in this routine.
+
+=item #Calls
+
+Number of calls to this routine.
+
+=item sec/call
+
+Average number of seconds per call to this routine.
+
+=item Name
+
+Name of routine.
+
+=item CumulS
+
+Time (in seconds) spent in this routine and routines called from it.
+
+=item ExclSec
+
+Time (in seconds) spent in this routine (not including those called
+from it).
+
+=item Csec/c
+
+Average time (in seconds) spent in each call of this routine
+(including those called from it).
+
+=back
+
+=head1 OPTIONS
+
+=over 5
+
+=item B<-a>
+
+Sort alphabetically by subroutine names.
+
+=item B<-d>
+
+Reverse whatever sort is used
+
+=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 are
+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 with regard to 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.
+
+=item B<-G> <regexp>
+
+Aggregate "Group" all calls matching the pattern together.
+For example this can be used to group all calls of a set of packages
+
+  -G "(package1::)|(package2::)|(package3::)"
+
+or to group subroutines by name:
+
+  -G "getNum"
+
+=item B<-P>
+
+Used with -G to aggregate "Pull" together all calls that did not match -G.
+
+=item B<-f> <regexp>
+
+Filter all calls matching the pattern.
+
+=item B<-h>
+
+Display brief help and exit.
+
+=item B<-H>
+
+Display long help and exit.
+
+=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
+
+sub shortusage {
+    print <<'EOF';
+dprofpp [options] [profile]
+
+    -A          Count autoloaded to *AUTOLOAD.
+    -a          Sort by alphabetic name of subroutines.
+    -d          Reverse sort.
+    -E          Sub times are reported exclusive of child times. (default)
+    -f          Filter all calls matching the pattern.
+    -G          Group all calls matching the pattern together.
+    -g subr     Count only subs who are SUBR or called from SUBR.
+    -H          Display long manual page.
+    -h          Display this short usage message.
+    -I          Sub times are reported inclusive of child times.
+    -l          Sort by number of calls to subroutines.
+    -O cnt      Specifies maximum number of subroutines to display.
+    -P          Used with -G to pull all other calls together.
+    -p script   Specifies name of script to be profiled.
+    -Q          Used with -p to indicate that dprofpp should quit
+                after profiling the script, without interpreting the data.
+    -q          Do not print column headers.
+    -R          Count anonymous subs separately even if from the same package.
+    -r          Use real elapsed time rather than user+system time.
+    -S          Create statistics for all the depths.
+    -s          Use system time rather than user+system time.
+    -T          Show call tree.
+    -t          Show call tree, compressed.
+    -U          Do not sort subroutines.
+    -u          Use user time rather than user+system time.
+    -V          Print dprofpp's version.
+    -v          Sort by average amount of time spent in subroutines.
+    -z          Sort by user+system time spent in subroutines. (default)
+EOF
+}
+
+use Getopt::Std 'getopts';
+use Config '%Config';
+
+Setup: {
+	my $options = 'O:g:G:Pf:dlzaAvuTtqrRsUFEIp:QVShH';
+
+	$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 ) or die "Try 'dprofpp -h' for help.\n";
+	if( @ARGV ){
+		# there was a filename, it overrides any earlier name.
+		$Monfile = shift;
+	}
+
+        if ( defined $opt_h ) {
+                shortusage();
+                exit;
+        }
+        if ( defined $opt_H ) {
+                require Pod::Usage;
+                Pod::Usage::pod2usage( {-verbose => 2, -input => $0 } );
+                exit;
+        }
+
+	if( defined $opt_V ){
+		my $fh = 'main::fh';
+		print "$0 version: $Devel::DProf::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;
+
+	if(defined $opt_d){
+		$sort = "r".$sort;
+	}
+	$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 );
+
+	#filter calls
+	if( $opt_f ){
+		for(my $i = 0;$i < @$idkeys - 2;){
+			$key = $$idkeys[$i];
+			if($key =~ /$opt_f/){
+				splice(@$idkeys, $i, 1);
+				$runtime -= $$times{$key};
+				next;
+			}
+			$i++;
+		}
+	}
+
+	if( $opt_G ){
+		group($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);
+}
+
+sub group{
+	my ($names, $calls, $times, $ctimes, $idkeys ) = @_;
+		print "Option G Grouping: [$opt_G]\n";
+		# create entries to store grouping
+		$$names{$opt_G} = $opt_G;
+		$$calls{$opt_G} = 0;
+		$$times{$opt_G} = 0;
+		$$ctimes{$opt_G} = 0;
+		$$idkeys[@$idkeys] = $opt_G;
+		# Sum calls for the grouping
+
+		my $other = "other";
+		if($opt_P){
+			$$names{$other} = $other;
+			$$calls{$other} = 0;
+			$$times{$other} = 0;
+			$$ctimes{$other} = 0;
+			$$idkeys[@$idkeys] = $other;
+		}
+
+		for(my $i = 0;$i < @$idkeys - 2;){
+			$key = $$idkeys[$i];
+			if($key =~ /$opt_G/){
+				$$calls{$opt_G} += $$calls{$key};
+				$$times{$opt_G} += $$times{$key};
+				$$ctimes{$opt_G} += $$ctimes{$key};
+				splice(@$idkeys, $i, 1);
+				next;
+			}else{
+				if($opt_P){
+					$$calls{$other} += $$calls{$key};
+					$$times{$other} += $$times{$key};
+					$$ctimes{$other} += $$ctimes{$key};
+					splice(@$idkeys, $i, 1);
+					next;
+				}
+			}
+			$i++;
+		}
+		print "Grouping [$opt_G] Calls: [$$calls{$opt_G}]\n".
+			  "Grouping [$opt_G] Times: [$$times{$opt_G}]\n".
+			  "Grouping [$opt_G] IncTimes: [$$ctimes{$opt_G}]\n";
+}
+
+# Sets $runtime to user, system, real, or user+system time.  The
+# result is given in seconds.
+#
+sub settime {
+  my( $runtime, $hz ) = @_;
+
+  $hz ||= 1;
+
+  if( $opt_r ){
+    $$runtime = ($rrun_rtime - $overhead)/$hz;
+  }
+  elsif( $opt_s ){
+    $$runtime = ($rrun_stime - $overhead)/$hz;
+  }
+  elsif( $opt_u ){
+    $$runtime = ($rrun_utime - $overhead)/$hz;
+  }
+  else{
+    $$runtime = ($rrun_ustime - $overhead)/$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;
+
+  my $time;
+  if (%{$deep_times->{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 %{$deep_times->{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) = @_;
+
+  for my $kid_name (keys %$source) {
+    my $source_kid = delete $source->{$kid_name};
+
+    if (my $dest_kid = $dest->{$kid_name}) {
+      $dest_kid->{count} += $source_kid->{count};
+      $dest_kid->{incl_time} += $source_kid->{incl_time};
+      move_keys($source_kid->{kids},$dest_kid->{kids});
+    } else {
+      $dest->{$kid_name} = $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;
+  my $entry = $curdeep_times->[-2]{kids}{$name} ||= {
+    count => 0,
+    kids => {},
+    incl_time => 0,
+  };
+  # 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 %outer;
+	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_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] if scalar @stack;
+		  $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;
+		if ( $dir eq '-' or $dir eq '*' ) {
+			my $ename = $dir eq '*' ? $stack[-1][0]  : $name;
+			$overhead += $over_per_call;
+			if ($name eq "Devel::DProf::write") {
+			  $overhead += $t - $dprof_stamp;
+			  next;
+			} elsif (defined $opt_g and $ename eq $opt_g) {
+			  $in_level--;
+			}
+			add_to_tree($curdeep_times, $ename,
+				    $t - $overhead) if $opt_S;
+			exitstamp( \@stack, \@tstack,
+				   $t - $overhead,
+				   $times, $ctimes, $name, \$in, $tab,
+				   $curdeep_times, \%outer );
+		}
+		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}++;
+                        $outer{$name}++;
+			push @$curdeep_times, { kids => {},
+						name => $name,
+						enter_stamp => $t - $overhead,
+					      } if $opt_S;
+			$x = [ $name, $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";
+	}
+
+        while (my ($key, $count) = each %outer) {
+            next unless $count;
+            warn "$key has $count unstacked calls in outer\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 - $overhead, $times,
+					   $ctimes, $name, \$in, $tab,
+					   $curdeep_times, \%outer );
+				add_to_tree($curdeep_times, $name,
+					    $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, $outer) = @_;
+	my( $x, $c, $z );
+
+	$x = pop( @$stack );
+	if( ! defined $x ){
+		die "Garbled profile, missing an enter time stamp";
+	}
+	if( $x->[0] ne $name and $opt_G and ($name =~ /$opt_G/)){
+	  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
+            unless --$outer->{$name};
+	$times->{$name} += $z - $c;
+	# 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;
+	my @script_parts = split /\s+/, $script;
+
+	system $startperl, "-d:$profiler", @script_parts;
+	if( $? / 256 > 0 ){
+		my $cmd = join ' ', @script_parts;
+		die "Failed: $startperl -d:$profiler $cmd: $!";
+	}
+}
+
+
+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} }
+# Reversed
+sub rby_time { $times->{$a} <=> $times->{$b} }
+sub rby_ctime { $ctimes->{$a} <=> $ctimes->{$b} }
+sub rby_calls { $calls->{$a} <=> $calls->{$b} }
+sub rby_alpha { $names->{$b} cmp $names->{$a} }
+sub rby_avgcpu { $persecs->{$a} <=> $persecs->{$b} }
+
+
+format CSTAT_top =
+Total Elapsed Time = @>>>>>>> Seconds
+(($rrun_rtime - $overhead) / $hz)
+  @>>>>>>>>>> Time = @>>>>>>> Seconds
+$whichtime, $runtime
+@<<<<<<<< Times
+$incl_excl
+%Time ExclSec CumulS #Calls sec/call Csec/c  Name
+.
+
+BEGIN {
+    my $fmt = ' ^>>>   ^>>>> ^>>>>> ^>>>>>   ^>>>>> ^>>>>>  ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<';
+    if (-t STDOUT and defined $stty and my ($cols) = `$stty -a` =~ /\bcolumns\s+(\d+)/)
+    {
+	$fmt .= '<' x ($cols - length $fmt) if $cols > 80;
+    }
+
+    eval "format STAT = \n$fmt" . '
+$pcnt, $secs, $csecs, $ncalls, $percall, $cpercall, $name
+.';
+}
diff --git a/cpan/Devel-DProf/dprof/V.pm b/cpan/Devel-DProf/dprof/V.pm
new file mode 100644
index 0000000000..e613f6f441
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/V.pm
@@ -0,0 +1,63 @@
+package V;
+
+use Getopt::Std 'getopts';
+getopts('vp:d:');
+
+require Exporter;
+@ISA = 'Exporter';
+
+@EXPORT = qw( dprofpp $opt_v $results $expected report @results );
+@EXPORT_OK = qw( notok ok $num );
+
+$num = 0;
+$results = $expected = '';
+$perl = $opt_p || $^X;
+$dpp = $opt_d || '../../utils/dprofpp';
+$dpp .= '.com' if $^O eq 'VMS';
+
+print "\nperl: $perl\n" if $opt_v;
+if( ! -f $perl ){ die "Where's Perl?" }
+if( ! -f $dpp ) { 
+    ($dpp = $^X) =~ s@(^.*)[/|\\].*@$1/dprofpp@;
+    die "Where's dprofpp?" if( ! -f $dpp );
+}
+
+sub dprofpp {
+	my $switches = shift;
+
+        open( D, "$perl \"-I../lib\" $dpp \"$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 {
+	print "ok $num\n";
+}
+
+sub notok {
+	print "not ok $num\n";
+	print "\nResult\n{$results}\n";
+	print "Expected\n{$expected}\n";
+}
+
+1;
diff --git a/cpan/Devel-DProf/dprof/test1_t b/cpan/Devel-DProf/dprof/test1_t
new file mode 100644
index 0000000000..d504cd5536
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test1_t
@@ -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/cpan/Devel-DProf/dprof/test1_v b/cpan/Devel-DProf/dprof/test1_v
new file mode 100644
index 0000000000..542a503414
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test1_v
@@ -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/cpan/Devel-DProf/dprof/test2_t b/cpan/Devel-DProf/dprof/test2_t
new file mode 100644
index 0000000000..edc46c527e
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test2_t
@@ -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/cpan/Devel-DProf/dprof/test2_v b/cpan/Devel-DProf/dprof/test2_v
new file mode 100644
index 0000000000..8b775b3131
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test2_v
@@ -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 5, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 6, 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 7, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 8, sub { $expected eq $results };
diff --git a/cpan/Devel-DProf/dprof/test3_t b/cpan/Devel-DProf/dprof/test3_t
new file mode 100644
index 0000000000..a5327f4d7a
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test3_t
@@ -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/cpan/Devel-DProf/dprof/test3_v b/cpan/Devel-DProf/dprof/test3_v
new file mode 100644
index 0000000000..df7543e2b8
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test3_v
@@ -0,0 +1,29 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$e1 = $expected =
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+};
+report 9, sub { $expected eq $results };
+
+dprofpp('-TF');
+$e2 = $expected =
+qq{main::bar
+main::baz
+   main::bar
+   main::foo
+};
+report 10, sub { $expected eq $results };
+
+dprofpp( '-t' );
+$expected = $e1;
+report 11, sub { 1 };
+
+dprofpp('-tF');
+$expected = $e2;
+report 12, sub { $expected eq $results };
diff --git a/cpan/Devel-DProf/dprof/test4_t b/cpan/Devel-DProf/dprof/test4_t
new file mode 100644
index 0000000000..729968270a
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test4_t
@@ -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();
+
+eval { fork };
+
+bar();
+baz();
+foo();
diff --git a/cpan/Devel-DProf/dprof/test4_v b/cpan/Devel-DProf/dprof/test4_v
new file mode 100644
index 0000000000..d9677ff785
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test4_v
@@ -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 13, sub { $expected eq $results };
+
+dprofpp('-TF');
+report 14, 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 15, sub { $expected eq $results };
+
+dprofpp('-tF');
+report 16, sub { $expected eq $results };
diff --git a/cpan/Devel-DProf/dprof/test5_t b/cpan/Devel-DProf/dprof/test5_t
new file mode 100644
index 0000000000..0b1113757f
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test5_t
@@ -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/cpan/Devel-DProf/dprof/test5_v b/cpan/Devel-DProf/dprof/test5_v
new file mode 100644
index 0000000000..9e9298c689
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test5_v
@@ -0,0 +1,15 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected =
+qq{main::foo1
+   main::bar
+      main::yeppers
+main::foo2
+   main::bar
+      main::yeppers
+};
+report 17, sub { $expected eq $results };
+
diff --git a/cpan/Devel-DProf/dprof/test6_t b/cpan/Devel-DProf/dprof/test6_t
new file mode 100644
index 0000000000..7b8bf4a722
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test6_t
@@ -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/cpan/Devel-DProf/dprof/test6_v b/cpan/Devel-DProf/dprof/test6_v
new file mode 100644
index 0000000000..2f651ea794
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test6_v
@@ -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 18, sub { $expected eq $results };
+
diff --git a/cpan/Devel-DProf/dprof/test7_t b/cpan/Devel-DProf/dprof/test7_t
new file mode 100644
index 0000000000..56dbfd341c
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test7_t
@@ -0,0 +1,9 @@
+BEGIN {
+	print "in BEGIN\n";
+}
+
+sub foo {
+	print "in sub foo\n";
+}
+
+foo();
diff --git a/cpan/Devel-DProf/dprof/test7_v b/cpan/Devel-DProf/dprof/test7_v
new file mode 100644
index 0000000000..1d19fe5cd5
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test7_v
@@ -0,0 +1,10 @@
+# perl
+
+use V;
+
+dprofpp( '-T' );
+$expected = 
+qq{main::BEGIN
+main::foo
+};
+report 19, sub { $expected eq $results };
diff --git a/cpan/Devel-DProf/dprof/test8_t b/cpan/Devel-DProf/dprof/test8_t
new file mode 100644
index 0000000000..6154c8a530
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test8_t
@@ -0,0 +1,15 @@
+sub foo {
+	print "in sub foo\n";
+}
+
+sub bar {
+	print "in sub bar\n";
+	$^P -= 0x40;
+}
+
+foo();
+$^P -= 0x40;
+foo();
+$^P += 0x40;
+bar();
+$^P += 0x40;
diff --git a/cpan/Devel-DProf/dprof/test8_v b/cpan/Devel-DProf/dprof/test8_v
new file mode 100644
index 0000000000..d5de3087fe
--- /dev/null
+++ b/cpan/Devel-DProf/dprof/test8_v
@@ -0,0 +1,11 @@
+# perl
+
+use V;
+
+dprofpp( '-t' );
+$expected = 
+qq{main::foo (2x)
+main::bar
+};
+
+report 20, sub { $expected eq $results };
diff --git a/cpan/Devel-DProf/t/DProf.t b/cpan/Devel-DProf/t/DProf.t
new file mode 100644
index 0000000000..c5e1d7b717
--- /dev/null
+++ b/cpan/Devel-DProf/t/DProf.t
@@ -0,0 +1,93 @@
+#!perl
+
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+	require 'test.pl';      # for which_perl() etc
+	require Config; import Config;
+	if ($Config{'extensions'} !~ /\bDevel\/DProf\b/){
+	    print "1..0 # Skip: Devel::DProf was not built\n";
+	    exit 0;
+	}
+	$perl = which_perl();
+    }
+    else {
+	$perl = $^X;
+    }
+}
+
+END {
+    while(-e 'tmon.out' && unlink 'tmon.out') {}
+    while(-e 'err' && unlink 'err') {}
+}
+
+use Benchmark qw( timediff timestr );
+use Getopt::Std 'getopts';
+getopts('vI:p:');
+
+# -v   Verbose
+# -I   Add to @INC
+# -p   Name of perl binary
+
+@tests = @ARGV ? @ARGV : sort (<dprof/*_t>, <dprof/*_v>);  # glob-sort, for OS/2
+
+$path_sep = $Config{path_sep} || ':';
+$perl5lib = $opt_I || join( $path_sep, @INC );
+$perl = $opt_p if $opt_p;
+
+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 -f \"$opt_d\" $test |" ) || warn "$0: Can't run. $!\n";
+	@results = <R>;
+	close R or warn "Could not close: $!";
+	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;
+
+	my $command = $perl.' "-I./dprof" '.$test;
+	$command .= ' -v' if $opt_v;
+	$command .= ' -p '. $perl;
+	system $command;
+}
+
+
+$| = 1;
+print "1..20\n";
+while( @tests ){
+	$test = shift @tests;
+	$test =~ s/\.$// if $^O eq 'VMS';
+	if( $test =~ /_t$/i ){
+		print "# $test" . '.' x (20 - length $test);
+		profile $test;
+	}
+	else{
+		verify $test;
+	}
+}
+
+unlink("tmon.out");