[Orca-checkins] rev 190 - in trunk/orca: . packages packages/DProf-19990108 packages/DProf-19990108/t
blair at orcaware.com
blair at orcaware.com
Tue Jan 7 23:20:32 PST 2003
Author: blair
Date: 2003-01-07 23:20:14 -0800 (Tue, 07 Jan 2003)
New Revision: 190
Added:
trunk/orca/packages/DProf-19990108/
trunk/orca/packages/DProf-19990108/Changes
trunk/orca/packages/DProf-19990108/DProf.pm
trunk/orca/packages/DProf-19990108/DProf.xs
trunk/orca/packages/DProf-19990108/MANIFEST
trunk/orca/packages/DProf-19990108/Makefile.PL
trunk/orca/packages/DProf-19990108/README
trunk/orca/packages/DProf-19990108/Todo
trunk/orca/packages/DProf-19990108/dprofpp.PL
trunk/orca/packages/DProf-19990108/t/
trunk/orca/packages/DProf-19990108/t/V.pm
trunk/orca/packages/DProf-19990108/t/test1.pl
trunk/orca/packages/DProf-19990108/t/test1.t
trunk/orca/packages/DProf-19990108/t/test1.v
trunk/orca/packages/DProf-19990108/t/test2.t
trunk/orca/packages/DProf-19990108/t/test2.v
trunk/orca/packages/DProf-19990108/t/test3.t
trunk/orca/packages/DProf-19990108/t/test3.v
trunk/orca/packages/DProf-19990108/t/test4.t
trunk/orca/packages/DProf-19990108/t/test4.v
trunk/orca/packages/DProf-19990108/t/test5.t
trunk/orca/packages/DProf-19990108/t/test5.v
trunk/orca/packages/DProf-19990108/t/test6.t
trunk/orca/packages/DProf-19990108/t/test6.v
trunk/orca/packages/DProf-19990108/test.pl
Modified:
trunk/orca/INSTALL
trunk/orca/configure.in
trunk/orca/packages/Makefile.in
Log:
To help profile Orca using Perl's Devel::DProf, include Devel::DProf
version 19990108 in the packages directory. Perl versions 5.6.1 and
newer come with newer versions of Devel::DProf, so this is to help
with older versions of Perl, such as 5.005_03 which is packaged with
Solaris 8.
* INSTALL (Determine which Perl modules need compiling and installing):
Update the table listing the required Perl modules to also list the
optional modules, Date::Parse and Devel::DProf.
Rename the column "Required Version" to "Required Package Version".
Add another column to the table, "Required Module Version". The
module version is the version of the module in the module's
$VERSION. The package version is the version number in the file
name of the .tar.gz that includes the Perl module.
Update RRDs's version number to 1.0.40 from 1.0.33 to reflect
reality.
Include the commands to download, compile and install Date::Parse
and Devel::Dprof in the section where the other Perl modules are
described.
* configure.in:
New variables DEVEL_DPROF_DIR, DEVEL_DPROF_VER, MAKE_DEVEL_DPROF,
TEST_DEVEL_DPROF, INSTALL_PERL_DEVEL_DPROF, CLEAN_DEVEL_DPROF,
DISTCLEAN_DEVEL_DPROF.
Check if Devel::DProf version 19990108 is installed in Perl. Set up
the Makefile's to build and install it if it isn't already
installed.
* packages/Makefile.in:
Add all the rules to make, test, install, clean and distclean
Devel::DProf.
* packages/DProf-19990108:
Directory contents copied from DProf-19990108.tar.gz.
Modified: trunk/orca/configure.in
==============================================================================
--- trunk/orca/configure.in (original)
+++ trunk/orca/configure.in 2003-01-07 23:20:26.000000000 -0800
@@ -31,6 +31,8 @@
DATA_DUMPER_VER=2.101
DATE_PARSE_DIR=TimeDate-1.14
DATE_PARSE_VER=2.24
+DEVEL_DPROF_DIR=DProf-19990108
+DEVEL_DPROF_VER=19990108
DIGEST_MD5_DIR=Digest-MD5-2.22
DIGEST_MD5_VER=2.22
MATH_INTERVALSEARCH_DIR=Math-Interpolate-1.05
@@ -45,6 +47,7 @@
AC_SUBST(COMPRESS_ZLIB_DIR)
AC_SUBST(DATA_DUMPER_DIR)
AC_SUBST(DATE_PARSE_DIR)
+AC_SUBST(DEVEL_DPROF_DIR)
AC_SUBST(DIGEST_MD5_DIR)
AC_SUBST(MATH_INTERVALSEARCH_DIR)
AC_SUBST(RRDTOOL_DIR)
@@ -53,6 +56,7 @@
AC_SUBST(COMPRESS_ZLIB_VER)
AC_SUBST(DATA_DUMPER_VER)
AC_SUBST(DATE_PARSE_VER)
+AC_SUBST(DEVEL_DPROF_VER)
AC_SUBST(DIGEST_MD5_VER)
AC_SUBST(MATH_INTERVALSEARCH_VER)
AC_SUBST(RRDTOOL_VER)
@@ -342,6 +346,21 @@
AC_SUBST(CLEAN_DATE_PARSE)
AC_SUBST(DISTCLEAN_DATE_PARSE)
+BORP_PERL_MODULE(orca_cv_perl_devel_dprof, $PERL, Devel::DProf, $DEVEL_DPROF_VER)
+test "$ALWAYS_BUILD_PERL_MODULES" && orca_cv_perl_devel_dprof=no
+if test "$orca_cv_perl_devel_dprof" = no; then
+ MAKE_DEVEL_DPROF=make_devel_dprof
+ TEST_DEVEL_DPROF=test_devel_dprof
+ INSTALL_PERL_DEVEL_DPROF=install_perl_devel_dprof
+ CLEAN_DEVEL_DPROF=clean_devel_dprof
+ DISTCLEAN_DEVEL_DPROF=distclean_devel_dprof
+fi
+AC_SUBST(MAKE_DEVEL_DPROF)
+AC_SUBST(TEST_DEVEL_DPROF)
+AC_SUBST(INSTALL_PERL_DEVEL_DPROF)
+AC_SUBST(CLEAN_DEVEL_DPROF)
+AC_SUBST(DISTCLEAN_DEVEL_DPROF)
+
BORP_PERL_MODULE(orca_cv_perl_digest_md5, $PERL, Digest::MD5, $DIGEST_MD5_VER)
test "$ALWAYS_BUILD_PERL_MODULES" && orca_cv_perl_digest_md5=no
if test "$orca_cv_perl_digest_md5" = no; then
Modified: trunk/orca/INSTALL
==============================================================================
--- trunk/orca/INSTALL (original)
+++ trunk/orca/INSTALL 2003-01-07 23:20:26.000000000 -0800
@@ -154,25 +154,37 @@
4) Determine which Perl modules need compiling and installing.
Optionally download newer versions of these modules.
- Orca requires the following Perl modules at the specified
- versions:
+ The Orca distribution includes the following Perl modules. Some
+ of them are required for Orca to execute and some are included as
+ modules that may be needed to help process data loaded by Orca
+ (such as Date::Parse) or to profile Orca for performance
+ improvements (Devel::DProf).
+
+ Here, the module version refers to the $VERSION variable in the
+ Perl module that is loaded by Perl and the package version refers
+ to the version number in the file name of the .tar.gz that
+ includes the Perl module.
+
+ Module Required Required Package Version
+ Name Module Package Included With
+ Version Version Orca
+ -------------------------------------------------------------------
+ Data::Dumper >= 2.101 >= 2.101 2.101
+ Date::Parse Not required by Orca 2.24
+ Devel::DProf Not required by Orca 19990108
+ Digest::MD5 >= 2.22 >= 2.22 2.22
+ Math::IntervalSearch >= 1.05 >= 1.05 1.05
+ RRDs >= 1.000401 >= 1.0.40 1.0.40
+ Storable >= 2.06 >= 2.06 2.06
- Name Required Version Included With Orca
- ----------------------------------------------------------------------
- Data::Dumper 2.101 or greater 2.101
- Digest::MD5 2.22 or greater 2.22
- Math::IntervalSearch 1.05 or greater 1.05
- RRDs 1.0.33 or greater 1.0.33
- Storable 2.06 or greater 2.06
-
- All five of these modules are included with the Orca distribution
+ All seven of these modules are included with the Orca distribution
in the packages directory. When you configure Orca in step 3),
configure will determine if you need any of these modules compiled
and installed. configure will then modify the packages/Makefile
file to only build those modules that need to be installed.
- All of the modules except for Math::IntervalSearch require a
- compiler and generate shared libraries by default.
+ All of the modules except for Date::Parse and Math::IntervalSearch
+ require a C compiler and generate shared libraries by default.
If you wish to download and install modules that have been updated
since this Orca package has been assembled, please use the
@@ -189,6 +201,28 @@
% make test
% make install
+ Date::Parse
+
+ http://www.perl.com/CPAN/authors/id/G/GB/GBARR/TimeDate-1.14.tar.gz
+
+ % gunzip -c TimeDate-1.14.tar.gz | tar xvf -
+ % cd TimeDate-1.14
+ % perl Makefile.PL
+ % make
+ % make test
+ % make install
+
+ Devel::DProf
+
+ http://www.perl.com/CPAN/authors/id/I/IL/ILYAZ/modules/DProf-19990108.tar.gz
+
+ % gunzip -c DProf-19990108.tar.gz | tar xvf -
+ % cd DProf-19990108
+ % perl Makefile.PL
+ % make
+ % make test
+ % make install
+
Digest::MD5
http://www.perl.com/CPAN/authors/id/G/GA/GAAS/Digest-MD5-2.22.tar.gz
Modified: trunk/orca/packages/Makefile.in
==============================================================================
--- trunk/orca/packages/Makefile.in (original)
+++ trunk/orca/packages/Makefile.in 2003-01-07 23:20:26.000000000 -0800
@@ -6,6 +6,7 @@
compress_zlib_dir = @COMPRESS_ZLIB_DIR@
data_dumper_dir = @DATA_DUMPER_DIR@
date_parse_dir = @DATE_PARSE_DIR@
+devel_dprof_dir = @DEVEL_DPROF_DIR@
digest_md5_dir = @DIGEST_MD5_DIR@
math_intervalsearch_dir = @MATH_INTERVALSEARCH_DIR@
rrdtool_dir = @RRDTOOL_DIR@
@@ -14,6 +15,7 @@
MAKE_COMPRESS_ZLIB = @MAKE_COMPRESS_ZLIB@
MAKE_DATA_DUMPER = @MAKE_DATA_DUMPER@
MAKE_DATE_PARSE = @MAKE_DATE_PARSE@
+MAKE_DEVEL_DPROF = @MAKE_DEVEL_DPROF@
MAKE_DIGEST_MD5 = @MAKE_DIGEST_MD5@
MAKE_MATH_INTERVALSEARCH = @MAKE_MATH_INTERVALSEARCH@
MAKE_RRDTOOL = @MAKE_RRDTOOL@
@@ -21,6 +23,7 @@
MAKE_TARGETS = $(MAKE_COMPRESS_ZLIB) \
$(MAKE_DATA_DUMPER) \
$(MAKE_DATE_PARSE) \
+ $(MAKE_DEVEL_DPROF) \
$(MAKE_DIGEST_MD5) \
$(MAKE_MATH_INTERVALSEARCH) \
$(MAKE_RRDTOOL) \
@@ -29,6 +32,7 @@
TEST_COMPRESS_ZLIB = @TEST_COMPRESS_ZLIB@
TEST_DATA_DUMPER = @TEST_DATA_DUMPER@
TEST_DATE_PARSE = @TEST_DATE_PARSE@
+TEST_DEVEL_DPROF = @TEST_DEVEL_DPROF@
TEST_DIGEST_MD5 = @TEST_DIGEST_MD5@
TEST_MATH_INTERVALSEARCH = @TEST_MATH_INTERVALSEARCH@
TEST_RRDTOOL = @TEST_RRDTOOL@
@@ -36,6 +40,7 @@
TEST_TARGETS = $(TEST_COMPRESS_ZLIB) \
$(TEST_DATA_DUMPER) \
$(TEST_DATE_PARSE) \
+ $(TEST_DEVEL_DPROF) \
$(TEST_DIGEST_MD5) \
$(TEST_MATH_INTERVALSEARCH) \
$(TEST_RRDTOOL) \
@@ -44,6 +49,7 @@
INSTALL_PERL_COMPRESS_ZLIB = @INSTALL_PERL_COMPRESS_ZLIB@
INSTALL_PERL_DATA_DUMPER = @INSTALL_PERL_DATA_DUMPER@
INSTALL_PERL_DATE_PARSE = @INSTALL_PERL_DATE_PARSE@
+INSTALL_PERL_DEVEL_DPROF = @INSTALL_PERL_DEVEL_DPROF@
INSTALL_PERL_DIGEST_MD5 = @INSTALL_PERL_DIGEST_MD5@
INSTALL_PERL_MATH_INTERVALSEARCH = @INSTALL_PERL_MATH_INTERVALSEARCH@
INSTALL_PERL_RRDTOOL = @INSTALL_PERL_RRDTOOL@
@@ -51,6 +57,7 @@
INSTALL_PERL_TARGETS = $(INSTALL_PERL_COMPRESS_ZLIB) \
$(INSTALL_PERL_DATA_DUMPER) \
$(INSTALL_PERL_DATE_PARSE) \
+ $(INSTALL_PERL_DEVEL_DPROF) \
$(INSTALL_PERL_DIGEST_MD5) \
$(INSTALL_PERL_MATH_INTERVALSEARCH) \
$(INSTALL_PERL_RRDTOOL) \
@@ -62,6 +69,7 @@
CLEAN_COMPRESS_ZLIB = @CLEAN_COMPRESS_ZLIB@
CLEAN_DATA_DUMPER = @CLEAN_DATA_DUMPER@
CLEAN_DATE_PARSE = @CLEAN_DATE_PARSE@
+CLEAN_DEVEL_DPROF = @CLEAN_DEVEL_DPROF@
CLEAN_DIGEST_MD5 = @CLEAN_DIGEST_MD5@
CLEAN_MATH_INTERVALSEARCH = @CLEAN_MATH_INTERVALSEARCH@
CLEAN_RRDTOOL = @CLEAN_RRDTOOL@
@@ -69,6 +77,7 @@
CLEAN_TARGETS = $(CLEAN_COMPRESS_ZLIB) \
$(CLEAN_DATA_DUMPER) \
$(CLEAN_DATE_PARSE) \
+ $(CLEAN_DEVEL_DPROF) \
$(CLEAN_DIGEST_MD5) \
$(CLEAN_MATH_INTERVALSEARCH) \
$(CLEAN_RRDTOOL) \
@@ -77,6 +86,7 @@
DISTCLEAN_COMPRESS_ZLIB = @DISTCLEAN_COMPRESS_ZLIB@
DISTCLEAN_DATA_DUMPER = @DISTCLEAN_DATA_DUMPER@
DISTCLEAN_DATE_PARSE = @DISTCLEAN_DATE_PARSE@
+DISTCLEAN_DEVEL_DPROF = @DISTCLEAN_DEVEL_DPROF@
DISTCLEAN_DIGEST_MD5 = @DISTCLEAN_DIGEST_MD5@
DISTCLEAN_MATH_INTERVALSEARCH = @DISTCLEAN_MATH_INTERVALSEARCH@
DISTCLEAN_RRDTOOL = @DISTCLEAN_RRDTOOL@
@@ -84,6 +94,7 @@
DISTCLEAN_TARGETS = $(DISTCLEAN_COMPRESS_ZLIB) \
$(DISTCLEAN_DATA_DUMPER) \
$(DISTCLEAN_DATE_PARSE) \
+ $(DISTCLEAN_DEVEL_DPROF) \
$(DISTCLEAN_DIGEST_MD5) \
$(DISTCLEAN_MATH_INTERVALSEARCH) \
$(DISTCLEAN_RRDTOOL) \
@@ -109,6 +120,12 @@
$(date_parse_dir)/Makefile: $(date_parse_dir)/Makefile.PL $(PERL)
cd $(date_parse_dir) && $(PERL) Makefile.PL
+make_devel_dprof: $(devel_dprof_dir)/Makefile
+ cd $(devel_dprof_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)"
+
+$(devel_dprof_dir)/Makefile: $(devel_dprof_dir)/Makefile.PL $(PERL)
+ cd $(devel_dprof_dir) && $(PERL) Makefile.PL
+
make_digest_md5: $(digest_md5_dir)/Makefile
cd $(digest_md5_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)"
@@ -152,6 +169,9 @@
test_date_parse: $(date_parse_dir)/Makefile
cd $(date_parse_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" test
+test_devel_dprof: $(devel_dprof_dir)/Makefile
+ cd $(devel_dprof_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" test
+
test_digest_md5: $(digest_md5_dir)/Makefile
cd $(digest_md5_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" test
@@ -180,6 +200,9 @@
install_perl_date_parse: $(date_parse_dir)/Makefile
cd $(date_parse_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" install
+install_perl_devel_dprof: $(devel_dprof_dir)/Makefile
+ cd $(devel_dprof_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" install
+
install_perl_digest_md5: $(digest_md5_dir)/Makefile
cd $(digest_md5_dir) && $(MAKE) OPTIMIZE="$(CFLAGS)" install
@@ -212,6 +235,12 @@
(cd $(date_parse_dir) && $(MAKE) clean); \
fi
+clean_devel_dprof:
+ @if test -r $(devel_dprof_dir)/Makefile; then \
+ echo 'cd $(devel_dprof_dir) && $(MAKE) clean'; \
+ (cd $(devel_dprof_dir) && $(MAKE) clean); \
+ fi
+
clean_digest_md5:
@if test -r $(digest_md5_dir)/Makefile; then \
echo 'cd $(digest_md5_dir) && $(MAKE) clean'; \
@@ -242,6 +271,8 @@
distclean_date_parse: clean_date_parse
+distclean_devel_dprof: clean_devel_dprof
+
distclean_digest_md5: clean_digest_md5
distclean_math_intervalsearch: clean_math_intervalsearch
Added: trunk/orca/packages/DProf-19990108/DProf.xs
==============================================================================
--- trunk/orca/packages/DProf-19990108/DProf.xs (original)
+++ trunk/orca/packages/DProf-19990108/DProf.xs 2003-01-07 23:20:26.000000000 -0800
@@ -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 FILE *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){
+ fprintf(fp,"- & %s\n", name );
+ } else if(ptype == OP_ENTERSUB) {
+ fprintf(fp,"+ & %s\n", name );
+ } else if(ptype == OP_DIE) {
+ fprintf(fp,"/ & %s\n", name );
+ } else {
+ fprintf(fp,"Profiler unknown prof code %d\n", ptype);
+ }
+ safefree(name);
+}
+
+static void
+prof_dumpa(opcode ptype, U32 id)
+{
+ if(ptype == OP_LEAVESUB){
+ fprintf(fp,"- %lx\n", id );
+ } else if(ptype == OP_ENTERSUB) {
+ fprintf(fp,"+ %lx\n", id );
+ } else if(ptype == OP_GOTO) {
+ fprintf(fp,"* %lx\n", id );
+ } else if(ptype == OP_DIE) {
+ fprintf(fp,"/ %lx\n", id );
+ } else {
+ fprintf(fp,"Profiler unknown prof code %d\n", ptype);
+ }
+}
+
+static void
+prof_dumps(U32 id, char *pname, char *gname)
+{
+ fprintf(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)
+{
+ fprintf(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;
+
+ fprintf(fp,"+ & Devel::DProf::write\n" );
+ fprintf(fp,"@ %ld %ld %ld\n",
+ t2.tms_utime - t1.tms_utime, t2.tms_stime - t1.tms_stime,
+ realtime2 - realtime1);
+ fprintf(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 */
+ fprintf(fp, "#fOrTyTwO\n" );
+ fprintf(fp, "$hz=%d;\n", DPROF_HZ );
+ fprintf(fp, "$XS_VERSION='DProf %s';\n", XS_VERSION );
+ fprintf(fp, "# All values are given in HZ\n" );
+ test_time(&r, &u, &s);
+ fprintf(fp, "$over_utime=%ld; $over_stime=%ld; $over_rtime=%ld;\n",
+ u, s, r);
+ fprintf(fp, "$over_tests=10000;\n");
+
+ TIMES_LOCATION = ftell(fp);
+
+ /* Pad with whitespace. */
+ /* This should be enough even for very large numbers. */
+ fprintf(fp, "%*s\n", 240 , "");
+
+ fprintf(fp, "\n");
+ fprintf(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: */
+ fprintf(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 );
+ fprintf(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;
Added: trunk/orca/packages/DProf-19990108/t/V.pm
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/V.pm (original)
+++ trunk/orca/packages/DProf-19990108/t/V.pm 2003-01-07 23:20:26.000000000 -0800
@@ -0,0 +1,65 @@
+package V;
+
+use Getopt::Std 'getopts';
+getopts('vp:');
+
+require Exporter;
+ at ISA = 'Exporter';
+
+ at EXPORT = qw( dprofpp $opt_v $results $expected report @results );
+ at 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 : ¬ok;
+}
+
+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;
Added: trunk/orca/packages/DProf-19990108/t/test1.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test1.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test1.t 2003-01-07 23:20:26.000000000 -0800
@@ -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();
Added: trunk/orca/packages/DProf-19990108/t/test2.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test2.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test2.t 2003-01-07 23:20:27.000000000 -0800
@@ -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();
Added: trunk/orca/packages/DProf-19990108/t/test3.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test3.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test3.t 2003-01-07 23:20:27.000000000 -0800
@@ -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();
Added: trunk/orca/packages/DProf-19990108/t/test1.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test1.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test1.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
Added: trunk/orca/packages/DProf-19990108/t/test4.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test4.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test4.t 2003-01-07 23:20:27.000000000 -0800
@@ -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();
Added: trunk/orca/packages/DProf-19990108/t/test2.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test2.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test2.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
Added: trunk/orca/packages/DProf-19990108/t/test5.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test5.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test5.t 2003-01-07 23:20:27.000000000 -0800
@@ -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 );
+
Added: trunk/orca/packages/DProf-19990108/t/test3.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test3.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test3.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
Added: trunk/orca/packages/DProf-19990108/t/test6.t
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test6.t (original)
+++ trunk/orca/packages/DProf-19990108/t/test6.t 2003-01-07 23:20:27.000000000 -0800
@@ -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(); };
+
Added: trunk/orca/packages/DProf-19990108/t/test4.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test4.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test4.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
Added: trunk/orca/packages/DProf-19990108/t/test5.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test5.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test5.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
+
Added: trunk/orca/packages/DProf-19990108/t/test6.v
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test6.v (original)
+++ trunk/orca/packages/DProf-19990108/t/test6.v 2003-01-07 23:20:27.000000000 -0800
@@ -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 };
+
Added: trunk/orca/packages/DProf-19990108/t/test1.pl
==============================================================================
--- trunk/orca/packages/DProf-19990108/t/test1.pl (original)
+++ trunk/orca/packages/DProf-19990108/t/test1.pl 2003-01-07 23:20:27.000000000 -0800
@@ -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();
+
Added: trunk/orca/packages/DProf-19990108/dprofpp.PL
==============================================================================
--- trunk/orca/packages/DProf-19990108/dprofpp.PL (original)
+++ trunk/orca/packages/DProf-19990108/dprofpp.PL 2003-01-07 23:20:27.000000000 -0800
@@ -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 at 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 ':';
Added: trunk/orca/packages/DProf-19990108/DProf.pm
==============================================================================
--- trunk/orca/packages/DProf-19990108/DProf.pm (original)
+++ trunk/orca/packages/DProf-19990108/DProf.pm 2003-01-07 23:20:27.000000000 -0800
@@ -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 at 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;
+ at 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;
Added: trunk/orca/packages/DProf-19990108/Todo
==============================================================================
--- trunk/orca/packages/DProf-19990108/Todo (original)
+++ trunk/orca/packages/DProf-19990108/Todo 2003-01-07 23:20:27.000000000 -0800
@@ -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;
Added: trunk/orca/packages/DProf-19990108/MANIFEST
==============================================================================
--- trunk/orca/packages/DProf-19990108/MANIFEST (original)
+++ trunk/orca/packages/DProf-19990108/MANIFEST 2003-01-07 23:20:27.000000000 -0800
@@ -0,0 +1,23 @@
+Changes
+DProf.pm
+DProf.xs
+MANIFEST
+Makefile.PL
+README
+Todo
+dprofpp.PL
+t/V.pm verification lib for tests
+t/test1.t
+t/test1.v
+t/test2.t
+t/test2.v
+t/test3.t
+t/test3.v
+t/test4.t fork test
+t/test4.v
+t/test5.t &bar as &bar(@_) test
+t/test5.v
+t/test6.t Nonlocal exit test
+t/test6.v
+test.pl test suite driver
+t/test1.pl alternate test
Added: trunk/orca/packages/DProf-19990108/Makefile.PL
==============================================================================
--- trunk/orca/packages/DProf-19990108/Makefile.PL (original)
+++ trunk/orca/packages/DProf-19990108/Makefile.PL 2003-01-07 23:20:27.000000000 -0800
@@ -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;
+}
Added: trunk/orca/packages/DProf-19990108/Changes
==============================================================================
--- trunk/orca/packages/DProf-19990108/Changes (original)
+++ trunk/orca/packages/DProf-19990108/Changes 2003-01-07 23:20:27.000000000 -0800
@@ -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.
+#
+
Added: trunk/orca/packages/DProf-19990108/test.pl
==============================================================================
--- trunk/orca/packages/DProf-19990108/test.pl (original)
+++ trunk/orca/packages/DProf-19990108/test.pl 2003-01-07 23:20:28.000000000 -0800
@@ -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';
+ at 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;
+ }
+}
Added: trunk/orca/packages/DProf-19990108/README
==============================================================================
--- trunk/orca/packages/DProf-19990108/README (original)
+++ trunk/orca/packages/DProf-19990108/README 2003-01-07 23:20:28.000000000 -0800
@@ -0,0 +1,18 @@
+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.
+
+The dprofpp tool is included in this package.
+
+For more information consult the pod in DProf.pm.
+
+Compatibility Notes (by Gurusamy Sarathy and Andreas König):
+------------------------------------------------------------
+
+DProf-19970614 will only work with 5.004 and above. DProf-19970930
+does work with 5.004 (stricly speaking), but it has a buggy testsuite
+that will fail (correctly) on 5.004.
+
+If you're using 5.003, you need to go back to the previous version on
+CPAN (DProf-19960930). DProf-19970606 and above will only work with
+perl 5.004 and later.
More information about the Orca-checkins
mailing list