Devel-DProf-20110802.00000755001750001750 011615775703 13305 5ustar00raflrafl000000000000Todo100600001750001750 103611615775703 14206 0ustar00raflrafl000000000000Devel-DProf-20110802.00- 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; README100644001750001750 46711615775703 14235 0ustar00raflrafl000000000000Devel-DProf-20110802.00 This archive contains the distribution Devel-DProf, version 20110802.00: a B Perl code profiler This software is copyright (c) 2011 by The Perl 5 Porters. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Changes100644001750001750 1557011615775703 14711 0ustar00raflrafl000000000000Devel-DProf-20110802.002011 Aug 02 Alexandr Ciornii - search for dprofpp inside bin/ directory - compatibility with perls before deprecate.pm was introduced 2011 Feb 28 Florian Ragwitz: - Support 5.10 and possibly even older versions of perl. 2011 Feb 25 Florian Ragwitz: - Tell PAUSE to not index our dprof/ directory containing test modules. 2011 Feb 25 Florian Ragwitz: - Deprecate this module in favour of Devel::NYTProf. - This is the first upload of Devel::DProf directly to CPAN. It's still part of the perl core as of version 5.14.0, but it's also deprecated there, will warn when being used without installing it from CPAN first, and will disappear as a core module in a future version of perl. 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. # LICENSE100644001750001750 4372211615775703 14423 0ustar00raflrafl000000000000Devel-DProf-20110802.00This software is copyright (c) 2011 by The Perl 5 Porters. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2011 by The Perl 5 Porters. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2011 by The Perl 5 Porters. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DProf.xs100600001750001750 5167211615775703 14777 0ustar00raflrafl000000000000Devel-DProf-20110802.00#define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef get_cvs #define get_cvs(name, flags) \ Perl_get_cvn_flags(aTHX_ name, sizeof(name) - 1, (flags)) #endif /* 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 /* prototype for sys$gettim() */ # include # 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 # 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 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 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; } DProf.pm100600001750001750 1547511615775703 14762 0ustar00raflrafl000000000000Devel-DProf-20110802.00use 5.006_001; =head1 NAME Devel::DProf - a B Perl code profiler =head1 SYNOPSIS perl -d:DProf test.pl =head1 ACHTUNG! C is B and will be removed from a future version of Perl. We strongly recommend that you install and use L 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 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. A tool like I 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 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 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, 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. =head1 ENVIRONMENT C sets size of output buffer in words. Defaults to 2**14. C sets number of ticks per second on some systems where a replacement for times() is used. Defaults to the value of C macro. C 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, 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 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 for more details. =head1 SEE ALSO L, L, 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 = '20110802.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; dist.ini100600001750001750 125211615775703 15022 0ustar00raflrafl000000000000Devel-DProf-20110802.00name = Devel-DProf version = 20110802.00 author = The Perl 5 Porters license = Perl_5 copyright_holder = The Perl 5 Porters main_module = DProf.pm [@Basic] [DualLife] [MetaConfig] [MetaJSON] [PodSyntaxTests] [MetaResources] repository.type = git repository.url = git://github.com/rafl/devel-dprof.git repository.web = http://github.com/rafl/devel-dprof bugtracker.web = http://rt.cpan.org/Public/Dist/Display.html?Name=Devel-DProf bugtracker.mailto = bug-Devel-DProf@rt.cpan.org homepage = http://search.cpan.org/dist/Devel-DProf [MetaNoIndex] directory = dprof [Authority] authority = cpan:FLORA do_metadata = 1 do_munging = 0 [Prereqs] XSLoader = 0 META.yml100644001750001750 726011615775703 14644 0ustar00raflrafl000000000000Devel-DProf-20110802.00--- abstract: 'a B Perl code profiler' author: - 'The Perl 5 Porters' build_requires: {} configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 4.200012, CPAN::Meta::Converter version 2.110930' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Devel-DProf no_index: directory: - dprof requires: XSLoader: 0 resources: bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Devel-DProf homepage: http://search.cpan.org/dist/Devel-DProf repository: git://github.com/rafl/devel-dprof.git version: 20110802.00 x_Dist_Zilla: plugins: - class: Dist::Zilla::Plugin::GatherDir name: '@Basic/GatherDir' version: 4.200012 - class: Dist::Zilla::Plugin::PruneCruft name: '@Basic/PruneCruft' version: 4.200012 - class: Dist::Zilla::Plugin::ManifestSkip name: '@Basic/ManifestSkip' version: 4.200012 - class: Dist::Zilla::Plugin::MetaYAML name: '@Basic/MetaYAML' version: 4.200012 - class: Dist::Zilla::Plugin::License name: '@Basic/License' version: 4.200012 - class: Dist::Zilla::Plugin::Readme name: '@Basic/Readme' version: 4.200012 - class: Dist::Zilla::Plugin::ExtraTests name: '@Basic/ExtraTests' version: 4.200012 - class: Dist::Zilla::Plugin::ExecDir name: '@Basic/ExecDir' version: 4.200012 - class: Dist::Zilla::Plugin::ShareDir name: '@Basic/ShareDir' version: 4.200012 - class: Dist::Zilla::Plugin::MakeMaker name: '@Basic/MakeMaker' version: 4.200012 - class: Dist::Zilla::Plugin::Manifest name: '@Basic/Manifest' version: 4.200012 - class: Dist::Zilla::Plugin::TestRelease name: '@Basic/TestRelease' version: 4.200012 - class: Dist::Zilla::Plugin::ConfirmRelease name: '@Basic/ConfirmRelease' version: 4.200012 - class: Dist::Zilla::Plugin::UploadToCPAN name: '@Basic/UploadToCPAN' version: 4.200012 - class: Dist::Zilla::Plugin::DualLife name: DualLife version: 0.01 - class: Dist::Zilla::Plugin::MetaConfig name: MetaConfig version: 4.200012 - class: Dist::Zilla::Plugin::MetaJSON name: MetaJSON version: 4.200012 - class: Dist::Zilla::Plugin::PodSyntaxTests name: PodSyntaxTests version: 4.200012 - class: Dist::Zilla::Plugin::MetaResources name: MetaResources version: 4.200012 - class: Dist::Zilla::Plugin::MetaNoIndex name: MetaNoIndex version: 4.200012 - class: Dist::Zilla::Plugin::Authority name: Authority version: 1.005 - class: Dist::Zilla::Plugin::Prereqs config: Dist::Zilla::Plugin::Prereqs: phase: runtime type: requires name: Prereqs version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':InstallModules' version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':IncModules' version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':TestFiles' version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':ExecFiles' version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':ShareFiles' version: 4.200012 - class: Dist::Zilla::Plugin::FinderCode name: ':MainModule' version: 4.200012 zilla: class: Dist::Zilla::Dist::Builder config: is_trial: 0 version: 4.200012 x_authority: cpan:FLORA MANIFEST100644001750001750 56711615775703 14507 0ustar00raflrafl000000000000Devel-DProf-20110802.00Changes DProf.pm DProf.xs LICENSE MANIFEST META.json META.yml Makefile.PL README Todo bin/dprofpp dist.ini dprof/V.pm dprof/test1_t dprof/test1_v dprof/test2_t dprof/test2_v dprof/test3_t dprof/test3_v dprof/test4_t dprof/test4_v dprof/test5_t dprof/test5_v dprof/test6_t dprof/test6_v dprof/test7_t dprof/test7_v dprof/test8_t dprof/test8_v t/DProf.t t/release-pod-syntax.t t000755001750001750 011615775703 13471 5ustar00raflrafl000000000000Devel-DProf-20110802.00DProf.t100600001750001750 342511615775703 15024 0ustar00raflrafl000000000000Devel-DProf-20110802.00/t#!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 (, ); # 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 = ; 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"); META.json100644001750001750 1341211615775703 15030 0ustar00raflrafl000000000000Devel-DProf-20110802.00{ "abstract" : "a B Perl code profiler", "author" : [ "The Perl 5 Porters" ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 4.200012, CPAN::Meta::Converter version 2.110930", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-DProf", "no_index" : { "directory" : [ "dprof" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.30" } }, "runtime" : { "requires" : { "XSLoader" : 0 } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Devel-DProf@rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Devel-DProf" }, "homepage" : "http://search.cpan.org/dist/Devel-DProf", "repository" : { "type" : "git", "url" : "git://github.com/rafl/devel-dprof.git", "web" : "http://github.com/rafl/devel-dprof" } }, "version" : "20110802.00", "x_Dist_Zilla" : { "plugins" : [ { "class" : "Dist::Zilla::Plugin::GatherDir", "name" : "@Basic/GatherDir", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::PruneCruft", "name" : "@Basic/PruneCruft", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::ManifestSkip", "name" : "@Basic/ManifestSkip", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::MetaYAML", "name" : "@Basic/MetaYAML", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::License", "name" : "@Basic/License", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::Readme", "name" : "@Basic/Readme", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::ExtraTests", "name" : "@Basic/ExtraTests", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::ExecDir", "name" : "@Basic/ExecDir", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::ShareDir", "name" : "@Basic/ShareDir", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::MakeMaker", "name" : "@Basic/MakeMaker", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::Manifest", "name" : "@Basic/Manifest", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::TestRelease", "name" : "@Basic/TestRelease", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::ConfirmRelease", "name" : "@Basic/ConfirmRelease", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::UploadToCPAN", "name" : "@Basic/UploadToCPAN", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::DualLife", "name" : "DualLife", "version" : "0.01" }, { "class" : "Dist::Zilla::Plugin::MetaConfig", "name" : "MetaConfig", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::MetaJSON", "name" : "MetaJSON", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::PodSyntaxTests", "name" : "PodSyntaxTests", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::MetaResources", "name" : "MetaResources", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::MetaNoIndex", "name" : "MetaNoIndex", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::Authority", "name" : "Authority", "version" : "1.005" }, { "class" : "Dist::Zilla::Plugin::Prereqs", "config" : { "Dist::Zilla::Plugin::Prereqs" : { "phase" : "runtime", "type" : "requires" } }, "name" : "Prereqs", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":InstallModules", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":IncModules", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":TestFiles", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ExecFiles", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":ShareFiles", "version" : "4.200012" }, { "class" : "Dist::Zilla::Plugin::FinderCode", "name" : ":MainModule", "version" : "4.200012" } ], "zilla" : { "class" : "Dist::Zilla::Dist::Builder", "config" : { "is_trial" : "0" }, "version" : "4.200012" } }, "x_authority" : "cpan:FLORA" } dprof000755001750001750 011615775703 14340 5ustar00raflrafl000000000000Devel-DProf-20110802.00V.pm100600001750001750 227311615775703 15237 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofpackage 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 || ($ENV{'PERL_CORE'}?'../../utils/dprofpp':'bin/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 = ; close D; open( 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 { print "ok $num\n"; } sub notok { print "not ok $num\n"; print "\nResult\n{$results}\n"; print "Expected\n{$expected}\n"; } 1; bin000755001750001750 011615775703 13776 5ustar00raflrafl000000000000Devel-DProf-20110802.00dprofpp100644001750001750 5752511615775703 15571 0ustar00raflrafl000000000000Devel-DProf-20110802.00/bin#!/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; if($] > 5.013010) { require deprecate; if (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> [B<-P>]] [B<-f> ] [profile] dprofpp B<-T> [B<-F>] [B<-g subroutine>] [profile] dprofpp B<-t> [B<-F>] [B<-g subroutine>] [profile] dprofpp B<-G> [B<-P>] [profile] dprofpp B<-p script> [B<-Q>] [other opts] dprofpp B<-V> [profile] =head1 DESCRIPTION The I command interprets profile data produced by a profiler, such as the Devel::DProf profiler. Dprofpp will read the file F 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 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 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 I the C switches to actual subroutine, so a separate statistics for C 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 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 subroutine call tree to stdout. Statistics are displayed for each branch of the tree. When a function is called multiple (I) 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 Ignore subroutines except C and whatever is called from it. =item B<-G> 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> 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 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. Mail bug reports and feature requests to the perl5-porters mailing list at Fperl5-porters@perl.orgE>. Bug reports should include the output of the B<-V> option. =head1 FILES dprofpp - profile processor tmon.out - raw profile =head1 SEE ALSO L, L, 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 .'; } Makefile.PL100644001750001750 207211615775703 15341 0ustar00raflrafl000000000000Devel-DProf-20110802.00 use strict; use warnings; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( 'ABSTRACT' => 'a B Perl code profiler', 'AUTHOR' => 'The Perl 5 Porters', 'BUILD_REQUIRES' => {}, 'CONFIGURE_REQUIRES' => { 'ExtUtils::MakeMaker' => '6.30' }, 'DISTNAME' => 'Devel-DProf', 'EXE_FILES' => [ 'bin/dprofpp' ], 'LICENSE' => 'perl', 'NAME' => 'Devel::DProf', 'PREREQ_PM' => { 'XSLoader' => '0' }, 'VERSION' => '20110802.00', 'test' => { 'TESTS' => 't/*.t' } ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.56) } ) { my $br = delete $WriteMakefileArgs{BUILD_REQUIRES}; my $pp = $WriteMakefileArgs{PREREQ_PM}; for my $mod ( keys %$br ) { if ( exists $pp->{$mod} ) { $pp->{$mod} = $br->{$mod} if $br->{$mod} > $pp->{$mod}; } else { $pp->{$mod} = $br->{$mod}; } } } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; $WriteMakefileArgs{INSTALLDIRS} = 'perl' if $] >= 5.009005 && $] <= 5.011000; WriteMakefile(%WriteMakefileArgs); test3_t100600001750001750 24311615775703 15757 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub 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(); test1_t100600001750001750 23111615775703 15752 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub 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(); test4_v100600001750001750 77111615775703 15770 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test2_t100600001750001750 26011615775703 15755 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub 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(); test7_v100600001750001750 16411615775703 15767 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# perl use V; dprofpp( '-T' ); $expected = qq{main::BEGIN main::foo }; report 19, sub { $expected eq $results }; test8_v100600001750001750 17011615775703 15765 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# perl use V; dprofpp( '-t' ); $expected = qq{main::foo (2x) main::bar }; report 20, sub { $expected eq $results }; test7_t100600001750001750 11311615775703 15757 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofBEGIN { print "in BEGIN\n"; } sub foo { print "in sub foo\n"; } foo(); test5_t100600001750001750 43411615775703 15763 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 ); test5_v100600001750001750 26611615775703 15770 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test6_v100600001750001750 26311615775703 15766 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test6_t100600001750001750 53211615775703 15763 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub 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(); }; test3_v100600001750001750 62611615775703 15766 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test2_v100600001750001750 76511615775703 15771 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test1_v100600001750001750 54111615775703 15760 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprof# 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 }; test8_t100600001750001750 22211615775703 15761 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub foo { print "in sub foo\n"; } sub bar { print "in sub bar\n"; $^P -= 0x40; } foo(); $^P -= 0x40; foo(); $^P += 0x40; bar(); $^P += 0x40; test4_t100600001750001750 30111615775703 15753 0ustar00raflrafl000000000000Devel-DProf-20110802.00/dprofsub 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(); release-pod-syntax.t100644001750001750 45011615775703 17521 0ustar00raflrafl000000000000Devel-DProf-20110802.00/t#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok();