Devel-NYTProf-6.06/000750 000766 000024 00000000000 13305245315 014255 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/demo/000750 000766 000024 00000000000 13305245314 015200 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/INSTALL000644 000766 000024 00000001615 12211321457 015313 0ustar00timbostaff000000 000000 # vim: ts=8 sw=2 sts=0 noexpandtab: Devel::NYTProf Installation Notes ================================= For the most part, users on Unix-like operating system can do: perl Makefile.PL make make test make install The module library tried to speed thing up when running in forkmode by using fpruge() to delete potential duplicated buffers. Unfortunately, althrough fpurge() *is* in the GNU manual, operating systems largely implement it very differently. The Makefile.PL does some magic to find out where your particular version of fpurge is. Usually it can be found in stdio.h or stdio_ext.h, so make sure those are in your INCLUDE path. It is also sometimes named fpurge _fpurge or __fpurge. COMPILE NOTES The module was written to compile silently with -Wall -pedantic -ansi. Some warnings might be generated from methods like XS_blah. These are in Perl generated code and cannot be fixed by me. Devel-NYTProf-6.06/bin/000750 000766 000024 00000000000 13305245314 015024 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/NYTProf.h000644 000766 000024 00000001136 12523657114 015742 0ustar00timbostaff000000 000000 /* vim: ts=8 sw=4 expandtab: * ************************************************************************ * This file is part of the Devel::NYTProf package. * Copyright 2008 Adam J. Kaplan, The New York Times Company. * Copyright 2008 Tim Bunce, Ireland. * Released under the same terms as Perl 5.8 * See http://metacpan.org/release/Devel-NYTProf/ * * Contributors: * Adam Kaplan, akaplan at nytimes.com * Tim Bunce, http://www.tim.bunce.name and http://blog.timbunce.org * Steve Peters, steve at fisharerojo.org * * ************************************************************************ */ Devel-NYTProf-6.06/Changes000644 000766 000024 00000074350 13305237272 015571 0ustar00timbostaff000000 000000 =head1 NAME Devel::NYTProf::Changes - History of significant changes in Devel::NYTProf =cut =head2 Changes in Devel::NYTProf 6.06 - 4th June 2018 Fix sorting of numbers ending ...5s as microsec thanks to pichi. #120 Fix tests for Strawberry Perl portable thanks to shawnlaffan. #123 Fixed broken link in the pod to YAPC::NA 2014 talk video thanks to manwar. #116 Add "NYTProf" to buffer overflow error message for easier triage thanks to atomicstack. #119. Add appveyor config file for CI on Windows thanks to shawnlaffan. #117 =head2 Changes in Devel::NYTProf 6.05 - 23rd March 2018 Fix test failures on Perl 5.27.6+ #113 Fix to prevent memory corruption in incr_sub_inclusive_time thanks to lucrocha #115 Fix test failures on Perl 5.26 w/ PERL_USE_UNSAFE_INC=0, thanks to Kent Fredric #112 Fix for the double opening of the web browser with --open, thanks to trizen #107 Updated links in docs from old svn repository to Github thanks to smpeters #114 =head2 Changes in Devel::NYTProf 6.04 - 24th November 2016 Fixed build on perl 5.25+ due to OpSIBLING, thanks to Dan Collins #102 Fixed nytprofmerge on Windows thanks to andrey-starodubtsev #99 Fixed nytprofhtml invalid UTF-8 char and improved CSS #105 Fixed spelling mistake in nytprofcsv docs. Closes #95 Table headers now stay visible, thanks to Sebastian Rose #106 Assorted improvments to .travis.yml =head2 Changes in Devel::NYTProf 6.03 - 25th March 2016 Fix to account for the deep stack optimizations in perl 5.23.8 by Dave Mitchell, with my great gratitude! Fix SIGUSR2 on MSWin32 and div by zero #78 PR#79 with thanks to Nicolas Georges. Fix for perl 5.8.8 but adding definition for tTHX. Unify 'Profile format error' messages. Improve the TROUBLESHOOTING docs. Added some more docs for the start=init option #85 Corrected URL of KCachegrind home page #87 with thanks to Denis Ibaev. Corrected URL of sample report #80 Removed dead code.nytimes.com URL and redundant history #84 =head2 Changes in Devel::NYTProf 6.02 - 2nd August 2015 FlameGraphs upgraded the latest version, which supports searching. Use JSON::MaybeXS instead of JSON::Any (deprecated), thanks to Ether #73 Updated metacpan urls, thanks to Ether #74 Internal context optimizations, thanks to jandubois #75 =head2 Changes in Devel::NYTProf 6.01 - 4th April 2015 Changed the clock used on Windows to high resolution QueryPerformanceCounter which makes NYTProf useful on windows, at last, thanks to bulk88, #68 Fallback to checking PATH for nytprof scripts, #61 thanks to calid Fix unused variable warnings thanks to zefram, RT#103107 Fix handling of PERL_DISABLE_PMC, thanks to bulk88, #67 Use larger buffer size when writing the data file, thanks to bulk88 #69 Clarified the docs re DB:: functions, #63 thanks to dbooth-boston Documentation cleanup thanks to wollmers, #64 Clarify reason for loading Devel::NYTProf as early as possible. Clarification of the RUN-TIME CONTROL OF PROFILING docs =head2 Changes in Devel::NYTProf 5.07 - 21st Feb 2015 Fixed use of nytprofcalls and flamegraph scripts to not require PATH #21 Fixed nytprofhtml --open for KDE4 thanks to HMBRAND RT#99080 Fixed for installs into directory path with spaces, mohawk2 #40 Fixed printf NV conversion compiler warnings thanks to zefram RT#91986 Disabled optimize in t/test25-strevalb.t if -DDEBUGGING and perl >= 5.20 as workaround for perl RT#70211, #38 Added 'addtimestamp' option to add a timestamp to the output filename (similar to addpid option), PR#17 thanks to Naosuke Yokoe (zentooo) Added nytprofpf script to generate reports in the plat_forms format http://www.plat-forms.org PR#11 thanks to Holger Schmeisky. Added ability to increase the maximum length of a subroutine name #44 Optimized output performance on threaded perl, thanks to bulk88. PR#27 Add docs re FCGI::Engine and open('-|') #20 Corrected typo in nytprofhtml thanks to wollmers #41 Fixed link to screencast, thanks to Herwin. #19 Added hint to use --no-flame for big reports. #28 =head2 Changes in Devel::NYTProf 5.06 - 12th Sept 2013 Fixed for perl 5.19.4. RT#88288 thanks to sprout. Fixed test for change in perl 5.18.x error message text. Fixed to no longer open a file when start=no. RT#86497/RT#87404. Fixed compiler warnings. RT#86728 thanks to Alexander Bluhm. Document that Devel::NYTProf needs to be loaded as early as possible even when using start=no. PR#10 thanks to moritz. Removed unused keyword $Id$. PR#9 thanks to dsteinbrunner. Removed old benchmark.pl files. RT#86704. Corrected assorted typos. PR#8 thanks to dsteinbrunner. Added meta-spec to META_MERGE. PR#12 thanks to dsteinbrunner. =head2 Changes in Devel::NYTProf 5.05 - 2nd July 2013 Fixed crash on "Can't use string as a subroutine ref" error, and probably other die-at-pp_entersub cases, with thanks to Zefram. RT#86638 Fixed crash with libcexit=1, thanks to Zefram. RT#86548 =head2 Changes in Devel::NYTProf 5.04 - 20th June 2013 Allow negative times in tests for systems with unstable clocks thanks to Gisle Aas, RT#85556. Added libcexit=1 option thanks to Zefram, RT#75912. Added documentation for endatexit and libcexit options. Added documentation for nytprofhtml --minimal thanks to Mike Doherty, RT#86039. =head2 Changes in Devel::NYTProf 5.03 - 20th May 2013 Fix windows to use flamegraph.bat [Christian Walde] Generates META.yml which mentions github repo [Christian Walde] Add meta robots noindex to html pages [Tokuhiro Matsuno] =head2 Changes in Devel::NYTProf 5.02 - 21st April 2013 Fix Windows build, properly RT#84738. =head2 Changes in Devel::NYTProf 5.01 - 19th April 2013 Fix Windows build RT#84738. Can't rely on #!-line to always work, PR#3 thanks to Gisle Aas. Avoid triggering "gcc internal compiler error" PR#4 thanks to Gisle Aas. =head2 Changes in Devel::NYTProf 5.00 - 8th April 2013 Added subroutine entry and return event stream, controlled via the calls=N option. Default calls=1. Added nytprofcalls command to process the call event stream to generate timings for distinct call stacks (experimental). Added Flame Graph visualization SVG using the call stack data. Changed blocks=N option to be 0 (disabled) by default. Fixed test for perl 5.17+ hash randomization. Fixed nytprofhtml for Windows thanks to Jan Dubois. PR#2 Fixed assorted nits thanks to Steve Peters. PR#1 Deprecated nytprofcsv - speak up if you use it! No longer warn about $&, $` and $' being slow if $] >= 5.017008. =head2 Changes in Devel::NYTProf 4.25 - 6th Feb 2013 Fix u2time clock (ie Time::HiRes, used by Windows) =head2 Changes in Devel::NYTProf 4.24 - 3rd Feb 2013 Clarify sigexit option docs. Loosen test timing constraints (for slow cpantester VMs). =head2 Changes in Devel::NYTProf 4.23 - 31st Dec 2012 Significant improvement in the accuracy of the subroutine profiler, especially for frequent calls to very short duration subs/ops, and more so for POSIX and OSX systems with sub-microsecond clocks. Fixed tests to work with perl 5.17.7+ (PL_sawampersand gone). Fixed some doc typos thanks to Jesse Sheidlower. Improved nytprofmerge behaviour with inconsistent attributes. Removed the usecputime=1 option. Use clock=N instead if possible. Moved main repo to git (and https://github.com/timbunce/devel-nytprof) =head2 Changes in Devel::NYTProf 4.12 - 28th Dec 2012 Fixed the perl v5.17+ fix to do-the-right-thing for 5.17.4. Fixed pod encoding issues. =head2 Changes in Devel::NYTProf 4.11 (svn 1442) 26th Dec 2012 Fixed to work with perl v5.17+, specifically string eval changes and hash randomization. Fixed so tests ignore sitecustomize.pl, RT#79784 thanks to JACOB@cpan.org. Fixed to sort tables with microsecond values in non-utf8 encodings, RT#77843 Deprecated the usecputime=1 option and documented that it will be removed in a future version. Corrected spelling thanks to Alessandro Ghedini @debian RT#80370 =head2 Changes in Devel::NYTProf 4.09 (svn 1431) 15th Sep 2012 Fixed to work for perl v5.17.3+ thanks to David Mitchell. =head2 Changes in Devel::NYTProf 4.08 (svn 1427) 11th Aug 2012 Fixed version numbers in nytprofhtml and nytprofmerge. =head2 Changes in Devel::NYTProf 4.07 (svn 1419) 10th Aug 2012 Fixed html generation to be valid, RT#70207 (H.Merijn Brand). nytprofmerge no longer dies on some errors, RT#75918. nytprofmerge now sums cumulative_overhead_ticks, RT#75909. nytprofmerge now gets in man page installed, RT#75911. Enable file=/dev/null to work as fix for RT#74565. Updated ::Apache docs including troubleshooting, RT#75912. Note Devel::NYTProf::Data is undocumented and why, RT#75914. Use Browser::Open if installed for nytprofhtml --open. Added and clarified some notes in the troubleshooting docs. Added warning for Apache2::SizeLimit in ::Apache, RT#75912. Clarified docs re fork generating multiple files, RT#78873. =head2 Changes in Devel::NYTProf 4.06 (svn r1406) 30th Nov 2010 Fixed risk of nytprofhtml failure due to over-long filenames RT#62319 Improved handling of Class::MOP/Moose generated methods. Improved handling of embedded filenames, e.g., "(eval N)[$path]" Updated and clarified usecputime=1 docs. Updated tests for (expected) new functionality in Sub::Name. Updated tests for changes in perl 5.13.x. Added special handling for the perl built-in accept() Effectively the clock stops ticking while in accept(). This makes profiles of pure-perl web servers more useful. Added --no-mergeevals option to nytprofhtml. Added "If Statement and Subroutine Timings Don't Match" and "If Headline Subroutine Timings Don't Match the Called Subs" sections to the DATA COLLECTION AND INTERPRETATION docs. Added note to the docs re profiling applications that use Coro. =head2 Changes in Devel::NYTProf 4.05 (svn 1359) 15th Sept 2010 Fixed tests to work with a new optimization in perl 5.13.4. Fixed handling of negative values for subroutine line ranges (that may be added to %DB::sub by buggy software). Fixed handling of negative times from unstable clocks that caused spikes in statement times. Fixed risk of bad line numbers hanging report generation. =head2 Changes in Devel::NYTProf 4.04 (svn 1332) 9th July 2010 Profile now reports presence of the slow regex match vars ($& $' $`). The (cumulative inclusive) recursion time measured for subs that are involved in recursion is now reported as 'recursion: ... sum of overlapping time'. Trace log messages are now flushed immediately. Reduced risk of crashes in embedded applications that don't handle PL_endav carefully, like current versions of mod_perl. =head2 Changes in Devel::NYTProf 4.03 (svn 1316) 19th June 2010 Fixed another nytprofhtml performance problem for profiles with many files/evals. Much faster merging of evals now. For subs that recurse, show max depth and time in subroutine table. =head2 Changes in Devel::NYTProf 4.02 (svn 1309) 17th June 2010 Fixed nytprofhtml performance problem for profiles with many files/evals. Added progress reporting to nytprofhtml. =head2 Changes in Devel::NYTProf 4.01 (svn 1296) 10th June 2010 Fixed links from block/sub level report pages to string eval report pages. RT#58284 Restored ordering of line - block - sub links on index page. Clarified that saving the source code of string evals requires perl version 5.8.9+, 5.10.1+, 5.12 or later. RT#58283 =head2 Changes in Devel::NYTProf 4.00 (svn 1291) 8th June 2010 Major changes: Added profile reporting of code executed in string evals. Each string eval executed gets it's own report page. You can 'see' the code that was executed, with profile info. String evals may be collapsed/merged in some cases. Improved many sub-optimal behaviours related to string evals. Subroutine calls that couldn't be associated with a specific line, such as calls made by perl to END blocks, are now shown in reports. Subroutine definitions that couldn't be associated with a specific file, such as xsubs in packages with no perl source, are now shown in reports. Enabled savesrc=1 by default. The data file format has changed so v3.x files can't be read. The Devel::NYTProf::ReadStream interface has also changed. Other changes: Fixed off-by-1 error in number of Files an xsub/opcode was called from. Fixed Devel::NYTProf::Apache to work in more situations and enable the addpid option by default. Fixed that END blocks defined at runtime are included in the profile thanks to Nicholas Clark. Compilation-only checks (perl -c) can be profiled thanks to Nicholas Clark. Improved behaviour for 'duplicate' anon-subs defined in separate invocations of a particular string eval. Multiple BEGINs (e.g., use) on the same line get distinct names. Added --minimal option to nytprofhtml to disable generation of graphviz .dot files and block/sub-level statement report files. Added automatic detection of calls to POSIX::_exit() by the sub profiler so finish_profile() gets called and a usable profile is produced. Added posix_exit=1 option to do the same thing (in a different way) when the sub profiler is not being used (i.e., subs=0). Documentation Changes: Sequences of blank lines are skipped in generated reports. Relevant for savesrc mode in which perl doesn't store pod sections. Corrected typos in nytprofhtml docs thanks to chocolate@cpan.org. Documented how to use Devel::NYTProf::Apache with virtual hosts that use the PerlOptions +Parent or +Clone configuration. =head2 Changes in Devel::NYTProf 3.11 (svn 1171) 12th March 2010 Fixed assorted issues on Windows thanks to Jan Dubois. Fixed assorted issues 64bit systems thanks to Jan Dubois. Refactored I/O to create an API that encapsulates the data file format, thanks to Nicholas Clark. Updated and optimized nytprofmerge to use the new API yielding a significant speed boost, thanks to Nicholas Clark. =head2 Changes in Devel::NYTProf 3.02 (svn 1094) 5th March 2010 Fixed handling of usecputime=1 option and updated docs to note the significant limitations. Fixed association of XS subs to source files in some edge cases thanks to Nicholas Clark. Fixed nytprofmerge edge cases thanks to Nicholas Clark. Added high-resolution (100ns) timer for Mac OS X many thanks to Markus Peter. Added assorted optimizations thanks to Nicholas Clark. Changed subroutine profiler to be slightly more efficient. Changed some tests to be more informative on failure. Changed nytprofhtml to be smarter when source isn't available. Changed nytprofhtml to show sort arrow on sortable tables. Removed Devel::NYTProf::PgPLPerl module. That's now a separate PostgreSQL::PLPerl::NYTProf distribution. Updated docs to include a note about timing on Windows. Updated docs to include a section about making NYTProf faster. =head2 Changes in Devel::NYTProf 3.01 (svn r1005) 28th Dec 2009 Fixed (removed) use of vfscanf() which broke on Windows. Fixed version number in nytprofmerge. Added documentation to nytprofcg and nytprofmerge. Updated NYTProf docs, including noting major contributors. Updated docs to fix assorted typos, thanks to Jonathan Yu. Updated nytprofcsv documentation. =head2 Changes in Devel::NYTProf 3.00 (svn r998) 24th Dec 2009 Note: The file format has changed. Old files can't be read. Fixed (rare) overflow bug for 32bit perls. Fixed discarding of (rare) negative intervals. Fixed risk of infinite recursion if trace enabled and $SIG{__WARN__} was set to a code reference. Fixed subroutine recursion depth measurement. Fixed missing embedded eval source code for some older perls. Fixed assorted compiler warnings for various configurations. Changed ReadStream SUB_LINE_RANGE tag to SUB_INFO. Added log=F option to write trace log to a file. Added warning when reading a file with a minor version higher than expected. Added slowops=N option which enables profiling of potentially slow perl opcodes (e.g., system calls and regexs). They're treated like xsubs. slowops=0 disables profiling of 'slowops' slowops=1 puts timings into one package ("CORE::", eg CORE::sleep) slowops=2 (the default) puts timings into into the package that made the call, e.g., "Foo::CORE:sleep" (note the single colon). Added sigexit=1 option to enable a useable profile when the process exits due to a signals (catches INT HUP PIPE BUS SEGV by default) Can also do sigexit=TRAP,ABRT,SYS,... to hook specific signals. Thanks to Andrew Sterling Hanenkamp for the seed of this idea. Added forkdepth=N option to enable profiling to be turned off after N generations of fork(). Added nameevals=0 and nameanonsubs=0 options to make NYTProf less visible to code that may assume the default perl naming behaviour. Note that using these will limit the usefulness of reports. Added initial support for profiling PostgreSQL PL/Perl code via Devel::NYTProf::PgPLPerl module. Added nytprofmerge utility: Reads multiple nytprof data files and writes a new merged file. Many thanks to Nicholas Clark! Changes to subroutine profiler: Rewritten. Captures more data more accurately and robustly. Added profiling of calls to xsubs that exit via an exception. Added profiling of goto ⊂ Added recording the name of the calling subroutine to enable proper linking of call trees. Previously only the calling file and line were recorded. (This is more significant than it sounds :) Added docs describing how the subroutine profiler works. Multiple BEGIN blocks (including "use") within a package are now distinguished by appending the number of the line they start on (for perl 5.8.9+ and 5.10.1+) Changes to nytprofhtml: Added interactive treemap view of package and subroutine times. Left-click to zoom in (drill-down) one level, right-click to zoom out. Added generation of GraphViz dot language files to visualize the call graph. A top-level link on the index page provides an inter-package graph, and per-source-file links provide a graph of sub calls in to, out of, and between the subs in the file. See http://en.wikipedia.org/wiki/Graphviz Added columns to the main source code reports to show a count of sub calls and time spent in those calls. Assorted cosmetic improvements. Changed colors on report pages to be less saturated. =head2 Changes in Devel::NYTProf 2.10 (svn r774) 18th June 2009 Fixed call count for XSubs that was one too high. Fixed enable_profile() after fork thanks to delamonpansie http://code.google.com/p/perl-devel-nytprof/issues/detail?id=15 Fixed to use correct scripts during test and so avoid permissions issues, thanks to David Golden. Fixed spurious "Unable to determine line number" warnings when using options like -p, -n, -Mfoo. Changed enable_profile() to discard the time spent since profile was disabled. Changed NYTPROF env var parsing to allow backslash to escape colons, for Windows, thanks to Joshua ben Jore. Added license, homepage, bugtracker, repository and MailingList resources to META.yml thanks to Michael G Schwern. Added nytprofcg utility to generate callgrind data for viewing via Kcachegrind, thanks to Chia-liang Kao. =head2 Changes in Devel::NYTProf 2.09 (svn r733) 29th March 2009 Added support for modules using AutoLoader, e.g., POSIX & Storable, to fix the "Unable to open '... (autosplit into ...)'" warnings. Fixed report filename generation to remove colons, for Windows, reported by Adam Kennedy in rt bug #43798. Fixed report filename generation to remove dots, for VMS. Fixed savesrc option which wasn't safe and reliable. Added missing t/test22-strevala.t to MANIFEST. Extended testing to exercise compress and savesrc options. Ported to VMS, thanks to Peter (Stig) Edwards: Renamed t/\d\d.test.t files to t/\d\d_test.t t/test*.pm.x files to t/test*.pm_x t/test*fork.\d.* files to t/test*fork-\d.* .js and .css file to only have one period/dot for greater portability. VMS ODS-2 files can only have one period/dot. Added t/92-file_port.t as a developer-only and request-using-ENV test, to help maintain portable files, currently .indent.pro and .perltidyrc fall foul of portable filename characters as defined by ANSI C and perlport. NYTProf.xs's open_output_file use mode 'wb' and not 'wbx' to avoid unsupported error when on VMS. =head2 Changes in Devel::NYTProf 2.08 (svn r685) 15th Feb 2009 Core: Added optimize=0 option to disable the perl optimizer so you can see more accurate statement execution counts for some kinds of constructs. Added savesrc=1 option to copy source code into the profile so reports are not affected by changes to the source files. Added ability for DB::enable_profile() to specify a new file for profile data to be written to. Reporting: Time spent within nested string evals is accounted for. Fixed searching @INC for source files for reports. Dramatically increased performance of nytprofhtml relative to the 2.07 version. Many tables in html reports are sortable by clicking on header columns (requires JavaScript, uses jQuery and tablesorter.js) Statement timings are now shown as integers in appropriate units: seconds, milliseconds, microseconds or nanoseconds. Hovering over times in subroutine or file summary tables now shows the percentage time. Added tables showing timings rolled up per package name depth. Improved HTML conformance thanks to Leland Johnson. =head2 Changes in Devel::NYTProf 2.07 (svn r583) 1st Nov 2008 Core: NOTE: The file format has changed. Files from 2.04 and 2.05 can still be read by this version. Subroutine inclusive time no longer counts time spent recursed into the same subroutine. That time is now recorded separately, along with the max recursion depth. Added stmts=0 option to disable the statement profiler so just the subroutine profiler runs. That reduces the profiler overhead and gives you much smaller data files. Now builds on Windows, with thanks to Jan Dubois! Removed use of vfscanf() to improve portability to Windows and old unix systems, thanks to Jan Dubois. The profiler takes more care to avoid changing $!. Reports: Fixed significant error in time reported as spent in a subroutine, which was showing the sum of the inclusive and exclusive time instead of just the inclusive time. Subroutine calls made within string evals are now shown in reports. Subroutine caller details now includes calls from within string evals. XS subs (xsubs) are now automatically associated with a source file that defines normal subs in the same package. Callers and timing information for xsubs are now shown at the bottom of the corresponding source file. References to xsubs in reports now include a working link if the xsub is in a package that contains profiled perl code. The html global subroutine index pages no longer list subs that were never called. Assorted report formating enhancements thanks to Gisle Aas. Exclusive and Inclusive time column positions have been switched to be consistent with how the times are presented elsewhere. nytprofhtml includes a --open option to open the generated html Documentation: Greatly expanded description of the clocks used for profiling and their issues, especially on multi-processor systems. Other: Added Devel::NYTProf::ReadStream module which provides a perl interface for reading the raw profile data, thanks to Gisle Aas. =head2 Changes in Devel::NYTProf 2.05 (svn r498) 8th Oct 2008 Fixed alteration of $! during profiling thanks to Slaven Rezic. Fixed clock_gettime() clock selection to fallback to CLOCK_REALTIME if CLOCK_MONOTONIC is not available, e.g, on linux 2.4. Fixed error when application ends after DB::disable_profile(). Added some docs to Devel::NYTProf::Apache Added clock=N option to enable user to select the clock. =head2 Changes in Devel::NYTProf 2.04 (svn r483) 1st Oct 2008 Fixed rare divide-by-zero error in reporting code. Fixed rare core dump in reporting code. Fixed detection of #line directives to be more picky. Fixed some compiler warnings thanks to Richard Foley. Added on-the-fly ~90% zip compression thanks to Nicholas Clark. Reduces data file size per million statements executed from approx ~13MB to ~1MB (depends on code being profiled). Added extra table of all subs sorted by inclusive time. No longer warns about '/loader/0x800d8c/...' synthetic file names perl assigns reading code from a CODE ref in @INC =head2 Changes in Devel::NYTProf 2.03 (svn r405) 15 Aug 2008 NOTES: 1. File format changed. Old profiles can't be read. 2. Perl 5.8.1 is the oldest perl version supported. Fixed accounting for time spent executing subs that were compiled in string evals. Fixed risk of file corruption by names containing newlines. Changed to also profile compile-time activity by default. Improved formating of stats for subs called by a statement. Added start=begin|init|end|no option to NYTPROF env var. Added addpid=1 option to NYTPROF env var. Added support for .pmc files. Added detection of #line directives in source code currently just warns that they are not handled. Known issues: Perl 5.8.8 can report garbage file names for XS subs. (Perl 5.8.6 and 5.10 don't seem to have this problem.) Where a subroutine is called from code compiled in a string evals, the artificial "eval file names" are not yet merged. (You're unlikely to notice this obscure case anyway.) =head2 Changes in Devel::NYTProf 2.02 (svn r361) 24 Jul 2008 Fixed colors to use the median (not average) deviation from the median value. Fixed sub name resolution to work in more, perhaps all, unusual cases. Improved accuracy of subroutine timing by deducting statement measurement overheads. Improved readability of subroutine caller lists. Replaced use of fpurge() with a more portable approach. Added exclusive subroutine time (time in sub excluding subs it called). Added recording of xsub filenames (i.e. DBI.c) Added use of clock_gettime(), if available, for 100ns resolution. Uses CLOCK_MONOTONIC or else CLOCK_REALTIME. Thanks to Steve Peters. =head2 Changes in Devel::NYTProf 2.01 Fixed and unified module version numbers. =head2 Changes in Devel::NYTProf 2.00 Major changes. Much extra functionality and performance. See http://blog.timbunce.org/2008/07/15/nytprof-v2-a-major-advance-in-perl-profilers/ =head2 Changes in and before 1.50 1.50 ? ? ? 0:00:00 2008 - Major revision to include Tim Bunce's call scope statistics features, code/doc refactoring, optimizations and bug fixes. - Fixes major issues with profiling code that forks. 1.13 Wed Mar 26 9:35:00 2008 - Fixed RedHat EL bug - %f isn't the C format for floating-point for RHEL Changed Reader.pm to warn-and-continue instead of dieing when a source file cannot be found. (the file will be skipped). Feature by request. Makefile.PL changes by tim.bunce - fix warning on LICENSE key when installed by older versions of MakeMaker. Added vim modeline. 1.12 Tue Mar 25 11:05:00 2008 - Fixed YET ANOTHER test failure caused by trivial differences between v5.6 and v5.8.x. Added test15 that only executes on <5.8 and test06 now only runs on >5.8.0 1.11 Mon Mar 24 11:26:00 2008 - Rewrote test06 and test 13 only. No functionality changes. There is a Perl debugger bug. In perl >5.6 closing "}" in empty loops get execution counts for some reason. This caused 5.6 to fail 'make test' needlessly. (5.6 actually handles it better and 5.8 & 5.10). So I changed the code to avoid empty loop tests, which are no more useful than loops with code in them. *test06 now tests only loops - foreach, while and do-while loops. *test13 now tests only forms of eval, and eval failures - loops removed 1.10 Web Mar 19 21:02:00 2008 - Another CPAN versioning fix. Hopefully the last!!! - Added Makefile.pl check to report unsupported OS on Win32 0.09 Wed Mar 19 13:05:00 2008 - Fixed broken CPAN version numbering - Implemented malloc() fix by Tim Bunce (tim.bunce@gmail.[nospam]com - Wrote a better eval test, now covers all uses ("", perlcode, {...}) - Fixed AutoSplit file source problem - Wrote AutoSplit/AutoLoader tests (test14) - Bugs fixed (hopefully) 33889, 34234, 33991, 33878 0.08 Mon Mar 10 17:35:00 2008 - Added #define to fix missing linkage for OutCopFile (Perl <5.8.0 fix) - Added test12, basic do script test - Moved min version to 5.6.0 again (another attempt) 0.05 Fri Mar 7 10:29:00 2008 - Changed XS code to compile clean with -ansi and -pedantic - Removed `cont' on file argument to process due to XS error in Perl 5.6 - Added code to Makefile.PL so that header sources are run through the C pre-processor (if available) as a potential fix for some BSD systems. 0.03 Thu Mar 6 09:12:00 2008 - Fixed a VERY tricky bug some people had encountered. Scalar references to code that is evaled at runtime will cause divide-by-zero error IF the reference was declared in a BEGIN {...} and used outside of a BEGIN. (The debugger/profiler can't see what happens in a BEGIN) - Added test case for above issue as test11 - Fixed (i hope) the OSX segfault when using a re-malloc'd pointer that was once freed. - Changed XS to compile cleanly with -Wall. - Adopted versioning scheme: modules/files start at 1.0 and the distro will continue from 0.0, thus making mixed versions less confusing. - Enabled the debugging switch so that NYTProf can be used in the form perl -MDevel::NYTProf code.pl (BUT this is ALPHA quality -- may bork) - Minor cleanup to Makefile.PL 0.02 Wed Mar 5 14:20:00 2008 - fixed a bunch of minor problems with the distribution that caused cpan warnings and also cause the exe scripts to not be installed - now a working cpan distro 0.01 Tue Feb 12 10:34:03 2008 - original version; created by h2xs 1.23 with options -A -n Devel::NYTProf =cut # vim: ts=8 sw=2 sts=2 expandtab: Devel-NYTProf-6.06/MemoryProfiling.pod000644 000766 000024 00000007340 12523657232 020122 0ustar00timbostaff000000 000000 =head1 Ideas and Plans for Memory Profiling with NYTProf XXX I. Somewhere to gather the info so it'll be easier to find when someone wants to work on it. It's also focussed on runtime profiling of total memory usage over time (rather than a detailed analysis of who 'owns' what memory as some particular point in time, like the end of the program). NYTProf currently only measures time and supports a limited range of "clocks" (realtime vs cputime). For profiling memory we need to add a new kind of "clock" that measures memory usage. Since we're generalizing the concept of what gets measured (and how we get the info from the system) a better name than "clock" would be "probe". Conjectural terminology: "Probe" means some measuring mechanism like get_clock(), times(), getrusage(), that may yield multiple pieces of information with a single call. "Measure" is one specific item generated by a probe. Probe "time" uses times(), measures: "time.user", "time.user+sys" etc Probe "clock" uses clock_gettime(), measures: "clock.realtime", "clock.monotonic" etc Probe "rusage" uses getrusage(), measures: "rusage.majflt", "rusage.nvcsw" etc Probe "memory" measures: "memory.bytes", "mem.allocs" etc Probe "arena" measures: "arena.svs", "arena.bytes" etc Generalize the concepts of probes. Have a structure defining a 'probe' with pointers to functions to get the values, subtract values to get relative ticks, return the tick units etc. Give them names and attributes (cpu, realtime etc). User could then pick a probe by name. By default we'd pick the best available realtime probe. Use the subtraction logic where we currently handle times in the statement and subroutine profilers. =head1 Email threads "Memory profiling in Devel::NYTProf?: - June 2009 http://groups.google.com/group/develnytprof-dev/browse_frm/thread/1df4cba3001cd4e4/136812b44e9f7631 Talking about the problems of measuring memory usage of the whole process re: http://blog.robin.smidsrod.no/index.php/2009/05/26/memory-footprint-of-popular-cpan-modules "Memory profiling possibilities in NYTProf" - September 2009 http://groups.google.com/group/develnytprof-dev/browse_frm/thread/c711c132216a3cea/035012e3dc2971ec This includes a detailed overview of the issues. "profiling memory" - Dec 2009 http://groups.google.com/group/develnytprof-dev/browse_frm/thread/5ffd24200866b0c1/201b58c18d826aaa Nicholas Clark offers an experimental patch that intercepts malloc and free and makes NYTProf measure memory usage. =head1 Possibly Relevant Perl Modules Per-process memory information: http://metacpan.org/pod/Devel::Mallinfo Arena, stash, and pad based memory reporters: http://metacpan.org/pod/Devel::Gladiator http://metacpan.org/release/Internals-DumpArenas/ http://metacpan.org/release/Internals-GraphArenas/ http://metacpan.org/pod/Devel::DumpSizes http://metacpan.org/pod/Devel::Arena Per-object memory size reporters: http://metacpan.org/pod/Devel::Size http://metacpan.org/pod/Devel::Size::Report Others: http://metacpan.org/release/Devel-Memalyzer/ http://metacpan.org/pod/Devel::Memalyzer::Plugin::ProcSmaps =head1 Other Items of Interest "Memory Efficient Perl" slides by jjore http://docs.google.com/present/view?id=dg7kgpct_24cjs3c9fv http://diotalevi.isa-geek.net/~josh/090402/frontend.png Other profile/memory visualization tools http://netjam.org/spoon/viz/ http://java.dzone.com/announcements/visualvm-12-great-java http://blogs.perl.org/users/alex_balhatchet/2012/01/debugging-memory-use-in-perl---help.html http://stackoverflow.com/questions/8715611/can-i-use-dtrace-on-os-x-10-5-to-determine-which-of-my-perl-subs-is-causing-the =cut Devel-NYTProf-6.06/NYTProf.xs000644 000766 000024 00000577745 13305236420 016165 0ustar00timbostaff000000 000000 /* vim: ts=8 sw=4 expandtab: * ************************************************************************ * This file is part of the Devel::NYTProf package. * Copyright 2008 Adam J. Kaplan, The New York Times Company. * Copyright 2009-2010 Tim Bunce, Ireland. * Released under the same terms as Perl 5.8 * See http://metacpan.org/release/Devel-NYTProf/ * * Contributors: * Tim Bunce, http://www.tim.bunce.name and http://blog.timbunce.org * Nicholas Clark, * Adam Kaplan, akaplan at nytimes.com * Steve Peters, steve at fisharerojo.org * * ************************************************************************ */ #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "FileHandle.h" #include "NYTProf.h" #ifndef NO_PPPORT_H #define NEED_my_snprintf_GLOBAL #define NEED_newRV_noinc_GLOBAL #define NEED_eval_pv #define NEED_grok_number #define NEED_grok_numeric_radix #define NEED_newCONSTSUB #define NEED_sv_2pv_flags #define NEED_newSVpvn_flags #define NEED_my_strlcat # include "ppport.h" #endif /* Until ppport.h gets this: */ #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, ("" s2 ""), (sizeof(s2)-1))) #endif #ifdef USE_HARD_ASSERT #undef NDEBUG #include #endif #if !defined(OutCopFILE) # define OutCopFILE CopFILE #endif #ifndef gv_fetchfile_flags /* added in perl 5.009005 */ /* we know our uses don't contain embedded nulls, so we just need to copy to a * buffer so we can add a trailing null byte */ #define gv_fetchfile_flags(a,b,c) Perl_gv_fetchfile_flags(aTHX_ a,b,c) static GV * Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, const U32 flags) { char buf[2000]; if (namelen >= sizeof(buf)-1) croak("panic: gv_fetchfile_flags overflow"); memcpy(buf, name, namelen); buf[namelen] = '\0'; /* null-terminate */ return gv_fetchfile(buf); } #endif #ifndef OP_SETSTATE #define OP_SETSTATE OP_NEXTSTATE #endif #ifndef PERLDBf_SAVESRC #define PERLDBf_SAVESRC PERLDBf_SUBLINE #endif #ifndef PERLDBf_SAVESRC_NOSUBS #define PERLDBf_SAVESRC_NOSUBS 0 #endif #ifndef CvISXSUB #define CvISXSUB CvXSUB #endif #if (PERL_VERSION < 8) || ((PERL_VERSION == 8) && (PERL_SUBVERSION < 8)) /* If we're using DB::DB() instead of opcode redirection with an old perl * then PL_curcop in DB() will refer to the DB() wrapper in Devel/NYTProf.pm * so we'd have to crawl the stack to find the right cop. However, for some * reason that I don't pretend to understand the following expression works: */ #define PL_curcop_nytprof (opt_use_db_sub ? ((cxstack + cxstack_ix)->blk_oldcop) : PL_curcop) #else #define PL_curcop_nytprof PL_curcop #endif #define OP_NAME_safe(op) ((op) ? OP_NAME(op) : "NULL") #ifdef I_SYS_TIME #include #endif #include #ifdef HAS_ZLIB #include #define default_compression_level 6 #else #define default_compression_level 0 #endif #ifndef ZLIB_VERSION #define ZLIB_VERSION "0" #endif #ifndef NYTP_MAX_SUB_NAME_LEN #define NYTP_MAX_SUB_NAME_LEN 500 #endif #define NYTP_FILE_MAJOR_VERSION 5 #define NYTP_FILE_MINOR_VERSION 0 #define NYTP_START_NO 0 #define NYTP_START_BEGIN 1 #define NYTP_START_CHECK_unused 2 /* not used */ #define NYTP_START_INIT 3 #define NYTP_START_END 4 #define NYTP_OPTf_ADDPID 0x0001 /* append .pid to output filename */ #define NYTP_OPTf_OPTIMIZE 0x0002 /* affect $^P & 0x04 */ #define NYTP_OPTf_SAVESRC 0x0004 /* copy source code lines into profile data */ #define NYTP_OPTf_ADDTIMESTAMP 0x0008 /* append timestamp to output filename */ #define NYTP_FIDf_IS_PMC 0x0001 /* .pm probably really loaded as .pmc */ #define NYTP_FIDf_VIA_STMT 0x0002 /* fid first seen by stmt profiler */ #define NYTP_FIDf_VIA_SUB 0x0004 /* fid first seen by sub profiler */ #define NYTP_FIDf_IS_AUTOSPLIT 0x0008 /* fid is an autosplit (see AutoLoader) */ #define NYTP_FIDf_HAS_SRC 0x0010 /* src is available to profiler */ #define NYTP_FIDf_SAVE_SRC 0x0020 /* src will be saved by profiler, if NYTP_FIDf_HAS_SRC also set */ #define NYTP_FIDf_IS_ALIAS 0x0040 /* fid is clone of the 'parent' fid it was autosplit from */ #define NYTP_FIDf_IS_FAKE 0x0080 /* eg dummy caller of a string eval that doesn't have a filename */ #define NYTP_FIDf_IS_EVAL 0x0100 /* is an eval */ /* indices to elements of the file info array */ #define NYTP_FIDi_FILENAME 0 #define NYTP_FIDi_EVAL_FID 1 #define NYTP_FIDi_EVAL_LINE 2 #define NYTP_FIDi_FID 3 #define NYTP_FIDi_FLAGS 4 #define NYTP_FIDi_FILESIZE 5 #define NYTP_FIDi_FILEMTIME 6 #define NYTP_FIDi_PROFILE 7 #define NYTP_FIDi_EVAL_FI 8 #define NYTP_FIDi_HAS_EVALS 9 #define NYTP_FIDi_SUBS_DEFINED 10 #define NYTP_FIDi_SUBS_CALLED 11 #define NYTP_FIDi_elements 12 /* highest index, plus 1 */ /* indices to elements of the sub info array (report-side only) */ #define NYTP_SIi_FID 0 /* fid of file sub was defined in */ #define NYTP_SIi_FIRST_LINE 1 /* line number of first line of sub */ #define NYTP_SIi_LAST_LINE 2 /* line number of last line of sub */ #define NYTP_SIi_CALL_COUNT 3 /* number of times sub was called */ #define NYTP_SIi_INCL_RTIME 4 /* incl real time in sub */ #define NYTP_SIi_EXCL_RTIME 5 /* excl real time in sub */ #define NYTP_SIi_SUB_NAME 6 /* sub name */ #define NYTP_SIi_PROFILE 7 /* ref to profile object */ #define NYTP_SIi_REC_DEPTH 8 /* max recursion call depth */ #define NYTP_SIi_RECI_RTIME 9 /* recursive incl real time in sub */ #define NYTP_SIi_CALLED_BY 10 /* { fid => { line => [...] } } */ #define NYTP_SIi_elements 11 /* highest index, plus 1 */ /* indices to elements of the sub call info array */ /* XXX currently ticks are accumulated into NYTP_SCi_*_TICKS during profiling * and then NYTP_SCi_*_RTIME are calculated and output. This avoids float noise * during profiling but we should really output ticks so the reporting side * can also be more accurate when merging subs, for example. * That'll probably need a file format bump and thus also a major version bump. * Will need coresponding changes to NYTP_SIi_* as well. */ #define NYTP_SCi_CALL_COUNT 0 /* count of calls to sub */ #define NYTP_SCi_INCL_RTIME 1 /* inclusive real time in sub (set from NYTP_SCi_INCL_TICKS) */ #define NYTP_SCi_EXCL_RTIME 2 /* exclusive real time in sub (set from NYTP_SCi_EXCL_TICKS) */ #define NYTP_SCi_INCL_TICKS 3 /* inclusive ticks in sub */ #define NYTP_SCi_EXCL_TICKS 4 /* exclusive ticks in sub */ #define NYTP_SCi_RECI_RTIME 5 /* recursive incl real time in sub */ #define NYTP_SCi_REC_DEPTH 6 /* max recursion call depth */ #define NYTP_SCi_CALLING_SUB 7 /* name of calling sub */ #define NYTP_SCi_elements 8 /* highest index, plus 1 */ /* we're not thread-safe (or even multiplicity safe) yet, so detect and bail */ #ifdef MULTIPLICITY static PerlInterpreter *orig_my_perl; #endif #define MAX_HASH_SIZE 512 typedef struct hash_entry Hash_entry; struct hash_entry { unsigned int id; char* key; int key_len; Hash_entry* next_entry; Hash_entry* next_inserted; /* linked list in insertion order */ }; typedef struct hash_table { Hash_entry** table; char *name; unsigned int size; unsigned int entry_struct_size; Hash_entry* first_inserted; Hash_entry* prior_inserted; /* = last_inserted before the last insertion */ Hash_entry* last_inserted; unsigned int next_id; /* starts at 1, 0 is reserved */ } Hash_table; typedef struct { Hash_entry he; unsigned int eval_fid; unsigned int eval_line_num; unsigned int file_size; unsigned int file_mtime; unsigned int fid_flags; char *key_abs; /* update autosplit logic in get_file_id if fields are added or changed */ } fid_hash_entry; static Hash_table fidhash = { NULL, "fid", MAX_HASH_SIZE, sizeof(fid_hash_entry), NULL, NULL, NULL, 1 }; typedef struct { Hash_entry he; } str_hash_entry; static Hash_table strhash = { NULL, "str", MAX_HASH_SIZE, sizeof(str_hash_entry), NULL, NULL, NULL, 1 }; /* END Hash table definitions */ /* defaults */ static NYTP_file out; /* options and overrides */ static char PROF_output_file[MAXPATHLEN+1] = "nytprof.out"; static unsigned int profile_opts = NYTP_OPTf_OPTIMIZE | NYTP_OPTf_SAVESRC; static int profile_start = NYTP_START_BEGIN; /* when to start profiling */ static char *nytp_panic_overflow_msg_fmt = "panic: buffer overflow of %s on '%s' (see TROUBLESHOOTING section of the NYTProf documentation)"; struct NYTP_options_t { const char *option_name; IV option_iv; char *option_pv; /* strdup'd */ }; /* XXX boolean options should be moved into profile_opts */ static struct NYTP_options_t options[] = { #define profile_usecputime options[0].option_iv { "usecputime", 0, NULL }, #define profile_subs options[1].option_iv { "subs", 1, NULL }, /* subroutine times */ #define profile_blocks options[2].option_iv { "blocks", 0, NULL }, /* block and sub *exclusive* times */ #define profile_leave options[3].option_iv { "leave", 1, NULL }, /* correct block end timing */ #define embed_fid_line options[4].option_iv { "expand", 0, NULL }, #define trace_level options[5].option_iv { "trace", 0, NULL }, #define opt_use_db_sub options[6].option_iv { "use_db_sub", 0, NULL }, #define compression_level options[7].option_iv { "compress", default_compression_level, NULL }, #define profile_clock options[8].option_iv { "clock", -1, NULL }, #define profile_stmts options[9].option_iv { "stmts", 1, NULL }, /* statement exclusive times */ #define profile_slowops options[10].option_iv { "slowops", 2, NULL }, /* slow opcodes, typically system calls */ #define profile_findcaller options[11].option_iv { "findcaller", 0, NULL }, /* find sub caller instead of trusting outer */ #define profile_forkdepth options[12].option_iv { "forkdepth", -1, NULL }, /* how many generations of kids to profile */ #define opt_perldb options[13].option_iv { "perldb", 0, NULL }, /* force certain PL_perldb value */ #define opt_nameevals options[14].option_iv { "nameevals", 1, NULL }, /* change $^P 0x100 bit */ #define opt_nameanonsubs options[15].option_iv { "nameanonsubs", 1, NULL }, /* change $^P 0x200 bit */ #define opt_calls options[16].option_iv { "calls", 1, NULL }, /* output call/return event stream */ #define opt_evals options[17].option_iv { "evals", 0, NULL } /* handling of string evals - TBD XXX */ }; /* XXX TODO: add these to options: if (strEQ(option, "file")) { strncpy(PROF_output_file, value, MAXPATHLEN); else if (strEQ(option, "log")) { else if (strEQ(option, "start")) { else if (strEQ(option, "addpid")) { else if (strEQ(option, "optimize") || strEQ(option, "optimise")) { else if (strEQ(option, "savesrc")) { else if (strEQ(option, "endatexit")) { else if (strEQ(option, "libcexit")) { and write the options to the stream when profiling starts. */ /* time tracking */ #ifdef WIN32 /* win32_gettimeofday has ~15 ms resolution on Win32, so use * QueryPerformanceCounter which has us or ns resolution depending on * motherboard and OS. Comment this out to use the old clock. */ # define HAS_QPC #endif /* WIN32 */ #ifdef HAS_CLOCK_GETTIME /* http://www.freebsd.org/cgi/man.cgi?query=clock_gettime * http://webnews.giga.net.tw/article//mailing.freebsd.performance/710 * http://sean.chittenden.org/news/2008/06/01/ * Explanation of why gettimeofday() (and presumably CLOCK_REALTIME) may go backwards: * https://groups.google.com/forum/#!topic/comp.os.linux.development.apps/3CkHHyQX918 */ typedef struct timespec time_of_day_t; # define CLOCK_GETTIME(ts) clock_gettime(profile_clock, ts) # define TICKS_PER_SEC 10000000 /* 10 million - 100ns */ # define get_time_of_day(into) CLOCK_GETTIME(&into) # define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \ overflow = 0; \ ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + (e.tv_nsec / (typ)100) - (s.tv_nsec / (typ)100)); \ } STMT_END #else /* !HAS_CLOCK_GETTIME */ #ifdef HAS_MACH_TIME #include #include mach_timebase_info_data_t our_timebase; typedef uint64_t time_of_day_t; # define TICKS_PER_SEC 10000000 /* 10 million - 100ns */ # define get_time_of_day(into) into = mach_absolute_time() # define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \ overflow = 0; \ if( our_timebase.denom == 0 ) mach_timebase_info(&our_timebase); \ ticks = (e-s) * our_timebase.numer / our_timebase.denom / (typ)100; \ } STMT_END #else /* !HAS_MACH_TIME */ #ifdef HAS_QPC # ifndef U64_CONST # ifdef _MSC_VER # define U64_CONST(x) x##UI64 # else # define U64_CONST(x) x##ULL # endif # endif unsigned __int64 time_frequency = U64_CONST(0); typedef unsigned __int64 time_of_day_t; # define TICKS_PER_SEC time_frequency # define get_time_of_day(into) QueryPerformanceCounter((LARGE_INTEGER*)&into) # define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \ overflow = 0; /* XXX whats this? */ \ ticks = (typ)(e-s); \ } STMT_END /* workaround for "error C2520: conversion from unsigned __int64 to double not implemented, use signed __int64" on VC 6 */ # if defined(_MSC_VER) && _MSC_VER < 1300 /* < VC 7/2003*/ # define NYTPIuint642NV(x) \ ((NV)(__int64)((x) & U64_CONST(0x7FFFFFFFFFFFFFFF)) \ + -(NV)(__int64)((x) & U64_CONST(0x8000000000000000))) # define get_NV_ticks_between(s, e, ticks, overflow) STMT_START { \ overflow = 0; /* XXX whats this? */ \ ticks = NYTPIuint642NV(e-s); \ } STMT_END # endif #elif defined(HAS_GETTIMEOFDAY) /* on Win32 gettimeofday is always implemented in Perl, not the MS C lib, so either we use PerlProc_gettimeofday or win32_gettimeofday, depending on the Perl defines about NO_XSLOCKS and PERL_IMPLICIT_SYS, to simplify logic, we don't check the defines, just the macro symbol to see if it forwards to presumably the iperlsys.h vtable call or not. See https://github.com/timbunce/devel-nytprof/pull/27#issuecomment-46102026 for more details. */ #if defined(WIN32) && !defined(gettimeofday) # define gettimeofday win32_gettimeofday #endif typedef struct timeval time_of_day_t; # define TICKS_PER_SEC 1000000 /* 1 million */ # define get_time_of_day(into) gettimeofday(&into, NULL) # define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \ overflow = 0; \ ticks = ((e.tv_sec - s.tv_sec) * TICKS_PER_SEC + e.tv_usec - s.tv_usec); \ } STMT_END #else /* !HAS_GETTIMEOFDAY */ /* worst-case fallback - use Time::HiRes which is expensive to call */ #define WANT_TIME_HIRES typedef UV time_of_day_t[2]; # define TICKS_PER_SEC 1000000 /* 1 million */ # define get_time_of_day(into) (*time_hires_u2time_hook)(aTHX_ into) # define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \ overflow = 0; \ ticks = ((e[0] - s[0]) * (typ)TICKS_PER_SEC + e[1] - s[1]); \ } STMT_END static int (*time_hires_u2time_hook)(pTHX_ UV *) = 0; #endif /* HAS_GETTIMEOFDAY else */ #endif /* HAS_MACH_TIME else */ #endif /* HAS_CLOCK_GETTIME else */ #ifndef get_NV_ticks_between # define get_NV_ticks_between(s, e, ticks, overflow) get_ticks_between(NV, s, e, ticks, overflow) #endif #ifndef NYTPIuint642NV # define NYTPIuint642NV(x) ((NV)(x)) #endif static time_of_day_t start_time; static time_of_day_t end_time; static unsigned int last_executed_line; static unsigned int last_executed_fid; static char *last_executed_fileptr; static unsigned int last_block_line; static unsigned int last_sub_line; static unsigned int is_profiling; /* disable_profile() & enable_profile() */ static Pid_t last_pid = 0; static NV cumulative_overhead_ticks = 0.0; static NV cumulative_subr_ticks = 0.0; static UV cumulative_subr_seqn = 0; static int main_runtime_used = 0; static SV *DB_CHECK_cv; static SV *DB_INIT_cv; static SV *DB_END_cv; static SV *DB_fin_cv; static const char *class_mop_evaltag = " defined at "; static int class_mop_evaltag_len = 12; static unsigned int ticks_per_sec = 0; /* 0 forces error if not set */ static AV *slowop_name_cache; /* prototypes */ static void output_header(pTHX); static SV *read_str(pTHX_ NYTP_file ifile, SV *sv); static unsigned int get_file_id(pTHX_ char*, STRLEN, int created_via); static void DB_stmt(pTHX_ COP *cop, OP *op); static void set_option(pTHX_ const char*, const char*); static int enable_profile(pTHX_ char *file); static int disable_profile(pTHX); static void finish_profile(pTHX); static void finish_profile_nocontext(void); static void open_output_file(pTHX_ char *); static int reinit_if_forked(pTHX); static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name); static void write_cached_fids(void); static void write_src_of_files(pTHX); static void write_sub_line_ranges(pTHX); static void write_sub_callers(pTHX); static AV *store_profile_line_entry(pTHX_ SV *rvav, unsigned int line_num, NV time, int count, unsigned int fid); /* copy of original contents of PL_ppaddr */ typedef OP * (CPERLscope(*orig_ppaddr_t))(pTHX); orig_ppaddr_t *PL_ppaddr_orig; #define run_original_op(type) CALL_FPTR(PL_ppaddr_orig[type])(aTHX) static OP *pp_entersub_profiler(pTHX); static OP *pp_subcall_profiler(pTHX_ int type); static OP *pp_leave_profiler(pTHX); static HV *sub_callers_hv; static HV *pkg_fids_hv; /* currently just package names */ /* PL_sawampersand is disabled in 5.17.7+ 1a904fc */ #if (PERL_VERSION < 17) || ((PERL_VERSION == 17) && (PERL_SUBVERSION < 7)) || defined(PERL_SAWAMPERSAND) static U8 last_sawampersand; #define CHECK_SAWAMPERSAND(fid,line) STMT_START { \ if (PL_sawampersand != last_sawampersand) { \ if (trace_level >= 1) \ logwarn("Slow regex match variable seen (0x%x->0x%x at %u:%u)\n", PL_sawampersand, last_sawampersand, fid, line); \ /* XXX this is a hack used by test14 to avoid different behaviour \ * pre/post perl 5.17.7 since it's not relevant to the test, which is really \ * about AutoSplit */ \ if (!getenv("DISABLE_NYTPROF_SAWAMPERSAND")) \ NYTP_write_sawampersand(out, fid, line); \ last_sawampersand = (U8)PL_sawampersand; \ } \ } STMT_END #else #define CHECK_SAWAMPERSAND(fid,line) (void)0 #endif /* macros for outputing profile data */ #ifndef HAS_GETPPID #define getppid() 0 #endif static FILE *logfh; /* predeclare to set attribute */ static void logwarn(const char *pat, ...) __attribute__format__(__printf__,1,2); static void logwarn(const char *pat, ...) { /* we avoid using any perl mechanisms here */ va_list args; NYTP_IO_dTHX; va_start(args, pat); if (!logfh) logfh = stderr; vfprintf(logfh, pat, args); /* Flush to ensure the log message gets pushed out to the kernel. * This flush will be expensive but is needed to ensure the log has recent info * if there's a core dump. Could add an option to disable flushing if needed. */ fflush(logfh); va_end(args); } /*********************************** * Devel::NYTProf Functions * ***********************************/ static NV gettimeofday_nv(void) { #ifdef HAS_GETTIMEOFDAY NYTP_IO_dTHX; struct timeval when; gettimeofday(&when, (struct timezone *) 0); return when.tv_sec + (when.tv_usec / 1000000.0); #else #ifdef WANT_TIME_HIRES NYTP_IO_dTHX; UV time_of_day[2]; (*time_hires_u2time_hook)(aTHX_ &time_of_day); return time_of_day[0] + (time_of_day[1] / 1000000.0); #else return (NV)time(); /* practically useless */ #endif /* WANT_TIME_HIRES else */ #endif /* HAS_GETTIMEOFDAY else */ } /** * output file header */ static void output_header(pTHX) { /* $0 - application name */ SV *const sv = get_sv("0",GV_ADDWARN); time_t basetime = PL_basetime; /* This comes back with a terminating \n, and we don't want that. */ const char *const basetime_str = ctime(&basetime); const STRLEN basetime_str_len = strlen(basetime_str); const char version[] = STRINGIFY(PERL_REVISION) "." STRINGIFY(PERL_VERSION) "." STRINGIFY(PERL_SUBVERSION); STRLEN len; const char *argv0 = SvPV(sv, len); assert(out != NULL); /* File header with "magic" string, with file major and minor version */ NYTP_write_header(out, NYTP_FILE_MAJOR_VERSION, NYTP_FILE_MINOR_VERSION); /* Human readable comments and attributes follow * comments start with '#', end with '\n', and are discarded * attributes start with ':', a word, '=', then the value, then '\n' */ NYTP_write_comment(out, "Perl profile database. Generated by Devel::NYTProf on %.*s", (int)basetime_str_len - 1, basetime_str); /* XXX add options, $0, etc, but beware of embedded newlines */ /* XXX would be good to adopt a proper charset & escaping for these */ NYTP_write_attribute_unsigned(out, STR_WITH_LEN("basetime"), (unsigned long)PL_basetime); /* $^T */ NYTP_write_attribute_string(out, STR_WITH_LEN("application"), argv0, len); /* perl constants: */ NYTP_write_attribute_string(out, STR_WITH_LEN("perl_version"), version, sizeof(version) - 1); NYTP_write_attribute_unsigned(out, STR_WITH_LEN("nv_size"), sizeof(NV)); /* sanity checks: */ NYTP_write_attribute_string(out, STR_WITH_LEN("xs_version"), STR_WITH_LEN(XS_VERSION)); NYTP_write_attribute_unsigned(out, STR_WITH_LEN("PL_perldb"), PL_perldb); /* these are really options: */ NYTP_write_attribute_signed(out, STR_WITH_LEN("clock_id"), profile_clock); NYTP_write_attribute_unsigned(out, STR_WITH_LEN("ticks_per_sec"), ticks_per_sec); if (1) { struct NYTP_options_t *opt_p = options; const struct NYTP_options_t *const opt_end = options + sizeof(options) / sizeof (struct NYTP_options_t); do { NYTP_write_option_iv(out, opt_p->option_name, opt_p->option_iv); } while (++opt_p < opt_end); } #ifdef HAS_ZLIB if (compression_level) { NYTP_start_deflate_write_tag_comment(out, compression_level); } #endif NYTP_write_process_start(out, getpid(), getppid(), gettimeofday_nv()); write_cached_fids(); /* empty initially, non-empty after fork */ NYTP_flush(out); } static SV * read_str(pTHX_ NYTP_file ifile, SV *sv) { STRLEN len; char *buf; unsigned char tag; NYTP_read(ifile, &tag, sizeof(tag), "string prefix"); if (NYTP_TAG_STRING != tag && NYTP_TAG_STRING_UTF8 != tag) croak("Profile format error at offset %ld%s, expected string tag but found %d ('%c') (see TROUBLESHOOTING in NYTProf docs)", NYTP_tell(ifile)-1, NYTP_type_of_offset(ifile), tag, tag); len = read_u32(ifile); if (sv) { SvGROW(sv, len+1); /* forces SVt_PV */ } else { sv = newSV(len+1); /* +1 to force SVt_PV even for 0 length string */ } SvPOK_on(sv); buf = SvPV_nolen(sv); NYTP_read(ifile, buf, len, "string"); SvCUR_set(sv, len); *SvEND(sv) = '\0'; if (NYTP_TAG_STRING_UTF8 == tag) SvUTF8_on(sv); if (trace_level >= 19) { STRLEN len2 = len; const char *newline = ""; if (buf[len2-1] == '\n') { --len2; newline = "\\n"; } logwarn(" read string '%.*s%s'%s\n", (int)len2, SvPV_nolen(sv), newline, (SvUTF8(sv)) ? " (utf8)" : ""); } return sv; } /** * An implementation of the djb2 hash function by Dan Bernstein. */ static unsigned long hash (char* _str, unsigned int len) { char* str = _str; unsigned long hash = 5381; while (len--) { /* hash * 33 + c */ hash = ((hash << 5) + hash) + *str++; } return hash; } /** * Returns a pointer to the ')' after the digits in the (?:re_)?eval prefix. * As the prefix length is known, this gives the length of the digits. */ static const char * eval_prefix(const char *filename, const char *prefix, STRLEN prefix_len) { if (memEQ(filename, prefix, prefix_len) && isdigit((int)filename[prefix_len])) { const char *s = filename + prefix_len + 1; while (isdigit((int)*s)) ++s; if (s[0] == ')') return s; } return NULL; } /** * Return true if filename looks like an eval */ static int filename_is_eval(const char *filename, STRLEN filename_len) { if (filename_len < 6) return 0; /* typically "(eval N)[...]" sometimes just "(eval N)" */ if (filename[filename_len - 1] != ']' && filename[filename_len - 1] != ')') return 0; if (eval_prefix(filename, "(eval ", 6)) return 1; if (eval_prefix(filename, "(re_eval ", 9)) return 1; return 0; } /** * Fetch/Store on hash table. entry must always be defined. * hash_op will find hash_entry in the hash table. * hash_entry not in table, insert is false: returns NULL * hash_entry not in table, insert is true: inserts hash_entry and returns hash_entry * hash_entry in table, insert IGNORED: returns pointer to the actual hash entry */ static char hash_op(Hash_table *hashtable, char *key, int key_len, Hash_entry** retval, bool insert) { unsigned long h = hash(key, key_len) % hashtable->size; Hash_entry* found = hashtable->table[h]; while(NULL != found) { if (found->key_len == key_len && memEQ(found->key, key, key_len) ) { *retval = found; return 0; } if (NULL == found->next_entry) { if (insert) { Hash_entry* e; Newc(0, e, hashtable->entry_struct_size, char, Hash_entry); memzero(e, hashtable->entry_struct_size); e->id = hashtable->next_id++; e->next_entry = NULL; e->key_len = key_len; e->key = (char*)safemalloc(sizeof(char) * key_len + 1); e->key[key_len] = '\0'; memcpy(e->key, key, key_len); found->next_entry = e; *retval = found->next_entry; hashtable->prior_inserted = hashtable->last_inserted; hashtable->last_inserted = e; return 1; } else { *retval = NULL; return -1; } } found = found->next_entry; } if (insert) { Hash_entry* e; Newc(0, e, hashtable->entry_struct_size, char, Hash_entry); memzero(e, hashtable->entry_struct_size); e->id = hashtable->next_id++; e->next_entry = NULL; e->key_len = key_len; e->key = (char*)safemalloc(sizeof(char) * e->key_len + 1); e->key[e->key_len] = '\0'; memcpy(e->key, key, key_len); *retval = hashtable->table[h] = e; if (!hashtable->first_inserted) hashtable->first_inserted = e; hashtable->prior_inserted = hashtable->last_inserted; hashtable->last_inserted = e; return 1; } *retval = NULL; return -1; } static void hash_stats(Hash_table *hashtable, int verbosity) { int idx = 0; int max_chain_len = 0; int buckets = 0; int items = 0; if (verbosity) warn("%s hash: size %d\n", hashtable->name, hashtable->size); if (!hashtable->table) return; for (idx=0; idx < hashtable->size; ++idx) { int chain_len = 0; Hash_entry *found = hashtable->table[idx]; if (!found) continue; ++buckets; while (NULL != found) { ++chain_len; ++items; found = found->next_entry; } if (verbosity) warn("%s hash[%3d]: %d items\n", hashtable->name, idx, chain_len); if (chain_len > max_chain_len) max_chain_len = chain_len; } /* XXX would be nice to show a histogram of chain lenths */ warn("%s hash: %d of %d buckets used, %d items, max chain %d\n", hashtable->name, buckets, hashtable->size, items, max_chain_len); } static void emit_fid (fid_hash_entry *fid_info) { char *file_name = fid_info->he.key; STRLEN file_name_len = fid_info->he.key_len; char *file_name_copy = NULL; if (fid_info->key_abs) { file_name = fid_info->key_abs; file_name_len = strlen(file_name); } #ifdef WIN32 /* Make sure we only use forward slashes in filenames */ if (memchr(file_name, '\\', file_name_len)) { STRLEN i; file_name_copy = (char*)safemalloc(file_name_len); for (i=0; ihe.id, fid_info->eval_fid, fid_info->eval_line_num, fid_info->fid_flags, fid_info->file_size, fid_info->file_mtime, file_name, (I32)file_name_len); if (file_name_copy) Safefree(file_name_copy); } /* return true if file is a .pm that was actually loaded as a .pmc */ static int fid_is_pmc(pTHX_ fid_hash_entry *fid_info) { int is_pmc = 0; char *file_name = fid_info->he.key; STRLEN len = fid_info->he.key_len; if (fid_info->key_abs) { file_name = fid_info->key_abs; len = strlen(file_name); } if (len > 3 && memEQs(file_name + len - 3, 3, ".pm")) { /* ends in .pm, ok, does a newer .pmc exist? */ /* based on doopen_pm() in perl's pp_ctl.c */ SV *const pmcsv = newSV(len + 2); char *const pmc = SvPVX(pmcsv); Stat_t pmstat; Stat_t pmcstat; memcpy(pmc, file_name, len); pmc[len] = 'c'; pmc[len + 1] = '\0'; if (PerlLIO_lstat(pmc, &pmcstat) == 0) { /* .pmc exists, is it newer than the .pm (if that exists) */ /* Keys in the fid_info are explicitly written with a terminating '\0', so it is safe to pass file_name to a system call. */ if (PerlLIO_lstat(file_name, &pmstat) < 0 || pmstat.st_mtime < pmcstat.st_mtime) { is_pmc = 1; /* hey, maybe it's Larry working on the perl6 comiler */ } } SvREFCNT_dec(pmcsv); } return is_pmc; } static char * fmt_fid_flags(pTHX_ int fid_flags, char *buf, Size_t len) { *buf = '\0'; if (fid_flags & NYTP_FIDf_IS_EVAL) my_strlcat(buf, "eval,", len); if (fid_flags & NYTP_FIDf_IS_FAKE) my_strlcat(buf, "fake,", len); if (fid_flags & NYTP_FIDf_IS_AUTOSPLIT) my_strlcat(buf, "autosplit,", len); if (fid_flags & NYTP_FIDf_IS_ALIAS) my_strlcat(buf, "alias,", len); if (fid_flags & NYTP_FIDf_IS_PMC) my_strlcat(buf, "pmc,", len); if (fid_flags & NYTP_FIDf_VIA_STMT) my_strlcat(buf, "viastmt,", len); if (fid_flags & NYTP_FIDf_VIA_SUB) my_strlcat(buf, "viasub,", len); if (fid_flags & NYTP_FIDf_HAS_SRC) my_strlcat(buf, "hassrc,", len); if (fid_flags & NYTP_FIDf_SAVE_SRC) my_strlcat(buf, "savesrc,", len); if (*buf) /* trim trailing comma */ buf[ my_strlcat(buf,"",len)-1 ] = '\0'; return buf; } static void write_cached_fids() { fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted; while (e) { if ( !(e->fid_flags & NYTP_FIDf_IS_ALIAS) ) emit_fid(e); e = (fid_hash_entry*)e->he.next_inserted; } } static fid_hash_entry * find_autosplit_parent(pTHX_ char* file_name) { /* extract basename from file_name, then search for most recent entry * in fidhash that has the same basename */ fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted; fid_hash_entry *match = NULL; const char *sep = "/"; char *base_end = strstr(file_name, " (autosplit"); char *base_start = rninstr(file_name, base_end, sep, sep+1); STRLEN base_len; base_start = (base_start) ? base_start+1 : file_name; base_len = base_end - base_start; if (trace_level >= 3) logwarn("find_autosplit_parent of '%.*s' (%s)\n", (int)base_len, base_start, file_name); for ( ; e; e = (fid_hash_entry*)e->he.next_inserted) { char *e_name; if (e->fid_flags & NYTP_FIDf_IS_AUTOSPLIT) continue; if (trace_level >= 4) logwarn("find_autosplit_parent: checking '%.*s'\n", e->he.key_len, e->he.key); /* skip if key is too small to match */ if (e->he.key_len < base_len) continue; /* skip if the last base_len bytes don't match the base name */ e_name = e->he.key + e->he.key_len - base_len; if (memcmp(e_name, base_start, base_len) != 0) continue; /* skip if the char before the matched key isn't a separator */ if (e->he.key_len > base_len && *(e_name-1) != *sep) continue; if (trace_level >= 3) logwarn("matched autosplit '%.*s' to parent fid %d '%.*s' (%c|%c)\n", (int)base_len, base_start, e->he.id, e->he.key_len, e->he.key, *(e_name-1),*sep); match = e; /* keep looking, so we'll return the most recently profiled match */ } return match; } #if 0 /* currently unused */ static Hash_entry * lookup_file_entry(pTHX_ char* file_name, STRLEN file_name_len) { Hash_entry entry, *found; entry.key = file_name; entry.key_len = (unsigned int)file_name_len; if (hash_op(fidhash, &entry, &found, 0) == 0) return found; return NULL; } #endif /** * Return a unique persistent id number for a file. * If file name has not been seen before * then, if created_via is false it returns 0 otherwise it * assigns a new id and outputs the file and id to the stream. * If the file name is a synthetic name for an eval then * get_file_id recurses to process the 'embedded' file name first. * The created_via flag bit is stored in the fid info * (currently only used as a diagnostic tool) */ static unsigned int get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via) { fid_hash_entry *found, *parent_entry; AV *src_av = Nullav; if (1 != hash_op(&fidhash, file_name, file_name_len, (Hash_entry**)&found, (bool)(created_via ? 1 : 0))) { /* found existing entry or else didn't but didn't create new one either */ if (trace_level >= 7) { if (found) logwarn("fid %d: %.*s\n", found->he.id, found->he.key_len, found->he.key); else logwarn("fid -: %.*s not profiled\n", (int)file_name_len, file_name); } return (found) ? found->he.id : 0; } /* inserted new entry */ if (fidhash.prior_inserted) fidhash.prior_inserted->next_inserted = fidhash.last_inserted; /* if this is a synthetic filename for a string eval * ie "(eval 42)[/some/filename.pl:line]" * then ensure we've already generated a fid for the underlying * filename, and associate that fid with this eval fid */ if ('(' == file_name[0]) { /* first char is '(' */ if (']' == file_name[file_name_len-1]) { /* last char is ']' */ char *start = strchr(file_name, '['); const char *colon = ":"; /* can't use strchr here (not nul terminated) so use rninstr */ char *end = rninstr(file_name, file_name+file_name_len-1, colon, colon+1); if (!start || !end || start > end) { /* should never happen */ logwarn("NYTProf unsupported filename syntax '%s'\n", file_name); return 0; } ++start; /* move past [ */ /* recurse */ found->eval_fid = get_file_id(aTHX_ start, end - start, NYTP_FIDf_IS_EVAL | created_via); found->eval_line_num = atoi(end+1); } else if (filename_is_eval(file_name, file_name_len)) { /* strange eval that doesn't have a filename associated */ /* seen in mod_perl, possibly from eval_sv(sv) api call */ /* also when nameevals=0 option is in effect */ char eval_file[] = "/unknown-eval-invoker"; found->eval_fid = get_file_id(aTHX_ eval_file, sizeof(eval_file) - 1, NYTP_FIDf_IS_EVAL | NYTP_FIDf_IS_FAKE | created_via ); found->eval_line_num = 1; } } /* detect Class::MOP #line evals */ /* See _add_line_directive() in Class::MOP::Method::Generated */ if (!found->eval_fid) { char *tag = ninstr(file_name, file_name+file_name_len, class_mop_evaltag, class_mop_evaltag+class_mop_evaltag_len); if (tag) { char *definer = tag + class_mop_evaltag_len; int len = file_name_len - (definer - file_name); found->eval_fid = get_file_id(aTHX_ definer, len, created_via); found->eval_line_num = 1; /* XXX pity Class::MOP doesn't include the line here */ if (trace_level >= 1) logwarn("Class::MOP eval for '%.*s' (fid %u:%u) from '%.*s'\n", len, definer, found->eval_fid, found->eval_line_num, (int)file_name_len, file_name); } } /* is the file is an autosplit, e.g., has a file_name like * "../../lib/POSIX.pm (autosplit into ../../lib/auto/POSIX/errno.al)" */ if ( ')' == file_name[file_name_len-1] && strstr(file_name, " (autosplit ")) { found->fid_flags |= NYTP_FIDf_IS_AUTOSPLIT; } /* if the file is an autosplit * then we want it to have the same fid as the file it was split from. * Thankfully that file will almost certainly be in the fid hash, * so we can find it and copy the details. * We do this after the string eval check above in the (untested) hope * that string evals inside autoloaded subs get treated properly! XXX */ if (found->fid_flags & NYTP_FIDf_IS_AUTOSPLIT && (parent_entry = find_autosplit_parent(aTHX_ file_name)) ) { /* copy some details from parent_entry to found */ found->he.id = parent_entry->he.id; found->eval_fid = parent_entry->eval_fid; found->eval_line_num = parent_entry->eval_line_num; found->file_size = parent_entry->file_size; found->file_mtime = parent_entry->file_mtime; found->fid_flags = parent_entry->fid_flags; /* prevent write_cached_fids() from writing this fid */ found->fid_flags |= NYTP_FIDf_IS_ALIAS; /* avoid a gap in the fid sequence */ --fidhash.next_id; /* write a log message if tracing */ if (trace_level >= 2) logwarn("Use fid %2u (after %2u:%-4u) %x e%u:%u %.*s %s\n", found->he.id, last_executed_fid, last_executed_line, found->fid_flags, found->eval_fid, found->eval_line_num, found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : ""); /* bail out without calling emit_fid() */ return found->he.id; } /* determine absolute path if file_name is relative */ found->key_abs = NULL; if (!found->eval_fid && !(file_name[0] == '-' && (file_name_len==1 || (file_name[1]=='e' && file_name_len==2))) && #ifdef WIN32 /* XXX should we check for UNC names too? */ (file_name_len < 3 || !isALPHA(file_name[0]) || file_name[1] != ':' || (file_name[2] != '/' && file_name[2] != '\\')) #else *file_name != '/' #endif ) { char file_name_abs[MAXPATHLEN * 2]; /* Note that the current directory may have changed * between loading the file and profiling it. * We don't use realpath() or similar here because we want to * keep the view of symlinks etc. as the program saw them. */ if (!getcwd(file_name_abs, sizeof(file_name_abs))) { /* eg permission */ logwarn("getcwd: %s\n", strerror(errno)); } else { #ifdef WIN32 char *p = file_name_abs; while (*p) { if ('\\' == *p) *p = '/'; ++p; } if (p[-1] != '/') #else if (strNE(file_name_abs, "/")) #endif { if (strnEQ(file_name, "./", 2)) { ++file_name; } else { #ifndef VMS strcat(file_name_abs, "/"); #endif } } strncat(file_name_abs, file_name, file_name_len); found->key_abs = strdup(file_name_abs); } } if (fid_is_pmc(aTHX_ found)) found->fid_flags |= NYTP_FIDf_IS_PMC; found->fid_flags |= created_via; /* NYTP_FIDf_VIA_STMT or NYTP_FIDf_VIA_SUB */ /* is source code available? */ /* source only available if PERLDB_LINE or PERLDB_SAVESRC is true */ /* which we set if savesrc option is enabled */ if ( (src_av = GvAV(gv_fetchfile_flags(found->he.key, found->he.key_len, 0))) ) if (av_len(src_av) > -1) found->fid_flags |= NYTP_FIDf_HAS_SRC; /* flag "perl -e '...'" and "perl -" as string evals */ if (found->he.key[0] == '-' && (found->he.key_len == 1 || (found->he.key[1] == 'e' && found->he.key_len == 2))) found->fid_flags |= NYTP_FIDf_IS_EVAL; /* if it's a string eval or a synthetic filename from CODE ref in @INC, * then we'd like to save the src (NYTP_FIDf_HAS_SRC) if it's available */ if (found->eval_fid || (found->fid_flags & NYTP_FIDf_IS_EVAL) || (profile_opts & NYTP_OPTf_SAVESRC) || (found->he.key_len > 10 && found->he.key[9] == 'x' && strnEQ(found->he.key, "/loader/0x", 10)) ) { found->fid_flags |= NYTP_FIDf_SAVE_SRC; } emit_fid(found); if (trace_level >= 2) { char buf[80]; /* including last_executed_fid can be handy for tracking down how * a file got loaded */ logwarn("New fid %2u (after %2u:%-4u) 0x%02x e%u:%u %.*s %s %s\n", found->he.id, last_executed_fid, last_executed_line, found->fid_flags, found->eval_fid, found->eval_line_num, found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : "", fmt_fid_flags(aTHX_ found->fid_flags, buf, sizeof(buf)) ); } return found->he.id; } /** * Return a unique persistent id number for a string. * * XXX Currently not used, so may trigger compiler warnings, but is intended to be * used to assign ids to strings like subroutine names like we do for file ids. */ static unsigned int get_str_id(pTHX_ char* str, STRLEN len) { str_hash_entry *found; hash_op(&strhash, str, len, (Hash_entry**)&found, 1); return found->he.id; } static UV uv_from_av(pTHX_ AV *av, int idx, UV default_uv) { SV **svp = av_fetch(av, idx, 0); UV uv = (!svp || !SvOK(*svp)) ? default_uv : SvUV(*svp); return uv; } static NV nv_from_av(pTHX_ AV *av, int idx, NV default_nv) { SV **svp = av_fetch(av, idx, 0); NV nv = (!svp || !SvOK(*svp)) ? default_nv : SvNV(*svp); return nv; } static const char * cx_block_type(PERL_CONTEXT *cx) { static char buf[20]; switch (CxTYPE(cx)) { case CXt_NULL: return "CXt_NULL"; case CXt_SUB: return "CXt_SUB"; case CXt_FORMAT: return "CXt_FORMAT"; case CXt_EVAL: return "CXt_EVAL"; case CXt_SUBST: return "CXt_SUBST"; #ifdef CXt_WHEN case CXt_WHEN: return "CXt_WHEN"; #endif case CXt_BLOCK: return "CXt_BLOCK"; #ifdef CXt_GIVEN case CXt_GIVEN: return "CXt_GIVEN"; #endif #ifdef CXt_LOOP case CXt_LOOP: return "CXt_LOOP"; #endif #ifdef CXt_LOOP_FOR case CXt_LOOP_FOR: return "CXt_LOOP_FOR"; #endif #ifdef CXt_LOOP_PLAIN case CXt_LOOP_PLAIN: return "CXt_LOOP_PLAIN"; #endif #ifdef CXt_LOOP_LAZYSV case CXt_LOOP_LAZYSV: return "CXt_LOOP_LAZYSV"; #endif #ifdef CXt_LOOP_LAZYIV case CXt_LOOP_LAZYIV: return "CXt_LOOP_LAZYIV"; #endif #ifdef CXt_LOOP_ARY case CXt_LOOP_ARY: return "CXt_LOOP_ARY"; #endif #ifdef CXt_LOOP_LIST case CXt_LOOP_LIST: return "CXt_LOOP_LIST"; #endif } /* short-lived and not thread safe but we only use this for tracing * and it should never be reached anyway */ sprintf(buf, "CXt_%ld", (long)CxTYPE(cx)); return buf; } /* based on S_dopoptosub_at() from perl pp_ctl.c */ static int dopopcx_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock, UV cx_type_mask) { I32 i; register PERL_CONTEXT *cx; for (i = startingblock; i >= 0; i--) { UV type_bit; cx = &cxstk[i]; type_bit = 1 << CxTYPE(cx); if (type_bit & cx_type_mask) return i; } return i; /* == -1 */ } static COP * start_cop_of_context(pTHX_ PERL_CONTEXT *cx) { OP *start_op, *o; int type; int trace = 6; switch (CxTYPE(cx)) { case CXt_EVAL: start_op = (OP*)cx->blk_oldcop; break; case CXt_FORMAT: start_op = CvSTART(cx->blk_sub.cv); break; case CXt_SUB: start_op = CvSTART(cx->blk_sub.cv); break; #ifdef CXt_LOOP case CXt_LOOP: # if (PERL_VERSION < 10) || (PERL_VERSION == 9 && !defined(CX_LOOP_NEXTOP_GET)) start_op = cx->blk_loop.redo_op; # else start_op = cx->blk_loop.my_op->op_redoop; # endif break; #else # if defined (CXt_LOOP_PLAIN) && defined(CXt_LOOP_LAZYIV) && defined (CXt_LOOP_LAZYSV) /* This is Perl 5.11.0 or later */ case CXt_LOOP_LAZYIV: case CXt_LOOP_LAZYSV: case CXt_LOOP_PLAIN: # if defined (CXt_LOOP_FOR) case CXt_LOOP_FOR: # else case CXt_LOOP_ARY: case CXt_LOOP_LIST: # endif start_op = cx->blk_loop.my_op->op_redoop; break; # else # warning "The perl you are using is missing some essential defines. Your results may not be accurate." # endif #endif case CXt_BLOCK: /* this will be NULL for the top-level 'main' block */ start_op = (OP*)cx->blk_oldcop; break; case CXt_SUBST: /* FALLTHRU */ case CXt_NULL: /* FALLTHRU */ default: start_op = NULL; break; } if (!start_op) { if (trace_level >= trace) logwarn("\tstart_cop_of_context: can't find start of %s\n", cx_block_type(cx)); return NULL; } /* find next cop from OP */ o = start_op; while ( o && (type = (o->op_type) ? o->op_type : (int)o->op_targ) ) { if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) { if (trace_level >= trace) logwarn("\tstart_cop_of_context %s is %s line %d of %s\n", cx_block_type(cx), OP_NAME(o), (int)CopLINE((COP*)o), OutCopFILE((COP*)o)); return (COP*)o; } if (trace_level >= trace) logwarn("\tstart_cop_of_context %s op '%s' isn't a cop, giving up\n", cx_block_type(cx), OP_NAME(o)); return NULL; #if 0 /* old code that never worked very well anyway */ if (CxTYPE(cx) == CXt_LOOP) /* e.g. "eval $_ for @ary" */ return NULL; /* should never get here but we do */ if (trace_level >= trace) { logwarn("\tstart_cop_of_context %s op '%s' isn't a cop\n", cx_block_type(cx), OP_NAME(o)); if (trace_level > trace) do_op_dump(1, PerlIO_stderr(), o); } o = o->op_next; #endif } if (trace_level >= 3) { logwarn("\tstart_cop_of_context: can't find next cop for %s line %ld\n", cx_block_type(cx), (long)CopLINE(PL_curcop_nytprof)); do_op_dump(1, PerlIO_stderr(), start_op); } return NULL; } /* Walk up the context stack calling callback * return first context that callback returns true for * else return null. * UV cx_type_mask is a bit flag that specifies what kinds of contexts the * callback should be called for: (cx_type_mask & (1 << CxTYPE(cx))) * Use ~0 to stop at all contexts. * The callback is called with the context pointer and a pointer to * a copy of the UV cx_type_mask argument (so it can change it on the fly). */ static PERL_CONTEXT * visit_contexts(pTHX_ UV cx_type_mask, int (*callback)(pTHX_ PERL_CONTEXT *cx, UV *cx_type_mask_ptr)) { /* modelled on pp_caller() in pp_ctl.c */ register I32 cxix = cxstack_ix; register PERL_CONTEXT *cx = NULL; register PERL_CONTEXT *ccstack = cxstack; PERL_SI *top_si = PL_curstackinfo; if (trace_level >= 6) logwarn("visit_contexts: \n"); while (1) { /* we may be in a higher stacklevel, so dig down deeper */ /* XXX so we'll miss code in sort blocks and signals? */ /* callback should perhaps be moved to dopopcx_at */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { if (trace_level >= 6) logwarn("Not on main stack (type %d); digging top_si %p->%p, ccstack %p->%p\n", (int)top_si->si_type, (void*)top_si, (void*)top_si->si_prev, (void*)ccstack, (void*)top_si->si_cxstack); top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = dopopcx_at(aTHX_ ccstack, top_si->si_cxix, cx_type_mask); } if (cxix < 0 || (cxix == 0 && !top_si->si_prev)) { /* cxix==0 && !top_si->si_prev => top-level BLOCK */ if (trace_level >= 5) logwarn("visit_contexts: reached top of context stack\n"); return NULL; } cx = &ccstack[cxix]; if (trace_level >= 5) logwarn("visit_context: %s cxix %d (si_prev %p)\n", cx_block_type(cx), (int)cxix, (void*)top_si->si_prev); if (callback(aTHX_ cx, &cx_type_mask)) return cx; /* no joy, look further */ cxix = dopopcx_at(aTHX_ ccstack, cxix - 1, cx_type_mask); } return NULL; /* not reached */ } static int _cop_in_same_file(COP *a, COP *b) { int same = 0; char *a_file = OutCopFILE(a); char *b_file = OutCopFILE(b); if (a_file == b_file) same = 1; else /* fallback to strEQ, surprisingly common (check why) XXX expensive */ if (strEQ(a_file, b_file)) same = 1; return same; } static int _check_context(pTHX_ PERL_CONTEXT *cx, UV *cx_type_mask_ptr) { COP *near_cop; PERL_UNUSED_ARG(cx_type_mask_ptr); if (CxTYPE(cx) == CXt_SUB) { if (PL_debstash && CvSTASH(cx->blk_sub.cv) == PL_debstash) return 0; /* skip subs in DB package */ near_cop = start_cop_of_context(aTHX_ cx); /* only use the cop if it's in the same file */ if (_cop_in_same_file(near_cop, PL_curcop_nytprof)) { last_sub_line = CopLINE(near_cop); /* treat sub as a block if we've not found a block yet */ if (!last_block_line) last_block_line = last_sub_line; } if (trace_level >= 8) { GV *sv = CvGV(cx->blk_sub.cv); logwarn("\tat %d: block %d sub %d for %s %s\n", last_executed_line, last_block_line, last_sub_line, cx_block_type(cx), (sv) ? GvNAME(sv) : ""); if (trace_level >= 99) sv_dump((SV*)cx->blk_sub.cv); } return 1; /* stop looking */ } /* NULL, EVAL, LOOP, SUBST, BLOCK context */ if (trace_level >= 6) logwarn("\t%s\n", cx_block_type(cx)); /* if we've got a block line, skip this context and keep looking for a sub */ if (last_block_line) return 0; /* if we can't get a line number for this context, skip it */ if ((near_cop = start_cop_of_context(aTHX_ cx)) == NULL) return 0; /* if this context is in a different file... */ if (!_cop_in_same_file(near_cop, PL_curcop_nytprof)) { /* if we started in a string eval ... */ if ('(' == *OutCopFILE(PL_curcop_nytprof)) { /* give up XXX could do better here */ last_block_line = last_sub_line = last_executed_line; return 1; } /* shouldn't happen! */ if (trace_level >= 5) logwarn("at %d: %s in different file (%s, %s)\n", last_executed_line, cx_block_type(cx), OutCopFILE(near_cop), OutCopFILE(PL_curcop_nytprof)); return 1; /* stop looking */ } last_block_line = CopLINE(near_cop); if (trace_level >= 5) logwarn("\tat %d: block %d for %s\n", last_executed_line, last_block_line, cx_block_type(cx)); return 0; } /* copied from perl's S_closest_cop in util.c as used by warn(...) */ static const COP* closest_cop(pTHX_ const COP *cop, const OP *o) { dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ if (!o || o == PL_op) return cop; if (o->op_flags & OPf_KIDS) { const OP *kid; for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) { const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it * the get the file and line number. */ if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) cop = (const COP *)kid; /* Keep searching, and return when we've found something. */ new_cop = closest_cop(aTHX_ cop, kid); if (new_cop) return new_cop; } } /* Nothing found. */ return NULL; } /** * Main statement profiling function. Called before each breakable statement. */ static void DB_stmt(pTHX_ COP *cop, OP *op) { int saved_errno; char *file; long elapsed, overflow; if (!is_profiling || !profile_stmts) return; #ifdef MULTIPLICITY if (orig_my_perl && my_perl != orig_my_perl) return; #endif saved_errno = errno; get_time_of_day(end_time); get_ticks_between(long, start_time, end_time, elapsed, overflow); reinit_if_forked(aTHX); /* XXX move down into the (file != last_executed_fileptr) block ? */ CHECK_SAWAMPERSAND(last_executed_fid, last_executed_line); if (last_executed_fid) { if (profile_blocks) NYTP_write_time_block(out, elapsed, overflow, last_executed_fid, last_executed_line, last_block_line, last_sub_line); else NYTP_write_time_line(out, elapsed, overflow, last_executed_fid, last_executed_line); if (trace_level >= 5) /* previous fid:line and how much time we spent there */ logwarn("\t@%d:%-4d %2ld ticks (%u, %u)\n", last_executed_fid, last_executed_line, elapsed, last_block_line, last_sub_line); } if (!cop) cop = PL_curcop_nytprof; if ( (last_executed_line = CopLINE(cop)) == 0 ) { /* Might be a cop that has been optimised away. We can try to find such a * cop by searching through the optree starting from the sibling of PL_curcop. * See Perl_vmess in perl's util.c for how warn("...") finds the line number. */ cop = (COP*)closest_cop(aTHX_ cop, OpSIBLING(cop)); if (!cop) cop = PL_curcop_nytprof; last_executed_line = CopLINE(cop); if (!last_executed_line) { /* perl options, like -n, -p, -Mfoo etc can cause this because perl effectively * treats those as 'line 0', so we try not to warn in those cases. */ char *pkg_name = CopSTASHPV(cop); int is_preamble = (PL_scopestack_ix <= 7 && strEQ(pkg_name,"main")); /* op is null when called via finish_profile called by END */ if (!is_preamble && op) { /* warn() can't either, in the cases I've encountered */ logwarn("Unable to determine line number in %s (ssix%d)\n", OutCopFILE(cop), (int)PL_scopestack_ix); if (trace_level > 5) do_op_dump(1, PerlIO_stderr(), (OP*)cop); } last_executed_line = 1; /* don't want zero line numbers in data */ } } file = OutCopFILE(cop); if (!last_executed_fid) { /* first time */ if (trace_level >= 1) { logwarn("~ first statement profiled at line %d of %s, pid %ld\n", (int)CopLINE(cop), OutCopFILE(cop), (long)getpid()); } } if (file != last_executed_fileptr) { /* cache (hit ratio ~50% e.g. for perlcritic) */ last_executed_fileptr = file; last_executed_fid = get_file_id(aTHX_ file, strlen(file), NYTP_FIDf_VIA_STMT); } if (trace_level >= 7) /* show the fid:line we're about to execute */ logwarn("\t@%d:%-4d... %s\n", last_executed_fid, last_executed_line, (profile_blocks) ? "looking for block and sub lines" : ""); if (profile_blocks) { last_block_line = 0; last_sub_line = 0; if (op) { visit_contexts(aTHX_ ~0, &_check_context); } /* if we didn't find block or sub scopes then use current line */ if (!last_block_line) last_block_line = last_executed_line; if (!last_sub_line) last_sub_line = last_executed_line; } get_time_of_day(start_time); /* measure time we've spent measuring so we can discount it */ get_ticks_between(long, end_time, start_time, elapsed, overflow); cumulative_overhead_ticks += elapsed; SETERRNO(saved_errno, 0); return; } static void DB_leave(pTHX_ OP *op, OP *prev_op) { int saved_errno, is_multicall; unsigned int prev_last_executed_fid, prev_last_executed_line; /* Called _after_ ops that indicate we've completed a statement * and are returning into the middle of some outer statement. * Used to ensure that time between now and the _next_ statement * being entered, is allocated to the outer statement we've * returned into and not the previous statement. * PL_curcop has already been updated. */ if (!is_profiling || !out || !profile_stmts) return; #ifdef MULTIPLICITY if (orig_my_perl && my_perl != orig_my_perl) return; #endif saved_errno = errno; prev_last_executed_fid = last_executed_fid; prev_last_executed_line = last_executed_line; #if defined(CxMULTICALL) && 0 /* disabled for now */ /* pp_return, pp_leavesub and pp_leavesublv * return a NULL op when returning from a MULTICALL. * See Lightweight Callbacks in perlcall. */ is_multicall = (!op && cxstack_ix >= 0 && CxMULTICALL(&cxstack[cxstack_ix])); #else is_multicall = 0; #endif /* measure and output end time of previous statement * (earlier than it would have been done) * and switch back to measuring the 'calling' statement */ DB_stmt(aTHX_ NULL, op); /* output a 'discount' marker to indicate the next statement time shouldn't * increment the count (because the time is not for a new statement but simply * a continuation of a previously counted statement). */ NYTP_write_discount(out); /* special cases */ if (last_executed_line == prev_last_executed_line && last_executed_fid == prev_last_executed_fid ) { /* XXX OP_UNSTACK needs help */ } if (trace_level >= 5) { logwarn("\tleft %u:%u via %s back to %s at %u:%u (b%u s%u) - discounting next statement%s\n", prev_last_executed_fid, prev_last_executed_line, OP_NAME_safe(prev_op), OP_NAME_safe(op), last_executed_fid, last_executed_line, last_block_line, last_sub_line, (op || is_multicall) ? "" : ", LEAVING PERL" ); } SETERRNO(saved_errno, 0); } /** * Sets or toggles the option specified by 'option'. */ static void set_option(pTHX_ const char* option, const char* value) { if (!value || !*value) croak("%s: invalid option", "NYTProf set_option"); if (!value || !*value) croak("%s: '%s' has no value", "NYTProf set_option", option); if (strEQ(option, "file")) { strncpy(PROF_output_file, value, MAXPATHLEN); } else if (strEQ(option, "log")) { FILE *fp = fopen(value, "a"); if (!fp) { logwarn("Can't open log file '%s' for writing: %s\n", value, strerror(errno)); return; } logfh = fp; } else if (strEQ(option, "start")) { if (strEQ(value,"begin")) profile_start = NYTP_START_BEGIN; else if (strEQ(value,"init")) profile_start = NYTP_START_INIT; else if (strEQ(value,"end")) profile_start = NYTP_START_END; else if (strEQ(value,"no")) profile_start = NYTP_START_NO; else croak("NYTProf option 'start' has invalid value '%s'\n", value); } else if (strEQ(option, "addpid")) { profile_opts = (atoi(value)) ? profile_opts | NYTP_OPTf_ADDPID : profile_opts & ~NYTP_OPTf_ADDPID; } else if (strEQ(option, "addtimestamp")) { profile_opts = (atoi(value)) ? profile_opts | NYTP_OPTf_ADDTIMESTAMP : profile_opts & ~NYTP_OPTf_ADDTIMESTAMP; } else if (strEQ(option, "optimize") || strEQ(option, "optimise")) { profile_opts = (atoi(value)) ? profile_opts | NYTP_OPTf_OPTIMIZE : profile_opts & ~NYTP_OPTf_OPTIMIZE; } else if (strEQ(option, "savesrc")) { profile_opts = (atoi(value)) ? profile_opts | NYTP_OPTf_SAVESRC : profile_opts & ~NYTP_OPTf_SAVESRC; } else if (strEQ(option, "endatexit")) { if (atoi(value)) PL_exit_flags |= PERL_EXIT_DESTRUCT_END; } else if (strEQ(option, "libcexit")) { if (atoi(value)) atexit(finish_profile_nocontext); } else { struct NYTP_options_t *opt_p = options; const struct NYTP_options_t *const opt_end = options + sizeof(options) / sizeof (struct NYTP_options_t); bool found = FALSE; do { if (strEQ(option, opt_p->option_name)) { opt_p->option_iv = (IV)strtol(value, NULL, 0); found = TRUE; break; } } while (++opt_p < opt_end); if (!found) { logwarn("Unknown NYTProf option: '%s'\n", option); return; } } if (trace_level) logwarn("# %s=%s\n", option, value); } /** * Open the output file. This is encapsulated because the code can be reused * without the environment parsing overhead after each fork. */ static void open_output_file(pTHX_ char *filename) { char filename_buf[MAXPATHLEN]; /* 'x' is a GNU C lib extension for O_EXCL which gives us a little * extra protection, but it isn't POSIX compliant */ const char *mode = (strnEQ(filename, "/dev/", 4) ? "wb" : "wbx"); /* most systems that don't support it will silently ignore it * but for some we need to remove it to avoid an error */ #ifdef WIN32 mode = "wb"; #endif #ifdef VMS mode = "wb"; #endif if ((profile_opts & (NYTP_OPTf_ADDPID|NYTP_OPTf_ADDTIMESTAMP)) || out /* already opened so assume we're forking and add the pid */ ) { if (strlen(filename) >= MAXPATHLEN-(20+20)) /* buffer overrun protection */ croak("Filename '%s' too long", filename); strcpy(filename_buf, filename); if ((profile_opts & NYTP_OPTf_ADDPID) || out) sprintf(&filename_buf[strlen(filename_buf)], ".%d", getpid()); if ( profile_opts & NYTP_OPTf_ADDTIMESTAMP ) sprintf(&filename_buf[strlen(filename_buf)], ".%.0"NVff"", gettimeofday_nv()); filename = filename_buf; /* caller is expected to have purged/closed old out if appropriate */ } /* some protection against multiple processes writing to the same file */ unlink(filename); /* throw away any previous file */ out = NYTP_open(filename, mode); if (!out) { int fopen_errno = errno; const char *hint = ""; if (fopen_errno==EEXIST && !(profile_opts & NYTP_OPTf_ADDPID)) hint = " (enable addpid option to protect against concurrent writes)"; disable_profile(aTHX); croak("NYTProf failed to open '%s' for writing, error %d: %s%s", filename, fopen_errno, strerror(fopen_errno), hint); } if (trace_level >= 1) logwarn("~ opened %s at %.6"NVff"\n", filename, gettimeofday_nv()); output_header(aTHX); } static void close_output_file(pTHX) { int result; NV timeofday; if (!out) return; timeofday = gettimeofday_nv(); /* before write_*() calls */ NYTP_write_attribute_nv(out, STR_WITH_LEN("cumulative_overhead_ticks"), cumulative_overhead_ticks); write_src_of_files(aTHX); write_sub_line_ranges(aTHX); write_sub_callers(aTHX); /* mark end of profile data for last_pid pid * which is the pid that this file relates to */ NYTP_write_process_end(out, last_pid, timeofday); if ((result = NYTP_close(out, 0))) logwarn("Error closing profile data file: %s\n", strerror(result)); out = NULL; if (trace_level >= 1) logwarn("~ closed file at %.6"NVff"\n", timeofday); } static int reinit_if_forked(pTHX) { int open_new_file; if (getpid() == last_pid) return 0; /* not forked */ /* we're now the child process */ if (trace_level >= 1) logwarn("~ new pid %d (was %d) forkdepth %"IVdf"\n", getpid(), last_pid, profile_forkdepth); /* reset state */ last_pid = getpid(); last_executed_fileptr = NULL; last_executed_fid = 0; /* don't count the fork in the child */ if (sub_callers_hv) hv_clear(sub_callers_hv); open_new_file = (out) ? 1 : 0; if (open_new_file) { /* data that was unflushed in the parent when it forked * is now duplicated unflushed in this child, * so discard it when we close the inherited filehandle. */ int result = NYTP_close(out, 1); if (result) logwarn("Error closing profile data file: %s\n", strerror(result)); out = NULL; /* if we fork while profiling then ensure we'll get a distinct filename */ profile_opts |= NYTP_OPTf_ADDPID; } if (profile_forkdepth == 0) { /* parent doesn't want children profiled */ disable_profile(aTHX); open_new_file = 0; } else /* count down another generation */ --profile_forkdepth; if (open_new_file) open_output_file(aTHX_ PROF_output_file); return 1; /* have forked */ } /****************************************** * Sub caller and inclusive time tracking ******************************************/ static AV * new_sub_call_info_av(pTHX) { AV *av = newAV(); av_store(av, NYTP_SCi_CALL_COUNT, newSVuv(1)); av_store(av, NYTP_SCi_INCL_RTIME, newSVnv(0.0)); av_store(av, NYTP_SCi_EXCL_RTIME, newSVnv(0.0)); av_store(av, NYTP_SCi_INCL_TICKS, newSVnv(0.0)); av_store(av, NYTP_SCi_EXCL_TICKS, newSVnv(0.0)); /* others allocated when needed */ return av; } /* subroutine profiler subroutine entry structure. Represents a call * from one sub to another (the arc between the nodes, if you like) */ typedef struct subr_entry_st subr_entry_t; struct subr_entry_st { unsigned int already_counted; U32 subr_prof_depth; long unsigned subr_call_seqn; I32 prev_subr_entry_ix; /* ix to callers subr_entry */ time_of_day_t initial_call_timeofday; struct tms initial_call_cputimes; NV initial_overhead_ticks; NV initial_subr_ticks; unsigned int caller_fid; int caller_line; const char *caller_subpkg_pv; SV *caller_subnam_sv; CV *called_cv; int called_cv_depth; const char *called_is_xs; /* NULL, "xsub", or "syop" */ const char *called_subpkg_pv; SV *called_subnam_sv; /* ensure all items are initialized in first phase of pp_subcall_profiler */ int hide_subr_call_time; /* eg for CORE:accept */ }; /* save stack index to the current subroutine entry structure */ static I32 subr_entry_ix = -1; #define subr_entry_ix_ptr(ix) ((ix != -1) ? SSPTR(ix, subr_entry_t *) : NULL) static void append_linenum_to_begin(pTHX_ subr_entry_t *subr_entry) { UV line = 0; SV *fullnamesv; SV *DBsv; char *subname = SvPVX(subr_entry->called_subnam_sv); STRLEN pkg_len; STRLEN total_len; /* If sub is a BEGIN then append the line number to our name * so multiple BEGINs (either explicit or implicit, e.g., "use") * in the same file/package can be distinguished. */ if (!subname || *subname != 'B' || strNE(subname,"BEGIN")) return; /* get, and delete, the entry for this sub in the PL_DBsub hash */ pkg_len = strlen(subr_entry->called_subpkg_pv); total_len = pkg_len + 2 /* :: */ + 5; /* BEGIN */ fullnamesv = newSV(total_len + 1); /* +1 for '\0' */ memcpy(SvPVX(fullnamesv), subr_entry->called_subpkg_pv, pkg_len); memcpy(SvPVX(fullnamesv) + pkg_len, "::BEGIN", 7 + 1); /* + 1 for '\0' */ SvCUR_set(fullnamesv, total_len); SvPOK_on(fullnamesv); DBsv = hv_delete(GvHV(PL_DBsub), SvPVX(fullnamesv), (I32)total_len, 1); if (DBsv && parse_DBsub_value(aTHX_ DBsv, NULL, &line, NULL, SvPVX(fullnamesv))) { (void)SvREFCNT_inc(DBsv); /* was made mortal by hv_delete */ sv_catpvf(fullnamesv, "@%u", (unsigned int)line); if (hv_fetch(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), (I32)SvCUR(fullnamesv), 0)) { static unsigned int dup_begin_seqn; sv_catpvf(fullnamesv, ".%u", ++dup_begin_seqn); } (void) hv_store(GvHV(PL_DBsub), SvPV_nolen(fullnamesv), (I32)SvCUR(fullnamesv), DBsv, 0); /* As we know the length of fullnamesv *before* the concatenation, we can calculate the length and offset of the formatted addition, and hence directly string append it, rather than duplicating the call to a *printf function. */ sv_catpvn(subr_entry->called_subnam_sv, SvPVX(fullnamesv) + total_len, SvCUR(fullnamesv) - total_len); } SvREFCNT_dec(fullnamesv); } static char * subr_entry_summary(pTHX_ subr_entry_t *subr_entry, int state) { static char buf[80]; /* XXX */ sprintf(buf, "(seix %d%s%d, ac%u)", (int)subr_entry->prev_subr_entry_ix, (state) ? "<-" : "->", (int)subr_entry_ix, subr_entry->already_counted ); return buf; } static void subr_entry_destroy(pTHX_ subr_entry_t *subr_entry) { if ((trace_level >= 6 || subr_entry->already_counted>1) /* ignore the typical second (fallback) destroy */ && !(subr_entry->prev_subr_entry_ix == subr_entry_ix && subr_entry->already_counted==1) ) { logwarn("%2u << %s::%s done %s\n", (unsigned int)subr_entry->subr_prof_depth, subr_entry->called_subpkg_pv, (subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv)) ? SvPV_nolen(subr_entry->called_subnam_sv) : "?", subr_entry_summary(aTHX_ subr_entry, 1)); } if (subr_entry->caller_subnam_sv) { sv_free(subr_entry->caller_subnam_sv); subr_entry->caller_subnam_sv = Nullsv; } if (subr_entry->called_subnam_sv) { sv_free(subr_entry->called_subnam_sv); subr_entry->called_subnam_sv = Nullsv; } if (subr_entry->prev_subr_entry_ix <= subr_entry_ix) subr_entry_ix = subr_entry->prev_subr_entry_ix; else logwarn("skipped attempt to raise subr_entry_ix from %d to %d\n", (int)subr_entry_ix, (int)subr_entry->prev_subr_entry_ix); } static void incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry) { int saved_errno = errno; char called_subname_pv[NYTP_MAX_SUB_NAME_LEN]; char *called_subname_pv_end = called_subname_pv; char subr_call_key[NYTP_MAX_SUB_NAME_LEN]; int subr_call_key_len; NV overhead_ticks, called_sub_ticks; SV *incl_time_sv, *excl_time_sv; NV incl_subr_ticks, excl_subr_ticks; SV *sv_tmp; AV *subr_call_av; time_of_day_t sub_end_time; long ticks, overflow; /* an undef SV is a special marker used by subr_entry_setup */ if (subr_entry->called_subnam_sv && !SvOK(subr_entry->called_subnam_sv)) { if (trace_level) logwarn("Don't know name of called sub, assuming xsub/builtin exited via an exception (which isn't handled yet)\n"); subr_entry->already_counted++; } /* For xsubs we get called both explicitly when the xsub returns, and by * the destructor. (That way if the xsub leaves via an exception then we'll * still get called, albeit a little later than we'd like.) */ if (subr_entry->already_counted) { subr_entry_destroy(aTHX_ subr_entry); return; } subr_entry->already_counted++; /* statement overheads we've accumulated since we entered the sub */ overhead_ticks = cumulative_overhead_ticks - subr_entry->initial_overhead_ticks; /* ticks spent in subroutines called by this subroutine */ called_sub_ticks = cumulative_subr_ticks - subr_entry->initial_subr_ticks; /* calculate ticks since we entered the sub */ get_time_of_day(sub_end_time); get_ticks_between(NV, subr_entry->initial_call_timeofday, sub_end_time, ticks, overflow); incl_subr_ticks = (overflow*ticks_per_sec) + ticks; /* subtract statement measurement overheads */ incl_subr_ticks -= overhead_ticks; if (subr_entry->hide_subr_call_time) { /* account for the time spent in the sub as if it was statement * profiler overhead. That has the effect of neatly subtracting * the time from all the sub calls up the call stack. */ cumulative_overhead_ticks += incl_subr_ticks; incl_subr_ticks = 0; called_sub_ticks = 0; } /* exclusive = inclusive - time spent in subroutines called by this subroutine */ excl_subr_ticks = incl_subr_ticks - called_sub_ticks; subr_call_key_len = my_snprintf(subr_call_key, sizeof(subr_call_key), "%s::%s[%u:%d]", subr_entry->caller_subpkg_pv, (subr_entry->caller_subnam_sv) ? SvPV_nolen(subr_entry->caller_subnam_sv) : "(null)", subr_entry->caller_fid, subr_entry->caller_line); if (subr_call_key_len >= sizeof(subr_call_key)) croak(nytp_panic_overflow_msg_fmt, "subr_call_key", subr_call_key); /* compose called_subname_pv as "${pkg}::${sub}" avoiding sprintf */ STMT_START { STRLEN len; const char *p; p = subr_entry->called_subpkg_pv; while (*p) *called_subname_pv_end++ = *p++; *called_subname_pv_end++ = ':'; *called_subname_pv_end++ = ':'; if (subr_entry->called_subnam_sv) { /* We create this SV, so we know that it is well-formed, and has a trailing '\0' */ p = SvPV(subr_entry->called_subnam_sv, len); } else { /* C string constants have a trailing '\0'. */ p = "(null)"; len = 6; } memcpy(called_subname_pv_end, p, len + 1); called_subname_pv_end += len; if (called_subname_pv_end >= called_subname_pv+sizeof(called_subname_pv)) croak(nytp_panic_overflow_msg_fmt, "called_subname_pv", called_subname_pv); } STMT_END; /* { called_subname => { "caller_subname[fid:line]" => [ count, incl_time, ... ] } } */ sv_tmp = *hv_fetch(sub_callers_hv, called_subname_pv, (I32)(called_subname_pv_end - called_subname_pv), 1); if (!SvROK(sv_tmp)) { /* autoviv hash ref - is first call of this called subname from anywhere */ HV *hv = newHV(); sv_setsv(sv_tmp, newRV_noinc((SV *)hv)); if (subr_entry->called_is_xs) { /* create dummy item with fid=0 & line=0 to act as flag to indicate xs */ AV *av = new_sub_call_info_av(aTHX); av_store(av, NYTP_SCi_CALL_COUNT, newSVuv(0)); sv_setsv(*hv_fetch(hv, "[0:0]", 5, 1), newRV_noinc((SV *)av)); if ( ('s' == *subr_entry->called_is_xs) /* "sop" (slowop) */ || (subr_entry->called_cv && SvTYPE(subr_entry->called_cv) == SVt_PVCV) ) { /* We just use an empty string as the filename for xsubs * because CvFILE() isn't reliable on perl 5.8.[78] * and the name of the .c file isn't very useful anyway. * The reader can try to associate the xsubs with the * corresonding .pm file using the package part of the subname. */ SV *sv = *hv_fetch(GvHV(PL_DBsub), called_subname_pv, (I32)(called_subname_pv_end - called_subname_pv), 1); if (!SvOK(sv)) sv_setpvs(sv, ":0-0"); /* empty file name */ if (trace_level >= 2) logwarn("Marking '%s' as %s\n", called_subname_pv, subr_entry->called_is_xs); } } } /* drill-down to array of sub call information for this subr_call_key */ sv_tmp = *hv_fetch((HV*)SvRV(sv_tmp), subr_call_key, subr_call_key_len, 1); if (!SvROK(sv_tmp)) { /* first call from this subname[fid:line] - autoviv array ref */ subr_call_av = new_sub_call_info_av(aTHX); sv_setsv(sv_tmp, newRV_noinc((SV *)subr_call_av)); if (subr_entry->called_subpkg_pv) { /* note that a sub in this package was called */ SV *pf_sv = *hv_fetch(pkg_fids_hv, subr_entry->called_subpkg_pv, (I32)strlen(subr_entry->called_subpkg_pv), 1); if (SvTYPE(pf_sv) == SVt_NULL) { /* log when first created */ sv_upgrade(pf_sv, SVt_PV); if (trace_level >= 3) logwarn("Noting that subs in package '%s' were called\n", subr_entry->called_subpkg_pv); } } } else { subr_call_av = (AV *)SvRV(sv_tmp); sv_inc(AvARRAY(subr_call_av)[NYTP_SCi_CALL_COUNT]); } if (trace_level >= 5) { logwarn("%2u <- %s %"NVgf" excl = %"NVgf"t incl - %"NVgf"t (%"NVgf"-%"NVgf"), oh %"NVff"-%"NVff"=%"NVff"t, d%d @%d:%d #%lu %p\n", (unsigned int)subr_entry->subr_prof_depth, called_subname_pv, excl_subr_ticks, incl_subr_ticks, called_sub_ticks, cumulative_subr_ticks, subr_entry->initial_subr_ticks, cumulative_overhead_ticks, subr_entry->initial_overhead_ticks, overhead_ticks, (int)subr_entry->called_cv_depth, subr_entry->caller_fid, subr_entry->caller_line, subr_entry->subr_call_seqn, (void*)subr_entry); } /* only count inclusive time for the outer-most calls */ if (subr_entry->called_cv_depth <= 1) { incl_time_sv = *av_fetch(subr_call_av, NYTP_SCi_INCL_TICKS, 1); sv_setnv(incl_time_sv, SvNV(incl_time_sv)+incl_subr_ticks); } else { /* recursing into an already entered sub */ /* measure max depth and accumulate incl time separately */ SV *reci_time_sv = *av_fetch(subr_call_av, NYTP_SCi_RECI_RTIME, 1); SV *max_depth_sv = *av_fetch(subr_call_av, NYTP_SCi_REC_DEPTH, 1); sv_setnv(reci_time_sv, (SvOK(reci_time_sv)) ? SvNV(reci_time_sv)+(incl_subr_ticks/ticks_per_sec) : (incl_subr_ticks/ticks_per_sec)); /* we track recursion depth here, which is called_cv_depth-1 */ if (!SvOK(max_depth_sv) || subr_entry->called_cv_depth-1 > SvIV(max_depth_sv)) sv_setiv(max_depth_sv, subr_entry->called_cv_depth-1); } excl_time_sv = *av_fetch(subr_call_av, NYTP_SCi_EXCL_TICKS, 1); sv_setnv(excl_time_sv, SvNV(excl_time_sv)+excl_subr_ticks); if (opt_calls && out) { NYTP_write_call_return(out, subr_entry->subr_prof_depth, called_subname_pv, incl_subr_ticks, excl_subr_ticks); } subr_entry_destroy(aTHX_ subr_entry); cumulative_subr_ticks += excl_subr_ticks; SETERRNO(saved_errno, 0); } static void /* wrapper called at scope exit due to save_destructor below */ incr_sub_inclusive_time_ix(pTHX_ void *subr_entry_ix_void) { /* recover the I32 ix that was stored as a void pointer */ I32 save_ix = (I32)PTR2IV(subr_entry_ix_void); incr_sub_inclusive_time(aTHX_ subr_entry_ix_ptr(save_ix)); } static CV * resolve_sub_to_cv(pTHX_ SV *sv, GV **subname_gv_ptr) { GV *dummy_gv; HV *stash; CV *cv; if (!subname_gv_ptr) subname_gv_ptr = &dummy_gv; else *subname_gv_ptr = Nullgv; /* copied from top of perl's pp_entersub */ /* modified to return either CV or else a GV */ /* or a NULL in cases that pp_entersub would croak */ switch (SvTYPE(sv)) { default: if (!SvROK(sv)) { char *sym; if (sv == &PL_sv_yes) { /* unfound import, ignore */ return NULL; } if (SvGMAGICAL(sv)) { mg_get(sv); if (SvROK(sv)) goto got_rv; sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else sym = SvPV_nolen(sv); if (!sym) return NULL; if (PL_op->op_private & HINT_STRICT_REFS) return NULL; cv = get_cv(sym, TRUE); break; } got_rv: { SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); } cv = (CV*)SvRV(sv); if (SvTYPE(cv) == SVt_PVCV) break; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: return NULL; case SVt_PVCV: cv = (CV*)sv; break; case SVt_PVGV: if (!(isGV_with_GP(sv) && (cv = GvCVu((GV*)sv)))) cv = sv_2cv(sv, &stash, subname_gv_ptr, FALSE); if (!cv) /* would autoload in this situation */ return NULL; break; } if (cv && !*subname_gv_ptr && CvGV(cv) && isGV_with_GP(CvGV(cv))) { *subname_gv_ptr = CvGV(cv); } return cv; } static CV* current_cv(pTHX_ I32 ix, PERL_SI *si) { /* returning the current cv */ /* logic based on perl's S_deb_curcv in dump.c */ /* see also http://metacpan.org/release/Devel-StackBlech/ */ PERL_CONTEXT *cx; if (!si) si = PL_curstackinfo; if (ix < 0) { /* caller isn't on the same stack so we'll walk the stacks as well */ if (si->si_type != PERLSI_MAIN) return current_cv(aTHX_ si->si_prev->si_cxix, si->si_prev); if (trace_level >= 9) logwarn("finding current_cv(%d,%p) si_type %d - context stack empty\n", (int)ix, (void*)si, (int)si->si_type); return Nullcv; /* PL_main_cv ? */ } cx = &si->si_cxstack[ix]; if (trace_level >= 9) logwarn("finding current_cv(%d,%p) - cx_type %d %s, si_type %d\n", (int)ix, (void*)si, CxTYPE(cx), cx_block_type(cx), (int)si->si_type); /* the common case of finding the caller on the same stack */ if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) return cx->blk_sub.cv; else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) return current_cv(aTHX_ ix - 1, si); /* recurse up stack */ else if (ix == 0 && si->si_type == PERLSI_MAIN) return PL_main_cv; else if (ix > 0) /* more on this stack? */ return current_cv(aTHX_ ix - 1, si); /* recurse up stack */ /* caller isn't on the same stack so we'll walk the stacks as well */ if (si->si_type != PERLSI_MAIN) { return current_cv(aTHX_ si->si_prev->si_cxix, si->si_prev); } return Nullcv; } static I32 subr_entry_setup(pTHX_ COP *prev_cop, subr_entry_t *clone_subr_entry, OPCODE op_type, SV *subr_sv) { int saved_errno = errno; subr_entry_t *subr_entry; I32 prev_subr_entry_ix; subr_entry_t *caller_subr_entry; const char *found_caller_by; char *file; /* allocate struct to save stack (very efficient) */ /* XXX "warning: cast from pointer to integer of different size" with use64bitall=define */ prev_subr_entry_ix = subr_entry_ix; subr_entry_ix = SSNEWa(sizeof(*subr_entry), MEM_ALIGNBYTES); if (subr_entry_ix <= prev_subr_entry_ix) { /* one cause of this is running NYTProf with threads */ logwarn("NYTProf panic: stack is confused, giving up! (Try running with subs=0) ix=%"IVdf" prev_ix=%"IVdf"\n", (IV)subr_entry_ix, (IV)prev_subr_entry_ix); /* limit the damage */ disable_profile(aTHX); return prev_subr_entry_ix; } subr_entry = subr_entry_ix_ptr(subr_entry_ix); Zero(subr_entry, 1, subr_entry_t); subr_entry->prev_subr_entry_ix = prev_subr_entry_ix; caller_subr_entry = subr_entry_ix_ptr(prev_subr_entry_ix); subr_entry->subr_prof_depth = (caller_subr_entry) ? caller_subr_entry->subr_prof_depth+1 : 1; get_time_of_day(subr_entry->initial_call_timeofday); subr_entry->initial_overhead_ticks = cumulative_overhead_ticks; subr_entry->initial_subr_ticks = cumulative_subr_ticks; subr_entry->subr_call_seqn = (unsigned long)(++cumulative_subr_seqn); /* try to work out what sub's being called in advance * mainly for xsubs because otherwise they're transparent * because xsub calls don't get a new context */ if (op_type == OP_ENTERSUB || op_type == OP_GOTO) { GV *called_gv = Nullgv; subr_entry->called_cv = resolve_sub_to_cv(aTHX_ subr_sv, &called_gv); if (called_gv) { char *p = HvNAME(GvSTASH(called_gv)); subr_entry->called_subpkg_pv = p; subr_entry->called_subnam_sv = newSVpv(GvNAME(called_gv), 0); /* detect calls to POSIX::_exit */ if ('P'==*p++ && 'O'==*p++ && 'S'==*p++ && 'I'==*p++ && 'X'==*p++ && 0==*p) { char *s = GvNAME(called_gv); if ('_'==*s++ && 'e'==*s++ && 'x'==*s++ && 'i'==*s++ && 't'==*s++ && 0==*s) { finish_profile(aTHX); } } } else { /* resolve_sub_to_cv couldn't work out what's being called, * possibly because it's something that'll cause pp_entersub to croak * anyway. So we mark the subr_entry in a particular way and hope that * pp_subcall_profiler() can fill in the details. * If there is an exception then we'll wind up in incr_sub_inclusive_time * which will see this mark and ignore the call. */ subr_entry->called_subnam_sv = newSV(0); } subr_entry->called_is_xs = NULL; /* work it out later */ } else { /* slowop */ /* pretend slowops (builtins) are xsubs */ const char *slowop_name = PL_op_name[op_type]; if (profile_slowops == 1) { /* 1 == put slowops into 1 package */ subr_entry->called_subpkg_pv = "CORE"; subr_entry->called_subnam_sv = newSVpv(slowop_name, 0); } else { /* 2 == put slowops into multiple packages */ SV **opname = NULL; SV *sv; if (!slowop_name_cache) slowop_name_cache = newAV(); opname = av_fetch(slowop_name_cache, op_type, TRUE); if (!opname) croak("panic: opname cache read for '%s' (%d)\n", slowop_name, op_type); sv = *opname; if(!SvOK(sv)) { const STRLEN len = strlen(slowop_name); sv_grow(sv, 5 + len + 1); memcpy(SvPVX(sv), "CORE:", 5); memcpy(SvPVX(sv) + 5, slowop_name, len + 1); SvCUR_set(sv, 5 + len); SvPOK_on(sv); } subr_entry->called_subnam_sv = SvREFCNT_inc(sv); subr_entry->called_subpkg_pv = CopSTASHPV(PL_curcop); } subr_entry->called_cv_depth = 1; /* an approximation for slowops */ subr_entry->called_is_xs = "sop"; /* XXX make configurable eg for wait(), and maybe even subs like FCGI::Accept * so perhaps use $hide_sub_calls->{$package}{$subname} to make it general. * Then the logic would have to move out of this block. */ if (OP_ACCEPT == op_type) subr_entry->hide_subr_call_time = 1; } /* These refer to the last perl statement executed, so aren't * strictly correct where an opcode or xsub is making the call, * but they're still more useful than nothing. * In reports the references line shows calls made by the * opcode or xsub that's called at that line. */ file = OutCopFILE(prev_cop); subr_entry->caller_fid = (file == last_executed_fileptr) ? last_executed_fid : get_file_id(aTHX_ file, strlen(file), NYTP_FIDf_VIA_SUB); subr_entry->caller_line = CopLINE(prev_cop); /* Gather details about the calling subroutine */ if (clone_subr_entry) { subr_entry->caller_subpkg_pv = clone_subr_entry->caller_subpkg_pv; subr_entry->caller_subnam_sv = SvREFCNT_inc(clone_subr_entry->caller_subnam_sv); found_caller_by = "(cloned)"; } else /* Should we calculate the caller or can we reuse the caller_subr_entry? * Sometimes we'll have a caller_subr_entry but it won't have the name yet. * For example if the caller is an xsub that's callback into perl. */ if (profile_findcaller /* user wants us to calculate each time */ || !caller_subr_entry /* we don't have a caller struct */ || !caller_subr_entry->called_subpkg_pv /* we don't have caller details */ || !caller_subr_entry->called_subnam_sv || !SvOK(caller_subr_entry->called_subnam_sv) ) { /* get the current CV and determine the current sub name from that */ CV *caller_cv = current_cv(aTHX_ cxstack_ix, NULL); subr_entry->caller_subnam_sv = newSV(0); /* XXX add cache/stack thing for these SVs */ if (0) { logwarn(" .. caller_subr_entry %p(%s::%s) cxstack_ix=%d: caller_cv=%p\n", (void*)caller_subr_entry, caller_subr_entry ? caller_subr_entry->called_subpkg_pv : "(null)", (caller_subr_entry && caller_subr_entry->called_subnam_sv && SvOK(caller_subr_entry->called_subnam_sv)) ? SvPV_nolen(caller_subr_entry->called_subnam_sv) : "(null)", (int)cxstack_ix, (void*)caller_cv ); } if (caller_cv == PL_main_cv) { /* PL_main_cv is run-time main (compile-time, eg 'use', is a main::BEGIN) */ /* We don't record timing data for main::RUNTIME because timing data * is stored per calling location, and there is no calling location. * XXX Currently we don't output a subinfo for main::RUNTIME unless * some sub is called from main::RUNTIME. That may change. */ subr_entry->caller_subpkg_pv = "main"; sv_setpvs(subr_entry->caller_subnam_sv, "RUNTIME"); /* *cough* */ ++main_runtime_used; } else if (caller_cv == 0) { /* should never happen - but does in PostgreSQL 8.4.1 plperl * possibly because perl_run() has already returned */ subr_entry->caller_subpkg_pv = "main"; sv_setpvs(subr_entry->caller_subnam_sv, "NULL"); /* *cough* */ } else { HV *stash_hv = NULL; GV *gv = CvGV(caller_cv); GV *egv = GvEGV(gv); if (!egv) gv = egv; if (gv && (stash_hv = GvSTASH(gv))) { subr_entry->caller_subpkg_pv = HvNAME(stash_hv); sv_setpvn(subr_entry->caller_subnam_sv,GvNAME(gv),GvNAMELEN(gv)); } else { logwarn("Can't determine name of calling sub (GV %p, Stash %p, CV flags %d) at %s line %d\n", (void*)gv, (void*)stash_hv, (int)CvFLAGS(caller_cv), OutCopFILE(prev_cop), (int)CopLINE(prev_cop)); sv_dump((SV*)caller_cv); subr_entry->caller_subpkg_pv = "__UNKNOWN__"; sv_setpvs(subr_entry->caller_subnam_sv, "__UNKNOWN__"); } } found_caller_by = (profile_findcaller) ? "" : "(calculated)"; } else { subr_entry_t *caller_se = caller_subr_entry; int caller_is_op = caller_se->called_is_xs && strEQ(caller_se->called_is_xs,"sop"); /* if the caller is an op then use the caller of that op as our caller. * that makes more sense from the users perspective (and is consistent * with the findcaller=1 option). * XXX disabled for now because (I'm pretty sure) it needs a corresponding * change in incr_sub_inclusive_time otherwise the incl/excl times are distorted. */ if (0 && caller_is_op) { subr_entry->caller_subpkg_pv = caller_se->caller_subpkg_pv; subr_entry->caller_subnam_sv = SvREFCNT_inc(caller_se->caller_subnam_sv); } else { subr_entry->caller_subpkg_pv = caller_se->called_subpkg_pv; subr_entry->caller_subnam_sv = SvREFCNT_inc(caller_se->called_subnam_sv); } found_caller_by = "(inherited)"; } if (trace_level >= 4) { logwarn("%2u >> %s at %u:%d from %s::%s %s %s\n", (unsigned int)subr_entry->subr_prof_depth, PL_op_name[op_type], subr_entry->caller_fid, subr_entry->caller_line, subr_entry->caller_subpkg_pv, SvPV_nolen(subr_entry->caller_subnam_sv), found_caller_by, subr_entry_summary(aTHX_ subr_entry, 0) ); } /* This is our safety-net destructor. For perl subs an identical destructor * will be pushed onto the stack _inside_ the scope we're interested in. * That destructor will be more accurate than this one. This one is here * mainly to catch exceptions thrown from xs subs and slowops. */ save_destructor_x(incr_sub_inclusive_time_ix, INT2PTR(void *, (IV)subr_entry_ix)); if (opt_calls >= 2 && out) { NYTP_write_call_entry(out, subr_entry->caller_fid, subr_entry->caller_line); } SETERRNO(saved_errno, 0); return subr_entry_ix; } static OP * pp_entersub_profiler(pTHX) { return pp_subcall_profiler(aTHX_ 0); } static OP * pp_slowop_profiler(pTHX) { return pp_subcall_profiler(aTHX_ 1); } static OP * pp_subcall_profiler(pTHX_ int is_slowop) { int saved_errno = errno; OP *op; COP *prev_cop = PL_curcop; /* not PL_curcop_nytprof here */ OP *next_op = PL_op->op_next; /* op to execute after sub returns */ /* pp_entersub can be called with PL_op->op_type==0 */ OPCODE op_type = (is_slowop || (opcode) PL_op->op_type == OP_GOTO) ? (opcode) PL_op->op_type : OP_ENTERSUB; CV *called_cv; dSP; SV *sub_sv = *SP; I32 this_subr_entry_ix; /* local copy (needed for goto) */ subr_entry_t *subr_entry; /* pre-conditions */ if (!profile_subs /* not profiling subs */ /* don't profile if currently disabled */ || !is_profiling /* don't profile calls to non-existant import() methods */ /* or our DB::_INIT as that makes tests perl version sensitive */ || (op_type==OP_ENTERSUB && (sub_sv == &PL_sv_yes || sub_sv == DB_CHECK_cv || sub_sv == DB_INIT_cv || sub_sv == DB_END_cv || sub_sv == DB_fin_cv)) /* don't profile other kinds of goto */ || (op_type==OP_GOTO && ( !(SvROK(sub_sv) && SvTYPE(SvRV(sub_sv)) == SVt_PVCV) || subr_entry_ix == -1) /* goto out of sub whose entry wasn't profiled */ ) #ifdef MULTIPLICITY || (orig_my_perl && my_perl != orig_my_perl) #endif ) { return run_original_op(op_type); } if (!profile_stmts) { reinit_if_forked(aTHX); CHECK_SAWAMPERSAND(last_executed_fid, last_executed_line); } if (trace_level >= 99) { logwarn("profiling a call [op %ld, %s, seix %d]\n", (long)op_type, PL_op_name[op_type], (int)subr_entry_ix); /* crude, but the only way to deal with the miriad logic at the * start of pp_entersub (which ought to be available as separate sub) */ sv_dump(sub_sv); } /* Life would be so much simpler if we could reliably tell, at this point, * what sub was going to get called. But we can't in many cases. * So we gather up as much into as possible before the call. */ if (op_type != OP_GOTO) { /* For normal subs, pp_entersub enters the sub and returns the * first op *within* the sub (typically a nextstate/dbstate). * For XS subs, pp_entersub executes the entire sub * and returns the op *after* the sub (PL_op->op_next). * Other ops we profile (eg slowops) act like xsubs. */ called_cv = NULL; this_subr_entry_ix = subr_entry_setup(aTHX_ prev_cop, NULL, op_type, sub_sv); /* This call may exit via an exception, in which case the * remaining code below doesn't get executed and the sub call * details are discarded. For perl subs that just means we don't * see calls the failed with "Unknown sub" errors, etc. * For xsubs it's a more significant issue. Especially if the * xsub calls back into perl. */ SETERRNO(saved_errno, 0); op = run_original_op(op_type); saved_errno = errno; } else { /* goto &sub opcode acts like a return followed by a call all in one. * When this op starts executing, the 'current' subr_entry that was * pushed onto the savestack by pp_subcall_profiler will be 'already_counted' * so the profiling of that call will be handled naturally for us. * So far so good. * Before it gets destroyed we'll take a copy of the subr_entry. * Then tell subr_entry_setup() to use our copy as a template so it'll * seem like the sub we goto'd was called by the same sub that called * the one that executed the goto. Except that we do use the fid:line * of the goto statement. That way the call graph makes sense and the * 'calling location' make sense. Got all that? */ /* save a copy of prev_cop - see t/test18-goto2.p */ COP prev_cop_copy = *prev_cop; /* save a copy of the subr_entry of the sub we're goto'ing out of */ /* so we can reuse the caller _* info after it's destroyed */ subr_entry_t goto_subr_entry; subr_entry_t *src = subr_entry_ix_ptr(subr_entry_ix); Copy(src, &goto_subr_entry, 1, subr_entry_t); /* XXX if the goto op or goto'd xsub croaks then this'll leak */ /* we can't mortalize here because we're about to leave scope */ (void)SvREFCNT_inc(goto_subr_entry.caller_subnam_sv); (void)SvREFCNT_inc(goto_subr_entry.called_subnam_sv); (void)SvREFCNT_inc(sub_sv); /* grab the CvSTART of the called sub since it's available */ called_cv = (CV*)SvRV(sub_sv); /* if goto &sub then op will be the first op of the called sub * if goto &xsub then op will be the first op after the call to the * op we're goto'ing out of. */ SETERRNO(saved_errno, 0); op = run_original_op(op_type); /* perform the goto &sub */ saved_errno = errno; /* now we're in goto'd sub, mortalize the REFCNT_inc's done above */ sv_2mortal(goto_subr_entry.caller_subnam_sv); sv_2mortal(goto_subr_entry.called_subnam_sv); this_subr_entry_ix = subr_entry_setup(aTHX_ &prev_cop_copy, &goto_subr_entry, op_type, sub_sv); SvREFCNT_dec(sub_sv); } subr_entry = subr_entry_ix_ptr(this_subr_entry_ix); /* detect wierdness/corruption */ assert(subr_entry); assert(subr_entry->caller_fid < fidhash.next_id); /* Check if this call has already been counted because the op performed * a leave_scope(). E.g., OP_SUBSTCONT at end of s/.../\1/ * or Scope::Upper's unwind() */ if (subr_entry->already_counted) { if (trace_level >= 9) logwarn("%2u -- %s::%s already counted %s\n", (unsigned int)subr_entry->subr_prof_depth, subr_entry->called_subpkg_pv, (subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv)) ? SvPV_nolen(subr_entry->called_subnam_sv) : "?", subr_entry_summary(aTHX_ subr_entry, 1)); assert(subr_entry->already_counted < 3); goto skip_sub_profile; } if (is_slowop) { /* already fully handled by subr_entry_setup */ } else { char *stash_name = NULL; const char *is_xs = NULL; if (op_type == OP_GOTO) { /* use the called_cv that was the arg to the goto op */ is_xs = (CvISXSUB(called_cv)) ? "xsub" : NULL; } else if (op != next_op) { /* have entered a sub */ /* use cv of sub we've just entered to get name */ called_cv = cxstack[cxstack_ix].blk_sub.cv; is_xs = NULL; } else { /* have returned from XS so use sub_sv for name */ /* determine the original fully qualified name for sub */ /* CV or NULL */ GV *gv = NULL; called_cv = resolve_sub_to_cv(aTHX_ sub_sv, &gv); if (!called_cv && gv) { /* XXX no test case for this */ stash_name = HvNAME(GvSTASH(gv)); sv_setpv(subr_entry->called_subnam_sv, GvNAME(gv)); if (trace_level >= 0) logwarn("Assuming called sub is named %s::%s at %s line %d (please report as a bug)\n", stash_name, SvPV_nolen(subr_entry->called_subnam_sv), OutCopFILE(prev_cop), (int)CopLINE(prev_cop)); } is_xs = "xsub"; } if (called_cv && CvGV(called_cv)) { GV *gv = CvGV(called_cv); /* Class::MOP can create CvGV where SvTYPE of GV is SVt_NULL */ if (SvTYPE(gv) == SVt_PVGV && GvSTASH(gv)) { /* for a plain call of an imported sub the GV is of the current * package, so we dig to find the original package */ stash_name = HvNAME(GvSTASH(gv)); sv_setpv(subr_entry->called_subnam_sv, GvNAME(gv)); } else if (trace_level >= 1) { logwarn("NYTProf is confused about CV %p called as %s at %s line %d (please report as a bug)\n", (void*)called_cv, SvPV_nolen(sub_sv), OutCopFILE(prev_cop), (int)CopLINE(prev_cop)); /* looks like Class::MOP doesn't give the CV GV stash a name */ if (trace_level >= 2) { sv_dump((SV*)called_cv); /* coredumps in Perl_do_gvgv_dump, looks line GvXPVGV is false, presumably on a Class::MOP wierdo sub */ sv_dump((SV*)gv); } } } /* called_subnam_sv should have been set by now - else we're getting desperate */ if (!SvOK(subr_entry->called_subnam_sv)) { const char *what = (is_xs) ? is_xs : "sub"; if (!called_cv) { /* should never get here as pp_entersub would have croaked */ logwarn("unknown entersub %s '%s' (please report this as a bug)\n", what, SvPV_nolen(sub_sv)); stash_name = CopSTASHPV(PL_curcop); sv_setpvf(subr_entry->called_subnam_sv, "__UNKNOWN__[%s,%s])", what, SvPV_nolen(sub_sv)); } else { /* unnamed CV, e.g. seen in mod_perl/Class::MOP. XXX do better? */ stash_name = HvNAME(CvSTASH(called_cv)); sv_setpvf(subr_entry->called_subnam_sv, "__UNKNOWN__[%s,0x%p]", what, (void*)called_cv); if (trace_level) logwarn("unknown entersub %s assumed to be anon called_cv '%s'\n", what, SvPV_nolen(sub_sv)); } if (trace_level >= 9) sv_dump(sub_sv); } subr_entry->called_subpkg_pv = stash_name; if (*SvPVX(subr_entry->called_subnam_sv) == 'B') append_linenum_to_begin(aTHX_ subr_entry); /* if called was xsub then we've already left it, so use depth+1 */ subr_entry->called_cv_depth = (called_cv) ? CvDEPTH(called_cv)+(is_xs?1:0) : 0; subr_entry->called_cv = called_cv; subr_entry->called_is_xs = is_xs; } /* ignore our own DB::_INIT sub - only shows up with 5.8.9+ & 5.10.1+ */ if (subr_entry->called_is_xs && subr_entry->called_subpkg_pv[0] == 'D' && subr_entry->called_subpkg_pv[1] == 'B' && subr_entry->called_subpkg_pv[2] == '\0' ) { STRLEN len; char *p = SvPV(subr_entry->called_subnam_sv, len); if(*p == '_' && (memEQs(p, len, "_CHECK") || memEQs(p, len, "_INIT") || memEQs(p, len, "_END"))) { subr_entry->already_counted++; goto skip_sub_profile; } } /* catch profile_subs being turned off by disable_profile call */ if (!profile_subs) subr_entry->already_counted++; if (trace_level >= 4) { logwarn("%2u ->%4s %s::%s from %s::%s @%u:%u (d%d, oh %"NVff"t, sub %"NVff"s) #%lu\n", (unsigned int)subr_entry->subr_prof_depth, (subr_entry->called_is_xs) ? subr_entry->called_is_xs : "sub", subr_entry->called_subpkg_pv, subr_entry->called_subnam_sv ? SvPV_nolen(subr_entry->called_subnam_sv) : "(null)", subr_entry->caller_subpkg_pv, subr_entry->caller_subnam_sv ? SvPV_nolen(subr_entry->caller_subnam_sv) : "(null)", subr_entry->caller_fid, subr_entry->caller_line, subr_entry->called_cv_depth, subr_entry->initial_overhead_ticks, subr_entry->initial_subr_ticks / ticks_per_sec, subr_entry->subr_call_seqn ); } if (subr_entry->called_is_xs) { /* for xsubs/builtins we've already left the sub, so end the timing now * rather than wait for the calling scope to get cleaned up. */ incr_sub_inclusive_time(aTHX_ subr_entry); } else { /* push a destructor hook onto the context stack to ensure we account * for time in the sub when we leave it, even if via an exception. */ save_destructor_x(incr_sub_inclusive_time_ix, INT2PTR(void *, (IV)this_subr_entry_ix)); } skip_sub_profile: SETERRNO(saved_errno, 0); return op; } static OP * pp_stmt_profiler(pTHX) /* handles OP_DBSTATE, OP_SETSTATE, etc */ { OP *op = run_original_op(PL_op->op_type); DB_stmt(aTHX_ NULL, op); return op; } static OP * pp_leave_profiler(pTHX) /* handles OP_LEAVESUB, OP_LEAVEEVAL, etc */ { OP *prev_op = PL_op; OP *op = run_original_op(PL_op->op_type); DB_leave(aTHX_ op, prev_op); return op; } static OP * pp_fork_profiler(pTHX) /* handles OP_FORK */ { OP *op = run_original_op(PL_op->op_type); reinit_if_forked(aTHX); return op; } static OP * pp_exit_profiler(pTHX) /* handles OP_EXIT, OP_EXEC, etc */ { DB_leave(aTHX_ NULL, PL_op); /* call DB_leave *before* run_original_op() */ if (PL_op->op_type == OP_EXEC) finish_profile(aTHX); /* this is the last chance we'll get */ return run_original_op(PL_op->op_type); } static int enable_profile(pTHX_ char *file) { /* enable the run-time aspects to profiling */ int prev_is_profiling = is_profiling; #ifdef MULTIPLICITY if (orig_my_perl && my_perl != orig_my_perl) { if (trace_level) logwarn("~ enable_profile call from different interpreter ignored\n"); return 0; } #endif if (profile_usecputime) { warn("The NYTProf usecputime option has been removed (try using clock=N if possible)"); return 0; } if (trace_level) logwarn("~ enable_profile (previously %s) to %s\n", prev_is_profiling ? "enabled" : "disabled", (file && *file) ? file : PROF_output_file); reinit_if_forked(aTHX); if (file && *file && strNE(file, PROF_output_file)) { /* caller wants output to go to a new file */ close_output_file(aTHX); strncpy(PROF_output_file, file, sizeof(PROF_output_file)-1); } if (!out) { open_output_file(aTHX_ PROF_output_file); } last_executed_fileptr = NULL; /* discard cached OutCopFILE */ is_profiling = 1; /* enable NYTProf profilers */ if (opt_use_db_sub) /* set PL_DBsingle if required */ sv_setiv(PL_DBsingle, 1); /* discard time spent since profiler was disabled */ get_time_of_day(start_time); return prev_is_profiling; } static int disable_profile(pTHX) { int prev_is_profiling = is_profiling; #ifdef MULTIPLICITY if (orig_my_perl && my_perl != orig_my_perl) { if (trace_level) logwarn("~ disable_profile call from different interpreter ignored\n"); return 0; } #endif if (is_profiling) { if (opt_use_db_sub) sv_setiv(PL_DBsingle, 0); if (out) NYTP_flush(out); is_profiling = 0; } if (trace_level) logwarn("~ disable_profile (previously %s, pid %d, trace %"IVdf")\n", prev_is_profiling ? "enabled" : "disabled", getpid(), trace_level); return prev_is_profiling; } static void finish_profile(pTHX) { /* can be called after the perl interp is destroyed, via libcexit */ int saved_errno = errno; #ifdef MULTIPLICITY if (orig_my_perl && my_perl != orig_my_perl) if (trace_level) { logwarn("~ finish_profile call from different interpreter ignored\n"); return; } #endif if (trace_level >= 1) logwarn("~ finish_profile (overhead %"NVgf"t, is_profiling %d)\n", cumulative_overhead_ticks, is_profiling); /* write data for final statement, unless DB_leave has already */ if (!profile_leave || opt_use_db_sub) DB_stmt(aTHX_ NULL, NULL); disable_profile(aTHX); close_output_file(aTHX); if (trace_level >= 2) { hash_stats(&fidhash, 0); hash_stats(&strhash, 0); } /* reset sub profiler data */ if (HvKEYS(sub_callers_hv)) { /* HvKEYS check avoids hv_clear() if interp has been destroyed RT#86548 */ hv_clear(sub_callers_hv); } /* reset other state */ cumulative_overhead_ticks = 0; cumulative_subr_ticks = 0; SETERRNO(saved_errno, 0); } static void finish_profile_nocontext() { /* can be called after the perl interp is destroyed, via libcexit */ dTHX; finish_profile(aTHX); } static void _init_profiler_clock(pTHX) { #ifdef HAS_CLOCK_GETTIME if (profile_clock == -1) { /* auto select */ # ifdef CLOCK_MONOTONIC profile_clock = CLOCK_MONOTONIC; # else profile_clock = CLOCK_REALTIME; # endif } /* downgrade to CLOCK_REALTIME if desired clock not available */ if (clock_gettime(profile_clock, &start_time) != 0) { if (trace_level) logwarn("~ clock_gettime clock %ld not available (%s) using CLOCK_REALTIME instead\n", (long)profile_clock, strerror(errno)); profile_clock = CLOCK_REALTIME; /* check CLOCK_REALTIME as well, just in case */ if (clock_gettime(profile_clock, &start_time) != 0) croak("clock_gettime CLOCK_REALTIME not available (%s), aborting", strerror(errno)); } #else if (profile_clock != -1) { /* user tried to select different clock */ logwarn("clock %ld not available (clock_gettime not supported on this system)\n", (long)profile_clock); profile_clock = -1; } #endif #ifdef HAS_QPC { const char * fnname; if(!QueryPerformanceFrequency((LARGE_INTEGER *)&time_frequency)) { fnname = "QueryPerformanceFrequency"; goto win32_failed; } { LARGE_INTEGER tmp; /* do 1 test call, dont check return value for further calls for performance reasons */ if(!QueryPerformanceCounter(&tmp)) { fnname = "QueryPerformanceCounter"; win32_failed: croak("%s failed with Win32 error %u, no clocks available", fnname, GetLastError()); } } } #endif ticks_per_sec = TICKS_PER_SEC; } /* Initial setup - should only be called once */ static int init_profiler(pTHX) { #ifndef HAS_GETTIMEOFDAY SV **svp; #endif #ifdef MULTIPLICITY if (!orig_my_perl) { if (1) orig_my_perl = my_perl; } else if (orig_my_perl && orig_my_perl != my_perl) { logwarn("NYTProf: perl interpreter address changed after init (threads/multiplicity not supported)\n"); return 0; } #endif /* Save the process id early. We monitor it to detect forks */ last_pid = getpid(); DB_CHECK_cv = (SV*)GvCV(gv_fetchpv("DB::_CHECK", FALSE, SVt_PVCV)); DB_INIT_cv = (SV*)GvCV(gv_fetchpv("DB::_INIT", FALSE, SVt_PVCV)); DB_END_cv = (SV*)GvCV(gv_fetchpv("DB::_END", FALSE, SVt_PVCV)); DB_fin_cv = (SV*)GvCV(gv_fetchpv("DB::finish_profile", FALSE, SVt_PVCV)); if (opt_use_db_sub) { PL_perldb |= PERLDBf_LINE; /* line-by-line profiling via DB::DB (if $DB::single true) */ PL_perldb |= PERLDBf_SINGLE; /* start (after BEGINs) with single-step on XXX still needed? */ } if (profile_opts & NYTP_OPTf_OPTIMIZE) PL_perldb &= ~PERLDBf_NOOPT; else PL_perldb |= PERLDBf_NOOPT; if (profile_opts & NYTP_OPTf_SAVESRC) { /* ask perl to keep the source lines so we can copy them */ PL_perldb |= PERLDBf_SAVESRC | PERLDBf_SAVESRC_NOSUBS; } if (!opt_nameevals) PL_perldb &= PERLDBf_NAMEEVAL; if (!opt_nameanonsubs) PL_perldb &= PERLDBf_NAMEANON; if (opt_perldb) /* force a PL_perldb value - for testing only, not documented */ PL_perldb = opt_perldb; _init_profiler_clock(aTHX); if (trace_level) logwarn("~ init_profiler for pid %d, clock %ld, tps %d, start %d, perldb 0x%lx, exitf 0x%lx\n", last_pid, (long)profile_clock, ticks_per_sec, profile_start, (long unsigned)PL_perldb, (long unsigned)PL_exit_flags); if (get_hv("DB::sub", 0) == NULL) { logwarn("NYTProf internal error - perl not in debug mode\n"); return 0; } #ifdef WANT_TIME_HIRES require_pv("Time/HiRes.pm"); /* before opcode redirection */ svp = hv_fetch(PL_modglobal, "Time::U2time", 12, 0); if (!svp || !SvIOK(*svp)) croak("Time::HiRes is required"); time_hires_u2time_hook = INT2PTR(int(*)(pTHX_ UV*), SvIV(*svp)); if (trace_level || !time_hires_u2time_hook) logwarn("NYTProf using Time::HiRes %p\n", time_hires_u2time_hook); #endif /* create file id mapping hash */ fidhash.table = (Hash_entry**)safemalloc(sizeof(Hash_entry*) * fidhash.size); memset(fidhash.table, 0, sizeof(Hash_entry*) * fidhash.size); /* redirect opcodes for statement profiling */ Newxc(PL_ppaddr_orig, OP_max, void *, orig_ppaddr_t); Copy(PL_ppaddr, PL_ppaddr_orig, OP_max, void *); if (profile_stmts && !opt_use_db_sub) { PL_ppaddr[OP_NEXTSTATE] = pp_stmt_profiler; PL_ppaddr[OP_DBSTATE] = pp_stmt_profiler; #ifdef OP_SETSTATE PL_ppaddr[OP_SETSTATE] = pp_stmt_profiler; #endif if (profile_leave) { PL_ppaddr[OP_LEAVESUB] = pp_leave_profiler; PL_ppaddr[OP_LEAVESUBLV] = pp_leave_profiler; PL_ppaddr[OP_LEAVE] = pp_leave_profiler; PL_ppaddr[OP_LEAVELOOP] = pp_leave_profiler; PL_ppaddr[OP_LEAVEWRITE] = pp_leave_profiler; PL_ppaddr[OP_LEAVEEVAL] = pp_leave_profiler; PL_ppaddr[OP_LEAVETRY] = pp_leave_profiler; PL_ppaddr[OP_RETURN] = pp_leave_profiler; /* natural end of simple loop */ PL_ppaddr[OP_UNSTACK] = pp_leave_profiler; /* OP_NEXT is missing because that jumps to OP_UNSTACK */ /* OP_EXIT and OP_EXEC need special handling */ PL_ppaddr[OP_EXIT] = pp_exit_profiler; PL_ppaddr[OP_EXEC] = pp_exit_profiler; } } /* calls reinit_if_forked() asap after a fork */ PL_ppaddr[OP_FORK] = pp_fork_profiler; if (profile_slowops) { /* XXX this should turn into a loop over an array that maps * opcodes to the subname we'll use: OP_PRTF => "printf" */ #include "slowops.h" } /* redirect opcodes for caller tracking */ if (!sub_callers_hv) sub_callers_hv = newHV(); if (!pkg_fids_hv) pkg_fids_hv = newHV(); PL_ppaddr[OP_ENTERSUB] = pp_entersub_profiler; PL_ppaddr[OP_GOTO] = pp_entersub_profiler; if (!PL_checkav) PL_checkav = newAV(); if (!PL_initav) PL_initav = newAV(); if (!PL_endav) PL_endav = newAV(); /* pre-extend PL_endav to reduce the chance of DB::_END realloc'ing * it while END blocks are executed (which could upset some embedded * applications that don't handle PL_endav carefully, like mod_perl) */ av_extend(PL_endav, av_len(PL_endav)+30); if (profile_start == NYTP_START_BEGIN) { enable_profile(aTHX_ NULL); } else { /* handled by _INIT */ av_push(PL_initav, SvREFCNT_inc(get_cv("DB::_INIT", GV_ADDWARN))); } if (PL_minus_c) { av_push(PL_checkav, SvREFCNT_inc(get_cv("DB::_CHECK", GV_ADDWARN))); } else { av_push(PL_endav, SvREFCNT_inc(get_cv("DB::_END", GV_ADDWARN))); } /* seed first run time */ get_time_of_day(start_time); if (trace_level >= 1) logwarn("~ init_profiler done\n"); return 1; } /************************************ * Devel::NYTProf::Reader Functions * ************************************/ static void add_entry(pTHX_ AV *dest_av, unsigned int file_num, unsigned int line_num, NV time, unsigned int eval_file_num, unsigned int eval_line_num, int count) { /* get ref to array of per-line data */ unsigned int fid = (eval_line_num) ? eval_file_num : file_num; SV *line_time_rvav = *av_fetch(dest_av, fid, 1); if (!SvROK(line_time_rvav)) /* autoviv */ sv_setsv(line_time_rvav, newRV_noinc((SV*)newAV())); store_profile_line_entry(aTHX_ line_time_rvav, line_num, time, count, fid); } static AV * store_profile_line_entry(pTHX_ SV *rvav, unsigned int line_num, NV time, int count, unsigned int fid) { SV *time_rvav = *av_fetch((AV*)SvRV(rvav), line_num, 1); AV *line_av; if (!SvROK(time_rvav)) { /* autoviv */ line_av = newAV(); sv_setsv(time_rvav, newRV_noinc((SV*)line_av)); av_store(line_av, 0, newSVnv(time)); av_store(line_av, 1, newSViv(count)); /* if eval then 2 is used for lines within the string eval */ if (embed_fid_line) { /* used to optimize reporting */ av_store(line_av, 3, newSVuv(fid)); av_store(line_av, 4, newSVuv(line_num)); } } else { SV *time_sv; line_av = (AV*)SvRV(time_rvav); time_sv = *av_fetch(line_av, 0, 1); sv_setnv(time_sv, time + SvNV(time_sv)); if (count) { SV *sv = *av_fetch(line_av, 1, 1); (count == 1) ? sv_inc(sv) : sv_setiv(sv, (IV)time + SvIV(sv)); } } return line_av; } /* Given a fully-qualified name, return the length of the package name. * As most callers get len via the hash API, they will have an I32, where * "negative" length signifies UTF-8. As we're only dealing with looking for * ASCII here, it doesn't matter to use which encoding sub_name is in, but it * reduces total code by doing the abs(len) in here. */ static STRLEN pkg_name_len(pTHX_ char *sub_name, I32 len) { /* pTHX_ needed for old rninstr in old perl versions */ const char *delim = "::"; /* find end of package name */ char *colon = rninstr(sub_name, sub_name+(len > 0 ? len : -len), delim, delim+2); if (!colon || colon == sub_name) return 0; /* no :: delimiter */ return (colon - sub_name); } /* Given a fully-qualified sub_name lookup the package name portion in * the pkg_fids_hv hash. Return Nullsv if there's no package name or no * correponding entry, else returns the SV. * * About pkg_fids_hv: * pp_subcall_profiler() creates undef entries for a package * name the first time a sub in the package is called. * write_sub_line_ranges() updates the SV with the filename associated * with the package, or at least its best guess. */ static SV * sub_pkg_filename_sv(pTHX_ char *sub_name, I32 len) { SV **svp; STRLEN pkg_len = pkg_name_len(aTHX_ sub_name, len); if (!pkg_len) return Nullsv; /* no :: delimiter */ svp = hv_fetch(pkg_fids_hv, sub_name, (I32)pkg_len, 0); if (!svp) return Nullsv; /* not a package we've profiled sub calls into */ return *svp; } static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name) { /* "filename:first-last" */ char *filename = SvPV_nolen(sv); char *first = strrchr(filename, ':'); /* find last colon */ char *last; int first_is_neg = 0; if (first && filename_len_p) *filename_len_p = first - filename; if (!first++) /* start of first number, if colon was found */ return 0; if ('-' == *first) { /* first number is negative */ ++first; first_is_neg = 1; } last = strchr(first, '-'); /* find separator dash */ if (!last || !grok_number(first, last-first, first_line_p)) return 0; if (first_is_neg) { warn("Negative first line number in %%DB::sub entry '%s' for %s\n", filename, sub_name); *first_line_p = 0; } if ('-' == *++last) { /* skip past dash, is next char a minus? */ warn("Negative last line number in %%DB::sub entry '%s' for %s\n", filename, sub_name); last = (char *)"0"; } if (last_line_p) *last_line_p = atoi(last); return 1; } static void write_sub_line_ranges(pTHX) { char *sub_name; I32 sub_name_len; SV *file_lines_sv; HV *hv = GvHV(PL_DBsub); unsigned int fid; if (trace_level >= 1) logwarn("~ writing sub line ranges - prescan\n"); /* Skim through PL_DBsub hash to build a package to filename hash * by associating the package part of the sub_name in the key * with the filename part of the value. * but only for packages we already know we're interested in */ hv_iterinit(hv); while (NULL != (file_lines_sv = hv_iternextsv(hv, &sub_name, &sub_name_len))) { STRLEN file_lines_len; char *filename = SvPV(file_lines_sv, file_lines_len); char *first; STRLEN filename_len; SV *pkg_filename_sv; /* This is a heuristic, and might not be robust, but it seems that it's possible to get problematically bogus entries in this hash. Specifically, setting the 'lvalue' attribute on an XS subroutine during a bootstrap can cause op.c to load attributes, and in turn cause a DynaLoader::BEGIN entry in %DB::sub associated with the .pm file of the XS sub's module, not DynaLoader. This has the result that if we try to associate XSUBs with filenames using %DB::sub, we can go very wrong. Fortunately all "wrong" entries so far spotted have a line range with a non-zero start, and a zero end. This cannot be legal, so we ignore those. */ if (file_lines_len > 4 && filename[file_lines_len - 2] == '-' && filename[file_lines_len - 1] == '0' && filename[file_lines_len - 4] != ':' && filename[file_lines_len - 3] != '0') continue; /* ignore filenames from %DB::sub that match /:[^0]-0$/ */ first = strrchr(filename, ':'); filename_len = (first) ? first - filename : 0; /* get sv for package-of-subname to filename mapping */ pkg_filename_sv = sub_pkg_filename_sv(aTHX_ sub_name, sub_name_len); if (!pkg_filename_sv) /* we don't know package */ continue; /* already got a cached filename for this package XXX should allow multiple */ if (SvOK(pkg_filename_sv)) { STRLEN cached_len; char *cached_filename = SvPV(pkg_filename_sv, cached_len); /* * if the cached filename is an eval and the current one isn't * then we should cache the current one instead */ if (filename_len > 0 && filename_is_eval(cached_filename, cached_len) && !filename_is_eval(filename, filename_len) ) { if (trace_level >= 3) logwarn("Package '%.*s' (of sub %.*s) association promoted from '%.*s' to '%.*s'\n", (int)pkg_name_len(aTHX_ sub_name, sub_name_len), sub_name, (int)sub_name_len, sub_name, (int)cached_len, cached_filename, (int)filename_len, filename); sv_setpvn(pkg_filename_sv, filename, filename_len); continue; } if (trace_level >= 3 && strnNE(SvPV_nolen(pkg_filename_sv), filename, filename_len) && !filename_is_eval(filename, filename_len) ) { /* eg utf8::SWASHNEW is already associated with .../utf8.pm not .../utf8_heavy.pl */ logwarn("Package '%.*s' (of sub %.*s) not associated with '%.*s' because already associated with '%s'\n", (int)pkg_name_len(aTHX_ sub_name, sub_name_len), sub_name, (int)sub_name_len, sub_name, (int)filename_len, filename, SvPV_nolen(pkg_filename_sv) ); } continue; } /* ignore if filename is empty (eg xs) */ if (!filename_len) { if (trace_level >= 3) logwarn("Sub %.*s has no filename associated (%s)\n", (int)sub_name_len, sub_name, filename); continue; } /* associate the filename with the package */ sv_setpvn(pkg_filename_sv, filename, filename_len); /* ensure a fid is assigned since we don't allow it below */ fid = get_file_id(aTHX_ filename, filename_len, NYTP_FIDf_VIA_SUB); if (trace_level >= 3) logwarn("Associating package of %s with %.*s (fid %d)\n", sub_name, (int)filename_len, filename, fid ); } if (main_runtime_used) { /* Create fake entry for main::RUNTIME sub */ char runtime[] = "main::RUNTIME"; const I32 runtime_len = sizeof(runtime) - 1; SV *sv = *hv_fetch(hv, runtime, runtime_len, 1); /* get name of file that contained first profiled sub in 'main::' */ SV *pkg_filename_sv = sub_pkg_filename_sv(aTHX_ runtime, runtime_len); if (!pkg_filename_sv) { /* no subs in main, so guess */ sv_setpvn(sv, fidhash.first_inserted->key, fidhash.first_inserted->key_len); } else if (SvOK(pkg_filename_sv)) { sv_setsv(sv, pkg_filename_sv); } else { sv_setpvn(sv, "", 0); } sv_catpvs(sv, ":1-1"); } if (trace_level >= 1) logwarn("~ writing sub line ranges of %ld subs\n", (long)HvKEYS(hv)); /* Iterate over PL_DBsub writing out fid and source line range of subs. * If filename is missing (i.e., because it's an xsub so has no source file) * then use the filename of another sub in the same package. */ while (NULL != (file_lines_sv = hv_iternextsv(hv, &sub_name, &sub_name_len))) { /* "filename:first-last" */ char *filename = SvPV_nolen(file_lines_sv); STRLEN filename_len; UV first_line, last_line; if (!parse_DBsub_value(aTHX_ file_lines_sv, &filename_len, &first_line, &last_line, sub_name)) { logwarn("Can't parse %%DB::sub entry for %s '%s'\n", sub_name, filename); continue; } if (!filename_len) { /* no filename, so presumably a fake entry for xsub */ /* do we know a filename that contains subs in the same package */ SV *pkg_filename_sv = sub_pkg_filename_sv(aTHX_ sub_name, sub_name_len); if (pkg_filename_sv && SvOK(pkg_filename_sv)) { filename = SvPV(pkg_filename_sv, filename_len); if (trace_level >= 2) logwarn("Sub %s is xsub, we'll associate it with filename %.*s\n", sub_name, (int)filename_len, filename); } } fid = get_file_id(aTHX_ filename, filename_len, 0); if (!fid) { if (trace_level >= 4) logwarn("Sub %s has no fid assigned (for file '%.*s')\n", sub_name, (int)filename_len, filename); continue; /* no point in writing subs in files we've not profiled */ } if (trace_level >= 2) logwarn("Sub %s fid %u lines %lu..%lu\n", sub_name, fid, (unsigned long)first_line, (unsigned long)last_line); NYTP_write_sub_info(out, fid, sub_name, sub_name_len, (unsigned long)first_line, (unsigned long)last_line); } } static void write_sub_callers(pTHX) { char *called_subname; I32 called_subname_len; SV *fid_line_rvhv; int negative_time_calls = 0; if (!sub_callers_hv) return; if (trace_level >= 1) logwarn("~ writing sub callers for %ld subs\n", (long)HvKEYS(sub_callers_hv)); hv_iterinit(sub_callers_hv); while (NULL != (fid_line_rvhv = hv_iternextsv(sub_callers_hv, &called_subname, &called_subname_len))) { HV *fid_lines_hv; char *caller_subname; I32 caller_subname_len; SV *sv; if (!SvROK(fid_line_rvhv) || SvTYPE(SvRV(fid_line_rvhv))!=SVt_PVHV) { logwarn("bad entry %s in sub_callers_hv\n", called_subname); continue; } fid_lines_hv = (HV*)SvRV(fid_line_rvhv); if (0) { logwarn("Callers of %s:\n", called_subname); /* level, *file, *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim */ do_sv_dump(0, Perl_debug_log, fid_line_rvhv, 0, 5, 0, 100); } /* iterate over callers to this sub ({ "subname[fid:line]" => [ ... ] }) */ hv_iterinit(fid_lines_hv); while (NULL != (sv = hv_iternextsv(fid_lines_hv, &caller_subname, &caller_subname_len))) { NV sc[NYTP_SCi_elements]; AV *av = (AV *)SvRV(sv); int trace = (trace_level >= 3); UV count; UV depth; unsigned int fid = 0, line = 0; const char *fid_line_delim = "["; char *fid_line_start = rninstr(caller_subname, caller_subname+caller_subname_len, fid_line_delim, fid_line_delim+1); if (!fid_line_start) { logwarn("bad fid_lines_hv key '%s'\n", caller_subname); continue; } if (2 != sscanf(fid_line_start+1, "%u:%u", &fid, &line)) { logwarn("bad fid_lines_hv format '%s'\n", caller_subname); continue; } /* trim length to effectively hide the [fid:line] suffix */ caller_subname_len = (I32)(fid_line_start-caller_subname); /* catch negative line numbers that have been stored unsigned */ if (line > 2147483600) { /* ~2**31 */ logwarn("%s called by %.*s at fid %u line %u - crazy line number changed to 0\n", called_subname, (int)caller_subname_len, caller_subname, fid, line); line = 0; } count = uv_from_av(aTHX_ av, NYTP_SCi_CALL_COUNT, 0); sc[NYTP_SCi_CALL_COUNT] = count * 1.0; sc[NYTP_SCi_INCL_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_INCL_TICKS, 0.0) / ticks_per_sec; sc[NYTP_SCi_EXCL_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_EXCL_TICKS, 0.0) / ticks_per_sec; sc[NYTP_SCi_RECI_RTIME] = nv_from_av(aTHX_ av, NYTP_SCi_RECI_RTIME, 0.0); depth = uv_from_av(aTHX_ av, NYTP_SCi_REC_DEPTH , 0); sc[NYTP_SCi_REC_DEPTH] = depth * 1.0; NYTP_write_sub_callers(out, fid, line, caller_subname, caller_subname_len, (unsigned int)count, sc[NYTP_SCi_INCL_RTIME], sc[NYTP_SCi_EXCL_RTIME], sc[NYTP_SCi_RECI_RTIME], (unsigned int)depth, called_subname, called_subname_len); /* sanity check - early warning */ if (sc[NYTP_SCi_INCL_RTIME] < 0.0 || sc[NYTP_SCi_EXCL_RTIME] < 0.0) { ++negative_time_calls; if (trace_level) { logwarn("%s call has negative time: incl %"NVff"s, excl %"NVff"s:\n", called_subname, sc[NYTP_SCi_INCL_RTIME], sc[NYTP_SCi_EXCL_RTIME]); trace = 1; } } if (trace) { if (!fid && !line) { logwarn("%s is xsub\n", called_subname); } else { logwarn("%s called by %.*s at %u:%u: count %ld (i%"NVff"s e%"NVff"s, d%d ri%"NVff"s)\n", called_subname, (int)caller_subname_len, caller_subname, fid, line, (long)sc[NYTP_SCi_CALL_COUNT], sc[NYTP_SCi_INCL_RTIME], sc[NYTP_SCi_EXCL_RTIME], (int)sc[NYTP_SCi_REC_DEPTH], sc[NYTP_SCi_RECI_RTIME]); } } } } if (negative_time_calls) { logwarn("Warning: %d subroutine calls had negative time! See TROUBLESHOOTING in the NYTProf documentation. (Clock %ld)\n", negative_time_calls, (long)profile_clock); } } static void write_src_of_files(pTHX) { fid_hash_entry *e; int t_has_src = 0; int t_save_src = 0; int t_no_src = 0; long t_lines = 0; if (trace_level >= 1) logwarn("~ writing file source code\n"); for (e = (fid_hash_entry*)fidhash.first_inserted; e; e = (fid_hash_entry*)e->he.next_inserted) { I32 lines; int line; AV *src_av = GvAV(gv_fetchfile_flags(e->he.key, e->he.key_len, 0)); if ( !(e->fid_flags & NYTP_FIDf_HAS_SRC) ) { const char *hint = ""; ++t_no_src; if (src_av && av_len(src_av) > -1) /* sanity check */ hint = " (NYTP_FIDf_HAS_SRC not set but src available!)"; if (trace_level >= 3 || *hint) logwarn("fid %d has no src saved for %.*s%s\n", e->he.id, e->he.key_len, e->he.key, hint); continue; } if (!src_av) { /* sanity check */ ++t_no_src; logwarn("fid %d has no src but NYTP_FIDf_HAS_SRC is set! (%.*s)\n", e->he.id, e->he.key_len, e->he.key); continue; } ++t_has_src; if ( !(e->fid_flags & NYTP_FIDf_SAVE_SRC) ) { continue; } ++t_save_src; lines = av_len(src_av); /* -1 is empty, 1 is 1 line etc, 0 shouldn't happen */ if (trace_level >= 3) logwarn("fid %d has %ld src lines for %.*s\n", e->he.id, (long)lines, e->he.key_len, e->he.key); for (line = 1; line <= lines; ++line) { /* lines start at 1 */ SV **svp = av_fetch(src_av, line, 0); STRLEN len = 0; const char *src = (svp) ? SvPV(*svp, len) : ""; /* outputting the tag and fid for each (non empty) line * is a little inefficient, but not enough to worry about */ NYTP_write_src_line(out, e->he.id, line, src, (I32)len); /* includes newline */ if (trace_level >= 8) { logwarn("fid %d src line %d: %s%s", e->he.id, line, src, (len && src[len-1]=='\n') ? "" : "\n"); } ++t_lines; } } if (trace_level >= 2) logwarn("~ wrote %ld source lines for %d files (%d skipped without savesrc option, %d others had no source available)\n", t_lines, t_save_src, t_has_src-t_save_src, t_no_src); } static void normalize_eval_seqn(pTHX_ SV *sv) { /* in-place-edit any eval sequence numbers to 0 */ STRLEN len; char *start = SvPV(sv, len); char *first_space; return; /* disabled, again */ /* effectively does s/( \( # first character is literal ( (?:re_)?eval\ # eval or re_eval followed by space ) # [capture that] [0-9]+ # digits (?=\)) # look ahead for literal ) /$1 0/xg # and rebuild, replacing the digts with 0 */ /* Assumption is that space is the least common character in a filename. */ for (; len >= 8 && (first_space = (char *)memchr(start, ' ', len)); (len -= first_space +1 - start), (start = first_space + 1)) { char *first_digit; char *close; if (!((first_space - start >= 5 && memEQ(first_space - 5, "(eval", 5)) || (first_space - start >= 8 && memEQ(first_space - 8, "(re_eval", 8)))) { /* Fixed string not found. Try again. */ continue; } first_digit = first_space + 1; if (*first_digit < '0' || *first_digit > '9') continue; close = first_digit + 1; while (*close >= '0' && *close <= '9') ++close; if (*close != ')') continue; if (trace_level >= 15) logwarn("recognized eval in name at '%s' in %s\n", first_digit, start); *first_digit++ = '0'; /* first_digit now points to the target of the move. */ if (close != first_digit) { /* 2 or more digits */ memmove(first_digit, close, start + len + 1 /* pointer beyond the trailing '\0' */ - close); /* pointer to the ) */ len -= (close - first_digit); SvCUR_set(sv, SvCUR(sv) - (close - first_digit)); } if (trace_level >= 15) logwarn("edited it to: %s\n", start); } } static AV * lookup_subinfo_av(pTHX_ SV *subname_sv, HV *sub_subinfo_hv) { /* { 'pkg::sub' => [ * fid, first_line, last_line, incl_time * ], ... } */ HE *he = hv_fetch_ent(sub_subinfo_hv, subname_sv, 1, 0); SV *sv = HeVAL(he); if (!SvROK(sv)) { /* autoviv */ AV *av = newAV(); SV *rv = newRV_noinc((SV *)av); /* 0: fid - may be undef * 1: start_line - may be undef if not known and not known to be xs * 2: end_line - ditto * typically due to an xsub that was called but exited via an exception */ sv_setsv(*av_fetch(av, NYTP_SIi_SUB_NAME, 1), newSVsv(subname_sv)); sv_setuv(*av_fetch(av, NYTP_SIi_CALL_COUNT, 1), 0); /* call count */ sv_setnv(*av_fetch(av, NYTP_SIi_INCL_RTIME, 1), 0.0); /* incl_time */ sv_setnv(*av_fetch(av, NYTP_SIi_EXCL_RTIME, 1), 0.0); /* excl_time */ sv_setsv(*av_fetch(av, NYTP_SIi_PROFILE, 1), &PL_sv_undef); /* ref to profile */ sv_setuv(*av_fetch(av, NYTP_SIi_REC_DEPTH, 1), 0); /* rec_depth */ sv_setnv(*av_fetch(av, NYTP_SIi_RECI_RTIME, 1), 0.0); /* reci_time */ sv_setsv(sv, rv); } return (AV *)SvRV(sv); } static void store_attrib_sv(pTHX_ HV *attr_hv, const char *text, I32 text_len, SV *value_sv) { (void)hv_store(attr_hv, text, text_len, value_sv, 0); if (trace_level >= 1) logwarn(": %.*s = '%s'\n", (int) text_len, text, SvPV_nolen(value_sv)); } #if 0 /* not used at the moment */ static int eval_outer_fid(pTHX_ AV *fid_fileinfo_av, unsigned int fid, int recurse, unsigned int *eval_file_num_ptr, unsigned int *eval_line_num_ptr ) { unsigned int outer_fid; AV *av; SV *fid_info_rvav = *av_fetch(fid_fileinfo_av, fid, 1); if (!SvROK(fid_info_rvav)) /* should never happen */ return 0; av = (AV *)SvRV(fid_info_rvav); outer_fid = (unsigned int)SvUV(*av_fetch(av,NYTP_FIDi_EVAL_FID,1)); if (!outer_fid) return 0; if (outer_fid == fid) { logwarn("Possible corruption: eval_outer_fid of %d is %d!\n", fid, outer_fid); return 0; } if (eval_file_num_ptr) *eval_file_num_ptr = outer_fid; if (eval_line_num_ptr) *eval_line_num_ptr = (unsigned int)SvUV(*av_fetch(av,NYTP_FIDi_EVAL_LINE,1)); if (recurse) eval_outer_fid(aTHX_ fid_fileinfo_av, outer_fid, recurse, eval_file_num_ptr, eval_line_num_ptr); return 1; } #endif typedef struct loader_state_base { unsigned long input_chunk_seqn; } Loader_state_base; typedef void (*loader_callback)(Loader_state_base *cb_data, const nytp_tax_index tag, ...); typedef struct loader_state_callback { Loader_state_base base_state; #ifdef MULTIPLICITY PerlInterpreter *interp; #endif CV *cb[nytp_tag_max]; SV *cb_args[11]; /* must be large enough for the largest callback argument list */ SV *tag_names[nytp_tag_max]; SV *input_chunk_seqn_sv; } Loader_state_callback; typedef struct loader_state_profiler { Loader_state_base base_state; #ifdef MULTIPLICITY PerlInterpreter *interp; #endif unsigned int last_file_num; unsigned int last_line_num; int statement_discount; UV total_stmts_discounted; UV total_stmts_measured; NV total_stmts_duration; UV total_sub_calls; AV *fid_line_time_av; AV *fid_block_time_av; AV *fid_sub_time_av; AV *fid_srclines_av; AV *fid_fileinfo_av; HV *sub_subinfo_hv; HV *live_pids_hv; HV *attr_hv; HV *option_hv; HV *file_info_stash; /* these times don't reflect profile_enable & profile_disable calls */ NV profiler_start_time; NV profiler_end_time; NV profiler_duration; } Loader_state_profiler; static void load_discount_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; PERL_UNUSED_ARG(tag); if (trace_level >= 8) logwarn("discounting next statement after %u:%d\n", state->last_file_num, state->last_line_num); if (state->statement_discount) logwarn("multiple statement discount after %u:%d\n", state->last_file_num, state->last_line_num); ++state->statement_discount; ++state->total_stmts_discounted; } static void load_time_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; char trace_note[80] = ""; SV *fid_info_rvav; NV seconds; unsigned int eval_file_num = 0; unsigned int eval_line_num = 0; I32 ticks; unsigned int file_num; unsigned int line_num; va_start(args, tag); ticks = va_arg(args, I32); file_num = va_arg(args, unsigned int); line_num = va_arg(args, unsigned int); seconds = (NV)ticks / ticks_per_sec; fid_info_rvav = *av_fetch(state->fid_fileinfo_av, file_num, 1); if (!SvROK(fid_info_rvav)) { /* should never happen */ if (!SvOK(fid_info_rvav)) { /* only warn once */ logwarn("Fid %u used but not defined\n", file_num); sv_setsv(fid_info_rvav, &PL_sv_no); } } if (trace_level >= 8) { const char *new_file_name = ""; if (file_num != state->last_file_num && SvROK(fid_info_rvav)) new_file_name = SvPV_nolen(*av_fetch((AV *)SvRV(fid_info_rvav), NYTP_FIDi_FILENAME, 1)); logwarn("Read %d:%-4d %2ld ticks%s %s\n", file_num, line_num, (long)ticks, trace_note, new_file_name); } add_entry(aTHX_ state->fid_line_time_av, file_num, line_num, seconds, eval_file_num, eval_line_num, 1 - state->statement_discount ); if (tag == nytp_time_block) { unsigned int block_line_num = va_arg(args, unsigned int); unsigned int sub_line_num = va_arg(args, unsigned int); if (!state->fid_block_time_av) state->fid_block_time_av = newAV(); add_entry(aTHX_ state->fid_block_time_av, file_num, block_line_num, seconds, eval_file_num, eval_line_num, 1 - state->statement_discount ); if (!state->fid_sub_time_av) state->fid_sub_time_av = newAV(); add_entry(aTHX_ state->fid_sub_time_av, file_num, sub_line_num, seconds, eval_file_num, eval_line_num, 1 - state->statement_discount ); if (trace_level >= 8) logwarn("\tblock %u, sub %u\n", block_line_num, sub_line_num); } va_end(args); state->total_stmts_measured++; state->total_stmts_duration += seconds; state->statement_discount = 0; state->last_file_num = file_num; state->last_line_num = line_num; } static void load_new_fid_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; AV *av; SV *rv; SV **svp; SV *filename_sv; unsigned int file_num; unsigned int eval_file_num; unsigned int eval_line_num; unsigned int fid_flags; unsigned int file_size; unsigned int file_mtime; va_start(args, tag); file_num = va_arg(args, unsigned int); eval_file_num = va_arg(args, unsigned int); eval_line_num = va_arg(args, unsigned int); fid_flags = va_arg(args, unsigned int); file_size = va_arg(args, unsigned int); file_mtime = va_arg(args, unsigned int); filename_sv = va_arg(args, SV *); va_end(args); if (trace_level >= 2) { char buf[80]; char parent_fid[80]; if (eval_file_num || eval_line_num) sprintf(parent_fid, " (is eval at %u:%u)", eval_file_num, eval_line_num); else sprintf(parent_fid, " (file sz%d mt%d)", file_size, file_mtime); logwarn("Fid %2u is %s%s 0x%x(%s)\n", file_num, SvPV_nolen(filename_sv), parent_fid, fid_flags, fmt_fid_flags(aTHX_ fid_flags, buf, sizeof(buf))); } /* [ name, eval_file_num, eval_line_num, fid, flags, size, mtime, ... ] */ av = newAV(); rv = newRV_noinc((SV*)av); sv_bless(rv, state->file_info_stash); svp = av_fetch(state->fid_fileinfo_av, file_num, 1); if (SvOK(*svp)) { /* should never happen, perhaps file is corrupt */ AV *old_av = (AV *)SvRV(*av_fetch(state->fid_fileinfo_av, file_num, 1)); SV *old_name = *av_fetch(old_av, 0, 1); logwarn("Fid %d redefined from %s to %s\n", file_num, SvPV_nolen(old_name), SvPV_nolen(filename_sv)); } sv_setsv(*svp, rv); av_store(av, NYTP_FIDi_FILENAME, filename_sv); /* av now owns the sv */ if (eval_file_num) { SV *has_evals; /* this eval fid refers to the fid that contained the eval */ SV *eval_fi = *av_fetch(state->fid_fileinfo_av, eval_file_num, 1); if (!SvROK(eval_fi)) { /* should never happen */ char buf[80]; logwarn("Eval '%s' (fid %d, flags:%s) has unknown invoking fid %d\n", SvPV_nolen(filename_sv), file_num, fmt_fid_flags(aTHX_ fid_flags, buf, sizeof(buf)), eval_file_num); /* so make it look like a real file instead of an eval */ av_store(av, NYTP_FIDi_EVAL_FI, NULL); eval_file_num = 0; eval_line_num = 0; } else { av_store(av, NYTP_FIDi_EVAL_FI, sv_rvweaken(newSVsv(eval_fi))); /* the fid that contained the eval has a list of eval fids */ has_evals = *av_fetch((AV *)SvRV(eval_fi), NYTP_FIDi_HAS_EVALS, 1); if (!SvROK(has_evals)) /* autoviv */ sv_setsv(has_evals, newRV_noinc((SV*)newAV())); av_push((AV *)SvRV(has_evals), sv_rvweaken(newSVsv(rv))); } } else { av_store(av, NYTP_FIDi_EVAL_FI, NULL); } av_store(av, NYTP_FIDi_EVAL_FID, (eval_file_num) ? newSVuv(eval_file_num) : &PL_sv_no); av_store(av, NYTP_FIDi_EVAL_LINE, (eval_file_num) ? newSVuv(eval_line_num) : &PL_sv_no); av_store(av, NYTP_FIDi_FID, newSVuv(file_num)); av_store(av, NYTP_FIDi_FLAGS, newSVuv(fid_flags)); av_store(av, NYTP_FIDi_FILESIZE, newSVuv(file_size)); av_store(av, NYTP_FIDi_FILEMTIME, newSVuv(file_mtime)); av_store(av, NYTP_FIDi_PROFILE, NULL); av_store(av, NYTP_FIDi_HAS_EVALS, NULL); av_store(av, NYTP_FIDi_SUBS_DEFINED, newRV_noinc((SV*)newHV())); av_store(av, NYTP_FIDi_SUBS_CALLED, newRV_noinc((SV*)newHV())); } static void load_src_line_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; unsigned int file_num; unsigned int line_num; SV *src; AV *file_av; va_start(args, tag); file_num = va_arg(args, unsigned int); line_num = va_arg(args, unsigned int); src = va_arg(args, SV *); va_end(args); /* first line in the file seen */ if (!av_exists(state->fid_srclines_av, file_num)) { file_av = newAV(); av_store(state->fid_srclines_av, file_num, newRV_noinc((SV*)file_av)); } else { file_av = (AV *)SvRV(*av_fetch(state->fid_srclines_av, file_num, 1)); } av_store(file_av, line_num, src); if (trace_level >= 8) { logwarn("Fid %2u:%u src: %s\n", file_num, line_num, SvPV_nolen(src)); } } static void load_sub_info_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; unsigned int fid; unsigned int first_line; unsigned int last_line; SV *subname_sv; int skip_subinfo_store = 0; STRLEN subname_len; char *subname_pv; AV *av; SV *sv; va_start(args, tag); fid = va_arg(args, unsigned int); first_line = va_arg(args, unsigned int); last_line = va_arg(args, unsigned int); subname_sv = va_arg(args, SV *); va_end(args); normalize_eval_seqn(aTHX_ subname_sv); subname_pv = SvPV(subname_sv, subname_len); if (trace_level >= 2) logwarn("Sub %s fid %u lines %u..%u\n", subname_pv, fid, first_line, last_line); av = lookup_subinfo_av(aTHX_ subname_sv, state->sub_subinfo_hv); if (SvOK(*av_fetch(av, NYTP_SIi_FID, 1))) { /* We've already seen this subroutine name. * Should only happen for anon subs in string evals so we warn * for other cases. */ if (!instr(subname_pv, "__ANON__[(eval")) logwarn("Sub %s already defined!\n", subname_pv); /* We could always discard the fid+first_line+last_line here, * because we already have them stored, but for consistency * (and for the stability of the tests) we'll prefer the lowest fid */ if (fid > SvUV(*av_fetch(av, NYTP_SIi_FID, 1))) skip_subinfo_store = 1; /* Finally, note that the fileinfo NYTP_FIDi_SUBS_DEFINED hash, * updated below, does get an entry for the sub *from each fid* * (ie string eval) that defines the subroutine. */ } if (!skip_subinfo_store) { sv_setuv(*av_fetch(av, NYTP_SIi_FID, 1), fid); sv_setuv(*av_fetch(av, NYTP_SIi_FIRST_LINE, 1), first_line); sv_setuv(*av_fetch(av, NYTP_SIi_LAST_LINE, 1), last_line); } /* add sub to NYTP_FIDi_SUBS_DEFINED hash */ sv = SvRV(*av_fetch(state->fid_fileinfo_av, fid, 1)); sv = SvRV(*av_fetch((AV *)sv, NYTP_FIDi_SUBS_DEFINED, 1)); (void)hv_store((HV *)sv, subname_pv, (I32)subname_len, newRV_inc((SV*)av), 0); } static void load_sub_callers_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; unsigned int fid; unsigned int line; SV *caller_subname_sv; unsigned int count; NV incl_time; NV excl_time; NV reci_time; unsigned int rec_depth; SV *called_subname_sv; char text[MAXPATHLEN*2]; SV *sv; AV *subinfo_av; int len; va_start(args, tag); fid = va_arg(args, unsigned int); line = va_arg(args, unsigned int); count = va_arg(args, unsigned int); incl_time = va_arg(args, NV); excl_time = va_arg(args, NV); reci_time = va_arg(args, NV); rec_depth = va_arg(args, unsigned int); called_subname_sv = va_arg(args, SV *); caller_subname_sv = va_arg(args, SV *); va_end(args); normalize_eval_seqn(aTHX_ caller_subname_sv); normalize_eval_seqn(aTHX_ called_subname_sv); if (trace_level >= 6) logwarn("Sub %s called by %s %u:%u: count %d, incl %"NVff", excl %"NVff"\n", SvPV_nolen(called_subname_sv), SvPV_nolen(caller_subname_sv), fid, line, count, incl_time, excl_time); subinfo_av = lookup_subinfo_av(aTHX_ called_subname_sv, state->sub_subinfo_hv); /* subinfo_av's NYTP_SIi_CALLED_BY element is a hash ref: * { caller_fid => { caller_line => [ count, incl_time, ... ] } } */ sv = *av_fetch(subinfo_av, NYTP_SIi_CALLED_BY, 1); if (!SvROK(sv)) /* autoviv */ sv_setsv(sv, newRV_noinc((SV*)newHV())); len = sprintf(text, "%u", fid); sv = *hv_fetch((HV*)SvRV(sv), text, len, 1); if (!SvROK(sv)) /* autoviv */ sv_setsv(sv, newRV_noinc((SV*)newHV())); /* XXX gets called with fid=0 to indicate is_xsub * That's a hack that should be removed once we have per-sub flags */ if (fid) { SV *fi; AV *av; len = sprintf(text, "%u", line); sv = *hv_fetch((HV*)SvRV(sv), text, len, 1); if (!SvROK(sv)) /* autoviv */ sv_setsv(sv, newRV_noinc((SV*)newAV())); else if (trace_level) /* calls to sub1 from the same fid:line could have different caller * subs due to evals or if profile_findcaller is off. */ logwarn("Merging extra sub caller info for %s called at %d:%d\n", SvPV_nolen(called_subname_sv), fid, line); av = (AV *)SvRV(sv); sv = *av_fetch(av, NYTP_SCi_CALL_COUNT, 1); sv_setuv(sv, (SvOK(sv)) ? SvUV(sv) + count : count); sv = *av_fetch(av, NYTP_SCi_INCL_RTIME, 1); sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + incl_time : incl_time); sv = *av_fetch(av, NYTP_SCi_EXCL_RTIME, 1); sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + excl_time : excl_time); sv = *av_fetch(av, NYTP_SCi_INCL_TICKS, 1); sv_setnv(sv, 0.0); sv = *av_fetch(av, NYTP_SCi_EXCL_TICKS, 1); sv_setnv(sv, 0.0); sv = *av_fetch(av, NYTP_SCi_RECI_RTIME, 1); sv_setnv(sv, (SvOK(sv)) ? SvNV(sv) + reci_time : reci_time); sv = *av_fetch(av, NYTP_SCi_REC_DEPTH, 1); if (!SvOK(sv) || SvUV(sv) < rec_depth) /* max() */ sv_setuv(sv, rec_depth); /* XXX temp hack way to store calling subname as key with undef value */ /* ideally we should assign ids to subs (sid) the way we do with files (fid) */ sv = *av_fetch(av, NYTP_SCi_CALLING_SUB, 1); if (!SvROK(sv)) /* autoviv */ sv_setsv(sv, newRV_noinc((SV*)newHV())); (void)hv_fetch_ent((HV *)SvRV(sv), caller_subname_sv, 1, 0); /* also reference this sub call info array from the calling fileinfo * fi->[NYTP_FIDi_SUBS_CALLED] => { line => { subname => [ ... ] } } */ fi = SvRV(*av_fetch(state->fid_fileinfo_av, fid, 1)); fi = *av_fetch((AV *)fi, NYTP_FIDi_SUBS_CALLED, 1); fi = *hv_fetch((HV*)SvRV(fi), text, len, 1); if (!SvROK(fi)) /* autoviv */ sv_setsv(fi, newRV_noinc((SV*)newHV())); fi = HeVAL(hv_fetch_ent((HV *)SvRV(fi), called_subname_sv, 1, 0)); if (1) { /* ref a clone of the sub call info array */ AV *av2 = av_make(AvFILL(av)+1, AvARRAY(av)); av = av2; } sv_setsv(fi, newRV_inc((SV *)av)); } else { /* is meta-data about sub */ /* line == 0: is_xs - set line range to 0,0 as marker */ sv_setiv(*av_fetch(subinfo_av, NYTP_SIi_FIRST_LINE, 1), 0); sv_setiv(*av_fetch(subinfo_av, NYTP_SIi_LAST_LINE, 1), 0); } /* accumulate per-sub totals into subinfo */ sv = *av_fetch(subinfo_av, NYTP_SIi_CALL_COUNT, 1); sv_setuv(sv, count + (SvOK(sv) ? SvUV(sv) : 0)); sv = *av_fetch(subinfo_av, NYTP_SIi_INCL_RTIME, 1); sv_setnv(sv, incl_time + (SvOK(sv) ? SvNV(sv) : 0.0)); sv = *av_fetch(subinfo_av, NYTP_SIi_EXCL_RTIME, 1); sv_setnv(sv, excl_time + (SvOK(sv) ? SvNV(sv) : 0.0)); /* sub rec_depth - record the maximum */ sv = *av_fetch(subinfo_av, NYTP_SIi_REC_DEPTH, 1); if (!SvOK(sv) || rec_depth > SvUV(sv)) sv_setuv(sv, rec_depth); sv = *av_fetch(subinfo_av, NYTP_SIi_RECI_RTIME, 1); sv_setnv(sv, reci_time + (SvOK(sv) ? SvNV(sv) : 0.0)); state->total_sub_calls += count; } static void load_pid_start_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; unsigned int pid; unsigned int ppid; NV start_time; char text[MAXPATHLEN*2]; int len; va_start(args, tag); pid = va_arg(args, unsigned int); ppid = va_arg(args, unsigned int); start_time = va_arg(args, NV); va_end(args); state->profiler_start_time = start_time; len = sprintf(text, "%d", pid); (void)hv_store(state->live_pids_hv, text, len, newSVuv(ppid), 0); if (trace_level) logwarn("Start of profile data for pid %s (ppid %d, %"IVdf" pids live) at %"NVff"\n", text, ppid, (IV)HvKEYS(state->live_pids_hv), start_time); store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_start_time"), newSVnv(start_time)); } static void load_pid_end_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; unsigned int pid; NV end_time; char text[MAXPATHLEN*2]; int len; va_start(args, tag); pid = va_arg(args, unsigned int); end_time = va_arg(args, NV); va_end(args); state->profiler_end_time = end_time; len = sprintf(text, "%d", pid); if (!hv_delete(state->live_pids_hv, text, len, 0)) logwarn("Inconsistent pids in profile data (pid %d not introduced)\n", pid); if (trace_level) logwarn("End of profile data for pid %s (%"IVdf" remaining) at %"NVff"\n", text, (IV)HvKEYS(state->live_pids_hv), state->profiler_end_time); store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_end_time"), newSVnv(end_time)); state->profiler_duration += state->profiler_end_time - state->profiler_start_time; store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_duration"), newSVnv(state->profiler_duration)); } static void load_attribute_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; char *key; unsigned long key_len; unsigned int key_utf8; char *value; unsigned long value_len; unsigned int value_utf8; va_start(args, tag); key = va_arg(args, char *); key_len = va_arg(args, unsigned long); key_utf8 = va_arg(args, unsigned int); value = va_arg(args, char *); value_len = va_arg(args, unsigned long); value_utf8 = va_arg(args, unsigned int); va_end(args); store_attrib_sv(aTHX_ state->attr_hv, key, key_utf8 ? -(I32)key_len : key_len, newSVpvn_flags(value, value_len, value_utf8 ? SVf_UTF8 : 0)); } static void load_option_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_profiler *state = (Loader_state_profiler *)cb_data; dTHXa(state->interp); va_list args; char *key; unsigned long key_len; unsigned int key_utf8; char *value; unsigned long value_len; unsigned int value_utf8; SV *value_sv; va_start(args, tag); key = va_arg(args, char *); key_len = va_arg(args, unsigned long); key_utf8 = va_arg(args, unsigned int); value = va_arg(args, char *); value_len = va_arg(args, unsigned long); value_utf8 = va_arg(args, unsigned int); va_end(args); value_sv = newSVpvn_flags(value, value_len, value_utf8 ? SVf_UTF8 : 0); (void)hv_store(state->option_hv, key, key_utf8 ? -(I32)key_len : key_len, value_sv, 0); if (trace_level >= 1) logwarn("! %.*s = '%s'\n", (int) key_len, key, SvPV_nolen(value_sv)); } struct perl_callback_info_t { const char *description; STRLEN len; const char *args; }; static struct perl_callback_info_t callback_info[nytp_tag_max] = { {STR_WITH_LEN("[no tag]"), NULL}, {STR_WITH_LEN("VERSION"), "uu"}, {STR_WITH_LEN("ATTRIBUTE"), "33"}, {STR_WITH_LEN("OPTION"), "33"}, {STR_WITH_LEN("COMMENT"), "3"}, {STR_WITH_LEN("TIME_BLOCK"), "iuuuu"}, {STR_WITH_LEN("TIME_LINE"), "iuu"}, {STR_WITH_LEN("DISCOUNT"), ""}, {STR_WITH_LEN("NEW_FID"), "uuuuuuS"}, {STR_WITH_LEN("SRC_LINE"), "uuS"}, {STR_WITH_LEN("SUB_INFO"), "uuus"}, {STR_WITH_LEN("SUB_CALLERS"), "uuunnnuss"}, {STR_WITH_LEN("PID_START"), "uun"}, {STR_WITH_LEN("PID_END"), "un"}, {STR_WITH_LEN("[string]"), NULL}, {STR_WITH_LEN("[string utf8]"), NULL}, {STR_WITH_LEN("START_DEFLATE"), ""}, {STR_WITH_LEN("SUB_ENTRY"), "uu"}, {STR_WITH_LEN("SUB_RETURN"), "unns"} }; static void load_perl_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...) { Loader_state_callback *state = (Loader_state_callback *)cb_data; dTHXa(state->interp); dSP; va_list args; SV **cb_args = state->cb_args; int i = 0; char type; const char *arglist = callback_info[tag].args; const char *const description = callback_info[tag].description; if (!arglist) { if (description) croak("Type '%s' passed to perl callback incorrectly", description); else croak("Unknown type %d passed to perl callback", tag); } if (!state->cb[tag]) return; if (trace_level >= 9) { logwarn("\tcallback %s[%s] \n", description, arglist); } sv_setuv_mg(state->input_chunk_seqn_sv, state->base_state.input_chunk_seqn); va_start(args, tag); PUSHMARK(SP); XPUSHs(state->tag_names[tag]); while ((type = *arglist++)) { switch(type) { case 'u': { unsigned int u = va_arg(args, unsigned int); sv_setuv(cb_args[i], u); XPUSHs(cb_args[i++]); break; } case 'i': { I32 i32 = va_arg(args, I32); sv_setuv(cb_args[i], i32); XPUSHs(cb_args[i++]); break; } case 'n': { NV n = va_arg(args, NV); sv_setnv(cb_args[i], n); XPUSHs(cb_args[i++]); break; } case 's': { SV *sv = va_arg(args, SV *); sv_setsv(cb_args[i], sv); XPUSHs(cb_args[i++]); break; } case 'S': { SV *sv = va_arg(args, SV *); XPUSHs(sv_2mortal(sv)); break; } case '3': { char *p = va_arg(args, char *); unsigned long len = va_arg(args, unsigned long); unsigned int utf8 = va_arg(args, unsigned int); sv_setpvn(cb_args[i], p, len); if (utf8) SvUTF8_on(cb_args[i]); else SvUTF8_off(cb_args[i]); XPUSHs(cb_args[i++]); break; } default: croak("Bad type '%c' in perl callback", type); } } va_end(args); assert(i <= C_ARRAY_LENGTH(state->cb_args)); PUTBACK; call_sv((SV *)state->cb[tag], G_DISCARD); } static loader_callback perl_callbacks[nytp_tag_max] = { 0, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback, load_perl_callback }; static loader_callback processing_callbacks[nytp_tag_max] = { 0, 0, /* version */ load_attribute_callback, load_option_callback, 0, /* comment */ load_time_callback, load_time_callback, load_discount_callback, load_new_fid_callback, load_src_line_callback, load_sub_info_callback, load_sub_callers_callback, load_pid_start_callback, load_pid_end_callback, 0, /* string */ 0, /* string utf8 */ 0, /* sub entry */ 0, /* sub return */ 0 /* start deflate */ }; /** * Process a profile output file and return the results in a hash like * { fid_fileinfo => [ [file, other...info ], ... ], # index by [fid] * fid_line_time => [ [...],[...],.. ] # index by [fid][line] * } * The value of each [fid][line] is an array ref containing: * [ number of calls, total time spent ] * lines containing string evals also get an extra element * [ number of calls, total time spent, [...] ] * which is an reference to an array containing the [calls,time] * data for each line of the string eval. */ static void load_profile_data_from_stream(pTHX_ loader_callback *callbacks, Loader_state_base *state, NYTP_file in) { int file_major, file_minor; SV *tmp_str1_sv = newSVpvn("",0); SV *tmp_str2_sv = newSVpvn("",0); size_t buffer_len = MAXPATHLEN * 2; char *buffer = (char *)safemalloc(buffer_len); if (1) { if (!NYTP_gets(in, &buffer, &buffer_len)) croak("NYTProf data format error while reading header"); if (2 != sscanf(buffer, "NYTProf %d %d\n", &file_major, &file_minor)) croak("NYTProf data format error while parsing header"); if (file_major != NYTP_FILE_MAJOR_VERSION) croak("NYTProf data format version %d.%d is not supported by NYTProf %s (which expects version %d.%d)", file_major, file_minor, XS_VERSION, NYTP_FILE_MAJOR_VERSION, NYTP_FILE_MINOR_VERSION); if (file_minor > NYTP_FILE_MINOR_VERSION) warn("NYTProf data format version %d.%d is newer than that understood by this NYTProf %s, so errors are likely", file_major, file_minor, XS_VERSION); } if (callbacks[nytp_version]) callbacks[nytp_version](state, nytp_version, file_major, file_minor); while (1) { /* Loop "forever" until EOF. We can only check the EOF flag *after* we attempt a read. */ char c; if (NYTP_read_unchecked(in, &c, sizeof(c)) != sizeof(c)) { if (NYTP_eof(in)) break; croak("Profile format error '%s' whilst reading tag at %ld (see TROUBLESHOOTING in NYTProf docs)", NYTP_fstrerror(in), NYTP_tell(in)); } state->input_chunk_seqn++; if (trace_level >= 9) logwarn("Chunk %lu token is %d ('%c') at %ld%s\n", state->input_chunk_seqn, c, c, NYTP_tell(in)-1, NYTP_type_of_offset(in)); switch (c) { case NYTP_TAG_DISCOUNT: { callbacks[nytp_discount](state, nytp_discount); break; } case NYTP_TAG_TIME_LINE: /*FALLTHRU*/ case NYTP_TAG_TIME_BLOCK: { I32 ticks = read_i32(in); unsigned int file_num = read_u32(in); unsigned int line_num = read_u32(in); unsigned int block_line_num = 0; unsigned int sub_line_num = 0; nytp_tax_index tag = nytp_time_line; if (c == NYTP_TAG_TIME_BLOCK) { block_line_num = read_u32(in); sub_line_num = read_u32(in); tag = nytp_time_block; } /* Because it happens that the two "optional" arguments are last, a single call will work. */ callbacks[tag](state, tag, ticks, file_num, line_num, block_line_num, sub_line_num); break; } case NYTP_TAG_NEW_FID: /* file */ { SV *filename_sv; unsigned int file_num = read_u32(in); unsigned int eval_file_num = read_u32(in); unsigned int eval_line_num = read_u32(in); unsigned int fid_flags = read_u32(in); unsigned int file_size = read_u32(in); unsigned int file_mtime = read_u32(in); filename_sv = read_str(aTHX_ in, NULL); callbacks[nytp_new_fid](state, nytp_new_fid, file_num, eval_file_num, eval_line_num, fid_flags, file_size, file_mtime, filename_sv); break; } case NYTP_TAG_SRC_LINE: { unsigned int file_num = read_u32(in); unsigned int line_num = read_u32(in); SV *src = read_str(aTHX_ in, NULL); callbacks[nytp_src_line](state, nytp_src_line, file_num, line_num, src); break; } case NYTP_TAG_SUB_ENTRY: { unsigned int file_num = read_u32(in); unsigned int line_num = read_u32(in); if (callbacks[nytp_sub_entry]) callbacks[nytp_sub_entry](state, nytp_sub_entry, file_num, line_num); break; } case NYTP_TAG_SUB_RETURN: { unsigned int depth = read_u32(in); NV incl_time = read_nv(in); NV excl_time = read_nv(in); SV *subname = read_str(aTHX_ in, tmp_str1_sv); if (callbacks[nytp_sub_return]) callbacks[nytp_sub_return](state, nytp_sub_return, depth, incl_time, excl_time, subname); break; } case NYTP_TAG_SUB_INFO: { unsigned int fid = read_u32(in); SV *subname_sv = read_str(aTHX_ in, tmp_str1_sv); unsigned int first_line = read_u32(in); unsigned int last_line = read_u32(in); callbacks[nytp_sub_info](state, nytp_sub_info, fid, first_line, last_line, subname_sv); break; } case NYTP_TAG_SUB_CALLERS: { unsigned int fid = read_u32(in); unsigned int line = read_u32(in); SV *caller_subname_sv = read_str(aTHX_ in, tmp_str2_sv); unsigned int count = read_u32(in); NV incl_time = read_nv(in); NV excl_time = read_nv(in); NV reci_time = read_nv(in); unsigned int rec_depth = read_u32(in); SV *called_subname_sv = read_str(aTHX_ in, tmp_str1_sv); callbacks[nytp_sub_callers](state, nytp_sub_callers, fid, line, count, incl_time, excl_time, reci_time, rec_depth, called_subname_sv, caller_subname_sv); break; } case NYTP_TAG_PID_START: { unsigned int pid = read_u32(in); unsigned int ppid = read_u32(in); NV start_time = read_nv(in); callbacks[nytp_pid_start](state, nytp_pid_start, pid, ppid, start_time); break; } case NYTP_TAG_PID_END: { unsigned int pid = read_u32(in); NV end_time = read_nv(in); callbacks[nytp_pid_end](state, nytp_pid_end, pid, end_time); break; } case NYTP_TAG_ATTRIBUTE: { char *value, *key_end; char *end = NYTP_gets(in, &buffer, &buffer_len); if (NULL == end) /* probably EOF */ croak("Profile format error reading attribute (see TROUBLESHOOTING in NYTProf docs)"); --end; /* End, as returned, points 1 after the \n */ if ((NULL == (value = (char *)memchr(buffer, '=', end - buffer)))) { logwarn("attribute malformed '%s'\n", buffer); continue; } key_end = value++; callbacks[nytp_attribute](state, nytp_attribute, buffer, (unsigned long)(key_end - buffer), 0, value, (unsigned long)(end - value), 0); if (memEQs(buffer, key_end - buffer, "ticks_per_sec")) { ticks_per_sec = (unsigned int)atoi(value); } else if (memEQs(buffer, key_end - buffer, "nv_size")) { if (sizeof(NV) != atoi(value)) croak("Profile data created by incompatible perl config (NV size %d but ours is %d)", atoi(value), (int)sizeof(NV)); } break; } case NYTP_TAG_OPTION: { char *value, *key_end; char *end = NYTP_gets(in, &buffer, &buffer_len); if (NULL == end) /* probably EOF */ croak("Profile format error reading attribute (see TROUBLESHOOTING in NYTProf docs)"); --end; /* end, as returned, points 1 after the \n */ if ((NULL == (value = (char *)memchr(buffer, '=', end - buffer)))) { logwarn("option malformed '%s'\n", buffer); continue; } key_end = value++; callbacks[nytp_option](state, nytp_option, buffer, (unsigned long)(key_end - buffer), 0, value, (unsigned long)(end - value), 0); break; } case NYTP_TAG_COMMENT: { char *end = NYTP_gets(in, &buffer, &buffer_len); if (!end) /* probably EOF */ croak("Profile format error reading comment (see TROUBLESHOOTING in NYTProf docs)"); if (callbacks[nytp_comment]) callbacks[nytp_comment](state, nytp_comment, buffer, (unsigned long)(end - buffer), 0); if (trace_level >= 1) logwarn("# %s", buffer); /* includes \n */ break; } case NYTP_TAG_START_DEFLATE: { #ifdef HAS_ZLIB if (callbacks[nytp_start_deflate]) { callbacks[nytp_start_deflate](state, nytp_start_deflate); } NYTP_start_inflate(in); #else croak("File uses compression but compression is not supported by this build of NYTProf"); #endif break; } default: croak("Profile format error: token %d ('%c'), chunk %lu, pos %ld%s (see TROUBLESHOOTING in NYTProf docs)", c, c, state->input_chunk_seqn, NYTP_tell(in)-1, NYTP_type_of_offset(in)); } } sv_free(tmp_str1_sv); sv_free(tmp_str2_sv); Safefree(buffer); } static HV* load_profile_to_hv(pTHX_ NYTP_file in) { Loader_state_profiler state; HV *profile_hv; HV *profile_modes; Zero(&state, 1, Loader_state_profiler); state.total_stmts_duration = 0.0; state.profiler_start_time = 0.0; state.profiler_end_time = 0.0; state.profiler_duration = 0.0; #ifdef MULTIPLICITY state.interp = my_perl; #endif state.fid_line_time_av = newAV(); state.fid_srclines_av = newAV(); state.fid_fileinfo_av = newAV(); state.sub_subinfo_hv = newHV(); state.live_pids_hv = newHV(); state.attr_hv = newHV(); state.option_hv = newHV(); state.file_info_stash = gv_stashpv("Devel::NYTProf::FileInfo", GV_ADDWARN); av_extend(state.fid_fileinfo_av, 64); /* grow them up front. */ av_extend(state.fid_srclines_av, 64); av_extend(state.fid_line_time_av, 64); load_profile_data_from_stream(aTHX_ processing_callbacks, (Loader_state_base *)&state, in); if (HvKEYS(state.live_pids_hv)) { logwarn("Profile data incomplete, no terminator for %"IVdf" pids %s\n", (IV)HvKEYS(state.live_pids_hv), "(refer to TROUBLESHOOTING in the NYTProf documentation)"); store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("complete"), &PL_sv_no); } else { store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("complete"), &PL_sv_yes); } sv_free((SV*)state.live_pids_hv); if (state.statement_discount) /* discard unused statement_discount */ state.total_stmts_discounted -= state.statement_discount; store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_measured"), newSVnv(state.total_stmts_measured)); store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_discounted"), newSVnv(state.total_stmts_discounted)); store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_stmts_duration"), newSVnv(state.total_stmts_duration)); store_attrib_sv(aTHX_ state.attr_hv, STR_WITH_LEN("total_sub_calls"), newSVnv(state.total_sub_calls)); if (1) { int show_summary_stats = (trace_level >= 1); if (state.profiler_end_time && state.total_stmts_duration > state.profiler_duration * 1.1 /* GetSystemTimeAsFiletime/gettimeofday_nv on Win32 have 15.625 ms resolution by default. 1 ms best case scenario if you use special options which Perl land doesn't use, and MS strongly discourages in "Timers, Timer Resolution, and Development of Efficient Code". So for short programs profiler_duration winds up being 0. If necessery, in the future profiler_duration could be set to 15.625 ms automatically on NYTProf start because of the argument that a process can not execute in 0 ms according to the laws of space and time, or at "the end" if profiler_duration is 0.0, set it to 15.625 ms*/ #ifdef HAS_QPC && state.profiler_duration != 0.0 #endif ) { logwarn("The sum of the statement timings is %.1"NVff"%% of the total time profiling." " (Values slightly over 100%% can be due simply to cumulative timing errors," " whereas larger values can indicate a problem with the clock used.)\n", state.total_stmts_duration / state.profiler_duration * 100); show_summary_stats = 1; } if (show_summary_stats) logwarn("Summary: statements profiled %lu (=%lu-%lu), sum of time %"NVff"s, profile spanned %"NVff"s\n", (unsigned long)(state.total_stmts_measured - state.total_stmts_discounted), (unsigned long)state.total_stmts_measured, (unsigned long)state.total_stmts_discounted, state.total_stmts_duration, state.profiler_end_time - state.profiler_start_time); } profile_hv = newHV(); profile_modes = newHV(); (void)hv_stores(profile_hv, "attribute", newRV_noinc((SV*)state.attr_hv)); (void)hv_stores(profile_hv, "option", newRV_noinc((SV*)state.option_hv)); (void)hv_stores(profile_hv, "fid_fileinfo", newRV_noinc((SV*)state.fid_fileinfo_av)); (void)hv_stores(profile_hv, "fid_srclines", newRV_noinc((SV*)state.fid_srclines_av)); (void)hv_stores(profile_hv, "fid_line_time", newRV_noinc((SV*)state.fid_line_time_av)); (void)hv_stores(profile_modes, "fid_line_time", newSVpvs("line")); if (state.fid_block_time_av) { (void)hv_stores(profile_hv, "fid_block_time", newRV_noinc((SV*)state.fid_block_time_av)); (void)hv_stores(profile_modes, "fid_block_time", newSVpvs("block")); } if (state.fid_sub_time_av) { (void)hv_stores(profile_hv, "fid_sub_time", newRV_noinc((SV*)state.fid_sub_time_av)); (void)hv_stores(profile_modes, "fid_sub_time", newSVpvs("sub")); } (void)hv_stores(profile_hv, "sub_subinfo", newRV_noinc((SV*)state.sub_subinfo_hv)); (void)hv_stores(profile_hv, "profile_modes", newRV_noinc((SV*)profile_modes)); return profile_hv; } static void load_profile_to_callback(pTHX_ NYTP_file in, SV *cb) { Loader_state_callback state; int i; HV *cb_hv = NULL; CV *default_cb = NULL; if (SvTYPE(cb) == SVt_PVHV) { /* A default callback is stored with an empty key. */ SV **svp; cb_hv = (HV *)cb; svp = hv_fetch(cb_hv, "", 0, 0); if (svp) { if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV) croak("Default callback is not a CODE reference"); default_cb = (CV *)SvRV(*svp); } } else if (SvTYPE(cb) == SVt_PVCV) { default_cb = (CV *) cb; } else croak("Not a CODE or HASH reference"); #ifdef MULTIPLICITY state.interp = my_perl; #endif state.base_state.input_chunk_seqn = 0; state.input_chunk_seqn_sv = save_scalar(gv_fetchpv(".", GV_ADD, SVt_IV)); i = C_ARRAY_LENGTH(state.tag_names); while (--i) { if (callback_info[i].args) { state.tag_names[i] = newSVpvn_flags(callback_info[i].description, callback_info[i].len, SVs_TEMP); SvREADONLY_on(state.tag_names[i]); /* Don't steal the string buffer. */ SvTEMP_off(state.tag_names[i]); } else state.tag_names[i] = NULL; if (cb_hv) { SV **svp = hv_fetch(cb_hv, callback_info[i].description, (I32)(callback_info[i].len), 0); if (svp) { if (!SvROK(*svp) && SvTYPE(SvRV(*svp)) != SVt_PVCV) croak("Callback for %s is not a CODE reference", callback_info[i].description); state.cb[i] = (CV *)SvRV(*svp); } else state.cb[i] = default_cb; } else state.cb[i] = default_cb; } for (i = 0; i < C_ARRAY_LENGTH(state.cb_args); i++) state.cb_args[i] = sv_newmortal(); load_profile_data_from_stream(aTHX_ perl_callbacks, (Loader_state_base *)&state, in); } struct int_constants_t { const char *name; int value; }; static struct int_constants_t int_constants[] = { /* NYTP_FIDf_* */ {"NYTP_FIDf_IS_PMC", NYTP_FIDf_IS_PMC}, {"NYTP_FIDf_VIA_STMT", NYTP_FIDf_VIA_STMT}, {"NYTP_FIDf_VIA_SUB", NYTP_FIDf_VIA_SUB}, {"NYTP_FIDf_IS_AUTOSPLIT", NYTP_FIDf_IS_AUTOSPLIT}, {"NYTP_FIDf_HAS_SRC", NYTP_FIDf_HAS_SRC}, {"NYTP_FIDf_SAVE_SRC", NYTP_FIDf_SAVE_SRC}, {"NYTP_FIDf_IS_ALIAS", NYTP_FIDf_IS_ALIAS}, {"NYTP_FIDf_IS_FAKE", NYTP_FIDf_IS_FAKE}, {"NYTP_FIDf_IS_EVAL", NYTP_FIDf_IS_EVAL}, /* NYTP_FIDi_* */ {"NYTP_FIDi_FILENAME", NYTP_FIDi_FILENAME}, {"NYTP_FIDi_EVAL_FID", NYTP_FIDi_EVAL_FID}, {"NYTP_FIDi_EVAL_LINE", NYTP_FIDi_EVAL_LINE}, {"NYTP_FIDi_FID", NYTP_FIDi_FID}, {"NYTP_FIDi_FLAGS", NYTP_FIDi_FLAGS}, {"NYTP_FIDi_FILESIZE", NYTP_FIDi_FILESIZE}, {"NYTP_FIDi_FILEMTIME", NYTP_FIDi_FILEMTIME}, {"NYTP_FIDi_PROFILE", NYTP_FIDi_PROFILE}, {"NYTP_FIDi_EVAL_FI", NYTP_FIDi_EVAL_FI}, {"NYTP_FIDi_HAS_EVALS", NYTP_FIDi_HAS_EVALS}, {"NYTP_FIDi_SUBS_DEFINED", NYTP_FIDi_SUBS_DEFINED}, {"NYTP_FIDi_SUBS_CALLED", NYTP_FIDi_SUBS_CALLED}, {"NYTP_FIDi_elements", NYTP_FIDi_elements}, /* NYTP_SIi_* */ {"NYTP_SIi_FID", NYTP_SIi_FID}, {"NYTP_SIi_FIRST_LINE", NYTP_SIi_FIRST_LINE}, {"NYTP_SIi_LAST_LINE", NYTP_SIi_LAST_LINE}, {"NYTP_SIi_CALL_COUNT", NYTP_SIi_CALL_COUNT}, {"NYTP_SIi_INCL_RTIME", NYTP_SIi_INCL_RTIME}, {"NYTP_SIi_EXCL_RTIME", NYTP_SIi_EXCL_RTIME}, {"NYTP_SIi_SUB_NAME", NYTP_SIi_SUB_NAME}, {"NYTP_SIi_PROFILE", NYTP_SIi_PROFILE}, {"NYTP_SIi_REC_DEPTH", NYTP_SIi_REC_DEPTH}, {"NYTP_SIi_RECI_RTIME", NYTP_SIi_RECI_RTIME}, {"NYTP_SIi_CALLED_BY", NYTP_SIi_CALLED_BY}, {"NYTP_SIi_elements", NYTP_SIi_elements}, /* NYTP_SCi_* */ {"NYTP_SCi_CALL_COUNT", NYTP_SCi_CALL_COUNT}, {"NYTP_SCi_INCL_RTIME", NYTP_SCi_INCL_RTIME}, {"NYTP_SCi_EXCL_RTIME", NYTP_SCi_EXCL_RTIME}, {"NYTP_SCi_INCL_TICKS", NYTP_SCi_INCL_TICKS}, {"NYTP_SCi_EXCL_TICKS", NYTP_SCi_EXCL_TICKS}, {"NYTP_SCi_RECI_RTIME", NYTP_SCi_RECI_RTIME}, {"NYTP_SCi_REC_DEPTH", NYTP_SCi_REC_DEPTH}, {"NYTP_SCi_CALLING_SUB", NYTP_SCi_CALLING_SUB}, {"NYTP_SCi_elements", NYTP_SCi_elements}, /* others */ {"NYTP_DEFAULT_COMPRESSION", default_compression_level}, {"NYTP_FILE_MAJOR_VERSION", NYTP_FILE_MAJOR_VERSION}, {"NYTP_FILE_MINOR_VERSION", NYTP_FILE_MINOR_VERSION}, }; /*********************************** * Perl XS Code Below Here * ***********************************/ MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Constants PROTOTYPES: DISABLE BOOT: { HV *stash = gv_stashpv("Devel::NYTProf::Constants", GV_ADDWARN); struct int_constants_t *constant = int_constants; const struct int_constants_t *end = constant + C_ARRAY_LENGTH(int_constants); do { /* 5.8.x and earlier don't declare newCONSTSUB() as const char *, even though it is. */ newCONSTSUB(stash, (char *) constant->name, newSViv(constant->value)); } while (++constant < end); newCONSTSUB(stash, "NYTP_ZLIB_VERSION", newSVpv(ZLIB_VERSION, 0)); } MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Util PROTOTYPES: DISABLE void trace_level() PPCODE: XSRETURN_IV(trace_level); MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Test PROTOTYPES: DISABLE void example_xsub(const char *unused="", SV *action=Nullsv, SV *arg=Nullsv) CODE: PERL_UNUSED_VAR(unused); if (!action) XSRETURN(0); if (SvROK(action) && SvTYPE(SvRV(action))==SVt_PVCV) { /* perl <= 5.8.8 doesn't use OP_ENTERSUB so won't be seen by NYTProf */ PUSHMARK(SP); call_sv(action, G_VOID|G_DISCARD); } else if (strEQ(SvPV_nolen(action),"eval")) eval_pv(SvPV_nolen(arg), TRUE); else if (strEQ(SvPV_nolen(action),"die")) croak("example_xsub(die)"); logwarn("example_xsub: unknown action '%s'\n", SvPV_nolen(action)); void example_xsub_eval(...) CODE: PERL_UNUSED_VAR(items); /* to enable testing of string evals in embedded environments * where there's no caller file information available. * Only it doesn't actually do that because perl knows * what it's executing at the time eval_pv() gets called. * We need a better test, closer to true embedded. */ eval_pv("Devel::NYTProf::Test::example_xsub()", 1); void set_errno(int e) CODE: SETERRNO(e, 0); void ticks_for_usleep(long u_seconds) PPCODE: NV elapsed = -1; NV overflow = -1; #ifdef HAS_SELECT time_of_day_t s_time; time_of_day_t e_time; struct timeval timebuf; timebuf.tv_sec = (long)(u_seconds / 1000000); timebuf.tv_usec = u_seconds - (timebuf.tv_sec * 1000000); if (!last_pid) _init_profiler_clock(aTHX); get_time_of_day(s_time); PerlSock_select(0, 0, 0, 0, &timebuf); get_time_of_day(e_time); get_NV_ticks_between(s_time, e_time, elapsed, overflow); #else PERL_UNUSED_VAR(u_seconds); #endif EXTEND(SP, 4); PUSHs(sv_2mortal(newSVnv(elapsed))); PUSHs(sv_2mortal(newSVnv(overflow))); PUSHs(sv_2mortal(newSVnv(ticks_per_sec))); PUSHs(sv_2mortal(newSViv(profile_clock))); MODULE = Devel::NYTProf PACKAGE = DB PROTOTYPES: DISABLE void DB_profiler(...) CODE: /* this sub gets aliased as "DB::DB" by NYTProf.pm if use_db_sub is true */ PERL_UNUSED_VAR(items); if (opt_use_db_sub) DB_stmt(aTHX_ NULL, PL_op); else logwarn("DB::DB called unexpectedly\n"); void set_option(const char *opt, const char *value) C_ARGS: aTHX_ opt, value int init_profiler() C_ARGS: aTHX int enable_profile(char *file = NULL) C_ARGS: aTHX_ file POSTCALL: /* if profiler was previously disabled */ /* then arrange for the enable_profile call to be noted */ if (!RETVAL) { DB_stmt(aTHX_ PL_curcop, PL_op); } int disable_profile() C_ARGS: aTHX void finish_profile(...) ALIAS: _finish = 1 C_ARGS: aTHX INIT: PERL_UNUSED_ARG(ix); PERL_UNUSED_ARG(items); void _INIT() CODE: if (profile_start == NYTP_START_INIT) { enable_profile(aTHX_ NULL); } else if (profile_start == NYTP_START_END) { SV *enable_profile_sv = (SV *)get_cv("DB::enable_profile", GV_ADDWARN); if (trace_level >= 1) logwarn("~ enable_profile deferred until END\n"); if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); /* we want to be first */ av_store(PL_endav, 0, SvREFCNT_inc(enable_profile_sv)); } av_extend(PL_endav, av_len(PL_endav)+20); /* see PL_endav in init_profiler() */ if (trace_level >= 1) logwarn("~ INIT done\n"); void _END() ALIAS: _CHECK = 1 CODE: /* we want to END { finish_profile() } but we want it to be the last END * block run, so we don't push it into PL_endav until END phase has started, * so it's likely to be the last thing run. Do this once, else we could end * up in an infinite loop arms race with something else trying the same * strategy. */ CV *finish_profile_cv = get_cv("DB::finish_profile", GV_ADDWARN); if (1) { /* defer */ if (!PL_checkav) PL_checkav = newAV(); if (!PL_endav) PL_endav = newAV(); av_push((ix == 1 ? PL_checkav : PL_endav), SvREFCNT_inc(finish_profile_cv)); } else { /* immediate */ call_sv((SV *)finish_profile_cv, G_VOID); } if (trace_level >= 1) logwarn("~ %s done\n", ix == 1 ? "CHECK" : "END"); MODULE = Devel::NYTProf PACKAGE = Devel::NYTProf::Data PROTOTYPES: DISABLE HV* load_profile_data_from_file(file,cb=NULL) char *file; SV* cb; PREINIT: int result; NYTP_file in; CODE: if (trace_level) logwarn("reading profile data from file %s\n", file); in = NYTP_open(file, "rb"); if (in == NULL) { croak("Failed to open input '%s': %s", file, strerror(errno)); } if (cb && SvROK(cb)) { load_profile_to_callback(aTHX_ in, SvRV(cb)); RETVAL = (HV*) &PL_sv_undef; } else { RETVAL = load_profile_to_hv(aTHX_ in); } if ((result = NYTP_close(in, 0))) logwarn("Error closing profile data file: %s\n", strerror(result)); OUTPUT: RETVAL Devel-NYTProf-6.06/MANIFEST000644 000766 000024 00000011022 13305245315 015407 0ustar00timbostaff000000 000000 .gdbinit .gitignore .indent.pro .perltidyrc .travis.yml Changes FileHandle.h FileHandle.xs HACKING INSTALL MANIFEST This list of files Makefile.PL MemoryProfiling.pod NYTProf.h NYTProf.xs README.md bin/flamegraph.pl bin/nytprofcalls bin/nytprofcg bin/nytprofcsv bin/nytprofhtml bin/nytprofmerge bin/nytprofpf demo/1m_stmts.pl demo/README demo/closure.pl demo/cpucache.pl demo/demo-code.pl demo/demo-run.pl demo/exclusive-sub-time.pl lib/Devel/NYTProf.pm lib/Devel/NYTProf/Apache.pm lib/Devel/NYTProf/Constants.pm lib/Devel/NYTProf/Core.pm lib/Devel/NYTProf/Data.pm lib/Devel/NYTProf/FileHandle.pm lib/Devel/NYTProf/FileInfo.pm lib/Devel/NYTProf/ReadStream.pm lib/Devel/NYTProf/Reader.pm lib/Devel/NYTProf/Run.pm lib/Devel/NYTProf/SubCallInfo.pm lib/Devel/NYTProf/SubInfo.pm lib/Devel/NYTProf/Test.pm lib/Devel/NYTProf/Util.pm lib/Devel/NYTProf/js/asc.png lib/Devel/NYTProf/js/bg.png lib/Devel/NYTProf/js/desc.png lib/Devel/NYTProf/js/jit/Treemap.css lib/Devel/NYTProf/js/jit/gradient-cushion1.png lib/Devel/NYTProf/js/jit/gradient.png lib/Devel/NYTProf/js/jit/gradient20.png lib/Devel/NYTProf/js/jit/gradient30.png lib/Devel/NYTProf/js/jit/gradient40.png lib/Devel/NYTProf/js/jit/gradient50.png lib/Devel/NYTProf/js/jit/jit-yc.js lib/Devel/NYTProf/js/jit/jit.js lib/Devel/NYTProf/js/jquery-min.js lib/Devel/NYTProf/js/jquery-tablesorter-min.js lib/Devel/NYTProf/js/style-tablesorter.css ppport.h slowops.h t/00-load.t t/10-run.t t/22-readstream.t t/30-util.t t/31-env.t t/40-savesrc.t t/42-global.t t/44-model.t t/50-errno.t t/60-forkdepth.t t/68-hashline.t t/70-subname.t t/71-moose.t t/72-autodie.t t/80-version.t t/90-pod.t t/91-pod_coverage.t t/92-file_port.t t/lib/NYTProfTest.pm t/test01.calls t/test01.p t/test01.rdt t/test01.t t/test01.x t/test02.calls t/test02.p t/test02.pf t/test02.pf.csv t/test02.rdt t/test02.t t/test02.x t/test03.calls t/test03.p t/test03.rdt t/test03.t t/test03.x t/test05.calls t/test05.p t/test05.rdt t/test05.t t/test05.x t/test06.calls t/test06.p t/test06.rdt t/test06.t t/test06.x t/test07.calls t/test07.p t/test07.rdt t/test07.t t/test07.x t/test08.calls t/test08.p t/test08.rdt t/test08.t t/test08.x t/test09.calls t/test09.p t/test09.rdt t/test09.t t/test09.x t/test10.calls t/test10.p t/test10.rdt t/test10.t t/test10.x t/test11.calls t/test11.p t/test11.rdt t/test11.t t/test11.x t/test12.calls t/test12.p t/test12.pl t/test12.rdt t/test12.t t/test12.x t/test13.calls t/test13.p t/test13.rdt t/test13.t t/test13.x t/test14.p t/test14.pm t/test14.pm_x t/test14.rdt t/test14.t t/test14.x t/test16.calls t/test16.p t/test16.rdt t/test16.t t/test16.x t/test17-goto.calls t/test17-goto.p t/test17-goto.rdt t/test17-goto.t t/test18-goto2.calls t/test18-goto2.p t/test18-goto2.pm t/test18-goto2.t t/test20-streval.calls t/test20-streval.p t/test20-streval.rdt t/test20-streval.t t/test20-streval.x t/test21-streval3.calls t/test21-streval3.p t/test21-streval3.rdt t/test21-streval3.t t/test21-streval3.x t/test22-strevala.calls t/test22-strevala.p t/test22-strevala.rdt t/test22-strevala.t t/test23-strevall.calls t/test23-strevall.p t/test23-strevall.rdt t/test23-strevall.t t/test24-strevalc.calls t/test24-strevalc.p t/test24-strevalc.rdt t/test24-strevalc.t t/test25-strevalb.t t/test30-fork-0.calls t/test30-fork-0.p t/test30-fork-0.rdt t/test30-fork-0.t t/test30-fork-0.x t/test30-fork-1.rdt t/test30-fork-1.x t/test40pmc.calls t/test40pmc.p t/test40pmc.pm t/test40pmc.pm_x t/test40pmc.pmc t/test40pmc.rdt t/test40pmc.t t/test40pmc.x t/test50-disable.calls t/test50-disable.p t/test50-disable.rdt t/test50-disable.t t/test50-disable.x t/test51-enable.calls t/test51-enable.p t/test51-enable.rdt t/test51-enable.t t/test51-enable.x t/test60-subname.calls t/test60-subname.p t/test60-subname.rdt t/test60-subname.t t/test61-submerge.calls t/test61-submerge.p t/test61-submerge.rdt t/test61-submerge.t t/test62-subcaller1.calls t/test62-subcaller1.p t/test62-subcaller1.rdt t/test62-subcaller1.t t/test62-tie-a.calls t/test62-tie-a.p t/test62-tie-a.rdt t/test62-tie-a.t t/test62-tie-b.calls t/test62-tie-b.p t/test62-tie-b.rdt t/test62-tie-b.t t/test70-subexcl.calls t/test70-subexcl.p t/test70-subexcl.t t/test80-recurs.calls t/test80-recurs.p t/test80-recurs.rdt t/test80-recurs.t t/test81-swash.t t/test82-version.t t/test90-strsubref.t t/zzz.t typemap xt/61-cputime.t xt/test23-strevalxs.p xt/test23-strevalxs.rdt xt/test23-strevalxs.t xt/test45-overload.p xt/test71-while.p xt/test82-stress.t xt/test90-stress.p META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Devel-NYTProf-6.06/FileHandle.xs000644 000766 000024 00000122464 13255276500 016646 0ustar00timbostaff000000 000000 /* vim: ts=8 sw=4 expandtab: * ************************************************************************ * This file is part of the Devel::NYTProf package. * See http://metacpan.org/release/Devel-NYTProf/ * For Copyright see lib/Devel/NYTProf.pm * For contribution history see repository logs. * ************************************************************************ */ #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #if defined(PERL_IMPLICIT_SYS) && !defined(NO_XSLOCKS) # ifndef fgets # define fgets PerlSIO_fgets # endif #endif #include "FileHandle.h" #include "NYTProf.h" #define NEED_sv_2pvbyte #include "ppport.h" #ifdef HAS_ZLIB # include #endif #define NYTP_FILE_STDIO 0 #define NYTP_FILE_DEFLATE 1 #define NYTP_FILE_INFLATE 2 /* to help find places in NYTProf.xs where we don't save/restore errno */ #if 0 #define ERRNO_PROBE errno=__LINE__ #else #define ERRNO_PROBE (void)0 #endif /* During profiling the large buffer collects the raw data until full. * Then flush_output zips it into the small buffer and writes it to disk. * A scale factor of ~90 makes the large buffer usually almost fill the small * one when zipped (so calls to flush_output() almost always trigger one fwrite()). * We use a lower number to save some memory as there's little performance * impact either way. */ #define NYTP_FILE_SMALL_BUFFER_SIZE 4096 #define NYTP_FILE_LARGE_BUFFER_SIZE (NYTP_FILE_SMALL_BUFFER_SIZE * 40) #ifdef HAS_ZLIB # define FILE_STATE(f) ((f)->state) #else # define FILE_STATE(f) NYTP_FILE_STDIO #endif #if defined(PERL_IMPLICIT_CONTEXT) && ! defined(tTHX) # define tTHX PerlInterpreter* #endif struct NYTP_file_t { FILE *file; #ifdef PERL_IMPLICIT_CONTEXT tTHX aTHX; /* on 5.8 and older, pTHX contains a "register" which is not compatible with a struct def, so use something else */ #endif #ifdef HAS_ZLIB unsigned char state; bool stdio_at_eof; bool zlib_at_eof; /* For input only, the position we are in large_buffer. */ unsigned int count; z_stream zs; unsigned char small_buffer[NYTP_FILE_SMALL_BUFFER_SIZE]; unsigned char large_buffer[NYTP_FILE_LARGE_BUFFER_SIZE]; #endif }; /* unlike dTHX which contains a function call, and therefore can never be optimized away, even if return value isn't used, the below will optimize away if NO_XSLOCKS is defined and PerlIO is not being used (i.e. native C lib IO is being used on Win32 )*/ #ifdef PERL_IMPLICIT_CONTEXT # define dNFTHX(x) dTHXa((x)->aTHX) #else # define dNFTHX(x) dNOOP #endif /* XXX The proper return value would be Off_t */ long NYTP_tell(NYTP_file file) { ERRNO_PROBE; #ifdef HAS_ZLIB /* This has to work with compressed files as it's used in the croaking routine. */ if (FILE_STATE(file) != NYTP_FILE_STDIO) { return FILE_STATE(file) == NYTP_FILE_INFLATE ? file->zs.total_out : file->zs.total_in; } #endif { dNFTHX(file); return (long)ftell(file->file); } } #ifdef HAS_ZLIB const char * NYTP_type_of_offset(NYTP_file file) { switch (FILE_STATE(file)) { case NYTP_FILE_STDIO: return ""; case NYTP_FILE_DEFLATE: return " in compressed output data"; break; case NYTP_FILE_INFLATE: return " in compressed input data"; break; default: return Perl_form_nocontext(" in stream in unknown state %d", FILE_STATE(file)); } } #endif #ifdef HAS_ZLIB # define CROAK_IF_NOT_STDIO(file, where) \ STMT_START { \ if (FILE_STATE(file) != NYTP_FILE_STDIO) { \ compressed_io_croak((file), (where)); \ } \ } STMT_END #else # define CROAK_IF_NOT_STDIO(file, where) #endif #ifdef HAS_ZLIB #ifdef HASATTRIBUTE_NORETURN __attribute__noreturn__ #endif static void compressed_io_croak(NYTP_file file, const char *function) { const char *what; switch (FILE_STATE(file)) { case NYTP_FILE_STDIO: what = "stdio"; break; case NYTP_FILE_DEFLATE: what = "compressed output"; break; case NYTP_FILE_INFLATE: what = "compressed input"; break; default: croak("Can't use function %s() on a stream of type %d at offset %ld", function, FILE_STATE(file), NYTP_tell(file)); } croak("Can't use function %s() on a %s stream at offset %ld", function, what, NYTP_tell(file)); } void NYTP_start_deflate(NYTP_file file, int compression_level) { int status; ERRNO_PROBE; CROAK_IF_NOT_STDIO(file, "NYTP_start_deflate"); FILE_STATE(file) = NYTP_FILE_DEFLATE; file->zs.next_in = (Bytef *) file->large_buffer; file->zs.avail_in = 0; file->zs.next_out = (Bytef *) file->small_buffer; file->zs.avail_out = NYTP_FILE_SMALL_BUFFER_SIZE; file->zs.zalloc = (alloc_func) 0; file->zs.zfree = (free_func) 0; file->zs.opaque = 0; status = deflateInit2(&(file->zs), compression_level, Z_DEFLATED, 15 /* windowBits */, 9 /* memLevel */, Z_DEFAULT_STRATEGY); if (status != Z_OK) { croak("deflateInit2 failed, error %d (%s)", status, file->zs.msg); } } void NYTP_start_inflate(NYTP_file file) { int status; ERRNO_PROBE; CROAK_IF_NOT_STDIO(file, "NYTP_start_inflate"); FILE_STATE(file) = NYTP_FILE_INFLATE; file->zs.next_in = (Bytef *) file->small_buffer; file->zs.avail_in = 0; file->zs.next_out = (Bytef *) file->large_buffer; file->zs.avail_out = NYTP_FILE_LARGE_BUFFER_SIZE; file->zs.zalloc = (alloc_func) 0; file->zs.zfree = (free_func) 0; file->zs.opaque = 0; status = inflateInit2(&(file->zs), 15); if (status != Z_OK) { croak("inflateInit2 failed, error %d (%s)", status, file->zs.msg); } } #endif NYTP_file NYTP_open(const char *name, const char *mode) { dTHX; FILE *raw_file = fopen(name, mode); NYTP_file file; ERRNO_PROBE; if (!raw_file) return NULL; /* MS libc has 4096 as default, this is too slow for GB size profiling data */ if (setvbuf(raw_file, NULL, _IOFBF, 16384)) return NULL; Newx(file, 1, struct NYTP_file_t); file->file = raw_file; #ifdef PERL_IMPLICIT_CONTEXT file->aTHX = aTHX; #endif #ifdef HAS_ZLIB file->state = NYTP_FILE_STDIO; file->count = 0; file->stdio_at_eof = FALSE; file->zlib_at_eof = FALSE; file->zs.msg = (char *)"[Oops. zlib hasn't updated this error string]"; #endif return file; } #ifdef HAS_ZLIB static void grab_input(NYTP_file ifile) { dNFTHX(ifile); ERRNO_PROBE; ifile->count = 0; ifile->zs.next_out = (Bytef *) ifile->large_buffer; ifile->zs.avail_out = NYTP_FILE_LARGE_BUFFER_SIZE; #ifdef DEBUG_INFLATE fprintf(stderr, "grab_input enter\n"); #endif while (1) { int status; if (ifile->zs.avail_in == 0 && !ifile->stdio_at_eof) { size_t got = fread(ifile->small_buffer, 1, NYTP_FILE_SMALL_BUFFER_SIZE, ifile->file); if (got == 0) { if (!feof(ifile->file)) { int eno = errno; croak("grab_input failed: %d (%s)", eno, strerror(eno)); } ifile->stdio_at_eof = TRUE; } ifile->zs.avail_in = got; ifile->zs.next_in = (Bytef *) ifile->small_buffer; } #ifdef DEBUG_INFLATE fprintf(stderr, "grab_input predef next_in= %p avail_in= %08x\n" " next_out=%p avail_out=%08x" " eof=%d,%d\n", ifile->zs.next_in, ifile->zs.avail_in, ifile->zs.next_out, ifile->zs.avail_out, ifile->stdio_at_eof, ifile->zlib_at_eof); #endif status = inflate(&(ifile->zs), Z_NO_FLUSH); #ifdef DEBUG_INFLATE fprintf(stderr, "grab_input postdef next_in= %p avail_in= %08x\n" " next_out=%p avail_out=%08x " "status=%d\n", ifile->zs.next_in, ifile->zs.avail_in, ifile->zs.next_out, ifile->zs.avail_out, status); #endif if (!(status == Z_OK || status == Z_STREAM_END)) { if (ifile->stdio_at_eof) croak("Profile data incomplete, inflate error %d (%s) at end of input file," " perhaps the process didn't exit cleanly or the file has been truncated " " (refer to TROUBLESHOOTING in the documentation)\n", status, ifile->zs.msg); croak("Error reading file: inflate failed, error %d (%s) at offset %ld in input file", status, ifile->zs.msg, (long)ftell(ifile->file)); } if (ifile->zs.avail_out == 0 || status == Z_STREAM_END) { if (status == Z_STREAM_END) { ifile->zlib_at_eof = TRUE; } return; } } } #endif size_t NYTP_read_unchecked(NYTP_file ifile, void *buffer, size_t len) { dNFTHX(ifile); #ifdef HAS_ZLIB size_t result = 0; #endif ERRNO_PROBE; if (FILE_STATE(ifile) == NYTP_FILE_STDIO) { return fread(buffer, 1, len, ifile->file); } #ifdef HAS_ZLIB else if (FILE_STATE(ifile) != NYTP_FILE_INFLATE) { compressed_io_croak(ifile, "NYTP_read"); return 0; } while (1) { unsigned char *p = ifile->large_buffer + ifile->count; int remaining = ((unsigned char *) ifile->zs.next_out) - p; if (remaining >= len) { Copy(p, buffer, len, unsigned char); ifile->count += len; result += len; return result; } Copy(p, buffer, remaining, unsigned char); ifile->count = NYTP_FILE_LARGE_BUFFER_SIZE; result += remaining; len -= remaining; buffer = (void *)(remaining + (char *)buffer); if (ifile->zlib_at_eof) return result; grab_input(ifile); } #endif } size_t NYTP_read(NYTP_file ifile, void *buffer, size_t len, const char *what) { size_t got = NYTP_read_unchecked(ifile, buffer, len); if (got != len) { croak("Profile format error whilst reading %s at %ld%s: expected %ld got %ld, %s (see TROUBLESHOOTING in docs)", what, NYTP_tell(ifile), NYTP_type_of_offset(ifile), (long)len, (long)got, (NYTP_eof(ifile)) ? "end of file" : NYTP_fstrerror(ifile)); } return len; } /* This isn't exactly fgets. It will resize the buffer as needed, and returns a pointer to one beyond the read data (usually the terminating '\0'), or NULL if it hit error/EOF */ char * NYTP_gets(NYTP_file ifile, char **buffer_p, size_t *len_p) { char *buffer = *buffer_p; size_t len = *len_p; size_t prev_len = 0; ERRNO_PROBE; #ifdef HAS_ZLIB if (FILE_STATE(ifile) == NYTP_FILE_INFLATE) { while (1) { const unsigned char *const p = ifile->large_buffer + ifile->count; const unsigned int remaining = ((unsigned char *) ifile->zs.next_out) - p; unsigned char *const nl = (unsigned char *)memchr(p, '\n', remaining); size_t got; size_t want; size_t extra; if (nl) { want = nl + 1 - p; extra = want + 1; /* 1 more to add a \0 */ } else { want = extra = remaining; } if (extra > len - prev_len) { prev_len = len; len += extra; buffer = (char *)saferealloc(buffer, len); } got = NYTP_read_unchecked(ifile, buffer + prev_len, want); if (got != want) croak("NYTP_gets unexpected short read. got %lu, expected %lu\n", (unsigned long)got, (unsigned long)want); if (nl) { buffer[prev_len + want] = '\0'; *buffer_p = buffer; *len_p = len; return buffer + prev_len + want; } if (ifile->zlib_at_eof) { *buffer_p = buffer; *len_p = len; return NULL; } grab_input(ifile); } } #endif CROAK_IF_NOT_STDIO(ifile, "NYTP_gets"); { dNFTHX(ifile); while(fgets(buffer + prev_len, (int)(len - prev_len), ifile->file)) { /* We know that there are no '\0' bytes in the part we've already read, so don't bother running strlen() over that part. */ char *end = buffer + prev_len + strlen(buffer + prev_len); if (end[-1] == '\n') { *buffer_p = buffer; *len_p = len; return end; } prev_len = len - 1; /* -1 to take off the '\0' at the end */ len *= 2; buffer = (char *)saferealloc(buffer, len); } } *buffer_p = buffer; *len_p = len; return NULL; } #ifdef HAS_ZLIB /* Cheat, by telling zlib about a reduced amount of available output space, such that our next write of the (slightly underused) output buffer will align the underlying file pointer back with the size of our output buffer (and hopefully the underlying OS block writes). */ static void sync_avail_out_to_ftell(NYTP_file ofile) { dNFTHX(ofile); const long result = ftell(ofile->file); const unsigned long where = result < 0 ? 0 : result; ERRNO_PROBE; ofile->zs.avail_out = NYTP_FILE_SMALL_BUFFER_SIZE - where % NYTP_FILE_SMALL_BUFFER_SIZE; #ifdef DEBUG_DEFLATE fprintf(stderr, "sync_avail_out_to_ftell pos=%ld, avail_out=%lu\n", result, (unsigned long) ofile->zs.avail_out); #endif } /* flush has values as described for "allowed flush values" in zlib.h */ static void flush_output(NYTP_file ofile, int flush) { dNFTHX(ofile); ERRNO_PROBE; ofile->zs.next_in = (Bytef *) ofile->large_buffer; #ifdef DEBUG_DEFLATE fprintf(stderr, "flush_output enter flush = %d\n", flush); #endif while (1) { int status; #ifdef DEBUG_DEFLATE fprintf(stderr, "flush_output predef next_in= %p avail_in= %08x\n" " next_out=%p avail_out=%08x" " flush=%d\n", ofile->zs.next_in, ofile->zs.avail_in, ofile->zs.next_out, ofile->zs.avail_out, flush); #endif status = deflate(&(ofile->zs), flush); /* workaround for RT#50851 */ if (status == Z_BUF_ERROR && flush != Z_NO_FLUSH && !ofile->zs.avail_in && ofile->zs.avail_out) status = Z_OK; #ifdef DEBUG_DEFLATE fprintf(stderr, "flush_output postdef next_in= %p avail_in= %08x\n" " next_out=%p avail_out=%08x " "status=%d\n", ofile->zs.next_in, ofile->zs.avail_in, ofile->zs.next_out, ofile->zs.avail_out, status); #endif if (status == Z_OK || status == Z_STREAM_END) { if (ofile->zs.avail_out == 0 || flush != Z_NO_FLUSH) { int terminate = ofile->zs.avail_in == 0 && ofile->zs.avail_out > 0; size_t avail = ((unsigned char *) ofile->zs.next_out) - ofile->small_buffer; const unsigned char *where = ofile->small_buffer; while (avail > 0) { size_t count = fwrite(where, 1, avail, ofile->file); if (count > 0) { where += count; avail -= count; } else { int eno = errno; croak("fwrite in flush error %d: %s", eno, strerror(eno)); } } ofile->zs.next_out = (Bytef *) ofile->small_buffer; ofile->zs.avail_out = NYTP_FILE_SMALL_BUFFER_SIZE; if (terminate) { ofile->zs.avail_in = 0; if (flush == Z_SYNC_FLUSH) { sync_avail_out_to_ftell(ofile); } return; } } else { ofile->zs.avail_in = 0; return; } } else { croak("deflate(%ld,%d) failed, error %d (%s) in pid %d", (long)ofile->zs.avail_in, flush, status, ofile->zs.msg, getpid()); } } } #endif size_t NYTP_write(NYTP_file ofile, const void *buffer, size_t len) { #ifdef HAS_ZLIB size_t result = 0; #endif ERRNO_PROBE; if (FILE_STATE(ofile) == NYTP_FILE_STDIO) { /* fwrite with len==0 is problematic */ /* http://www.opengroup.org/platform/resolutions/bwg98-007.html */ if (len == 0) return len; { dNFTHX(ofile); if (fwrite(buffer, 1, len, ofile->file) < 1) { int eno = errno; croak("fwrite error %d writing %ld bytes to fd%d: %s", eno, (long)len, fileno(ofile->file), strerror(eno)); } } return len; } #ifdef HAS_ZLIB else if (FILE_STATE(ofile) != NYTP_FILE_DEFLATE) { compressed_io_croak(ofile, "NYTP_write"); return 0; } while (1) { int remaining = NYTP_FILE_LARGE_BUFFER_SIZE - ofile->zs.avail_in; unsigned char *p = ofile->large_buffer + ofile->zs.avail_in; if (remaining >= len) { Copy(buffer, p, len, unsigned char); ofile->zs.avail_in += len; result += len; return result; } else { /* Copy what we can, then flush the buffer. Lather, rinse, repeat. */ Copy(buffer, p, remaining, unsigned char); ofile->zs.avail_in = NYTP_FILE_LARGE_BUFFER_SIZE; result += remaining; len -= remaining; buffer = (void *)(remaining + (char *)buffer); flush_output(ofile, Z_NO_FLUSH); } } #endif } int NYTP_printf(NYTP_file ofile, const char *format, ...) { int retval; va_list args; ERRNO_PROBE; CROAK_IF_NOT_STDIO(ofile, "NYTP_printf"); va_start(args, format); { dNFTHX(ofile); retval = vfprintf(ofile->file, format, args); } va_end(args); return retval; } int NYTP_flush(NYTP_file file) { ERRNO_PROBE; #ifdef HAS_ZLIB if (FILE_STATE(file) == NYTP_FILE_DEFLATE) { flush_output(file, Z_SYNC_FLUSH); } #endif { dNFTHX(file); return fflush(file->file); } } int NYTP_eof(NYTP_file ifile) { ERRNO_PROBE; #ifdef HAS_ZLIB if (FILE_STATE(ifile) == NYTP_FILE_INFLATE) { return ifile->zlib_at_eof; } #endif { dNFTHX(ifile); return feof(ifile->file); } } const char * NYTP_fstrerror(NYTP_file file) { #ifdef HAS_ZLIB if (FILE_STATE(file) == NYTP_FILE_DEFLATE || FILE_STATE(file) == NYTP_FILE_INFLATE) { return file->zs.msg; } #endif { dNFTHX(file); return strerror(errno); } } int NYTP_close(NYTP_file file, int discard) { FILE *raw_file = file->file; int result; dNFTHX(file); ERRNO_PROBE; #ifdef HAS_ZLIB if (!discard && FILE_STATE(file) == NYTP_FILE_DEFLATE) { const double ratio = file->zs.total_in / (double) file->zs.total_out; flush_output(file, Z_FINISH); fprintf(raw_file, "#\n" "# Compressed %lu bytes to %lu, ratio %f:1, data shrunk by %f%%\n", (long)file->zs.total_in, (long)file->zs.total_out, ratio, 100 * (1 - 1 / ratio)); } if (FILE_STATE(file) == NYTP_FILE_DEFLATE) { int status = deflateEnd(&(file->zs)); if (status != Z_OK) { if (discard && status == Z_DATA_ERROR) { /* deflateEnd returns Z_OK if success, Z_STREAM_ERROR if the stream state was inconsistent, Z_DATA_ERROR if the stream was freed prematurely (some input or output was discarded). */ } else { croak("deflateEnd failed, error %d (%s) in %d", status, file->zs.msg, getpid()); } } } else if (FILE_STATE(file) == NYTP_FILE_INFLATE) { int err = inflateEnd(&(file->zs)); if (err != Z_OK) { croak("inflateEnd failed, error %d (%s)", err, file->zs.msg); } } #endif Safefree(file); result = ferror(raw_file) ? errno : 0; if (discard) { /* close the underlying fd first so any buffered data gets discarded * when fclose is called below */ close(fileno(raw_file)); } if (result || discard) { /* Something has already gone wrong, so try to preserve its error */ fclose(raw_file); return result; } return fclose(raw_file) == 0 ? 0 : errno; } /* ====== Low-level element I/O functions ====== */ /** * Output an integer in bytes, optionally preceded by a tag. Use the special tag * NYTP_TAG_NO_TAG to suppress the tag output. A wrapper macro output_u32(fh, i) * does this for you. * "In bytes" means output the number in binary, using the least number of bytes * possible. All numbers are positive. Use sign slot as a marker */ static size_t output_tag_u32(NYTP_file file, unsigned char tag, U32 i) { U8 buffer[6]; U8 *p = buffer; if (tag != NYTP_TAG_NO_TAG) *p++ = tag; /* general case. handles all integers */ if (i < 0x80) { /* < 8 bits */ *p++ = (U8)i; } else if (i < 0x4000) { /* < 16 bits */ *p++ = (U8)((i >> 8) | 0x80); *p++ = (U8)i; } else if (i < 0x200000) { /* < 24 bits */ *p++ = (U8)((i >> 16) | 0xC0); *p++ = (U8)(i >> 8); *p++ = (U8)i; } else if (i < 0x10000000) { /* < 32 bits */ *p++ = (U8)((i >> 24) | 0xE0); *p++ = (U8)(i >> 16); *p++ = (U8)(i >> 8); *p++ = (U8)i; } else { /* need all the bytes. */ *p++ = 0xFF; *p++ = (U8)(i >> 24); *p++ = (U8)(i >> 16); *p++ = (U8)(i >> 8); *p++ = (U8)i; } return NYTP_write(file, buffer, p - buffer); } static size_t output_tag_i32(NYTP_file file, unsigned char tag, I32 i) { return output_tag_u32(file, tag, *( (U32*) &i ) ); } #define output_u32(fh, i) output_tag_u32((fh), NYTP_TAG_NO_TAG, (i)) #define output_i32(fh, i) output_tag_i32((fh), NYTP_TAG_NO_TAG, (i)) /** * Read an integer by decompressing the next 1 to 4 bytes of binary into a 32- * bit integer. See output_int() for the compression details. */ U32 read_u32(NYTP_file ifile) { unsigned char d; U32 newint; NYTP_read(ifile, &d, sizeof(d), "integer prefix"); if (d < 0x80) { /* < 8 bits */ newint = d; } else { unsigned char buffer[4]; unsigned char *p = buffer; unsigned int length; if (d < 0xC0) { /* < 16 bits */ newint = d & 0x7F; length = 1; } else if (d < 0xE0) { /* < 24 bits */ newint = d & 0x1F; length = 2; } else if (d < 0xFF) { /* < 32 bits */ newint = d & 0xF; length = 3; } else { /* d == 0xFF */ /* = 32 bits */ newint = 0; length = 4; } NYTP_read(ifile, buffer, length, "integer"); while (length--) { newint <<= 8; newint |= *p++; } } return newint; } I32 read_i32(NYTP_file ifile) { U32 u = read_u32(ifile); return *( (I32*)&u ); } static size_t output_str(NYTP_file file, const char *str, I32 len) { /* negative len signifies utf8 */ unsigned char tag = NYTP_TAG_STRING; size_t retval; size_t total; if (len < 0) { tag = NYTP_TAG_STRING_UTF8; len = -len; } total = retval = output_tag_u32(file, tag, len); if (retval <= 0) return retval; if (len) { total += retval = NYTP_write(file, str, len); if (retval <= 0) return retval; } return total; } /** * Output a double precision float via a simple binary write of the memory. * (Minor portbility issues are seen as less important than speed and space.) */ size_t output_nv(NYTP_file file, NV nv) { return NYTP_write(file, (unsigned char *)&nv, sizeof(NV)); } /** * Read an NV by simple byte copy to memory */ NV read_nv(NYTP_file ifile) { NV nv; /* no error checking on the assumption that a later token read will * detect the error/eof condition */ NYTP_read(ifile, (unsigned char *)&nv, sizeof(NV), "float"); return nv; } /* ====== Higher-level protocol I/O functions ====== */ size_t NYTP_write_header(NYTP_file ofile, U32 major, U32 minor) { return NYTP_printf(ofile, "NYTProf %u %u\n", major, minor); } size_t NYTP_write_comment(NYTP_file ofile, const char *format, ...) { size_t retval; size_t retval2; va_list args; ERRNO_PROBE; retval = NYTP_write(ofile, "#", 1); if (retval != 1) return retval; va_start(args, format); if(strEQ(format, "%s")) { const char * const s = va_arg(args, char*); STRLEN len = strlen(s); retval = NYTP_write(ofile, s, len); } else { CROAK_IF_NOT_STDIO(ofile, "NYTP_printf"); { dNFTHX(ofile); retval = vfprintf(ofile->file, format, args); } } va_end(args); retval2 = NYTP_write(ofile, "\n", 1); if (retval2 != 1) return retval2; return retval + 2; } static size_t NYTP_write_plain_kv(NYTP_file ofile, const char prefix, const char *key, size_t key_len, const char *value, size_t value_len) { size_t total; size_t retval; total = retval = NYTP_write(ofile, &prefix, 1); if (retval != 1) return retval; total += retval = NYTP_write(ofile, key, key_len); if (retval != key_len) return retval; total += retval = NYTP_write(ofile, "=", 1); if (retval != 1) return retval; total += retval = NYTP_write(ofile, value, value_len); if (retval != value_len) return retval; total += retval = NYTP_write(ofile, "\n", 1); if (retval != 1) return retval; return total; } size_t NYTP_write_attribute_string(NYTP_file ofile, const char *key, size_t key_len, const char *value, size_t value_len) { return NYTP_write_plain_kv(ofile, ':', key, key_len, value, value_len); } #ifndef CHAR_BIT # define CHAR_BIT 8 #endif #define LOG_2_OVER_LOG_10 0.30103 size_t NYTP_write_attribute_unsigned(NYTP_file ofile, const char *key, size_t key_len, unsigned long value) { /* 3: 1 for rounding errors, 1 for the '\0' */ char buffer[(int)(sizeof (unsigned long) * CHAR_BIT * LOG_2_OVER_LOG_10 + 3)]; const size_t len = my_snprintf(buffer, sizeof(buffer), "%lu", value); return NYTP_write_attribute_string(ofile, key, key_len, buffer, len); } size_t NYTP_write_attribute_signed(NYTP_file ofile, const char *key, size_t key_len, long value) { /* 3: 1 for rounding errors, 1 for the sign, 1 for the '\0' */ char buffer[(int)(sizeof (long) * CHAR_BIT * LOG_2_OVER_LOG_10 + 3)]; const size_t len = my_snprintf(buffer, sizeof(buffer), "%ld", value); return NYTP_write_attribute_string(ofile, key, key_len, buffer, len); } size_t NYTP_write_attribute_nv(NYTP_file ofile, const char *key, size_t key_len, NV value) { char buffer[NV_DIG+20]; /* see Perl_sv_2pv_flags */ const size_t len = my_snprintf(buffer, sizeof(buffer), "%"NVgf, value); return NYTP_write_attribute_string(ofile, key, key_len, buffer, len); } /* options */ size_t NYTP_write_option_pv(NYTP_file ofile, const char *key, const char *value, size_t value_len) { return NYTP_write_plain_kv(ofile, '!', key, strlen(key), value, value_len); } size_t NYTP_write_option_iv(NYTP_file ofile, const char *key, IV value) { /* 3: 1 for rounding errors, 1 for the sign, 1 for the '\0' */ char buffer[(int)(sizeof (IV) * CHAR_BIT * LOG_2_OVER_LOG_10 + 3)]; const size_t len = my_snprintf(buffer, sizeof(buffer), "%"IVdf, value); return NYTP_write_option_pv(ofile, key, buffer, len); } /* other */ #ifdef HAS_ZLIB size_t NYTP_start_deflate_write_tag_comment(NYTP_file ofile, int compression_level) { const unsigned char tag = NYTP_TAG_START_DEFLATE; size_t total; size_t retval; total = retval = NYTP_write_comment(ofile, "Compressed at level %d with zlib %s", compression_level, zlibVersion()); if (retval < 1) return retval; total += retval = NYTP_write(ofile, &tag, sizeof(tag)); if (retval < 1) return retval; NYTP_start_deflate(ofile, compression_level); return total; } #endif size_t NYTP_write_process_start(NYTP_file ofile, U32 pid, U32 ppid, NV time_of_day) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_PID_START, pid); if (retval < 1) return retval; total += retval = output_u32(ofile, ppid); if (retval < 1) return retval; total += retval = output_nv(ofile, time_of_day); if (retval < 1) return retval; return total; } size_t NYTP_write_process_end(NYTP_file ofile, U32 pid, NV time_of_day) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_PID_END, pid); if (retval < 1) return retval; total += retval = output_nv(ofile, time_of_day); if (retval < 1) return retval; return total; } size_t NYTP_write_sawampersand(NYTP_file ofile, U32 fid, U32 line) { size_t total; size_t retval; total = retval = NYTP_write_attribute_unsigned(ofile, STR_WITH_LEN("sawampersand_fid"), fid); if (retval < 1) return retval; total += retval = NYTP_write_attribute_unsigned(ofile, STR_WITH_LEN("sawampersand_line"), line); if (retval < 1) return retval; return total; } size_t NYTP_write_new_fid(NYTP_file ofile, U32 id, U32 eval_fid, U32 eval_line_num, U32 flags, U32 size, U32 mtime, const char *name, I32 len) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_NEW_FID, id); if (retval < 1) return retval; total += retval = output_u32(ofile, eval_fid); if (retval < 1) return retval; total += retval = output_u32(ofile, eval_line_num); if (retval < 1) return retval; total += retval = output_u32(ofile, flags); if (retval < 1) return retval; total += retval = output_u32(ofile, size); if (retval < 1) return retval; total += retval = output_u32(ofile, mtime); if (retval < 1) return retval; total += retval = output_str(ofile, name, len); if (retval < 1) return retval; return total; } static size_t write_time_common(NYTP_file ofile, unsigned char tag, I32 elapsed, U32 overflow, U32 fid, U32 line) { size_t total; size_t retval; if (overflow) { dNFTHX(ofile); /* XXX needs protocol change to output a new time-overflow tag */ fprintf(stderr, "profile time overflow of %lu seconds discarded!\n", (unsigned long)overflow); } total = retval = output_tag_i32(ofile, tag, elapsed); if (retval < 1) return retval; total += retval = output_u32(ofile, fid); if (retval < 1) return retval; total += retval = output_u32(ofile, line); if (retval < 1) return retval; return total; } size_t NYTP_write_time_block(NYTP_file ofile, I32 elapsed, U32 overflow, U32 fid, U32 line, U32 last_block_line, U32 last_sub_line) { size_t total; size_t retval; total = retval = write_time_common(ofile, NYTP_TAG_TIME_BLOCK, elapsed, overflow, fid, line); if (retval < 1) return retval; total += retval = output_u32(ofile, last_block_line); if (retval < 1) return retval; total += retval = output_u32(ofile, last_sub_line); if (retval < 1) return retval; return total; } size_t NYTP_write_time_line(NYTP_file ofile, I32 elapsed, U32 overflow, U32 fid, U32 line) { return write_time_common(ofile, NYTP_TAG_TIME_LINE, elapsed, overflow, fid, line); } size_t NYTP_write_call_entry(NYTP_file ofile, U32 caller_fid, U32 caller_line) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_ENTRY, caller_fid); if (retval < 1) return retval; total += retval = output_u32(ofile, caller_line); if (retval < 1) return retval; return total; } size_t NYTP_write_call_return(NYTP_file ofile, U32 prof_depth, const char *called_subname_pv, NV incl_subr_ticks, NV excl_subr_ticks) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_RETURN, prof_depth); if (retval < 1) return retval; total += retval = output_nv(ofile, incl_subr_ticks); if (retval < 1) return retval; total += retval = output_nv(ofile, excl_subr_ticks); if (retval < 1) return retval; if (!called_subname_pv) called_subname_pv = "(null)"; total += retval = output_str(ofile, called_subname_pv, strlen(called_subname_pv)); if (retval < 1) return retval; return total; } size_t NYTP_write_sub_info(NYTP_file ofile, U32 fid, const char *name, I32 len, U32 first_line, U32 last_line) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_INFO, fid); if (retval < 1) return retval; total += retval = output_str(ofile, name, (I32)len); if (retval < 1) return retval; total += retval = output_u32(ofile, first_line); if (retval < 1) return retval; total += retval = output_u32(ofile, last_line); if (retval < 1) return retval; if (retval < 1) return retval; return total; } size_t NYTP_write_sub_callers(NYTP_file ofile, U32 fid, U32 line, const char *caller_name, I32 caller_name_len, U32 count, NV incl_rtime, NV excl_rtime, NV reci_rtime, U32 depth, const char *called_name, I32 called_name_len) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_CALLERS, fid); if (retval < 1) return retval; total += retval = output_u32(ofile, line); if (retval < 1) return retval; total += retval = output_str(ofile, caller_name, caller_name_len); if (retval < 1) return retval; total += retval = output_u32(ofile, count); if (retval < 1) return retval; total += retval = output_nv(ofile, incl_rtime); if (retval < 1) return retval; total += retval = output_nv(ofile, excl_rtime); if (retval < 1) return retval; total += retval = output_nv(ofile, reci_rtime); if (retval < 1) return retval; total += retval = output_u32(ofile, depth); if (retval < 1) return retval; total += retval = output_str(ofile, called_name, called_name_len); if (retval < 1) return retval; return total; } size_t NYTP_write_src_line(NYTP_file ofile, U32 fid, U32 line, const char *text, I32 text_len) { size_t total; size_t retval; total = retval = output_tag_u32(ofile, NYTP_TAG_SRC_LINE, fid); if (retval < 1) return retval; total += retval = output_u32(ofile, line); if (retval < 1) return retval; total += retval = output_str(ofile, text, text_len); if (retval < 1) return retval; return total; } size_t NYTP_write_discount(NYTP_file ofile) { const unsigned char tag = NYTP_TAG_DISCOUNT; return NYTP_write(ofile, &tag, sizeof(tag)); } MODULE = Devel::NYTProf::FileHandle PACKAGE = Devel::NYTProf::FileHandle PREFIX = NYTP_ PROTOTYPES: DISABLE void open(pathname, mode) char *pathname char *mode PREINIT: NYTP_file fh = NYTP_open(pathname, mode); SV *object; PPCODE: if(!fh) XSRETURN(0); object = newSV(0); sv_usepvn(object, (char *) fh, sizeof(struct NYTP_file_t)); ST(0) = sv_bless(sv_2mortal(newRV_noinc(object)), gv_stashpvs("Devel::NYTProf::FileHandle", GV_ADD)); XSRETURN(1); int DESTROY(handle) NYTP_file handle ALIAS: close = 1 PREINIT: SV *guts; CODE: guts = SvRV(ST(0)); PERL_UNUSED_VAR(ix); RETVAL = NYTP_close(handle, 0); SvPV_set(guts, NULL); SvLEN_set(guts, 0); OUTPUT: RETVAL size_t write(handle, string) NYTP_file handle SV *string PREINIT: STRLEN len; char *p; CODE: p = SvPVbyte(string, len); RETVAL = NYTP_write(handle, p, len); OUTPUT: RETVAL #ifdef HAS_ZLIB void NYTP_start_deflate(handle, compression_level = 6) NYTP_file handle int compression_level void NYTP_start_deflate_write_tag_comment(handle, compression_level = 6) NYTP_file handle int compression_level #endif size_t NYTP_write_comment(handle, comment) NYTP_file handle char *comment CODE: RETVAL = NYTP_write_comment(handle, "%s", comment); OUTPUT: RETVAL size_t NYTP_write_attribute(handle, key, value) NYTP_file handle SV *key SV *value PREINIT: STRLEN key_len; const char *const key_p = SvPVbyte(key, key_len); STRLEN value_len; const char *const value_p = SvPVbyte(value, value_len); CODE: RETVAL = NYTP_write_attribute_string(handle, key_p, key_len, value_p, value_len); OUTPUT: RETVAL size_t NYTP_write_option(handle, key, value) NYTP_file handle SV *key SV *value PREINIT: STRLEN key_len; const char *const key_p = SvPVbyte(key, key_len); STRLEN value_len; const char *const value_p = SvPVbyte(value, value_len); CODE: RETVAL = NYTP_write_option_pv(handle, key_p, value_p, value_len); OUTPUT: RETVAL size_t NYTP_write_process_start(handle, pid, ppid, time_of_day) NYTP_file handle U32 pid U32 ppid NV time_of_day size_t NYTP_write_process_end(handle, pid, time_of_day) NYTP_file handle U32 pid NV time_of_day size_t NYTP_write_new_fid(handle, id, eval_fid, eval_line_num, flags, size, mtime, name) NYTP_file handle U32 id U32 eval_fid int eval_line_num U32 flags U32 size U32 mtime SV *name PREINIT: STRLEN len; const char *const p = SvPV(name, len); CODE: RETVAL = NYTP_write_new_fid(handle, id, eval_fid, eval_line_num, flags, size, mtime, p, SvUTF8(name) ? -(I32)len : (I32)len ); OUTPUT: RETVAL size_t NYTP_write_time_block(handle, elapsed, overflow, fid, line, last_block_line, last_sub_line) NYTP_file handle U32 elapsed U32 overflow U32 fid U32 line U32 last_block_line U32 last_sub_line size_t NYTP_write_time_line(handle, elapsed, overflow, fid, line) NYTP_file handle U32 elapsed U32 overflow U32 fid U32 line size_t NYTP_write_call_entry(handle, caller_fid, caller_line) NYTP_file handle U32 caller_fid U32 caller_line size_t NYTP_write_call_return(handle, prof_depth, called_subname_pv, incl_subr_ticks, excl_subr_ticks) NYTP_file handle U32 prof_depth const char *called_subname_pv NV incl_subr_ticks NV excl_subr_ticks size_t NYTP_write_sub_info(handle, fid, name, first_line, last_line) NYTP_file handle U32 fid SV *name U32 first_line U32 last_line PREINIT: STRLEN len; const char *const p = SvPV(name, len); CODE: RETVAL = NYTP_write_sub_info(handle, fid, p, SvUTF8(name) ? -(I32)len : (I32)len, first_line, last_line); OUTPUT: RETVAL size_t NYTP_write_sub_callers(handle, fid, line, caller, count, incl_rtime, excl_rtime, reci_rtime, depth, called_sub) NYTP_file handle U32 fid U32 line SV *caller U32 count NV incl_rtime NV excl_rtime NV reci_rtime U32 depth SV *called_sub PREINIT: STRLEN caller_len; const char *const caller_p = SvPV(caller, caller_len); STRLEN called_len; const char *const called_p = SvPV(called_sub, called_len); CODE: RETVAL = NYTP_write_sub_callers(handle, fid, line, caller_p, SvUTF8(caller) ? -(I32)caller_len : (I32)caller_len, count, incl_rtime, excl_rtime, reci_rtime, depth, called_p, SvUTF8(called_sub) ? -(I32)called_len : (I32)called_len); OUTPUT: RETVAL size_t NYTP_write_src_line(handle, fid, line, text) NYTP_file handle U32 fid U32 line SV *text PREINIT: STRLEN len; const char *const p = SvPV(text, len); CODE: RETVAL = NYTP_write_src_line(handle, fid, line, p, SvUTF8(text) ? -(I32)len : (I32)len); OUTPUT: RETVAL size_t NYTP_write_discount(handle) NYTP_file handle size_t NYTP_write_header(handle, major, minor) NYTP_file handle U32 major U32 minor Devel-NYTProf-6.06/FileHandle.h000644 000766 000024 00000014042 12523657114 016434 0ustar00timbostaff000000 000000 /* vim: ts=8 sw=4 expandtab: * ************************************************************************ * This file is part of the Devel::NYTProf package. * Copyright 2008 Adam J. Kaplan, The New York Times Company. * Copyright 2008 Tim Bunce, Ireland. * Released under the same terms as Perl 5.8 * See http://metacpan.org/release/Devel-NYTProf/ * * Contributors: * Adam Kaplan, akaplan at nytimes.com * Tim Bunce, http://www.tim.bunce.name and http://blog.timbunce.org * Steve Peters, steve at fisharerojo.org * * ************************************************************************ */ /* Arguably this header is naughty, as it's not self contained, because it assumes that stdlib.h has already been included (via perl.h) */ #if defined(PERL_IMPLICIT_SYS) && !defined(NO_XSLOCKS) /* on Win32 XSUB.h redirects stdio to PerlIO, interp context is then required */ # define NYTP_IO_dTHX dTHX # define NYTP_IO_NEEDS_THX #else # define NYTP_IO_dTHX dNOOP #endif typedef struct NYTP_file_t *NYTP_file; void NYTP_start_deflate(NYTP_file file, int compression_level); void NYTP_start_inflate(NYTP_file file); NYTP_file NYTP_open(const char *name, const char *mode); char *NYTP_gets(NYTP_file ifile, char **buffer, size_t *len); size_t NYTP_read_unchecked(NYTP_file ifile, void *buffer, size_t len); size_t NYTP_read(NYTP_file ifile, void *buffer, size_t len, const char *what); size_t NYTP_write(NYTP_file ofile, const void *buffer, size_t len); int NYTP_scanf(NYTP_file ifile, const char *format, ...); int NYTP_printf(NYTP_file ofile, const char *format, ...); int NYTP_flush(NYTP_file file); int NYTP_eof(NYTP_file ifile); long NYTP_tell(NYTP_file file); int NYTP_close(NYTP_file file, int discard); const char *NYTP_fstrerror(NYTP_file file); #ifdef HAS_ZLIB const char *NYTP_type_of_offset(NYTP_file file); #else # define NYTP_type_of_offset(file) "" #endif #define NYTP_TAG_NO_TAG '\0' /* Used as a flag to mean "no tag" */ #define NYTP_TAG_ATTRIBUTE ':' /* :name=value\n */ #define NYTP_TAG_OPTION '!' /* !name=value\n */ #define NYTP_TAG_COMMENT '#' /* till newline */ #define NYTP_TAG_TIME_BLOCK '*' #define NYTP_TAG_TIME_LINE '+' #define NYTP_TAG_DISCOUNT '-' #define NYTP_TAG_NEW_FID '@' #define NYTP_TAG_SRC_LINE 'S' /* fid, line, str */ #define NYTP_TAG_SUB_INFO 's' #define NYTP_TAG_SUB_CALLERS 'c' #define NYTP_TAG_PID_START 'P' #define NYTP_TAG_PID_END 'p' #define NYTP_TAG_STRING '\'' #define NYTP_TAG_STRING_UTF8 '"' #define NYTP_TAG_START_DEFLATE 'z' #define NYTP_TAG_SUB_ENTRY '>' #define NYTP_TAG_SUB_RETURN '<' /* also add new items to nytp_tax_index below */ typedef enum { /* XXX keep in sync with various *_callback strucures */ nytp_no_tag, nytp_version, /* Not actually a tag, but needed by the perl callback */ nytp_attribute, nytp_option, nytp_comment, nytp_time_block, nytp_time_line, nytp_discount, nytp_new_fid, nytp_src_line, nytp_sub_info, nytp_sub_callers, nytp_pid_start, nytp_pid_end, nytp_string, nytp_string_utf8, nytp_start_deflate, nytp_sub_entry, nytp_sub_return, nytp_tag_max /* keep last */ } nytp_tax_index; void NYTProf_croak_if_not_stdio(NYTP_file file, const char *function); size_t NYTP_write_header(NYTP_file ofile, U32 major, U32 minor); size_t NYTP_write_comment(NYTP_file ofile, const char *format, ...); size_t NYTP_write_attribute_string(NYTP_file ofile, const char *key, size_t key_len, const char *value, size_t value_len); size_t NYTP_write_attribute_signed(NYTP_file ofile, const char *key, size_t key_len, long value); size_t NYTP_write_attribute_unsigned(NYTP_file ofile, const char *key, size_t key_len, unsigned long value); size_t NYTP_write_attribute_nv(NYTP_file ofile, const char *key, size_t key_len, NV value); size_t NYTP_write_option_pv(NYTP_file ofile, const char *key, const char *value, size_t value_len); size_t NYTP_write_option_iv(NYTP_file ofile, const char *key, IV value); size_t NYTP_start_deflate_write_tag_comment(NYTP_file ofile, int compression_level); size_t NYTP_write_process_start(NYTP_file ofile, U32 pid, U32 ppid, NV time_of_day); size_t NYTP_write_process_end(NYTP_file ofile, U32 pid, NV time_of_day); size_t NYTP_write_sawampersand(NYTP_file ofile, U32 fid, U32 line); size_t NYTP_write_new_fid(NYTP_file ofile, U32 id, U32 eval_fid, U32 eval_line_num, U32 flags, U32 size, U32 mtime, const char *name, I32 len); size_t NYTP_write_time_block(NYTP_file ofile, I32 elapsed, U32 overflow, U32 fid, U32 line, U32 last_block_line, U32 last_sub_line); size_t NYTP_write_time_line(NYTP_file ofile, I32 elapsed, U32 overflow, U32 fid, U32 line); size_t NYTP_write_sub_info(NYTP_file ofile, U32 fid, const char *name, I32 len, U32 first_line, U32 last_line); size_t NYTP_write_sub_callers(NYTP_file ofile, U32 fid, U32 line, const char *caller_name, I32 caller_name_len, U32 count, NV incl_rtime, NV excl_rtime, NV reci_rtime, U32 depth, const char *called_name, I32 called_name_len); size_t NYTP_write_src_line(NYTP_file ofile, U32 fid, U32 line, const char *text, I32 text_len); size_t NYTP_write_discount(NYTP_file ofile); size_t NYTP_write_call_entry(NYTP_file ofile, U32 caller_fid, U32 caller_line); size_t NYTP_write_call_return(NYTP_file ofile, U32 prof_depth, const char *called_subname_pv, NV incl_subr_ticks, NV excl_subr_ticks); /* XXX * On the write-side the functions above encapsulate the data format. * On the read-side we've not got that far yet (and there's less need). */ U32 read_u32(NYTP_file ifile); I32 read_i32(NYTP_file ifile); NV read_nv(NYTP_file ifile); Devel-NYTProf-6.06/ppport.h000644 000766 000024 00000605530 13015654276 016000 0ustar00timbostaff000000 000000 #if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- ppport.h -- Perl/Pollution/Portability Version 3.35 Automatically created by Devel::PPPort running under perl 5.022002. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME ppport.h - Perl/Pollution/Portability version 3.35 =head1 SYNOPSIS perl ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.20. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagically add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl ppport.h --list-provided to see which API elements are provided by ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL SvRX() NEED_SvRX NEED_SvRX_GLOBAL caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl ppport.h --copy=.new To display portability information for the C function, use: perl ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report here: L Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.35; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( ASCII_TO_NEED||5.007001|n AvFILLp|5.004050||p AvFILL||| BhkDISABLE||5.024000| BhkENABLE||5.024000| BhkENTRY_set||5.024000| BhkENTRY||| BhkFLAGS||| CALL_BLOCK_HOOKS||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| C_ARRAY_END|5.013002||p C_ARRAY_LENGTH|5.008001||p CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002|5.004050|p Copy||| CvPADLIST||5.008001| CvSTASH||| CvWEAKOUTSIDE||| DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n DEFSV_set|5.010001||p DEFSV|5.004050||p DO_UTF8||5.006000| END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvAV||| GvCV||| GvHV||| GvSV||| Gv_AMupdate||5.011000| HEf_SVKEY|5.003070||p HeHASH||5.003070| HeKEY||5.003070| HeKLEN||5.003070| HePV||5.004000| HeSVKEY_force||5.003070| HeSVKEY_set||5.004000| HeSVKEY||5.003070| HeUTF8|5.010001|5.008000|p HeVAL||5.003070| HvENAMELEN||5.015004| HvENAMEUTF8||5.015004| HvENAME||5.013007| HvNAMELEN_get|5.009003||p HvNAMELEN||5.015004| HvNAMEUTF8||5.015004| HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LINKLIST||5.013006| LVRET||| MARK||| MULTICALL||5.024000| MUTABLE_PTR|5.010001||p MUTABLE_SV|5.010001||p MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002|5.004050|p Move||| NATIVE_TO_NEED||5.007001|n NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| OP_CLASS||5.013007| OP_DESC||5.007003| OP_NAME||5.007003| OP_TYPE_IS_OR_WAS||5.019010| OP_TYPE_IS||5.019007| ORIGMARK||| OpHAS_SIBLING|5.021007||p OpLASTSIB_set|5.021011||p OpMAYBESIB_set|5.021011||p OpMORESIB_set|5.021011||p OpSIBLING|5.021007||p PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.024000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.003070||p PERL_INT_MAX|5.003070||p PERL_INT_MIN|5.003070||p PERL_LONG_MAX|5.003070||p PERL_LONG_MIN|5.003070||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.024000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.024000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.024000||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.024000||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.003070||p PERL_QUAD_MIN|5.003070||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.003070||p PERL_SHORT_MIN|5.003070||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.024000| PERL_UCHAR_MAX|5.003070||p PERL_UCHAR_MIN|5.003070||p PERL_UINT_MAX|5.003070||p PERL_UINT_MIN|5.003070||p PERL_ULONG_MAX|5.003070||p PERL_ULONG_MIN|5.003070||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_RESULT|5.021001||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.003070||p PERL_UQUAD_MIN|5.003070||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.003070||p PERL_USHORT_MIN|5.003070||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.024000||p PL_bufptr|5.024000||p PL_check||5.006000| PL_compiling|5.004050||p PL_comppad_name||5.017004| PL_comppad||5.008001| PL_copline|5.024000||p PL_curcop|5.004050||p PL_curpad||5.005000| PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.024000||p PL_expect|5.024000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.024000||p PL_in_my|5.024000||p PL_keyword_plugin||5.011002| PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.024000||p PL_lex_stuff|5.024000||p PL_linestr|5.024000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_opfreehook||5.011000|n PL_parser|5.009005||p PL_peepp||5.007003|n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rpeepp||5.013005|n PL_rsfp_filters|5.024000||p PL_rsfp|5.024000||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.024000||p POP_MULTICALL||5.024000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n POPul||5.006000|n POPu||5.004000|n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.024000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PadARRAY||5.024000| PadMAX||5.024000| PadlistARRAY||5.024000| PadlistMAX||5.024000| PadlistNAMESARRAY||5.024000| PadlistNAMESMAX||5.024000| PadlistNAMES||5.024000| PadlistREFCNT||5.017004| PadnameIsOUR||| PadnameIsSTATE||| PadnameLEN||5.024000| PadnameOURSTASH||| PadnameOUTER||| PadnamePV||5.024000| PadnameREFCNT_dec||5.024000| PadnameREFCNT||5.024000| PadnameSV||5.024000| PadnameTYPE||| PadnameUTF8||5.021007| PadnamelistARRAY||5.024000| PadnamelistMAX||5.024000| PadnamelistREFCNT_dec||5.024000| PadnamelistREFCNT||5.024000| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_restore_errno||| PerlIO_save_errno||| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p READ_XDIGIT||5.017006| RESTORE_LC_NUMERIC||5.024000| RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STORE_LC_NUMERIC_FORCE_TO_UNDERLYING||5.024000| STORE_LC_NUMERIC_SET_TO_NEEDED||5.024000| STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_INVLIST||5.019002| SVt_IV||| SVt_NULL||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVFM||| SVt_PVGV||| SVt_PVHV||| SVt_PVIO||| SVt_PVIV||| SVt_PVLV||| SVt_PVMG||| SVt_PVNV||| SVt_PV||| SVt_REGEXP||5.011000| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_ro||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_nomg||5.013002| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg_nolen|5.013007||p SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec_NN||5.017007| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK|5.009005||p SvRX|5.009005||p SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTHINKFIRST||| SvTRUE_nomg||5.013006| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8SKIP||5.006000| UTF8_MAXBYTES|5.009002||p UVCHR_SKIP||5.022000| UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.024000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p WIDEST_UTYPE|5.015004||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_APIVERSION_BOOTCHECK||5.024000| XS_EXTERNAL||5.024000| XS_INTERNAL||5.024000| XS_VERSION_BOOTCHECK||5.024000| XS_VERSION||| XSprePUSH|5.006000||p XS||| XopDISABLE||5.024000| XopENABLE||5.024000| XopENTRYCUSTOM||5.024000| XopENTRY_set||5.024000| XopENTRY||5.024000| XopFLAGS||5.013007| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _add_range_to_invlist||| _append_range_to_invlist||| _core_swash_init||| _get_encoding||| _get_regclass_nonbitmap_data||| _get_swash_invlist||| _invlistEQ||| _invlist_array_init|||n _invlist_contains_cp|||n _invlist_dump||| _invlist_intersection_maybe_complement_2nd||| _invlist_intersection||| _invlist_invert||| _invlist_len|||n _invlist_populate_swatch|||n _invlist_search|||n _invlist_subtract||| _invlist_union_maybe_complement_2nd||| _invlist_union||| _is_cur_LC_category_utf8||| _is_in_locale_category||5.021001| _is_uni_FOO||5.017008| _is_uni_perl_idcont||5.017008| _is_uni_perl_idstart||5.017007| _is_utf8_FOO||5.017008| _is_utf8_char_slow||5.021001|n _is_utf8_idcont||5.021001| _is_utf8_idstart||5.021001| _is_utf8_mark||5.017008| _is_utf8_perl_idcont||5.017008| _is_utf8_perl_idstart||5.017007| _is_utf8_xidcont||5.021001| _is_utf8_xidstart||5.021001| _load_PL_utf8_foldclosures||| _make_exactf_invlist||| _new_invlist_C_array||| _new_invlist||| _pMY_CXT|5.007003||p _setlocale_debug_string|||n _setup_canned_invlist||| _swash_inversion_hash||| _swash_to_invlist||| _to_fold_latin1||| _to_uni_fold_flags||5.014000| _to_upper_title_latin1||| _to_utf8_case||| _to_utf8_fold_flags||5.019009| _to_utf8_lower_flags||5.019009| _to_utf8_title_flags||5.019009| _to_utf8_upper_flags||5.019009| _warn_problematic_locale|||n aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.024000||p aTHXR|5.024000||p aTHX_|5.006000||p aTHX|5.006000||p add_above_Latin1_folds||| add_cp_to_invlist||| add_data|||n add_multi_match||| add_utf16_textfilter||| adjust_size_and_find_bucket|||n advance_one_LB||| advance_one_SB||| advance_one_WB||| alloc_maybe_populate_EXACT||| alloccopstash||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_deref_call||5.013007| amagic_i_ncmp||| amagic_is_enabled||| amagic_ncmp||| anonymise_cv_maybe||| any_dup||| ao||| append_utf8_from_native_byte||5.019004|n apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| assert_uft8_cache_coherent||| assignment_type||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend_guts||| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_tindex||5.017009| av_top_index||5.017009| av_undef||| av_unshift||| ax|||n backup_one_LB||| backup_one_SB||| backup_one_WB||| bad_type_gv||| bad_type_pv||| bind_match||| block_end||5.004000| block_gimme||5.004000| block_start||5.004000| blockhook_register||5.013003| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_cmp_utf8||5.013007| bytes_from_utf8||5.007001| bytes_to_utf8||5.006001| cBOOL|5.013000||p call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p caller_cx|5.013005|5.006000|p calloc||5.007002|n cando||| cast_i32||5.006000|n cast_iv||5.006000|n cast_ulong||5.006000|n cast_uv||5.006000|n check_locale_boundary_crossing||| check_type_and_open||| check_uni||| check_utf8_print||| checkcomma||| ckWARN|5.006000||p ck_entersub_args_core||| ck_entersub_args_list||5.013006| ck_entersub_args_proto_or_list||5.013006| ck_entersub_args_proto||5.013006| ck_warner_d||5.011001|v ck_warner||5.011001|v ckwarn_common||| ckwarn_d||5.009003| ckwarn||5.009003| clear_defarray||5.023008| clear_placeholders||| clear_special_blocks||| clone_params_del|||n clone_params_new|||n closest_cop||| cntrl_to_mnemonic|||n compute_EXACTish|||n construct_ahocorasick_from_trie||| cop_fetch_label||5.015001| cop_free||| cop_hints_2hv||5.013007| cop_hints_fetch_pvn||5.013007| cop_hints_fetch_pvs||5.013007| cop_hints_fetch_pv||5.013007| cop_hints_fetch_sv||5.013007| cop_store_label||5.015001| cophh_2hv||5.013007| cophh_copy||5.013007| cophh_delete_pvn||5.013007| cophh_delete_pvs||5.013007| cophh_delete_pv||5.013007| cophh_delete_sv||5.013007| cophh_fetch_pvn||5.013007| cophh_fetch_pvs||5.013007| cophh_fetch_pv||5.013007| cophh_fetch_sv||5.013007| cophh_free||5.013007| cophh_new_empty||5.024000| cophh_store_pvn||5.013007| cophh_store_pvs||5.013007| cophh_store_pv||5.013007| cophh_store_sv||5.013007| core_prototype||| coresub_op||| cr_textfilter||| create_eval_scope||| croak_memory_wrap||5.019003|n croak_no_mem|||n croak_no_modify||5.013003|n croak_nocontext|||vn croak_popstack|||n croak_sv||5.013001| croak_xs_usage||5.010001|n croak|||v csighandler||5.009003|n current_re_engine||| curse||| custom_op_desc||5.007003| custom_op_get_field||| custom_op_name||5.007003| custom_op_register||5.013007| custom_op_xop||5.013007| cv_ckproto_len_flags||| cv_clone_into||| cv_clone||| cv_const_sv_or_av|||n cv_const_sv||5.003070|n cv_dump||| cv_forget_slab||| cv_get_call_checker||5.013006| cv_name||5.021005| cv_set_call_checker_flags||5.021004| cv_set_call_checker||5.013006| cv_undef_flags||| cv_undef||| cvgv_from_hek||| cvgv_set||| cvstash_set||| cx_dump||5.005000| cx_dup||| cx_popblock||5.023008| cx_popeval||5.023008| cx_popformat||5.023008| cx_popgiven||5.023008| cx_poploop||5.023008| cx_popsub_args||5.023008| cx_popsub_common||5.023008| cx_popsub||5.023008| cx_popwhen||5.023008| cx_pushblock||5.023008| cx_pusheval||5.023008| cx_pushformat||5.023008| cx_pushgiven||5.023008| cx_pushloop_for||5.023008| cx_pushloop_plain||5.023008| cx_pushsub||5.023008| cx_pushwhen||5.023008| cx_topblock||5.023008| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.024000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v defelem_target||| del_sv||| delete_eval_scope||| delimcpy||5.004000|n deprecate_commaless_var_list||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_sv||5.013001| die_unwind||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_close||| do_delete_local||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_ncmp||| do_oddball||| do_op_dump||5.006000| do_open6||| do_open9||5.006000| do_open_raw||| do_openn||5.007001| do_open||5.003070| do_pmop_dump||5.006000| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval_compile||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogivenfor||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| drand48_init_r|||n drand48_r|||n dtrace_probe_call||| dtrace_probe_load||| dtrace_probe_op||| dtrace_probe_phase||| dump_all_perl||| dump_all||5.006000| dump_c_backtrace||| dump_eval||5.006000| dump_exec_pos||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs_perl||| dump_packsubs||5.006000| dump_sub_perl||| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| edit_distance|||n emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| finalize_optree||| finalize_op||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_default_stash||| find_hash_subscript||| find_in_my_stash||| find_lexical_cv||| find_runcv_where||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_rundefsv||5.013002| find_script||| find_uninit_var||| first_symbol|||n fixup_errno_string||| foldEQ_latin1||5.013008|n foldEQ_locale||5.013002|n foldEQ_utf8_flags||5.013010| foldEQ_utf8||5.013002| foldEQ||5.013002|n fold_constants||| forbid_setid||| force_ident_maybe_lex||| force_ident||| force_list||| force_next||| force_strict_version||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form_short_octal_warning||| form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_c_backtrace||| free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_ANYOF_cp_list_for_ssc||| get_and_check_backslash_N_name||| get_aux_mg||| get_av|5.006000||p get_c_backtrace_dump||| get_c_backtrace||| get_context||5.006000|n get_cvn_flags||| get_cvs|5.011000||p get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_invlist_iter_addr|||n get_invlist_offset_addr|||n get_invlist_previous_index_addr|||n get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| gp_dup||| gp_free||| gp_ref||| grok_atoUV|||n grok_bin|5.007003||p grok_bslash_N||| grok_bslash_c||| grok_bslash_o||| grok_bslash_x||| grok_hex|5.007003||p grok_infnan||5.021004| grok_number_flags||5.021002| grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_add_by_type||5.011000| gv_autoload4||5.004000| gv_autoload_pvn||5.015004| gv_autoload_pv||5.015004| gv_autoload_sv||5.015004| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.003070| gv_efullname4||5.006001| gv_efullname||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmeth_internal||| gv_fetchmeth_pv_autoload||5.015004| gv_fetchmeth_pvn_autoload||5.015004| gv_fetchmeth_pvn||5.015004| gv_fetchmeth_pv||5.015004| gv_fetchmeth_sv_autoload||5.015004| gv_fetchmeth_sv||5.015004| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_pv_flags||5.015004| gv_fetchmethod_pvn_flags||5.015004| gv_fetchmethod_sv_flags||5.015004| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||| gv_fullname3||5.003070| gv_fullname4||5.006001| gv_fullname||| gv_handler||5.007001| gv_init_pvn||| gv_init_pv||5.015004| gv_init_svtype||| gv_init_sv||5.015004| gv_init||| gv_is_in_main||| gv_magicalize_isa||| gv_magicalize||| gv_name_set||5.009004| gv_override||| gv_setref||| gv_stashpvn_internal||| gv_stashpvn|5.003070||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsvpvn_cached||| gv_stashsv||| gv_try_downgrade||| handle_named_backref||| handle_possible_posix||| handle_regex_sets||| he_dup||| hek_dup||| hfree_next_entry||| hfreeentries||| hsplit||| hv_assert||| hv_auxinit_internal|||n hv_auxinit||| hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||5.009004| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.003070| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_ename_add||| hv_ename_delete||| hv_exists_ent||5.003070| hv_exists||| hv_fetch_ent||5.003070| hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent_ret||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.003070| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.003070| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||| hv_placeholders_set||5.009003| hv_rand_set||5.018000| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.003070| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef_flags||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_constants||| init_dbargs||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| inplace_aassign||| instr|||n intro_my||5.004000| intuit_method||| intuit_more||| invert||| invlist_array|||n invlist_clear||| invlist_clone||| invlist_contents||| invlist_extend||| invlist_highest|||n invlist_is_iterating|||n invlist_iterfinish|||n invlist_iterinit|||n invlist_iternext|||n invlist_max|||n invlist_previous_index|||n invlist_replace_list_destroys_src||| invlist_set_len||| invlist_set_previous_index|||n invlist_trim|||n invoke_exception_hook||| io_close||| isALNUMC|5.006000||p isALNUM_lazy||5.021001| isALPHANUMERIC||5.017008| isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isFOO_lc||| isFOO_utf8_lc||| isGCB|||n isGRAPH|5.006000||p isIDCONT||5.017008| isIDFIRST_lazy||5.021001| isIDFIRST||| isLB||| isLOWER||| isOCTAL||5.013005| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSB||| isSPACE||| isUPPER||| isUTF8_CHAR||5.021001| isWB||| isWORDCHAR||5.013006| isXDIGIT|5.006000||p is_an_int||| is_ascii_string||5.011000| is_handle_constructor|||n is_invariant_string||5.021007|n is_lvalue_sub||5.007001| is_safe_syscall||5.019004| is_ssc_worth_it|||n is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.017007| is_uni_alnumc||5.017007| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_blank_lc||5.017002| is_uni_blank||5.017002| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.017007| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_blank||5.017002| is_utf8_char_buf||5.015008|n is_utf8_char||5.006000|n is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_perl_space||5.011001| is_utf8_perl_word||5.011001| is_utf8_posix_digit||5.011001| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003|n is_utf8_string_loc||5.008001|n is_utf8_string||5.006001|n is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| is_utf8_xidcont||5.013010| is_utf8_xidfirst||5.013010| isa_lookup||| isinfnansv||| isinfnan||5.021004|n items|||n ix|||n jmaybe||| join_exact||| keyword_plugin_standard||| keyword||| leave_adjust_stacks||5.023008| leave_scope||| lex_bufutf8||5.011002| lex_discard_to||5.011002| lex_grow_linestr||5.011002| lex_next_chunk||5.011002| lex_peek_unichar||5.011002| lex_read_space||5.011002| lex_read_to||5.011002| lex_read_unichar||5.011002| lex_start||5.009005| lex_stuff_pvn||5.011002| lex_stuff_pvs||5.013005| lex_stuff_pv||5.013006| lex_stuff_sv||5.011002| lex_unstuff||5.011002| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.010001||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.010001||p mXPUSHu|5.009002||p magic_clear_all_env||| magic_cleararylen_p||| magic_clearenv||| magic_clearhints||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_copycallchecker||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdebugvar||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_methcall1||| magic_methcall|||v magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdebugvar||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setlvref||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||5.021001| matcher_matches_sv||| maybe_multimagic_gv||| mayberelocate||| measure_struct||| memEQs|5.009005||p memEQ|5.004000||p memNEs|5.009005||p memNE|5.004000||p mem_collxfrm||| mem_log_alloc|||n mem_log_common|||n mem_log_free|||n mem_log_realloc|||n mess_alloc||| mess_nocontext|||vn mess_sv||5.013001| mess||5.006000|v mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find_mglob||| mg_findext|5.013008||pn mg_find|||n mg_free_type||5.013006| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical|||n mg_set||| mg_size||5.005000| mini_mktime||5.007002|n minus_v||| missingterm||| mode_from_discipline||| modkids||| more_bodies||| more_sv||| moreswitches||| move_proto_attr||| mro_clean_isarev||| mro_gather_and_rename||| mro_get_from_name||5.010001| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.010001| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_package_moved||| mro_register||5.010001| mro_set_mro||5.010001| mro_set_private_data||5.010001| mul128||| mulexp10|||n multideref_stringify||| my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy||5.004050|n my_bytes_to_utf8|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005|n my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_kid||| my_lstat_flags||| my_lstat||5.024000| my_memcmp|||n my_memset|||n my_pclose||5.003070| my_popen_list||5.007001| my_popen||5.003070| my_setenv||| my_setlocale||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat_flags||| my_stat||5.024000| my_strerror||5.021001| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB_x||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB_flags||5.015006| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||5.021006| newFORM||| newFOROP||5.013007| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen_flags||5.015004| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMETHOP_internal||| newMETHOP_named||5.021005| newMETHOP||5.021005| newMYSUB||5.017004| newNULLLIST||| newOP||| newPADNAMELIST||5.021007|n newPADNAMEouter||5.021007|n newPADNAMEpvn||5.021007|n newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSTUB||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVavdefelem||| newSVhek||5.009003| newSViv||| newSVnv||| newSVpadname||5.017004| newSVpv_share||5.013006| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.010001||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.010001||p newSVpvn|5.004050||p newSVpvs_flags|5.010001||p newSVpvs_share|5.009003||p newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newUNOP_AUX||5.021007| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.013007| newXS_deffile||| newXS_flags||5.009004| newXS_len_flags||| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr|||n no_bareword_allowed||| no_fh_allowed||| no_op||| noperl_die|||vn not_a_number||| not_incrementable||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n oopsAV||| oopsHV||| op_append_elem||5.013006| op_append_list||5.013006| op_clear||| op_contextualize||5.013006| op_convert_list||5.021006| op_dump||5.006000| op_free||| op_integerize||| op_linklist||5.013006| op_lvalue_flags||| op_lvalue||5.013007| op_null||5.007002| op_parent|||n op_prepend_elem||5.013006| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_relocate_sv||| op_scope||5.013007| op_sibling_splice||5.021002|n op_std_init||| op_unscope||| open_script||| openn_cleanup||| openn_setup||| opmethod_stash||| opslab_force_free||| opslab_free_nopad||| opslab_free||| output_or_return_posix_warnings||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package_version||| package||| packlist||5.008001| pad_add_anon||5.008001| pad_add_name_pvn||5.015001| pad_add_name_pvs||5.015001| pad_add_name_pv||5.015001| pad_add_name_sv||5.015001| pad_add_weakref||| pad_alloc_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||5.009003| pad_findlex||| pad_findmy_pvn||5.015001| pad_findmy_pvs||5.015001| pad_findmy_pv||5.015001| pad_findmy_sv||5.015001| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||5.008001| pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| pad_tidy||5.008001| padlist_dup||| padlist_store||| padname_dup||| padname_free||| padnamelist_dup||| padnamelist_fetch||5.021007|n padnamelist_free||| padnamelist_store||5.021007| parse_arithexpr||5.013008| parse_barestmt||5.013007| parse_block||5.013007| parse_body||| parse_fullexpr||5.013008| parse_fullstmt||5.013005| parse_gv_stash_name||| parse_ident||| parse_label||5.013007| parse_listexpr||5.013008| parse_lparen_question_flags||| parse_stmtseq||5.013006| parse_subsignature||| parse_termexpr||5.013008| parse_unicode_opts||| parser_dup||| parser_free_nexttoke_ops||| parser_free||| path_is_searchable|||n peep||| pending_ident||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmop_dump||5.006000| pmruntime||| pmtrans||| pop_scope||| populate_ANYOF_from_invlist||| populate_isa|||v pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prescan_version||5.011004| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_hash|||n ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_charclass_bitmap_innards_common||| put_charclass_bitmap_innards_invlist||| put_charclass_bitmap_innards||| put_code_point||| put_range||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| quadmath_format_needed|||n quadmath_format_single|||n re_compile||5.009005| re_croak2||| re_dup_guts||| re_exec_indentf|||v re_indentf|||v re_intuit_start||5.019001| re_intuit_string||5.006000| re_op_compile||| re_printf|||v realloc||5.007002|n reentrant_free||5.024000| reentrant_init||5.024000| reentrant_retry||5.024000|vn reentrant_size||5.024000| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch_pvn||| refcounted_he_fetch_pvs||| refcounted_he_fetch_pv||| refcounted_he_fetch_sv||| refcounted_he_free||| refcounted_he_inc||| refcounted_he_new_pvn||| refcounted_he_new_pvs||| refcounted_he_new_pv||| refcounted_he_new_sv||| refcounted_he_value||| refkids||| refto||| ref||5.024000| reg2Lanode||| reg_check_named_buff_matched|||n reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment|||n reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump_intflags||| regdump||5.005000| regdupe_internal||| regex_set_precedence|||n regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regnode_guts||| regpiece||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reg||| repeatcpy|||n report_evil_fh||| report_redefined_cv||| report_uninit||| report_wrongway_fh||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr|||n rpeep||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rv2cv_op_cv||5.013006| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem_flags||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hdelete||5.011000| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||5.010001| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic_flags||| save_mortalizesv||5.007001| save_nogv||| save_op||5.005000| save_padsv_and_mortalize||5.010001| save_pptr||| save_pushi32ptr||5.010001| save_pushptri32ptr||| save_pushptrptr||5.010001| save_pushptr||5.010001| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_strlen||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpvs||5.013006| savesharedpv||5.007003| savesharedsvpv||5.013006| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| savetmps||5.023008| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| search_const||| seed||5.008001| sequence_num||| set_ANYOF_arg||| set_caret_X||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| set_padlist|||n setdefout||| share_hek_flags||| share_hek||5.004000| should_warn_nl|||n si_dup||| sighandler|||n simplify_sort||| skip_to_be_ignored_text||| skipspace_flags||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| ssc_add_range||| ssc_and||| ssc_anything||| ssc_clear_locale|||n ssc_cp_and||| ssc_finalize||| ssc_init||| ssc_intersection||| ssc_is_anything|||n ssc_is_cp_posixl_init|||n ssc_or||| ssc_union||| stack_grow||| start_glob||| start_subparse||5.004000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool_flags||5.013006| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv_flags||5.013001| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff|||n sv_bless||| sv_buf_to_ro||| sv_buf_to_rw||| sv_cat_decode||5.008001| sv_catpv_flags||5.013006| sv_catpv_mg|5.004050||p sv_catpv_nomg||5.013006| sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs_flags||5.013006| sv_catpvs_mg||5.013006| sv_catpvs_nomg||5.013006| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_flags||5.013006| sv_cmp_locale_flags||5.013006| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm_flags||5.013006| sv_collxfrm||| sv_copypv_flags||5.017002| sv_copypv_nomg||5.017002| sv_copypv||| sv_dec_nomg||5.013002| sv_dec||| sv_del_backref||| sv_derived_from_pvn||5.015004| sv_derived_from_pv||5.015004| sv_derived_from_sv||5.015004| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_display||| sv_does_pvn||5.015004| sv_does_pv||5.015004| sv_does_sv||5.015004| sv_does||5.009004| sv_dump||| sv_dup_common||| sv_dup_inc_multiple||| sv_dup_inc||| sv_dup||| sv_eq_flags||5.013006| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_get_backrefs||5.021008|n sv_gets||5.003070| sv_grow||| sv_i_ncmp||| sv_inc_nomg||5.013002| sv_inc||| sv_insert_flags||5.010001| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8_nomg||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.024000|5.004000|p sv_magicext_mglob||| sv_magicext||5.007003| sv_magic||| sv_mortalcopy_flags||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_only_taint_gmagic|||n sv_or_pv_pos_u2b||| sv_peek||5.005000| sv_pos_b2u_flags||5.019003| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_flags||5.011005| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_ref||5.015004| sv_replace||| sv_report_used||| sv_resetpvn||| sv_reset||| sv_rvweaken||5.006000| sv_sethek||| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs_mg||5.013006| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pvs||5.024000| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagicext|5.013008||p sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn_flags||5.017002| sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p svtype||| swallow_bom||| swash_fetch||5.007002| swash_init||5.006000| swash_scan_list_line||| swatch_get||| sync_locale||5.021004| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tied_method|||v tmps_grow_p||| toFOLD_utf8||5.019001| toFOLD_uvchr||5.023009| toFOLD||5.019001| toLOWER_L1||5.019001| toLOWER_LC||5.004000| toLOWER_utf8||5.015007| toLOWER_uvchr||5.023009| toLOWER||| toTITLE_utf8||5.015007| toTITLE_uvchr||5.023009| toTITLE||5.019001| toUPPER_utf8||5.015007| toUPPER_uvchr||5.023009| toUPPER||| to_byte_substr||| to_lower_latin1|||n to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.015007| to_utf8_lower||5.015007| to_utf8_substr||| to_utf8_title||5.015007| to_utf8_upper||5.015007| tokenize_use||| tokeq||| tokereport||| too_few_arguments_pv||| too_many_arguments_pv||| translate_substr_offsets|||n try_amagic_bin||| try_amagic_un||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unreferenced_to_tmp_stack||| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.003070| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000|n utf8_length||5.007001| utf8_mg_len_cache_update||| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr_buf||5.015009| utf8_to_uvchr||5.007001| utf8_to_uvuni_buf||5.015009| utf8_to_uvuni||5.007001| utf8n_to_uvchr||5.007001| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||5.007001| uvoffuni_to_utf8_flags||5.019004| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| valid_utf8_to_uvchr||5.015009| valid_utf8_to_uvuni||5.015009| validate_proto||| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warn_sv||5.013001| warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v was_lvalue_sub||| watch||| whichsig_pvn||5.015004| whichsig_pv||5.015004| whichsig_sv||5.015004| whichsig||| win32_croak_not_implemented|||n with_queued_errors||| wrap_op_checker||5.015008| write_to_stderr||| xs_boot_epilog||| xs_handshake|||vn xs_version_bootcheck||| yyerror_pvn||| yyerror_pv||| yyerror||| yylex||| yyparse||| yyunlex||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef LONGSIZE # define LONGSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef LONGSIZE # define LONGSIZE 4 #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs # define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef cBOOL # define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) #endif #ifndef OpHAS_SIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #endif #ifndef OpSIBLING # define OpSIBLING(o) (0 + (o)->op_sibling) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #endif #ifndef OpMAYBESIB_set # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif #ifndef SvRX #if defined(NEED_SvRX) static void * DPPP_(my_SvRX)(pTHX_ SV *rv); static #else extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); #endif #ifdef SvRX # undef SvRX #endif #define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) #if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) void * DPPP_(my_SvRX)(pTHX_ SV *rv) { if (SvROK(rv)) { SV *sv = SvRV(rv); if (SvMAGICAL(sv)) { MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); if (mg && mg->mg_obj) { return mg->mg_obj; } } } return 0; } #endif #endif #ifndef SvRXOK # define SvRXOK(sv) (!!SvRX(sv)) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef PERL_UNUSED_RESULT # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END # else # define PERL_UNUSED_RESULT(v) ((void)(v)) # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifdef HAS_QUAD # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif #else # define WIDEST_UTYPE U32 #endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif /* Until we figure out how to support this in older perls... */ #if (PERL_BCDVERSION >= 0x5008000) #ifndef HeUTF8 # define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he)) #endif #endif #ifndef C_ARRAY_LENGTH # define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif #ifndef C_ARRAY_END # define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doing. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #elif (PERL_BCDVERSION > 0x5003000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # elif IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # else # error "cannot define IV/UV formats" # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_nomg_nolen # define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* Hint: newSVpvn_share * The SVs created by this function only mimic the behaviour of * shared PVs without really being shared. Only use if you know * what you're doing. */ #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef gv_fetchpvn_flags #if defined(NEED_gv_fetchpvn_flags) static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); static #else extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); #endif #ifdef gv_fetchpvn_flags # undef gv_fetchpvn_flags #endif #define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) #define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) #if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { char *namepv = savepvn(name, len); GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); Safefree(namepv); return stash; } #endif #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchsv # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags # define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef gv_init_pvn # define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef newSVpvs_share # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif /* Some random bits for sv_unmagicext. These should probably be pulled in for real and organized at some point */ #ifndef HEf_SVKEY # define HEf_SVKEY -2 #endif #ifndef MUTABLE_PTR #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) #else # define MUTABLE_PTR(p) ((void *) (p)) #endif #endif #ifndef MUTABLE_SV # define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) #endif /* end of random bits */ #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #if !defined(mg_findext) #if defined(NEED_mg_findext) static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); static #else extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); #endif #define mg_findext DPPP_(my_mg_findext) #define Perl_mg_findext DPPP_(my_mg_findext) #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { if (sv) { MAGIC *mg; #ifdef AvPAD_NAMELIST assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); #endif for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && mg->mg_virtual == vtbl) return mg; } } return NULL; } #endif #endif #if !defined(sv_unmagicext) #if defined(NEED_sv_unmagicext) static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); static #else extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); #endif #ifdef sv_unmagicext # undef sv_unmagicext #endif #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) int DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) { MAGIC* mg; MAGIC** mgp; if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(SvMAGIC(sv)); for (mg = *mgp; mg; mg = *mgp) { const MGVTBL* const virt = mg->mg_virtual; if (mg->mg_type == type && virt == vtbl) { *mgp = mg->mg_moremagic; if (virt && virt->svt_free) virt->svt_free(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ mg_magical(sv); /* else fix the flags now */ } else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } return 0; } #endif #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #if (PERL_BCDVERSION >= 0x5006000) #ifndef caller_cx # if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) static I32 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: return i; } } return i; } # endif # if defined(NEED_caller_cx) static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); static #else extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); #endif #ifdef caller_cx # undef caller_cx #endif #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) #define Perl_caller_cx DPPP_(my_caller_cx) #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); register const PERL_CONTEXT *cx; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); } if (cxix < 0) return NULL; /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); } cx = &ccstack[cxix]; if (dbcxp) *dbcxp = cx; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } return cx; } # endif #endif /* caller_cx */ #endif /* 5.6.0 */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%" UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%" UVxf "}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File ppport.h */ Devel-NYTProf-6.06/t/000750 000766 000024 00000000000 13305245314 014517 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/.gdbinit000644 000766 000024 00000012077 12067023751 015714 0ustar00timbostaff000000 000000 # From http://cpansearch.perl.org/src/GOZER/mod_perl-1.31/.gdbinit #some handy debugging macros, hopefully you'll never need them #some don't quite work, like dump_hv and hv_fetch, #where's the bloody manpage for .gdbinit syntax? define thttpd run -X -f `pwd`/t/conf/httpd.conf -d `pwd`/t # set $sv = perl_eval_pv("$Apache::ErrLog = '/tmp/mod_perl_error_log'",1) end define httpd run -X -d `pwd` set $sv = perl_eval_pv("$Apache::ErrLog = Apache->server_root_relative('logs/error_log')", 1) #printf "error_log = %s\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define STpvx print ((XPV*) (PL_stack_base [ax + ($arg0)] )->sv_any )->xpv_pv end define TOPs print ((XPV*) (**sp)->sv_any )->xpv_pv end define curstash print ((XPVHV*) (PL_curstash)->sv_any)->xhv_name end define defstash print ((XPVHV*) (PL_defstash)->sv_any)->xhv_name end define curinfo printf "%d:%s\n", PL_curcop->cop_line, \ ((XPV*)(*(XPVGV*)PL_curcop->cop_filegv->sv_any)\ ->xgv_gp->gp_sv->sv_any)->xpv_pv end define SvPVX print ((XPV*) ($arg0)->sv_any )->xpv_pv end define SvCUR print ((XPV*) ($arg0)->sv_any )->xpv_cur end define SvLEN print ((XPV*) ($arg0)->sv_any )->xpv_len end define SvEND print (((XPV*) ($arg0)->sv_any )->xpv_pv + ((XPV*)($arg0)->sv_any )->xpv_cur) - 1 end define SvSTASH print ((XPVHV*)((XPVMG*)($arg0)->sv_any )->xmg_stash)->sv_any->xhv_name end define SvTAINTED print ((($arg0)->sv_flags & (0x00002000 |0x00004000 |0x00008000 )) && Perl_sv_tainted ($arg0)) end define SvTRUE print ( !$arg0 ? 0 : (($arg0)->sv_flags & 0x00040000 ) ? ((PL_Xpv = (XPV*)($arg0)->sv_any ) && (*PL_Xpv ->xpv_pv > '0' || PL_Xpv ->xpv_cur > 1 || (PL_Xpv ->xpv_cur && *PL_Xpv ->xpv_pv != '0')) ? 1 : 0) : (($arg0)->sv_flags & 0x00010000 ) ? ((XPVIV*) ($arg0)->sv_any )->xiv_iv != 0 : (($arg0)->sv_flags & 0x00020000 ) ? ((XPVNV*)($arg0)->sv_any )->xnv_nv != 0.0 : Perl_sv_2bool ($arg0) ) end define GvHV set $hv = (((((XPVGV*)($arg0)->sv_any ) ->xgv_gp) )->gp_hv) end define GvSV print ((XPV*) ((((XPVGV*)($arg0)->sv_any ) ->xgv_gp) ->gp_sv )->sv_any )->xpv_pv end define GvNAME print (((XPVGV*)($arg0)->sv_any ) ->xgv_name) end define GvFILEGV print ((XPV*) ((((XPVGV*)$arg0->filegv)->xgv_gp)->gp_sv)->sv_any)->xpv_pv end define CvNAME print ((XPVGV*)(((XPVCV*)($arg0)->sv_any)->xcv_gv)->sv_any)->xgv_name end define CvSTASH print ((XPVHV*)(((XPVGV*)(((XPVCV*)($arg0)->sv_any)->xcv_gv)->sv_any)->xgv_stash)->sv_any)->xhv_name end define CvDEPTH print ((XPVCV*)($arg0)->sv_any )->xcv_depth end define CvFILEGV print ((XPV*) ((((XPVGV*)((XPVCV*)($arg0)->sv_any )->xcv_filegv)->xgv_gp)->gp_sv)->sv_any)->xpv_pv end define SVOPpvx print ((XPV*) ( ((SVOP*)$arg0)->op_sv)->sv_any )->xpv_pv end define HvNAME print ((XPVHV*)$arg0->sv_any)->xhv_name end define HvKEYS print ((XPVHV*) ($arg0)->sv_any)->xhv_keys end define AvFILL print ((XPVAV*) ($arg0)->sv_any)->xav_fill end define dumpav set $n = ((XPVAV*) ($arg0)->sv_any)->xav_fill set $i = 0 while $i <= $n set $sv = *Perl_av_fetch($arg0, $i, 0) printf "[%u] -> `%s'\n", $i, ((XPV*) ($sv)->sv_any )->xpv_pv set $i = $i + 1 end end define dumphv set $n = ((XPVHV*) ($arg0)->sv_any)->xhv_keys set $i = 0 set $key = 0 set $klen = 0 Perl_hv_iterinit($arg0) while $i <= $n set $sv = Perl_hv_iternextsv($arg0, &$key, &$klen) printf "%s = `%s'\n", $key, ((XPV*) ($sv)->sv_any )->xpv_pv set $i = $i + 1 end end define hvfetch set $klen = strlen($arg1) set $sv = *Perl_hv_fetch($arg0, $arg1, $klen, 0) printf "%s = `%s'\n", $arg1, ((XPV*) ($sv)->sv_any )->xpv_pv end define hvINCval set $hv = (((((XPVGV*)(PL_incgv)->sv_any)->xgv_gp))->gp_hv) set $klen = strlen($arg0) set $sv = *Perl_hv_fetch($hv, $arg0, $klen, 0) printf "%s = `%s'\n", $arg0, ((XPV*) ($sv)->sv_any )->xpv_pv end define dumpany set $sv = Perl_newSVpv("use Data::Dumper; Dumper \\",0) set $void = Perl_sv_catpv($sv, $arg0) set $dump = perl_eval_pv(((XPV*) ($sv)->sv_any )->xpv_pv, 1) printf "%s = `%s'\n", $arg0, ((XPV*) ($dump)->sv_any )->xpv_pv end define dumpanyrv set $rv = Perl_newRV((SV*)$arg0) set $rvpv = perl_get_sv("main::DumpAnyRv", 1) set $void = Perl_sv_setsv($rvpv, $rv) set $sv = perl_eval_pv("use Data::Dumper; Dumper $::DumpAnyRv",1) printf "`%s'\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define svpeek set $pv = Perl_sv_peek((SV*)$arg0) printf "%s\n", $pv end define caller set $sv = perl_eval_pv("scalar caller", 1) printf "caller = %s\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define cluck set $sv = perl_eval_pv("Carp::cluck(); `tail '$Apache::ErrLog'`", 1) printf "%s\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define longmess set $sv = perl_eval_pv("Carp::longmess()", 1) printf "%s\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define shortmess set $sv = perl_eval_pv("Carp::shortmess()", 1) printf "%s\n", ((XPV*) ($sv)->sv_any )->xpv_pv end define perl_get_sv set $sv = perl_get_sv($arg0, 0) printf "%s\n", $sv ? ((XPV*) ((SV*)$sv)->sv_any)->xpv_pv : "undef" end Devel-NYTProf-6.06/xt/000750 000766 000024 00000000000 13305245314 014707 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/README.md000644 000766 000024 00000001446 13305236420 015543 0ustar00timbostaff000000 000000 # Devel::NYTProf Devel::NYTProf is a powerful feature-rich source code profiler for Perl 5. [![Build Status](https://secure.travis-ci.org/timbunce/devel-nytprof.png)](http://travis-ci.org/timbunce/devel-nytprof) For more information see: * https://www.youtube.com/watch?v=T7EK6RZAnEA * http://www.slideshare.net/Tim.Bunce/nyt-prof-201406key * http://blog.timbunce.org/tag/nytprof/ ## DOWNLOAD AND INSTALLATION Download a release from CPAN using your favorite tool, such as cpanm. Or else from https://metacpan.org/release/Devel-NYTProf and then unpack the tar.gz file. You're most welcome to contribute, in which case cloning or forking the git repo is a good place to start. To build and install, just incant the typical mantra: perl Makefile.PL make make test make install Devel-NYTProf-6.06/typemap000644 000766 000024 00000000460 12067023751 015666 0ustar00timbostaff000000 000000 const char * T_PV NYTP_file T_NYTPROF_FILE INPUT T_NYTPROF_FILE if (sv_isa($arg, \"Devel::NYTProf::FileHandle\")) $var = (NYTP_file)SvPVX(SvRV($arg)); else Perl_croak(aTHX_ \"%s: %s is not of type Devel::NYTProf::FileHandle\", ${$ALIAS?\q[GvNAME(CvGV(cv))]:\qq[\"$pname\"]}, \"$var\") Devel-NYTProf-6.06/.indent.pro000644 000766 000024 00000000024 12067023751 016341 0ustar00timbostaff000000 000000 -i4 -nce -nfc1 -l98 Devel-NYTProf-6.06/.gitignore000644 000766 000024 00000000562 13015653676 016270 0ustar00timbostaff000000 000000 # / FileHandle.c FileHandle.o MANIFEST.bak MYMETA.json MYMETA.yml Makefile Makefile.old NYTProf.bs NYTProf.c NYTProf.o blib/ *.tar.gz *.o *.obj *.pdb *.def *.c *.bs *.out .*.swp nytprof-50-errno.out /t/*.new /t/*.newp /t/*.out /t/nytprof_t.out /t/nytprof-test51-*.out /t/nytprof_test30-fork-*.out.* /t/*_outdir /t/auto pm_to_blib /_eumm/ dll.base dll.exp NYTProf_def.oldDevel-NYTProf-6.06/META.yml000640 000766 000024 00000001771 13305245314 015534 0ustar00timbostaff000000 000000 --- abstract: 'Powerful fast feature-rich Perl source code profiler' author: - 'Tim Bunce ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-NYTProf no_index: directory: - t - inc package: - SVG requires: File::Which: '1.09' Getopt::Long: '0' JSON::MaybeXS: '0' List::Util: '0' Test::Differences: '0.60' Test::More: '0.84' XSLoader: '0' resources: MailingList: http://groups.google.com/group/develnytprof-dev bugtracker: https://github.com/timbunce/devel-nytprof/issues homepage: https://code.google.com/p/perl-devel-nytprof/ license: http://dev.perl.org/licenses/ repository: git://github.com/timbunce/devel-nytprof.git version: '6.06' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Devel-NYTProf-6.06/HACKING000644 000766 000024 00000041713 12533402722 015256 0ustar00timbostaff000000 000000 # vim: ts=8 sw=2 sts=0 noexpandtab: HACKING Devel::NYTProf ====================== We encourage hacking Devel::NYTProf! OBTAINING THE CURRENT RELEASE ----------------------------- The current official release can be obtained from CPAN http://metacpan.org/release/Devel-NYTProf/ OBTAINING THE LATEST DEVELOPMENT CODE ------------------------------------- You can grab the head of the latest trunk code from the Google Code repository, see http://code.google.com/p/perl-devel-nytprof/source/checkout CONTRIBUTING ------------ Please work with the latest code from the repository - see above. Small patches can be uploaded via the issue tracker at http://code.google.com/p/perl-devel-nytprof/issues/list For larger changes please talk to us first via the mailing list at http://code.google.com/p/perl-devel-nytprof/source/checkout When developing, please ensure that no new compiler warnings are output. TESTING ------- Please try to add tests covering any changes you make. You can run individual tests like this: perl -Mblib t/30-util.t Most tests include some underlying perl code that's being profiled. Either as a .p file, which can be profiled like this: perl -Mblib -MDevel::NYTProf t/test01.p or embedded at the end of a t/*.t file, which can be profiled like this: perl -Mblib -MDevel::NYTProf -x t/70-subname The output will be in the ./nytprof.out file. RESOURCES --------- Google Code: http://code.google.com/p/perl-devel-nytprof/ Google Devel Group (must subscribe here): http://groups.google.com/group/develnytprof-dev NYTimes Open Code Blog: http://open.nytimes.com/ TODO (unsorted, unprioritized, unconsidered, even unreasonable and daft :) ---- *** For build/test Add (very) basic nytprofhtml test (ie it runs and produces output) Add tests for evals in regex: s/.../ ...perl code... /e Add tests for -block and -sub csv reports. Add tests with various kinds of blocks and loops (if, do, while, until, etc). Add mechanism to specify inside the .p file that NYTProf should not be loaded via the command line. That's needed to test behaviors in environments where perl is init'd first. Such as mod_perl. Then we can test things like not having the sub line range for some subs. *** For core only See MemoryProfiling.pod file Store raw NYTPROF option string in the data file. Include parsed version in report index page. Add actual size and mtime of fid to data file. (Already in data file as zero, just needs the stat() call.) Don't alter errno. Add help option which would print a summary of the options and exit. Could also print list of available clocks for the clock=N option (using a set of #ifdef's) The subroutine profiler could calculate the running variance of the samples using this logic http://www.johndcook.com/standard_deviation.html so the reports can display the standard deviation. Replace DB::enable_profiling() and DB::disable_profiling() with $DB::profile = 1|0; That a more consistent API with $DB::single etc., but more importantly it lets users leave the code in place when NYTProf is not loaded. It'll just do nothing, whereas currently the user will get a fatal error if NYTProf isn't loaded. It also allows smart things like use of local() for temporary overrides. Combine current profile_* globals into a single global int using bit fields. That way assigning to $DB::profile can offer a finer degree of control. Specifically to enable/disable the sub or statement profiler separately. Add mechanism to enable control of profiling on a per-sub-name and/or per-package-name basis. For example, specify a regex and whenever a sub is entered (for the first time, to make it cheap) check if the sub name matches the regex. If it does then save the current $DB::profile value and set a new one. When the sub exits restore the previous $DB::profile value. Work around OP_UNSTACK bug (http://rt.perl.org/rt3/Ticket/Display.html?id=60954) while ( foo() ) { # all calls to foo should be from here ... ... # no calls to foo() should appear here } *** For core and reports Add @INC to data file so reports can be made more readable by removing (possibly very long) library paths where appropriate. Tricky thing is that @INC can change during the life of the program. One approach might be to output it whenever we assign a new fid but only if different to the last @INC that was ouput. Add marker with timestamp for phases BEGIN, CHECK, INIT, END (could combine with pid marker) Add marker with timestamp for enable_profile and disable_profile. Could also dump-and-zero the sub profiler data so we could report per-phase timing. The goals here are to a) know how long the different phases of execution took mostly for general interest, and b) know how much time was spent with the profiler enabled to calculate accurate percentages and also be able to spot 'leaks' in the data processing (e.g. if the sum of the statement times don't match the time spent with the profiler enabled, due to nested string evals for example). Add flags to sub call info to indicate what phase (BEGIN, etc) the call happened in. That'll allow call graphs to ignore BEGIN-time calls (which tend to make graphviz output too noisy to be useful). *** For reports only ::Reader and its data structures need to be refactored to death. The whole reporting framework needs a rewrite to use a single 'thin' command line and classes for the Model (lines, files, subs), View (html, csv etc), and Controller (composing views to form reports). Dependent on a richer data model. Then rework bin/ntyprof* to use the new subclasses Ideally end up with a single nytprof command that just sets up the appropriate classes to do the work. Trim leading @INC portion from filename in __ANON__[/very/long/path/...] in report output. (Keep full path in link/tooltip/title as it may be ambiguous when shortened). Add help link in reports. Could go to docs page on search.cpan.org. Add a 'permalink' icon (eg infinity symbol) to the right of lines that define subs to make it easer to email/IM links to particular places in the code. Report could track which subs it has reported caller info for and so be able to identify subs that were called but haven't been included in the report because we didn't know where the sub was. They could them be included in a separate 'miscellaneous' page. This is a more general way to view the problem of xsubs in packages for which we don't have any perl source code. Consider restoring inclusive-time treemap with an appropriate description to explain how to interpret it. *** Other - mostly unsorted - stuff *** Intercept all opcodes that may fork and run perl code in the child ie fork, open, entersub (ie xs), others? and fflush before executing the op (so fpurge isn't strictly required) and reinit_if_forked() afterwards add option to force reinit_if_forked check per stmt just-in-case Alternatively it might be better to use pthread_atfork() [if available] with a child handler. The man page says "Remember: only async-cancel-safe functions are allowed on the child side of fork()" so it seems that the safe thing to do is to use a volatile flag variable, and change its value in the handler to signal to the main code. Support profiling programs which use threads: - move all relevant globals into a structure - add lock around output to file Set options via import so perl -d:NYTProf=... works. Very handy. May need alternative option syntax. Also perl gives special meaning to 't' option (threads) so we should reserve the same for eventual thread support. Problem with this is that the import() call happens after init_profiler() so limits the usefulness. So we'd need to limit it to certain options (trace would certainly be useful). Add resolution of __ANON__ sub names (eg imported 'constants') where possible. [I can't recall what I meant by that now. I think this means where an anon sub has been imported, if the refcnt is 1 then use the imported name instead of the __ANON__ name.] The appending of an @line to BEGIN subs should also be applied to END subs. Record $AUTOLOAD when AUTOLOAD() called. Perhaps as ...::AUTOLOAD[$AUTOLOAD] Or perhaps just use the original name if the 'resolved' one is AUTOLOAD. Could be argued either way. More generally, consider the problem of code where one code path is fast and just sets $sql = ... (for example) and another code path executes the sql. Some $sql may be fast and others slow. The profile can't separate the timings based on what was in $sql because the code path was the same in both cases. (For sql DBI::Profile can be used, but the underlying issue is general.) The sub_caller information is currently one level deep. It would be good to make it two levels. Especially because it would allow you to "see through" AUTOLOADs and other kinds of 'dispatch' subs. Refactor this HACKING file! The data file includes the information mapping a line-level line to the corresponding block-level and sub-level lines. This should be added to the data structure. It would enable a much richer visualization of which lines have contributed to the 'rolled up' counts. That's especially tricky to work out with the block level view. Following on from that I have a totally crazy idea that the browsers css engine could be used to highlight the corresponding rollup line when hovering over a source line, and/or the opposite. Needs lots of thought, but it's an interesting idea. Profile and optimize report generation Bug or limitation?: sub calls in a continue { ... } block of a while () get associated with the 'next;' within the loop. Fixed by perl change 33710? Investigate style.css problem when using --outfile=some/other/dir Class::MOP should update %DB::sub (if $^P & 0x10 set) when it creates methods. Sub::Name should do same (extracting the file and line from the ANON[...:...]) Profile should report _both_ the 'raw original' filename (possibly relative) used by the application being profiled, plus an absolute filename determined ASAP (to avoid problems with scripts that chdir). Add (very) basic nytprofhtml test (ie it runs and produces output) so we check the VERSION has been updated. In the called by list in html: "by $subname line $line of $file" make the file not include the @INC portion Monitor and report when method cache is invalidated. Watch generation number and output a tag when it changes. Report locations of changes. Highlight those that happen after INIT phase. Fix testing of t/*.pm_x files which are currently being ignored. The autosplit handling doesn't address the naming of pseudo-fids from string evals inside autoloaded subs, like "(eval 0)[test14.pm (autosplit into auto/test14/bar.al):17]" The 'file name' for the eval fid needs to be edited when read in to remove the ' (autosplit...', but care should be taken to not remove the text for evals in autosplit files for which we've not been able to alias to the parent. Add a FID_ATTRIB tag to allow additional info about fids to be generated after the initial fid info is output. Use FID_ATTRIB tag to record autoload fids being aliases to a fid so that reports can include a list of autoloaded subs. Check if pp_leavegiven and pp_leavewhen need handling in init_profiler(). Copy the nytprof.out file into the output report dir, so a report is more 'self-contained' and can be archived and thrown around as a tarball/zip and still used for further analysis. To stress-test NYTProf using perl's own test suite, set env vars: NYTPROF='file=/tmp/nytprof.out:addpid=1:nameanonsubs=0:nameevals=0' PERL5OPT='-d:NYTProf' and hack t/TEST to not delete the PERL5OPT env var. The findcaller option doesn't notice if the caller is an opcode. Opcodes that call subs (like subst calling utf8::SWASHGET) probably shouldn't appear as the caller in the call-tree because, while strictly accurate, it's probably less useful from the users perspective. Fixing that part is easy but handling incl/excl time needs more thought. For xsubs and opcodes that call perl subs: In the subroutine prologue that currently lists where the sub was called from, for xsubs & opcodes, add a list of subs that it called (typically none). That would be handy because currently calls from xsubs & opcodes appear in the reports at the line of the last _perl_ statement executed, and not in the fake 'stub' that we add to the end of the package source. Use gethrtime() on platforms that support it. http://developers.sun.com/solaris/articles/time_stamp.html http://www.informit.com/guides/content.aspx?g=cplusplus&seqNum=332 Currently lvalue subs aren't profiled when use_db_sub is in effect. http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2010-02/msg00824.html Idle conjecture: perhaps loading the profile data into an SQLite database would be a better approach to reporting. (An nytprofimport utility could read an nytprof.out and write an nytprof.db) Then, rather than hand-crafting inflexible data structures we could use SQL (or, say, DBIx::Class) to return relevant data. Would also provide another route for other data sources (languages/tools) to be included in a report. Could also simplify: comparing profiles, merging profiles, ... Also 'pipelines' of plugin db-to-db transformations could be developed. Any volunteers to explore writing an nytprofimport for SQLite? Option to add sub call and return events into the data file as they happen. Would enable a dprofpp -T like output. See https://rt.cpan.org/Ticket/Display.html?id=50766 Especially relevant as DProf is being removed from the code and this is something NYTProf still doesn't do. String evals could/should be tied into the subroutine profiler. That would give inclusive timings which we don't have at the moment. The evals appear in the html report as if they're calls but the timings are statement timings of the eval fid that don't include time spent in subs defined elsewhere but called from the string eval. The inconsistency is confusing. Modify csv output to optionally include extra metadata lines. Use for testing. In html report where sub callers are shown (called N times by S from F at line L) also show in compact form links to the callers of the caller, if there aren't too many. This makes it faster to climb the call stack. A simple mouseover will show the filename of the caller (perhaps a tooltip could give the file and sub). Also needed for modules that take shortcuts calling XS functions (*cough DBI*). And/or, add a simple up arrow that'll just to the calling sub. Typically that'll be the surrounding "sub foo { ..." (which'll be handy for big subs) but for cases where the call to that sub wasn't recorded (eg pre 5.8.9 or the DBI's xs calling optimization) it'll be the most recent sub entry that was recorded. Generate extra report pages for xsubs in packages that don't have source code. They're currently all dumped into the 'main' file. Docs describing how the subroutine profiler works need updating. Add 'u' key to treemap to trigger moving 'up' a level. Add "calls N subs" to treemap mouseover box Upgrade treemap to JIT version 2 (which has transition animations). Sub profiler should avoid sv_setpvf(subname_sv, "%s::%s", stash_name, GvNAME(gv)); because it's expensive (Perl_sv_setpvf_nocontext accounts for 29% of pp_entersub_profiler). Use a two level hash: HvNAME(GvSTASH(gv)) then GvNAME(gv). Should then also be able to avoid newSV/free for subname_sv (which accounts for 50% of its time). The subroutine profiler spends a lot of its time allocating the two calle[rd]_subname_sv SVs in subr_entry_setup and freeing them in subr_entry_destroy. If, instead of freeing the SVs they were chained into a freelist that subr_entry_setup could pull from, we'd get a significant boost in performance for the subroutine profiler. It would also greatly reduce the risk of NYTProf overwriting a recently freed but still on the stack SV. Would be good to be able to measure the time spent in require. The easy way would be to treat it as a slowop. I recall enabling this in the early days of slowop support but running into problems. It would be good to revisit. This would help with profiling issues like: http://blog.moose.perl.org/2010/08/moose-110-and-classmop-105-now-compiling-10-faster.html We need a start=runtime option to start at the _end_ of any INIT subs. (The current start=init option is the closest we have but it's not very useful if lots of other work is done in INIT blocks.) We need an option to discount the time spent in specific subs, like we do for CORE:accept so that time pure-perl webservers spend waiting for the next request doesn't distort the profile. Probably just needs a hash lookup. http://stackoverflow.com/questions/4132270/how-to-ignore-some-subroutine-calls-in-nytprof-reporting/14085984#14085984 Remove nytprofcsv Add "goto skip_sub_profile;" to this?: (and/or figure out why already_counted++ isn't enough) /* catch profile_subs being turned off by disable_profile call */ if (!profile_subs) subr_entry->already_counted++; study http://www.postgresql.org/docs/9.2/static/pgtesttiming.html See pg contrib/pg_test_timing/pg_test_timing.c Show /sys/devices/system/clocksource/clocksource0/available_clocksource and /sys/devices/system/clocksource/clocksource0/current_clocksource in the Makefile.PL and test output, if present Devel-NYTProf-6.06/lib/000750 000766 000024 00000000000 13305245314 015022 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/slowops.h000644 000766 000024 00000014551 12414301061 016136 0ustar00timbostaff000000 000000 /* generated by Makefile.PL for perl 5.011002 */ PL_ppaddr[OP_ACCEPT] = pp_slowop_profiler; PL_ppaddr[OP_BACKTICK] = pp_slowop_profiler; PL_ppaddr[OP_BIND] = pp_slowop_profiler; PL_ppaddr[OP_BINMODE] = pp_slowop_profiler; PL_ppaddr[OP_CHDIR] = pp_slowop_profiler; PL_ppaddr[OP_CHMOD] = pp_slowop_profiler; PL_ppaddr[OP_CHOWN] = pp_slowop_profiler; PL_ppaddr[OP_CHROOT] = pp_slowop_profiler; PL_ppaddr[OP_CLOSE] = pp_slowop_profiler; PL_ppaddr[OP_CLOSEDIR] = pp_slowop_profiler; PL_ppaddr[OP_CONNECT] = pp_slowop_profiler; PL_ppaddr[OP_CRYPT] = pp_slowop_profiler; PL_ppaddr[OP_DBMCLOSE] = pp_slowop_profiler; PL_ppaddr[OP_DBMOPEN] = pp_slowop_profiler; PL_ppaddr[OP_DUMP] = pp_slowop_profiler; PL_ppaddr[OP_EGRENT] = pp_slowop_profiler; PL_ppaddr[OP_EHOSTENT] = pp_slowop_profiler; PL_ppaddr[OP_ENETENT] = pp_slowop_profiler; PL_ppaddr[OP_ENTERWRITE] = pp_slowop_profiler; PL_ppaddr[OP_EOF] = pp_slowop_profiler; PL_ppaddr[OP_EPROTOENT] = pp_slowop_profiler; PL_ppaddr[OP_EPWENT] = pp_slowop_profiler; PL_ppaddr[OP_ESERVENT] = pp_slowop_profiler; PL_ppaddr[OP_FCNTL] = pp_slowop_profiler; PL_ppaddr[OP_FLOCK] = pp_slowop_profiler; PL_ppaddr[OP_FORMLINE] = pp_slowop_profiler; PL_ppaddr[OP_FTATIME] = pp_slowop_profiler; PL_ppaddr[OP_FTBINARY] = pp_slowop_profiler; PL_ppaddr[OP_FTBLK] = pp_slowop_profiler; PL_ppaddr[OP_FTCHR] = pp_slowop_profiler; PL_ppaddr[OP_FTCTIME] = pp_slowop_profiler; PL_ppaddr[OP_FTDIR] = pp_slowop_profiler; PL_ppaddr[OP_FTEEXEC] = pp_slowop_profiler; PL_ppaddr[OP_FTEOWNED] = pp_slowop_profiler; PL_ppaddr[OP_FTEREAD] = pp_slowop_profiler; PL_ppaddr[OP_FTEWRITE] = pp_slowop_profiler; PL_ppaddr[OP_FTFILE] = pp_slowop_profiler; PL_ppaddr[OP_FTIS] = pp_slowop_profiler; PL_ppaddr[OP_FTLINK] = pp_slowop_profiler; PL_ppaddr[OP_FTMTIME] = pp_slowop_profiler; PL_ppaddr[OP_FTPIPE] = pp_slowop_profiler; PL_ppaddr[OP_FTREXEC] = pp_slowop_profiler; PL_ppaddr[OP_FTROWNED] = pp_slowop_profiler; PL_ppaddr[OP_FTRREAD] = pp_slowop_profiler; PL_ppaddr[OP_FTRWRITE] = pp_slowop_profiler; PL_ppaddr[OP_FTSGID] = pp_slowop_profiler; PL_ppaddr[OP_FTSIZE] = pp_slowop_profiler; PL_ppaddr[OP_FTSOCK] = pp_slowop_profiler; PL_ppaddr[OP_FTSUID] = pp_slowop_profiler; PL_ppaddr[OP_FTSVTX] = pp_slowop_profiler; PL_ppaddr[OP_FTTEXT] = pp_slowop_profiler; PL_ppaddr[OP_FTTTY] = pp_slowop_profiler; PL_ppaddr[OP_FTZERO] = pp_slowop_profiler; PL_ppaddr[OP_GETC] = pp_slowop_profiler; PL_ppaddr[OP_GETLOGIN] = pp_slowop_profiler; PL_ppaddr[OP_GETPEERNAME] = pp_slowop_profiler; PL_ppaddr[OP_GETSOCKNAME] = pp_slowop_profiler; PL_ppaddr[OP_GGRENT] = pp_slowop_profiler; PL_ppaddr[OP_GGRGID] = pp_slowop_profiler; PL_ppaddr[OP_GGRNAM] = pp_slowop_profiler; PL_ppaddr[OP_GHBYADDR] = pp_slowop_profiler; PL_ppaddr[OP_GHBYNAME] = pp_slowop_profiler; PL_ppaddr[OP_GHOSTENT] = pp_slowop_profiler; PL_ppaddr[OP_GLOB] = pp_slowop_profiler; PL_ppaddr[OP_GNBYADDR] = pp_slowop_profiler; PL_ppaddr[OP_GNBYNAME] = pp_slowop_profiler; PL_ppaddr[OP_GNETENT] = pp_slowop_profiler; PL_ppaddr[OP_GPBYNAME] = pp_slowop_profiler; PL_ppaddr[OP_GPBYNUMBER] = pp_slowop_profiler; PL_ppaddr[OP_GPROTOENT] = pp_slowop_profiler; PL_ppaddr[OP_GPWENT] = pp_slowop_profiler; PL_ppaddr[OP_GPWNAM] = pp_slowop_profiler; PL_ppaddr[OP_GPWUID] = pp_slowop_profiler; PL_ppaddr[OP_GSBYNAME] = pp_slowop_profiler; PL_ppaddr[OP_GSBYPORT] = pp_slowop_profiler; PL_ppaddr[OP_GSERVENT] = pp_slowop_profiler; PL_ppaddr[OP_GSOCKOPT] = pp_slowop_profiler; PL_ppaddr[OP_IOCTL] = pp_slowop_profiler; PL_ppaddr[OP_LEAVEWRITE] = pp_slowop_profiler; PL_ppaddr[OP_LINK] = pp_slowop_profiler; PL_ppaddr[OP_LISTEN] = pp_slowop_profiler; PL_ppaddr[OP_LOCK] = pp_slowop_profiler; PL_ppaddr[OP_LSTAT] = pp_slowop_profiler; PL_ppaddr[OP_MATCH] = pp_slowop_profiler; PL_ppaddr[OP_MKDIR] = pp_slowop_profiler; PL_ppaddr[OP_MSGCTL] = pp_slowop_profiler; PL_ppaddr[OP_MSGGET] = pp_slowop_profiler; PL_ppaddr[OP_MSGRCV] = pp_slowop_profiler; PL_ppaddr[OP_MSGSND] = pp_slowop_profiler; PL_ppaddr[OP_OPEN] = pp_slowop_profiler; PL_ppaddr[OP_OPEN_DIR] = pp_slowop_profiler; PL_ppaddr[OP_PACK] = pp_slowop_profiler; PL_ppaddr[OP_PRINT] = pp_slowop_profiler; PL_ppaddr[OP_PRTF] = pp_slowop_profiler; PL_ppaddr[OP_QR] = pp_slowop_profiler; PL_ppaddr[OP_RCATLINE] = pp_slowop_profiler; PL_ppaddr[OP_READ] = pp_slowop_profiler; PL_ppaddr[OP_READDIR] = pp_slowop_profiler; PL_ppaddr[OP_READLINE] = pp_slowop_profiler; PL_ppaddr[OP_READLINK] = pp_slowop_profiler; PL_ppaddr[OP_RECV] = pp_slowop_profiler; PL_ppaddr[OP_REGCOMP] = pp_slowop_profiler; PL_ppaddr[OP_RENAME] = pp_slowop_profiler; PL_ppaddr[OP_REWINDDIR] = pp_slowop_profiler; PL_ppaddr[OP_RMDIR] = pp_slowop_profiler; #if (PERL_VERSION >= 10) PL_ppaddr[OP_SAY] = pp_slowop_profiler; #endif PL_ppaddr[OP_SEEK] = pp_slowop_profiler; PL_ppaddr[OP_SEEKDIR] = pp_slowop_profiler; PL_ppaddr[OP_SELECT] = pp_slowop_profiler; PL_ppaddr[OP_SEMCTL] = pp_slowop_profiler; PL_ppaddr[OP_SEMGET] = pp_slowop_profiler; PL_ppaddr[OP_SEMOP] = pp_slowop_profiler; PL_ppaddr[OP_SEND] = pp_slowop_profiler; PL_ppaddr[OP_SGRENT] = pp_slowop_profiler; PL_ppaddr[OP_SHMCTL] = pp_slowop_profiler; PL_ppaddr[OP_SHMGET] = pp_slowop_profiler; PL_ppaddr[OP_SHMREAD] = pp_slowop_profiler; PL_ppaddr[OP_SHMWRITE] = pp_slowop_profiler; PL_ppaddr[OP_SHOSTENT] = pp_slowop_profiler; PL_ppaddr[OP_SHUTDOWN] = pp_slowop_profiler; PL_ppaddr[OP_SLEEP] = pp_slowop_profiler; PL_ppaddr[OP_SNETENT] = pp_slowop_profiler; PL_ppaddr[OP_SOCKET] = pp_slowop_profiler; PL_ppaddr[OP_SORT] = pp_slowop_profiler; PL_ppaddr[OP_SPROTOENT] = pp_slowop_profiler; PL_ppaddr[OP_SPWENT] = pp_slowop_profiler; PL_ppaddr[OP_SSELECT] = pp_slowop_profiler; PL_ppaddr[OP_SSERVENT] = pp_slowop_profiler; PL_ppaddr[OP_SSOCKOPT] = pp_slowop_profiler; PL_ppaddr[OP_STAT] = pp_slowop_profiler; PL_ppaddr[OP_SUBST] = pp_slowop_profiler; PL_ppaddr[OP_SUBSTCONT] = pp_slowop_profiler; PL_ppaddr[OP_SYMLINK] = pp_slowop_profiler; PL_ppaddr[OP_SYSCALL] = pp_slowop_profiler; PL_ppaddr[OP_SYSOPEN] = pp_slowop_profiler; PL_ppaddr[OP_SYSREAD] = pp_slowop_profiler; PL_ppaddr[OP_SYSSEEK] = pp_slowop_profiler; PL_ppaddr[OP_SYSTEM] = pp_slowop_profiler; PL_ppaddr[OP_SYSWRITE] = pp_slowop_profiler; PL_ppaddr[OP_TELL] = pp_slowop_profiler; PL_ppaddr[OP_TELLDIR] = pp_slowop_profiler; PL_ppaddr[OP_TRUNCATE] = pp_slowop_profiler; PL_ppaddr[OP_UMASK] = pp_slowop_profiler; PL_ppaddr[OP_UNLINK] = pp_slowop_profiler; PL_ppaddr[OP_UNPACK] = pp_slowop_profiler; PL_ppaddr[OP_UTIME] = pp_slowop_profiler; PL_ppaddr[OP_WAIT] = pp_slowop_profiler; PL_ppaddr[OP_WAITPID] = pp_slowop_profiler; Devel-NYTProf-6.06/Makefile.PL000644 000766 000024 00000024454 13015653676 016260 0ustar00timbostaff000000 000000 # vim: ts=8 sw=2 sts=0 noexpandtab: ########################################################## ## This script is part of the Devel::NYTProf distribution ## ## Copyright, contact and other information can be found ## at the bottom of this file, or by going to: ## http://metacpan.org/release/Devel-NYTProf/ ## ########################################################### use 5.008001; use warnings; use strict; use ExtUtils::MakeMaker; use Getopt::Long; use Config; my $is_developer = (-d '.git'); # This lets perl developers build under ext/Devel, and profile parts of the core in place unless($ENV{PERL_CORE}) { $ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV; } my @man; if ($ENV{PERL_CORE}) { @man = ( MAN1PODS => {}, MAN3PODS => {} ); } else { @man = ( MAN1PODS => { 'bin/nytprofhtml' => '$(INST_MAN1DIR)/nytprofhtml.1', 'bin/nytprofmerge'=> '$(INST_MAN1DIR)/nytprofmerge.1', 'bin/nytprofcsv' => '$(INST_MAN1DIR)/nytprofcsv.1', 'bin/nytprofcalls'=> '$(INST_MAN1DIR)/nytprofcalls.1', 'bin/nytprofcg' => '$(INST_MAN1DIR)/nytprofcg.1', 'bin/nytprofpf' => '$(INST_MAN1DIR)/nytprofpf.1' } ); } # --- Options GetOptions( 'g!' => \my $opt_g, # compile with -g (for debugging) 'assert!' => \my $opt_assert, # enable assert()ions in the code (and perl headers) 'pg!' => \my $opt_pg, # compile with -pg (for profiling NYTProf itself) 'zlib!' => \(my $opt_zlib=1), # --nozlib to disallow use of zlib 'gettime!' => \(my $opt_gettime=1), # --nogettime to disallow use of POSIX clock_gettime 'machtime!' => \(my $opt_machtime=1), # --nomachtime to disallow use of mac osx clock ) or exit 1; if (not defined $opt_assert) { $opt_assert = 1 if $opt_g; $opt_assert = 1 if $ENV{AUTOMATED_TESTING}; # enable assert()s for cpan-testers } # --- make sure t/test40pmc.pmc is newer than t/test40pmc.pmc utime time(), time(), "t/test40pmc.pmc" or die "Can't update mod time of t/test40pmc.pmc"; # --- Discover how much of stdio is implemented my $cpp = $Config{cpp} || do { warn "Warning: cpp not found in your perl config. Falling back to 'cat'\n"; 'cat'; }; print "Looking for header files and functions...\n"; my $INCLUDE; my $h_files; my @h_dirs; push @h_dirs, split /:/, $ENV{INCLUDE} if $ENV{INCLUDE}; push @h_dirs, split ' ', $Config{libsdirs}; push @h_dirs, qw(/include /usr/include /usr/local/include /usr/include/mach); @h_dirs = grep { -d $_ } @h_dirs; $h_files = find_h_files(@h_dirs); # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my %mm_opts; my @libs = (); my @hdr_match_lib; push @hdr_match_lib, ['time.h', qr/(clock_gettime)\s*\(/, '-DHAS_CLOCK_GETTIME', '-lrt'] if $opt_gettime; push @hdr_match_lib, ['zlib.h', qr/(deflateInit2)(?:_)?\s*\(/, '-DHAS_ZLIB', '-lz'] if $opt_zlib; push @hdr_match_lib, ['mach_time.h', qr/(mach_absolute_time)\s*\(/, '-DHAS_MACH_TIME', undef] if $opt_machtime and $^O eq 'darwin'; foreach (@hdr_match_lib) { my ($header, $regexp, $define, $libs) = @$_; if (my $result = search_h_file($header, $regexp)) { print "Found $result in $header\n"; push @libs, $libs if $libs; $mm_opts{DEFINE} .= " $define" if $define; } } if ($opt_assert or (not defined $opt_assert and $is_developer)) { warn "Assertion testing enabled\n"; $mm_opts{DEFINE} .= " -DUSE_HARD_ASSERT"; } if ($ENV{NYTP_MAX_SUB_NAME_LEN}) { $mm_opts{DEFINE} .= " -DNYTP_MAX_SUB_NAME_LEN=$ENV{NYTP_MAX_SUB_NAME_LEN}"; } $mm_opts{LICENSE} = 'perl' if $ExtUtils::MakeMaker::VERSION >= 6.3002; $mm_opts{OPTIMIZE} = '-g' if $opt_g; $mm_opts{CCFLAGS} = "-pg" if $opt_pg; if( $ExtUtils::MakeMaker::VERSION >= 6.45 ) { $mm_opts{META_MERGE} = { "meta-spec" => { version => 2 }, no_index => { package => [ 'SVG' ], # in bin/flamegraph.pl }, resources => { license => 'http://dev.perl.org/licenses/', homepage => 'https://code.google.com/p/perl-devel-nytprof/', bugtracker => { web => 'https://github.com/timbunce/devel-nytprof/issues', # old => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Devel-NYTProf', mailto => 'bug-devel-nytprof@rt.cpan.org', }, repository => { url => 'git://github.com/timbunce/devel-nytprof.git', web => 'https://github.com/timbunce/devel-nytprof', type => 'git', }, # not a valid key: MailingList => 'http://groups.google.com/group/develnytprof-dev', } } } if (my $gccversion = $Config{gccversion}) { # ask gcc to be more pedantic print "Your perl was compiled with gcc (version $Config{gccversion}), okay.\n"; $gccversion =~ s/[^\d\.]//g; # just a number please $mm_opts{DEFINE} .= ' -W -Wall -Wpointer-arith -Wbad-function-cast'; $mm_opts{DEFINE} .= ' -Wno-comment -Wno-sign-compare -Wno-cast-qual'; $mm_opts{DEFINE} .= ' -Wmissing-noreturn -Wno-unused-parameter' if $gccversion ge "3.0"; if ($is_developer && $opt_g) { $mm_opts{DEFINE} .= ' -DPERL_GCC_PEDANTIC -ansi -pedantic' if $gccversion ge "3.0"; $mm_opts{DEFINE} .= ' -Wdisabled-optimization -Wformat' if $gccversion ge "3.0"; $mm_opts{DEFINE} .= ' -Wmissing-prototypes'; } } WriteMakefile( NAME => 'Devel::NYTProf', VERSION_FROM => 'lib/Devel/NYTProf/Core.pm', # finds $VERSION ABSTRACT_FROM => 'lib/Devel/NYTProf.pm', # retrieve abstract from module AUTHOR => 'Tim Bunce ', LICENSE => 'perl', PREREQ_PM => { 'List::Util' => 0, 'Test::More' => '0.84', 'File::Which' => '1.09', 'Test::Differences' => '0.60', 'XSLoader' => 0, 'Getopt::Long' => 0, 'JSON::MaybeXS' => 0, }, LIBS => [join ' ', @libs], OBJECT => q/$(O_FILES)/, FUNCLIST => ['boot_Devel__NYTProf', 'boot_Devel__NYTProf__FileHandle'], EXE_FILES => ['bin/nytprofhtml', 'bin/flamegraph.pl', 'bin/nytprofcsv', 'bin/nytprofcalls', 'bin/nytprofcg', 'bin/nytprofmerge', 'bin/nytprofpf'], @man, INC => $INCLUDE, clean => { FILES => join(" ", "nytprof demo-out", map { ("t/$_", "xt/$_") } qw( nytprof nytprof*.out nytprof*.out.* *_outdir test*.*_new auto )) }, dist => { DIST_DEFAULT => 'clean distcheck disttest tardist', PREOP => '$(MAKE) -f Makefile.old distdir', COMPRESS => 'gzip -v9', SUFFIX => 'gz', }, META_MERGE => { resources => { repository => 'https://github.com/timbunce/devel-nytprof', }, }, %mm_opts, ); exit 0; # --- Utility functions --- sub find_h_files { my @dirs = @_; my %h_files; foreach my $dir (@dirs) { next unless $dir; opendir(DIR, $dir) or next; # silently ignore missing directories while (my $file = readdir(DIR)) { next unless $file =~ /\.h$/; $h_files{$file} ||= $dir; # record first found } } close DIR; return \%h_files; } sub search_h_file { my ($h_file, $regex) = @_; my $dir = $h_files->{$h_file} or return undef; open H, "$cpp $dir/$h_file |"; while () { return $1 if m/$regex/; } close H; return undef; } # --- MakeMaker overrides --- package MY; # add some extra utility targets to the make file sub post_constants { q{ ptest prove:: pure_all time nice prove -b -j 9 --shuffle # not require because it confuses the call-graph # not dofile because it's an alias for require # (and causes problems like http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6409150.html) # not fork because it doesn't make much sense slowops:: $(NOECHO) $(PERL) -e 'require v5.10.0; # only regenerate with 5.10+ to get all ops' $(PERL) -MOpcode=opset_to_ops,opset \ -e 'print "/* generated by Makefile.PL for perl $$] */\n";' \ -e 'my @ops = opset_to_ops(opset(":base_io",":filesys_read",":filesys_write",":filesys_open",":sys_db",":subprocess",":others",qw(match subst substcont qr regcomp prtf crypt chdir flock ioctl socket getpeername ssockopt bind connect listen accept shutdown gsockopt getsockname sleep sort pack unpack syscall dump chroot dbmopen dbmclose lock sselect select), qw(!fileno !require !dofile !fork)));' \ -e 'print "PL_ppaddr[OP_\U$$_\E] = pp_slowop_profiler;\n" for sort @ops;' \ > slowops.h $(PERL) -e "warn qq{NOTE: slowops.h will need manual editing to restore lost #ifdef's around some opcodes!\n}"; svnmanifest:: svn list -R .@HEAD | sort | grep -v '/$$' > MANIFEST svn diff MANIFEST checkkeywords: $(RM_RF) blib find . \( -name .svn -prune -or -name t -prune -or -name \*.pm -or -name \*.PL -or -name \*.pl \) -type f \ -exec bash -c '[ "$$(svn pg svn:keywords {})" != "Id Revision Date" ] && echo svn propset svn:keywords \"Id Revision Date\" {}' \; checkpod: $(RM_RF) blib find . -type f \( -name .svn -prune -o -name \*.pm -o -name \*.PL -o -name \*.pl \) \ -exec podchecker {} \; 2>&1 | grep -v "pod syntax OK" PERLTIDY=perltidy --profile=.perltidyrc -nst -b perltidy: $(PERLTIDY) bin/nytprofhtml bin/nytprofcsv $(PERLTIDY) lib/Devel/NYTProf.pm lib/Devel/NYTProf/*.pm # the XS portion of the file will be mangled and require manual fixup ctidy_bcpp: bcpp -f 2 -i 4 -bcl -qb 10 -ylcnc -yb NYTProf.xs } } sub dynamic { my $make = shift->SUPER::dynamic(@_); my $xsl_dest_dir = '$(INST_LIB)/$(PARENT_NAME)/auto/$(FULLEXT)'; my $xsl_dest = '$(XSL_DEST_DIR)/$(DLBASE).$(DLEXT)'; if($^O eq 'VMS'){ $xsl_dest_dir = File::Spec->catdir('blib','lib','Devel','auto','Devel','NYTProf'); $xsl_dest = File::Spec->catfile('blib','lib','Devel','auto','Devel','NYTProf','PL_Devel__NYTProf'.'.exe'); } $make .= join "\n", '# Copy extension to where XSLoader looks to avoid fallback to DynaLoader', '# See t/test14.p for more details', "XSL_DEST_DIR = $xsl_dest_dir", "XSL_DEST = $xsl_dest", '', 'dynamic :: $(INST_DYNAMIC)', "\t" . '$(NOECHO) $(MKPATH) $(XSL_DEST_DIR)', "\t" . '$(CP) $(INST_DYNAMIC) $(XSL_DEST)', ''; return $make; } # vim:ts=8:sw=4:sts=0:noexpandtab Devel-NYTProf-6.06/.perltidyrc000644 000766 000024 00000002257 12067023751 016454 0ustar00timbostaff000000 000000 # Perl Best Practices (plus errata) .perltidyrc file -l=98 # Max line width is 98 cols -i=4 # Indent level is 4 cols -ci=4 # Continuation indent is 4 cols -st # Output to STDOUT -se # Errors to STDERR -vt=2 # Maximal vertical tightness -cti=0 # No extra indentation for closing brackets -pt=1 # Medium parenthesis tightness -bt=1 # Medium brace tightness -sbt=1 # Medium square bracket tightness -bbt=1 # Medium block brace tightness -nsfs # No space before semicolons -nolq # Don't outdent long quoted strings -wbb="% + - * / x != == >= <= =~ < > | & **= += *= &= <<= &&= -= /= |= >>= ||= .= %= ^= x=" # Break before all operators # extras/overrides/deviations from PBP #--maximum-line-length=100 # be slightly more generous --warning-output # Show warnings --maximum-consecutive-blank-lines=2 # default is 1 --nohanging-side-comments # troublesome for commented out code -isbc # block comments may only be indented if they have some space characters before the # # for the up-tight folk :) -pt=2 # High parenthesis tightness -bt=2 # High brace tightness -sbt=2 # High square bracket tightness Devel-NYTProf-6.06/.travis.yml000644 000766 000024 00000001672 13015662274 016406 0ustar00timbostaff000000 000000 language: perl perl: - "dev" - "dev-thr-mb-shrplib-dbg" - "5.24" - "5.24-extras" - "5.24-thr-mb-shrplib-dbg" - "5.22" - "5.22-extras" - "5.20" - "5.20-extras" - "5.18" - "5.18-extras" - "5.16" - "5.14" - "5.12" - "5.10" - "5.8" sudo: false # faster builds as long as you don't need sudo access before_install: - git clone git://github.com/travis-perl/helpers ~/travis-perl-helpers - source ~/travis-perl-helpers/init - build-perl - perl -V - build-dist - cd $BUILD_DIR # $BUILD_DIR is set by the build-dist command install: - cpan-install --deps # installs prereqs, including recommends - cpanm Test::Pod Test::Pod::Coverage || true - cpanm Test::Portability::Files || true matrix: fast_finish: true allow_failures: - perl: dev - perl: dev-thr-mb-shrplib-dbg notifications: irc: "irc.perl.org#nytprof" Devel-NYTProf-6.06/META.json000640 000766 000024 00000003365 13305245315 015706 0ustar00timbostaff000000 000000 { "abstract" : "Powerful fast feature-rich Perl source code profiler", "author" : [ "Tim Bunce " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Devel-NYTProf", "no_index" : { "directory" : [ "t", "inc" ], "package" : [ "SVG" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "File::Which" : "1.09", "Getopt::Long" : "0", "JSON::MaybeXS" : "0", "List::Util" : "0", "Test::Differences" : "0.60", "Test::More" : "0.84", "XSLoader" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-devel-nytprof@rt.cpan.org", "web" : "https://github.com/timbunce/devel-nytprof/issues" }, "homepage" : "https://code.google.com/p/perl-devel-nytprof/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/timbunce/devel-nytprof.git", "web" : "https://github.com/timbunce/devel-nytprof" }, "x_MailingList" : "http://groups.google.com/group/develnytprof-dev" }, "version" : "6.06", "x_serialization_backend" : "JSON::PP version 2.27203" } Devel-NYTProf-6.06/lib/Devel/000750 000766 000024 00000000000 13305245314 016061 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/lib/Devel/NYTProf.pm000644 000766 000024 00000147465 13305236563 017754 0ustar00timbostaff000000 000000 # vim: ts=8 sw=2 sts=0 noexpandtab: ########################################################## ## This script is part of the Devel::NYTProf distribution ## ## Copyright, contact and other information can be found ## at the bottom of this file, or by going to: ## http://metacpan.org/release/Devel-NYTProf/ ## ########################################################### package Devel::NYTProf; our $VERSION = '6.06'; # also change in Devel::NYTProf::Core package # hide the package from the PAUSE indexer DB; # Enable specific perl debugger flags (others may be set later). # Set the flags that influence compilation ASAP so we get full details # (sub line ranges etc) of modules loaded as a side effect of loading # Devel::NYTProf::Core (ie XSLoader, strict, Exporter etc.) # See "perldoc perlvar" for details of the $^P ($PERLDB) flags $^P = 0x010 # record line range of sub definition | 0x100 # informative "file" names for evals | 0x200; # informative names for anonymous subroutines require Devel::NYTProf::Core; # loads XS and sets options # XXX hack, need better option handling e.g., add DB::get_option('use_db_sub') my $use_db_sub = ($ENV{NYTPROF} && $ENV{NYTPROF} =~ m/\buse_db_sub=1\b/); if ($use_db_sub) { # install DB::DB sub *DB = ($] < 5.008008) ? sub { goto &DB_profiler } # workaround bug in old perl versions (slow) : \&DB_profiler; } # DB::sub shouldn't be called, but needs to exist for perl <5.8.7 ( =head1 DESCRIPTION Devel::NYTProf is a powerful, fast, feature-rich perl source code profiler. =over =item * Performs per-line statement profiling for fine detail =item * Performs per-subroutine statement profiling for overview =item * Performs per-opcode profiling for slow perl builtins =item * Performs per-block statement profiling (the first profiler to do so) =item * Accounts correctly for time spent after calls return =item * Performs inclusive and exclusive timing of subroutines =item * Subroutine times are per calling location (a powerful feature) =item * Can profile compile-time activity, just run-time, or just END time =item * Uses novel techniques for efficient profiling =item * Sub-microsecond (100ns) resolution on supported systems =item * Very fast - the fastest statement and subroutine profilers for perl =item * Handles applications that fork, with no performance cost =item * Immune from noise caused by profiling overheads and I/O =item * Program being profiled can stop/start the profiler =item * Generates richly annotated and cross-linked html reports =item * Captures source code, including string evals, for stable results =item * Trivial to use with mod_perl - add one line to httpd.conf =item * Includes an extensive test suite =item * Tested on very large codebases =back NYTProf is effectively two profilers in one: a statement profiler, and a subroutine profiler. =head2 Statement Profiling The statement profiler measures the time between entering one perl statement and entering the next. Whenever execution reaches a new statement, the time since entering the previous statement is calculated and added to the time associated with the line of the source file that the previous statement starts on. By default the statement profiler also determines the first line of the current block and the first line of the current statement, and accumulates times associated with those. Another innovation unique to NYTProf is automatic compensation for a problem inherent in simplistic statement-to-statement timing. Consider a statement that calls a subroutine and then performs some other work that doesn't execute new statements, for example: foo(...) + mkdir(...); In all other statement profilers the time spent in remainder of the expression (mkdir in the example) will be recorded as having been spent I! Here's another example: while (<>) { ... 1; } After the first time around the loop, any further time spent evaluating the condition (waiting for input in this example) would be recorded as having been spent I! (Until perl bug #60954 is fixed this problem still applies to some loops. For more information see L) NYTProf avoids these problems by intercepting the opcodes which indicate that control is returning into some previous statement and adjusting the profile accordingly. The statement profiler naturally generates a lot of data which is streamed out to a file in a very compact format. NYTProf takes care to not include the measurement and writing overheads in the profile times (some profilers produce 'noisy' data due to periodic stdio flushing). =head2 Subroutine Profiling The subroutine profiler measures the time between entering a subroutine and leaving it. It then increments a call count and accumulates the duration. For each subroutine called, separate counts and durations are stored I. Subroutine entry is detected by intercepting the C opcode. Subroutine exit is detected via perl's internal save stack. As a result the subroutine profiler is both fast and robust. =head3 Subroutine Recursion For subroutines that recurse directly or indirectly, such as Error::try, the inclusive time is only measured for the outer-most call. The inclusive times of recursive calls are still measured and are accumulated separately. Also the 'maximum recursion depth' per calling location is recorded. =head3 Goto &Subroutine Perl implements a C as a C followed by a call to C<&destination>, so that's how it will appear in the report. The C will be shown with a very short time because it's effectively just a C. The C<&destination> sub will show a call I from the location of the C but from the location of the call to the sub that performed the C. =head3 accept() The perl built-in accept() function waits listening for a connection on a socket, and so is a key part of pure-perl network service applications. The time spent waiting for a remotely initiated connection can be relatively high but is not relevant to the performance of the application. So the accept() function is treated as a special case. The subroutine profiler discounts the time spent in the accept() function. It does this in a way that also discounts that time from all the callers up the call stack. The effect on the reports is that all accept() calls appear to be instant. The I profiler still shows the time actually spent in the statement that executed the accept() call. =head2 Application Profiling NYTProf records extra information in the data file to capture details that may be useful when analyzing the performance. It also records the filename and line ranges of all the subroutines. NYTProf can profile applications that fork, and does so with no loss of performance. NYTProf detects the fork and starts writing a new profile file with the pid appended to the filename. Since L only works with a single profile file you may want to merge multiple files using L. =head2 Fast Profiling The NYTProf profiler is written almost entirely in C and great care has been taken to ensure it's very efficient. =head2 Apache Profiling Just add one line near the start of your httpd.conf file: PerlModule Devel::NYTProf::Apache By default you'll get a F file for the parent process and a F file for each worker process. NYTProf takes care to detect when control is returning back from perl to mod_perl so time spent in mod_perl (such as waiting for the next request) does not get allocated to the last statement executed. Works with mod_perl 1 and 2. See L for more information. =head1 PROFILING Usually you'd load Devel::NYTProf on the command line using the perl -d option: perl -d:NYTProf some_perl.pl To save typing the ':NYTProf' you could set the PERL5DB env var PERL5DB='use Devel::NYTProf' and then just perl -d would work: perl -d some_perl.pl Or you can avoid the need to add the -d option at all by using the C env var: PERL5OPT=-d:NYTProf That's also very handy when you can't alter the perl command line being used to run the script you want to profile. Usually you'll want to enable the L option to ensure any nested invocations of perl don't overwrite the profile. =head1 NYTPROF ENVIRONMENT VARIABLE The behavior of Devel::NYTProf may be modified by setting the environment variable C. It is possible to use this environment variable to effect multiple setting by separating the values with a C<:>. For example: export NYTPROF=trace=2:start=init:file=/tmp/nytprof.out Any colon or equal characters in a value can be escaped by preceding them with a backslash. =head2 addpid=1 Append the current process id to the end of the filename. This avoids concurrent, or consecutive, processes from overwriting the same file. If a fork is detected during profiling then the child process will automatically add the process id to the filename. =head2 addtimestamp=1 Append the current time, as integer epoch seconds, to the end of the filename. =head2 trace=N Set trace level to N. 0 is off (the default). Higher values cause more detailed trace output. Trace output is written to STDERR or wherever the L option has specified. =head2 log=F Specify the name of the file that L output should be written to. =head2 start=... Specify at which phase of program execution the profiler should be enabled: start=begin - start immediately (the default) start=init - start at beginning of INIT phase (after compilation/use/BEGIN) start=end - start at beginning of END phase start=no - don't automatically start The start=no option is handy if you want to explicitly control profiling by calling DB::enable_profile() and DB::disable_profile() yourself. See L. The start=init option is handy if you want to avoid profiling the loading and initialization of modules. =head2 optimize=0 Disable the perl optimizer. By default NYTProf leaves perl's optimizer enabled. That gives you more accurate profile timing overall, but can lead to I statement counts for individual sets of lines. That's because the perl's peephole optimizer has effectively rewritten the statements but you can't see what the rewritten version looks like. For example: 1 if (...) { 2 return; 3 } may be rewritten as 1 return if (...) so the profile won't show a statement count for line 2 in your source code because the C was merged into the C statement on the preceding line. Also 'empty' statements like C<1;> are removed entirely. Such statements are empty because the optimizer has already removed the pointless constant in void context. It then goes on to remove the now empty statement (in perl >= 5.13.7). Using the C option disables the optimizer so you'll get lower overall performance but more accurately assigned statement counts. If you find any other examples of the effect of optimizer on NYTProf output (other than performance, obviously) please let us know. =head2 subs=0 Set to 0 to disable the collection of subroutine caller and timing details. =head2 blocks=1 Set to 1 to enable the determination of block and subroutine location per statement. This makes the profiler about 50% slower (as of July 2008) and produces larger output files, but you gain some valuable insight in where time is spent in the blocks within large subroutines and scripts. =head2 stmts=0 Set to 0 to disable the statement profiler. (Implies C.) The reports won't contain any statement timing detail. This significantly reduces the overhead of the profiler and can also be useful for profiling large applications that would normally generate a very large profile data file. =head2 calls=N This option is I. With calls=1 (the default) subroutine call I events are emitted into the data stream as they happen. With calls=2 subroutine call I events are also emitted. With calls=0 no subroutine call events are produced. This option depends on the C option being enabled, which it is by default. The L utility can be used to process this data. It too is I and so likely to change. The subroutine profiler normally gathers data in memory and outputs a summary when the profile data is being finalized, usually when the program has finished. The summary contains aggregate information for all the calls from one location to another, but the details of individual calls have been lost. The calls option enables the recording of individual call events and thus more detailed analysis and reporting of that data. =head2 leave=0 Set to 0 to disable the extra work done by the statement profiler to allocate times accurately when returning into the middle of statement. For example leaving a subroutine and returning into the middle of statement, or re-evaluating a loop condition. This feature also ensures that in embedded environments, such as mod_perl, the last statement executed doesn't accumulate the time spent 'outside perl'. =head2 findcaller=1 Force NYTProf to recalculate the name of the caller of the each sub instead of 'inheriting' the name calculated when the caller was entered. (Rarely needed, but might be useful in some odd cases.) =head2 use_db_sub=1 Set to 1 to enable use of the traditional DB::DB() subroutine to perform profiling, instead of the faster 'opcode redirection' technique that's used by default. Also effectively sets C (see above). The default 'opcode redirection' technique can't profile subroutines that were compiled before NYTProf was loaded. So using use_db_sub=1 can be useful in cases where you can't load the profiler early in the life of the application. Another side effect of C is that it enables recording of the source code of the C<< perl -e '...' >> and C<< perl - >> input for old versions of perl. See also L. =head2 savesrc=0 Disable the saving of source code. By default NYTProf saves a copy of all source code into the profile data file. This makes the file self-contained, so the reporting tools no longer depend on having the unmodified source code files available. With C some source code is still saved: the arguments to the C option, the script fed to perl via STDIN when using C, and the source code of string evals. Saving the source code of string evals requires perl version 5.8.9+, 5.10.1+, or 5.12 or later. Saving the source code of the C<< perl -e '...' >> or C<< perl - >> input requires either a recent perl version, as above, or setting the L option. =head2 slowops=N Profile perl opcodes that can be slow. These include opcodes that make system calls, such as C, C, C, C etc., plus regular expression opcodes like C and C. If C is 0 then slowops profiling is disabled. If C is 1 then all the builtins are treated as being defined in the C package. So times for C calls from anywhere in your code are merged and accounted for as calls to an xsub called C. If C is 2 (the default) then builtins are treated as being defined in the package that calls them. So calls to C from package C are treated as calls to an xsub called C. Note the single colon after CORE. The opcodes are currently profiled using their internal names, so C is C and the C<-x> file test is C. This may change in future. Opcodes that call subroutines, perhaps by triggering a FETCH from a tied variable, currently appear in the call tree as the caller of the sub. This is likely to change in future. =head2 usecputime=1 This option has been removed. Profiling won't be enabled if set. Use the L option to select a high-resolution CPU time clock, if available on your system, instead. That will give you higher resolution and work for the subroutine profiler as well. =head2 file=... Specify the output file to write profile data to (default: './nytprof.out'). =head2 compress=... Specify the compression level to use, if NYTProf is compiled with compression support. Valid values are 0 to 9, with 0 disabling compression. The default is 6 as higher values yield little extra compression but the cpu cost starts to rise significantly. Using level 1 still gives you a significant reduction in file size. If NYTProf was not compiled with compression support, this option is silently ignored. =head2 clock=N Systems which support the C system call typically support several clocks. By default NYTProf uses CLOCK_MONOTONIC. This option enables you to select a different clock by specifying the integer id of the clock (which may vary between operating system types). If the clock you select isn't available then CLOCK_REALTIME is used. See L for more information. =head2 sigexit=1 When perl exits normally it runs any code defined in C blocks. NYTProf defines an END block that finishes profiling and writes out the final profile data. If the process ends due to a signal then END blocks are not executed so the profile will be incomplete and unusable. The C option tells NYTProf to catch some signals (e.g. INT, HUP, PIPE, SEGV, BUS) and ensure a usable profile by executing: DB::finish_profile(); exit 1; You can also specify which signals to catch in this way by listing them, separated by commas, as the value of the option (case is not significant): sigexit=int,hup =head2 posix_exit=1 The NYTProf subroutine profiler normally detects calls to C (which exits the process without running END blocks) and automatically calls C for you, so NYTProf 'just works'. When using the C option to disable the subroutine profiler the C option can be used to tell NYTProf to take other steps to arrange for C to be called before C. =head2 libcexit=1 Arranges for L to be called via the C library C function. This may help some tricky cases where the process may exit without perl executing the C block that NYTProf uses to call /finish_profile(). =head2 endatexit=1 Sets the PERL_EXIT_DESTRUCT_END flag in the PL_exit_flags of the perl interpreter. This makes perl run C blocks in perl_destruct() instead of perl_run() which may help in cases, like Apache, where perl is embedded but perl_run() isn't called. =head2 forkdepth=N When a perl process that is being profiled executes a fork() the child process is also profiled. The forkdepth option can be used to control this. If forkdepth is zero then profiling will be disabled in the child process. If forkdepth is greater than zero then profiling will be enabled in the child process and the forkdepth value in that process is decremented by one. If forkdepth is -1 (the default) then there's no limit on the number of generations of children that are profiled. =head2 nameevals=0 The 'file name' of a string eval is normally a string like "C<(eval N)>", where C is a sequence number. By default NYTProf asks perl to give evals more informative names like "C<(eval N)[file:line]>", where C and C are the file and line number where the string C was executed. The C option can be used to disable the more informative names and return to the default behaviour. This may be need in rare cases where the application code is sensitive to the name given to a C. (The most common case in when running test suites undef NYTProf.) The downside is that the NYTProf reporting tools are less useful and may get confused if this option is used. =head2 nameanonsubs=0 The name of a anonymous subroutine is normally "C<__ANON__>". By default NYTProf asks perl to give anonymous subroutines more informative names like "C<__ANON__[file:line]>", where C and C are the file and line number where the anonymous subroutine was defined. The C option can be used to disable the more informative names and return to the default behaviour. This may be need in rare cases where the application code is sensitive to the name given to a anonymous subroutines. (The most common case in when running test suites undef NYTProf.) The downside is that the NYTProf reporting tools are less useful and may get confused if this option is used. =head1 RUN-TIME CONTROL OF PROFILING You can profile only parts of an application by calling DB::disable_profile() to stop collecting profile data, and calling DB::enable_profile() to start collecting profile data. Using the C option lets you leave the profiler disabled initially until you call DB::enable_profile() at the right moment. You still need to load Devel::NYTProf as early as possible, even if you don't call DB::enable_profile() until much later. That's because any code that's compiled before Devel::NYTProf is loaded will not be profiled by default. See also L. The profile output file can't be used until it's been properly completed and closed. Calling DB::disable_profile() doesn't do that. To make a profile file usable before the profiled application has completed you can call DB::finish_profile(). Alternatively you could call DB::enable_profile($newfile). Always call the DB::enable_profile(), DB::disable_profile() or DB::finish_profile() function with the C prefix as shown because you can't import them. They're provided automatically when NYTProf is in use. =head2 disable_profile DB::disable_profile() Stops collection of profile data until DB:enable_profile() is called. Subroutine calls which were made while profiling was enabled and are still on the call stack (have not yet exited) will still have their profile data collected when they exit. Compare with L below. =head2 enable_profile DB::enable_profile($newfile) DB::enable_profile() Enables collection of profile data. If $newfile is specified the profile data will be written to $newfile (after completing and closing the previous file, if any). If $newfile already exists it will be deleted first. If DB::enable_profile() is called without a filename argument then profile data will continue to be written to the current file (nytprof.out by default). =head2 finish_profile DB::finish_profile() Calls DB::disable_profile(), then completes the profile data file by writing subroutine profile data, and then closes the file. The in memory subroutine profile data is then discarded. Normally NYTProf arranges to call finish_profile() for you via an END block. =head1 DATA COLLECTION AND INTERPRETATION NYTProf tries very hard to gather accurate information. The nature of the internals of perl mean that, in some cases, the information that's gathered is accurate but surprising. In some cases it can appear to be misleading. (Of course, in some cases it may actually be plain wrong. Caveat lector.) =head2 If Statement and Subroutine Timings Don't Match NYTProf has two profilers: a statement profiler that's invoked when perl moves from one perl statement to another, and a subroutine profiler that's invoked when perl calls or returns from a subroutine. The individual statement timings for a subroutine usually add up to slightly less than the exclusive time for the subroutine. That's because the handling of the subroutine call and return overheads is included in the exclusive time for the subroutine. The difference may only be a few microseconds but that may become noticeable for subroutines that are called hundreds of thousands of times. The statement profiler keeps track how much time was spent on overheads, like writing statement profile data to disk. The subroutine profiler subtracts the overheads that have accumulated between entering and leaving the subroutine in order to give a more accurate profile. The statement profiler is generally very fast because most writes get buffered for zip compression so the profiler overhead per statement tends to be very small, often a single 'tick'. The result is that the accumulated overhead is quite noisy. This becomes more significant for subroutines that are called frequently and are also fast. This may be another, smaller, contribution to the discrepancy between statement time and exclusive times. =head2 If Headline Subroutine Timings Don't Match the Called Subs Overall subroutine times are reported with a headline like C. In this example, 10 seconds were spent inside the subroutine (the "inclusive time") and, of that, 8 seconds were spent in subroutines called by this one. That leaves 2 seconds as the time spent in the subroutine code itself (the "exclusive time", sometimes also called the "self time"). The report shows the source code of the subroutine. Lines that make calls to other subroutines are annotated with details of the time spent in those calls. Sometimes the sum of the times for calls made by the lines of code in the subroutine is less than the inclusive-exclusive time reported in the headline (10-2 = 8 seconds in the example above). What's happening here is that calls to other subroutines are being made but NYTProf isn't able to determine the calling location correctly so the calls don't appear in the report in the correct place. Using an old version of perl is one cause (see below). Another is calling subroutines that exit via C - most frequently encountered in AUTOLOAD subs and code using the L module. In general the overall subroutine timing is accurate and should be trusted more than the sum of statement or nested sub call timings. =head2 Perl 5.10.1+ (or else 5.8.9+) is Recommended These versions of perl yield much more detailed information about calls to BEGIN, CHECK, INIT, and END blocks, the code handling tied or overloaded variables, and callbacks from XS code. Perl 5.12 will hopefully also fix an inaccuracy in the timing of the last statement and the condition clause of some kinds of loops: L =head2 eval $string Perl treats each execution of a string eval (C not C) as a distinct file, so NYTProf does as well. The 'files' are given names with this structure: (eval $sequence)[$filename:$line] for example "C<(eval 93)[/foo/bar.pm:42]>" would be the name given to the 93rd execution of a string eval by that process and, in this case, the 93rd eval happened to be one at line 42 of "/foo/bar.pm". Nested string evals can give rise to file names like (eval 1047)[(eval 93)[/foo/bar.pm:42]:17] =head3 Merging Evals Some applications execute a great many string eval statements. If NYTProf generated a report page for each one it would not only slow report generation but also make the overall report less useful by scattering performance data too widely. On the other hand, being able to see the actual source code executed by an eval, along with the timing details, is often I useful. To try to balance these conflicting needs, NYTProf currently I. What does that mean? Well, for each source code line that executed any string evals, NYTProf first gathers the corresponding eval 'files' for that line (known as the 'siblings') into groups keyed by distinct source code. Then, for each of those groups of siblings, NYTProf will 'merge' a group that shares the same source code and doesn't execute any string evals itself. Merging means to pick one sibling as the survivor and merge and delete all the data from the others into it. If there are a large number of sibling groups then the data for all of them are merged into one regardless. The report annotations will indicate when evals have been merged together. =head3 Merging Anonymous Subroutines Anonymous subroutines defined within string evals have names like this: main::__ANON__[(eval 75)[/foo/bar.pm:42]:12] That anonymous subroutine was defined on line 12 of the source code executed by the string eval on line 42 of F. That was the 75th string eval executed by the program. Anonymous subroutines I are also merged. That is, the profile information is merged into one and the others are discarded. =head3 Timing Care should be taken when interpreting the report annotations associated with a string eval statement. Normally the report annotations embedded into the source code related to timings from the I profiler. This isn't (currently) true of annotations for string eval statements. This makes a significant different if the eval defines any subroutines that get called I the eval has returned. Because the time shown for a string eval is based on the I times it will include time spent executing statements within the subs defined by the eval. In future NYTProf may involve the subroutine profiler in timings evals and so be able to avoid this issue. =head2 Calls from XSUBs and Opcodes Calls record the current filename and line number of the perl code at the time the call was made. That's fine and accurate for calls from perl code. For calls that originate from C code however, such as an XSUB or an opcode, the filename and line number recorded are still those of the last I statement executed. For example, a line that calls an xsub will appear in reports to also have also called any subroutines that that xsub called. This can be construed as a feature. As an extreme example, the first time a regular expression that uses character classes is executed on a unicode string you'll find profile data like this: # spent 1ms within main::BEGIN@4 which was called # once (1ms+0s) by main::CORE:subst at line 0 4 s/ (?: [A-Z] | [\d] )+ (?= [\s] ) //x; # spent 38.8ms making 1 call to main::CORE:subst # spent 25.4ms making 2 calls to utf8::SWASHNEW, avg 12.7ms/call # spent 12.4ms making 1 call to utf8::AUTOLOAD =for comment No doubt more odd cases will be added here over time. =head1 MAKING NYTPROF FASTER You can reduce the cost of profiling by adjusting some options. The trade-off is reduced detail and/or accuracy in reports. If you don't need statement-level profiling then you can disable it via L. To further boost statement-level profiling performance try L but note that I apportion timings for some kinds of statements less accurate). If you don't need call stacks or flamegraph then disable it via L. If you don't need subroutine profiling then you can disable it via L. If you do need it but don't need timings for perl opcodes then set L. Generally speaking, setting calls=0 and slowops=0 will give you a useful boost with the least loss of detail. Another approach is to only enable NYTProf in the sections of code that interest you. See L for more details. To speed up L try using the --minimal (-m) or --no-flame options. =head1 REPORTS The L module provides a low-level interface for loading the profile data. The L module provides an interface for generating arbitrary reports. This means that you can implement your own output format in perl. (Though the module is in a state of flux and may be deprecated soon.) Included in the bin directory of this distribution are some scripts which turn the raw profile data into more useful formats: =head2 nytprofhtml Creates attractive, richly annotated, and fully cross-linked html reports (including statistics, source code and color highlighting). This is the main report generation tool for NYTProf. =head2 nytprofcg Translates a profile into a format that can be loaded into KCachegrind L =head2 nytprofcalls Reads a profile and processes the calls events it contains. =head2 nytprofmerge Reads multiple profile data files and writes out a new file containing the merged profile data. =head1 LIMITATIONS =head2 Threads and Multiplicity C is not currently thread safe or multiplicity safe. If you'd be interested in helping to fix that then please get in touch with us. Meanwhile, profiling is disabled when a thread is created, and NYTProf tries to ignore any activity from perl interpreters other than the first one that loaded it. =head2 Coro The C subroutine profiler gets confused by the stack gymnastics performed by the L module and aborts. When profiling applications that use Coro you should disable the subroutine profiler using the L option. =head2 FCGI::Engine Using C in code running under L causes a panic in nytprofcalls. See https://github.com/timbunce/devel-nytprof/issues/20 for more information. =head2 For perl < 5.8.8 it may change what caller() returns For example, the L module croaks with "Invalid tie" when profiled with perl versions before 5.8.8. That's because L explicitly checking for certain values from caller(). The L module is also affected. =head2 For perl < 5.10.1 it can't see some implicit calls and callbacks For perl versions prior to 5.8.9 and 5.10.1, some implicit subroutine calls can't be seen by the I profiler. Technically this affects calls made via the various perl C internal APIs. For example, BEGIN/CHECK/INIT/END blocks, the CI subroutine called by C, all calls made via operator overloading, and callbacks from XS code, are not seen. The effect is that time in those subroutines is accumulated by the subs that triggered the call to them. So time spent in calls invoked by perl to handle overloading are accumulated by the subroutines that trigger overloading (so it is measured, but the cost is dispersed across possibly many calling locations). Although the calls aren't seen by the subroutine profiler, the individual I executed by the code in the called subs are profiled by the statement profiler. =head2 #line directives The reporting code currently doesn't handle #line directives, but at least it warns about them. Patches welcome. =head2 Freed values in @_ may be mutated Perl has a class of bugs related to the fact that values placed in the stack are not reference counted. Consider this example: @a = (1..9); sub s { undef @a; print $_ for @_ } s(@a); The C frees the values that C<@_> refers to. Perl can sometimes detect when a freed value is accessed and treats it as an undef. However, if the freed value is assigned some new value then @_ is effectively corrupted. NYTProf allocates new values while it's profiling, in order to record program activity, and so may appear to corrupt C<@_> in this (rare) situation. If this happens, NYTProf is simply exposing an existing problem in the code. =head2 Lvalue subroutines aren't profiled when using use_db_sub=1 Currently 'lvalue' subroutines (subs that can be assigned to, like C) are not profiled when using use_db_sub=1. =head1 CLOCKS Here we discuss the way NYTProf gets high-resolution timing information from your system and related issues. =head2 POSIX Clocks These are the clocks that your system may support if it supports the POSIX C function. Other clock sources are listed in the L section below. The C interface allows clocks to return times to nanosecond precision. Of course few offer nanosecond I but the extra precision helps reduce the cumulative error that naturally occurs when adding together many timings. When using these clocks NYTProf outputs timings as a count of 100 nanosecond ticks. =head3 CLOCK_MONOTONIC CLOCK_MONOTONIC represents the amount of time since an unspecified point in the past (typically system start-up time). It increments uniformly independent of adjustments to 'wallclock time'. NYTProf will use this clock by default, if available. =head3 CLOCK_REALTIME CLOCK_REALTIME is typically the system's main high resolution 'wall clock time' source. The same source as used for the gettimeofday() call used by most kinds of perl benchmarking and profiling tools. The problem with real time is that it's far from simple. It tends to drift and then be reset to match 'reality', either sharply or by small adjustments (via the adjtime() system call). Surprisingly, it can also go backwards, for reasons explained in http://preview.tinyurl.com/5wawnn so CLOCK_MONOTONIC is preferred. =head3 CLOCK_VIRTUAL CLOCK_VIRTUAL increments only when the CPU is running in user mode on behalf of the calling process. =head3 CLOCK_PROF CLOCK_PROF increments when the CPU is running in user I kernel mode. =head3 CLOCK_PROCESS_CPUTIME_ID CLOCK_PROCESS_CPUTIME_ID represents the amount of execution time of the process associated with the clock. =head3 CLOCK_THREAD_CPUTIME_ID CLOCK_THREAD_CPUTIME_ID represents the amount of execution time of the thread associated with the clock. =head3 Finding Available POSIX Clocks On unix-like systems you can find the CLOCK_* clocks available on you system using a command like: grep -r 'define *CLOCK_' /usr/include Look for a group that includes CLOCK_REALTIME. The integer values listed are the clock ids that you can use with the C option. A future version of NYTProf should be able to list the supported clocks. =head2 Other Clocks This section lists other clock sources that NYTProf may use. If your system doesn't support clock_gettime() then NYTProf will use gettimeofday(), or the nearest equivalent, =head3 gettimeofday This is the traditional high resolution time of day interface for most unix-like systems. With this clock NYTProf outputs timings as a count of 1 microsecond ticks. =head3 mach_absolute_time On Mac OS X the mach_absolute_time() function is used. With this clock NYTProf outputs timings as a count of 100 nanosecond ticks. =head3 Time::HiRes On systems which don't support other clocks, NYTProf falls back to using the L module. With this clock NYTProf outputs timings as a count of 1 microsecond ticks. =head2 Clock References Relevant specifications and manual pages: http://www.opengroup.org/onlinepubs/000095399/functions/clock_getres.html http://linux.die.net/man/3/clock_gettime Why 'realtime' can appear to go backwards: http://preview.tinyurl.com/5wawnn The PostgreSQL pg_test_timing utility documentation has a good summary of timing issues: http://www.postgresql.org/docs/9.2/static/pgtesttiming.html =for comment http://preview.tinyurl.com/5wawnn redirects to: http://groups.google.com/group/comp.os.linux.development.apps/tree/browse_frm/thread/dc29071f2417f75f/ac44671fdb35f6db?rnum=1&_done=%2Fgroup%2Fcomp.os.linux.development.apps%2Fbrowse_frm%2Fthread%2Fdc29071f2417f75f%2Fc46264dba0863463%3Flnk%3Dst%26rnum%3D1%26 =for comment - these links seem broken http://webnews.giga.net.tw/article//mailing.freebsd.performance/710 http://sean.chittenden.org/news/2008/06/01/ =head1 CAVEATS =head2 SMP Systems On systems with multiple processors, which includes most modern machines, (from Linux docs though applicable to most SMP systems): The CLOCK_PROCESS_CPUTIME_ID and CLOCK_THREAD_CPUTIME_ID clocks are realized on many platforms using timers from the CPUs (TSC on i386, AR.ITC on Itanium). These registers may differ between CPUs and as a consequence these clocks may return bogus results if a process is migrated to another CPU. If the CPUs in an SMP system have different clock sources then there is no way to maintain a correlation between the timer registers since each CPU will run at a slightly different frequency. If that is the case then clock_getcpuclockid(0) will return ENOENT to signify this condition. The two clocks will then only be useful if it can be ensured that a process stays on a certain CPU. The processors in an SMP system do not start all at exactly the same time and therefore the timer registers are typically running at an offset. Some architectures include code that attempts to limit these offsets on bootup. However, the code cannot guarantee to accurately tune the offsets. Glibc contains no provisions to deal with these offsets (unlike the Linux Kernel). Typically these offsets are small and therefore the effects may be negligible in most cases. In summary, SMP systems are likely to give 'noisy' profiles. Setting a L may help. =head3 Processor Affinity Processor affinity is an aspect of task scheduling on SMP systems. "Processor affinity takes advantage of the fact that some remnants of a process may remain in one processor's state (in particular, in its cache) from the last time the process ran, and so scheduling it to run on the same processor the next time could result in the process running more efficiently than if it were to run on another processor." (From http://en.wikipedia.org/wiki/Processor_affinity) Setting an explicit processor affinity can avoid the problems described in L. Processor affinity can be set using the C command on Linux. Note that processor affinity is inherited by child processes, so if the process you're profiling spawns cpu intensive sub processes then your process will be impacted by those more than it otherwise would. =head3 Windows B On Windows NYTProf uses Time::HiRes which uses the windows QueryPerformanceCounter() API with some extra logic to adjust for the current clock speed and try to resync the raw counter to wallclock time every so often (every 30 seconds or if the timer drifts by more than 0.5 of a seconds). This extra logic may lead to occasional spurious results. (It would be great if someone could contribute a patch to NYTProf to use QueryPerformanceCounter() directly and avoid the overheads and resyncing behaviour of Time::HiRes.) =head2 Virtual Machines I recommend you don't do performance profiling while running in a virtual machine. If you do you're likely to find inexplicable spikes of real-time appearing at unreasonable places in your code. You should pay less attention to the statement timings and rely more on the subroutine timings. They will still be noisy but less so than the statement times. You could also try using the C option to select a high-resolution I clock instead of a real-time one. That should be much less noisy, though you will lose visibility of wait-times due to network and disk I/O, for example. =head1 BUGS Possibly. All complex software has bugs. Let me know if you find one. =head1 SEE ALSO Screenshots of L v2.01 reports can be seen at L and L. A writeup of the new features of NYTProf v2 can be found at L and the background story, explaining the "why", can be found at L. Mailing list and discussion at L Blog posts L Public Github Repository and hacking instructions at L L is a script included that produces html reports. L is another script included that produces plain text CSV reports. L is the module that powers the report scripts. You might want to check this out if you plan to implement a custom report (though it's very likely to be deprecated in a future release). L is the module that lets you read a profile data file as a stream of chunks of data. Other tools: DTrace L =head1 TROUBLESHOOTING =head2 "Profile data incomplete, ..." or "Profile format error: ..." This error message means the file doesn't contain all the expected data or the data has been corrupted in some way. That may be because it was truncated (perhaps the filesystem was full) or, more commonly, because the all the expected data hasn't been written. NYTProf writes some important data to the data file when I profiling. If you read the file before the profiling has finished you'll get this error. If the process being profiled is still running you'll need to wait until it exits cleanly (runs C blocks or L is called explicitly). If the process being profiled has exited then it's likely that it met with a sudden and unnatural death that didn't give NYTProf a chance to finish the profile. If the sudden death was due to a signal, like SIGTERM, or a SIGINT from pressing Ctrl-C, then the L option may help. If the sudden death was due to calling C then you'll need to call L before calling C. You'll also get this error if the code trying to read the profile is itself being profiled. That's most likely to happen if you enable profiling via the C environment variable and have forgotten to unset it. If you've encountered this error message, and you're sure you've understood the concerns described above, and you're sure they don't apply in your case, then please open an issue. Be sure to include sufficient information so I can see how you've addressed these likely causes. =head2 Some source files don't have profile information This is usually due to NYTProf being initialized after some perl files have already been compiled. If you can't alter the command line to add "C<-d:NYTProf>" you could try using the C environment variable. See L. You could also try using the L option. =head2 Eval ... has unknown invoking fid When using the statement profiler you may see a warning message like this: Eval '(eval 2)' (fid 9, flags:viastmt,savesrc) has unknown invoking fid 10 Notice that the eval file id (fid 9 in this case) is lower than the file id that invoked the eval (fid 10 in this case). This is a known problem caused by the way perl works and how the profiler assigns and outputs the file ids. The invoking fid is known but gets assigned a fid and output after the fid for the eval, and that causes the warning when the file is read. =head2 Warning: %d subroutine calls had negative time There are two likely causes for this: clock instability, or accumulated timing errors. Clock instability, if present on your system, is most likely to be noticeable on very small/fast subroutines that are called very few times. Accumulated timing errors can arise because the subroutine profiler uses floating point values (NVs) to store the times. They are most likely to be noticed on subroutines that are called a few times but which make a large number of calls to very fast subroutines (such as opcodes). In this case the accumulated time apparently spent making those calls can be greater than the time spent in the calling subroutine. If you rerun nytprofhtml (etc.) with the L option set >0 you'll see trace messages like "%s call has negative time: incl %fs, excl %fs" for each affected subroutine. Try profiling with the L option set to 0 to disable the profiling of opcodes. Since opcodes often execute in a few microseconds they are a common cause of this warning. You could also try recompiling perl to use 'long doubles' for the NV floating point type (use Configure -Duselongdouble). If you try this please let me know. I'd also happily take a patch to use long doubles, if available, by default. =head2 panic: buffer overflow ... You have unusually long subroutine names in your code. You'll need to rebuild Devel::NYTProf with the NYTP_MAX_SUB_NAME_LEN environment variable set to a value longer than the longest subroutine names in your code. =head1 AUTHORS AND CONTRIBUTORS B (L and L) leads the project and has done most of the development work thus far. B contributed zip compression and C. B contributed C. B contributed the VMS port. B contributed the Windows port. B contributed the Devel::NYTProf::ReadStream module. B contributed greater perl version portability and use of POSIX high-resolution clocks. Other contributors are noted in the Changes file. Many thanks to B who created C initially by forking C adding reporting from C and a test suite. For more details see L below. =head1 COPYRIGHT AND LICENSE Copyright (C) 2008 by Adam Kaplan and The New York Times Company. Copyright (C) 2008-2016 by Tim Bunce, Ireland. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =head2 Background Subroutine-level profilers: Devel::DProf | 1995-10-31 | ILYAZ Devel::AutoProfiler | 2002-04-07 | GSLONDON Devel::Profiler | 2002-05-20 | SAMTREGAR Devel::Profile | 2003-04-13 | JAW Devel::DProfLB | 2006-05-11 | JAW Devel::WxProf | 2008-04-14 | MKUTTER Statement-level profilers: Devel::SmallProf | 1997-07-30 | ASHTED Devel::FastProf | 2005-09-20 | SALVA Devel::NYTProf | 2008-03-04 | AKAPLAN Devel::Profit | 2008-05-19 | LBROCARD Devel::NYTProf is a (now distant) fork of Devel::FastProf, which was itself an evolution of Devel::SmallProf. Adam Kaplan forked Devel::FastProf and added html report generation (based on Devel::Cover) and a test suite - a tricky thing to do for a profiler. Meanwhile Tim Bunce had been extending Devel::FastProf to add novel per-sub and per-block timing, plus subroutine caller tracking. When Devel::NYTProf was released Tim switched to working on Devel::NYTProf because the html report would be a good way to show the extra profile data, and the test suite made development much easier and safer. Then Tim went a little crazy and added a slew of new features, in addition to per-sub and per-block timing and subroutine caller tracking. These included the 'opcode interception' method of profiling, ultra-fast and robust inclusive subroutine timing, doubling performance, plus major changes to html reporting to display all the extra profile call and timing data in richly annotated and cross-linked reports. Steve Peters came on board along the way with patches for portability and to keep NYTProf working with the latest development perl versions. Nicholas Clark added zip compression, many optimizations, and C. Jan Dubois contributed Windows support. Adam's work was sponsored by The New York Times Co. L. Tim's work was partly sponsored by Shopzilla L during 2008 but hasn't been sponsored since then. For the record, Tim has never worked for the New York Times nor has he received any kind of sponsorship or support from them in relation to NYTProf. The name of this module is simply result of the history outlined above, which can be summarised as: Adam forked an existing module when he added his enhancements and Tim didn't. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/000750 000766 000024 00000000000 13305245314 017362 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/lib/Devel/NYTProf/Run.pm000644 000766 000024 00000005232 12523657114 020501 0ustar00timbostaff000000 000000 package Devel::NYTProf::Run; # vim: ts=8 sw=4 expandtab: ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################### =head1 NAME Devel::NYTProf::Run - Invoke NYTProf on a piece of code and return the profile =head1 SYNOPSIS =head1 DESCRIPTION This module is experimental and subject to change. =cut use warnings; use strict; use base qw(Exporter); use Carp; use Config qw(%Config); use Devel::NYTProf::Data; our @EXPORT_OK = qw( profile_this perl_command_words ); my $this_perl = $^X; $this_perl .= $Config{_exe} if $^O ne 'VMS' and $this_perl !~ m/$Config{_exe}$/i; sub perl_command_words { my %opt = @_; my @perl = ($this_perl); # testing just $Config{usesitecustomize} isn't reliable for perl 5.11.x if (($Config{usesitecustomize}||'') eq 'define' or $Config{ccflags} =~ /(?new may croak, e.g., if data truncated sub profile_this { my %opt = @_; my $out_file = $opt{out_file} || 'nytprof.out'; my @perl = (perl_command_words(%opt), '-d:NYTProf'); warn sprintf "profile_this() using %s with NYTPROF=%s\n", join(" ", @perl), $ENV{NYTPROF} || '' if $opt{verbose}; # ensure child has same libs as us (e.g., if we were run with perl -Mblib) local $ENV{PERL5LIB} = join($Config{path_sep}, @INC); if (my $src_file = $opt{src_file}) { system(@perl, $src_file) == 0 or carp "Exit status $? from @perl $src_file"; } elsif (my $src_code = $opt{src_code}) { my $cmd = join ' ', map qq{"$_"}, @perl; open my $fh, "| $cmd" or croak "Can't open pipe to $cmd"; print $fh $src_code; close $fh or carp $! ? "Error closing $cmd pipe: $!" : "Exit status $? from $cmd"; } else { croak "Neither src_file or src_code was provided"; } # undocumented hack that's handy for testing if ($opt{htmlopen}) { my @nytprofhtml_open = ("perl", "nytprofhtml", "--open", "-file=$out_file"); warn "Running @nytprofhtml_open\n"; system @nytprofhtml_open; } my $profile = Devel::NYTProf::Data->new( { filename => $out_file } ); unlink $out_file; return $profile; } 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/FileHandle.pm000644 000766 000024 00000001014 12067023751 021717 0ustar00timbostaff000000 000000 #!perl use strict; use warnings; package Devel::NYTProf::FileHandle; # We have to jump through some hoops to load a second XS file from the same # shared object. require DynaLoader; require Devel::NYTProf::Core; my $c_name = 'boot_Devel__NYTProf__FileHandle'; my $c = DynaLoader::dl_find_symbol_anywhere($c_name); die "Can't locate '$c_name' in Devel::NYTProf shared object" unless $c; my $xs = DynaLoader::dl_install_xsub(__PACKAGE__ . '::bootstrap', $c, __FILE__); &$xs(__PACKAGE__, $Devel::NYTProf::Core::VERSION); Devel-NYTProf-6.06/lib/Devel/NYTProf/Constants.pm000644 000766 000024 00000002017 12067023751 021704 0ustar00timbostaff000000 000000 package Devel::NYTProf::Constants; use strict; use Devel::NYTProf::Core; use base 'Exporter'; our @EXPORT_OK = qw(const_bits2names); my $const_bits2names_groups; do { my $symbol_table = do { no strict; \%{"Devel::NYTProf::Constants::"} }; my %consts = map { $_ => $symbol_table->{$_}() } grep { /^NYTP_/ } keys %$symbol_table; push @EXPORT_OK, keys %consts; for my $sym (keys %consts) { $sym =~ /^(NYTP_[A-Z]+[a-z])_/ or next; $const_bits2names_groups->{$1}{ $consts{$sym} } = $sym; } }; sub const_bits2names { # const_bits2names("NYTP_FIDf",$flags) my ($group, $bits) = @_; my $names = $const_bits2names_groups->{$group} or return; my @names; for my $bit (0..31) { my $bitval = 1 << $bit; push @names, $names->{$bitval} if $bits & $bitval; } return @names if wantarray; return join " | ", @names; } # warn scalar const_bits2names("NYTP_FIDf", NYTP_FIDf_SAVE_SRC|NYTP_FIDf_IS_PMC); #warn "Constants: ".join(" ", sort @EXPORT_OK); 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/js/000750 000766 000024 00000000000 13305245314 017776 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/lib/Devel/NYTProf/Apache.pm000644 000766 000024 00000016720 12523657114 021122 0ustar00timbostaff000000 000000 # vim: ts=8 sw=4 expandtab: ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################### package Devel::NYTProf::Apache; our $VERSION = '4.00'; BEGIN { # Load Devel::NYTProf before loading any other modules # in order that $^P settings apply to the compilation # of those modules. if (!$ENV{NYTPROF}) { $ENV{NYTPROF} = "file=/tmp/nytprof.$$.out"; warn "NYTPROF env var not set, so defaulting to NYTPROF='$ENV{NYTPROF}'"; } require Devel::NYTProf::Core; DB::set_option("endatexit", 1); # for vhost with PerlOption +Parent DB::set_option("addpid", 1); require Devel::NYTProf; } use strict; use constant TRACE => ($ENV{NYTPROF} =~ /\b trace = [^0] /x); use constant MP2 => (exists $ENV{MOD_PERL_API_VERSION} && $ENV{MOD_PERL_API_VERSION} == 2); # https://rt.cpan.org/Ticket/Display.html?id=42862 die "Threads not supported" if $^O eq 'MSWin32'; # help identify MULTIPLICITY issues *current_perl_id = (MP2 and eval "require ModPerl::Util") ? \&ModPerl::Util::current_perl_id : sub { 0+\$$ }; sub trace { return unless TRACE; warn sprintf "NYTProf %d.%s: %s\n", $$, current_perl_id(), shift } sub child_init { trace("child_init(@_)") if TRACE; warn "Apache2::SizeLimit is loaded and will corrupt NYTProf profile if it terminates the process\n" if $Apache2::SizeLimit::VERSION # doubled just to avoid typo warning && $Apache2::SizeLimit::VERSION; DB::enable_profile() unless $ENV{NYTPROF} =~ m/\b start = (?: no | end ) \b/x; } sub child_exit { trace("child_exit(@_)") if TRACE; DB::finish_profile(); } # arrange for the profile to be enabled in each child # and cleanly finished when the child exits if (MP2) { # For mod_perl2 we rely on profiling being active in the parent # and for normal fork detection to detect the new child. # We just need to be sure the profile is finished properly # and an END block works well for that (if loaded right, see docs) # We rely on NYTProf's own END block to finish the profile. #trace("adding child_exit hook") if TRACE; #eval q{ END { child_exit('END') } 1 } or die; } else { # the simple steps for mod_perl2 above might also be fine for mod_perl1 # but I'm not in a position to check right now. Try it out and let me know. require Apache; if (Apache->can('push_handlers')) { Apache->push_handlers(PerlChildInitHandler => \&child_init); Apache->push_handlers(PerlChildExitHandler => \&child_exit); warn "$$: Apache child handlers installed" if TRACE; } else { Carp::carp("Apache.pm was not loaded"); } } 1; __END__ =head1 NAME Devel::NYTProf::Apache - Profile mod_perl applications with Devel::NYTProf =head1 SYNOPSIS # in your Apache config file with mod_perl installed PerlPassEnv NYTPROF PerlModule Devel::NYTProf::Apache If you're using virtual hosts with C that include either C<+Parent> or C<+Clone> then see L below. =head1 DESCRIPTION This module allows mod_perl applications to be profiled using C. If the NYTPROF environment variable isn't set I then Devel::NYTProf::Apache will issue a warning and default it to: file=/tmp/nytprof.$$.out:addpid=1:endatexit=1 The file actually created by NTProf will also have the process id appended to it because the C option is enabled by default. See L for more details on the settings effected by this environment variable. Try using C in your httpd.conf if you can set the NYTPROF environment variable externally. Note that if you set the NYTPROF environment variable externally then the file name obviously can't include the parent process id. For example, to set stmts=0 externally, use: NYTPROF=file=/tmp/nytprof.out:out:addpid=1:endatexit=1:stmts=0 Each profiled mod_perl process will need to have terminated cleanly before you can successfully read the profile data file. The simplest approach is to start the httpd, make some requests (e.g., 100 of the same request), then stop it and process the profile data. Alternatively you could send a TERM signal to the httpd worker process to terminate that one process. The parent httpd process will start up another one for you ready for more profiling. =head2 Example httpd.conf It's usually a good idea to use just one child process when profiling, which you can do by setting the C to 1 in httpd.conf. Set C to 0 to avoid worker processes exiting and restarting during the profiling, which would split the profile data across multiple files. Using an C blocks lets you leave the profile configuration in place and enable it whenever it's needed by adding C<-D NYTPROF> to the httpd startup command line. MaxClients 1 MaxRequestsPerChild 0 PerlModule Devel::NYTProf::Apache With that configuration you should get two profile files, one for the parent process and one for the worker. =head1 VIRTUAL HOSTS If your httpd configuration includes virtual hosts with C that include either C<+Parent> or C<+Clone> then mod_perl2 will create a new perl interpreter to handle requests for that virtual host. This causes some issues for profiling. If C is loaded in the top-level configuration then activity in any virtual hosts that use their own perl interpreter won't be profiled. Normal virtual hosts will be profiled just fine. You can profile a I virtual host that uses its own perl interpreter by loading C I. In this case I use C directive. You need to use a C directive instead, like this: ... use Devel::NYTProf::Apache; ... =head1 LIMITATIONS Profiling mod_perl on Windows is not supported because NYTProf currently doesn't support threads. =head1 TROUBLESHOOTING Truncated profile: Profiles for large applications can take a while to write to the disk. Allow sufficient time after stopping apache, or check the process has actually exited, before trying to read the profile. Truncated profile: The mod_perl child_terminate() function terminates the child without giving perl an opportunity to cleanup. Since C doesn't intercept the mod_perl child_terminate() function (yet) the profile will be corrupted if it's called. You're most likely to encounter this when using L, so you may want to disable it while profiling. =head1 SEE ALSO L =head1 AUTHOR B, C<< >> B, L and L B, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2008 by Adam Kaplan and The New York Times Company. Copyright (C) 2008 by Steve Peters. Copyright (C) 2008-2012 by Tim Bunce. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/ReadStream.pm000644 000766 000024 00000014027 12130047577 021766 0ustar00timbostaff000000 000000 package Devel::NYTProf::ReadStream; use warnings; use strict; our $VERSION = '4.00'; use base 'Exporter'; our @EXPORT_OK = qw( for_chunks ); use Devel::NYTProf::Data; sub for_chunks (&%) { my($cb, %opts) = @_; Devel::NYTProf::Data->new( { %opts, callback => $cb, }); } 1; __END__ =head1 NAME Devel::NYTProf::ReadStream - Read Devel::NYTProf data file as a stream =head1 SYNOPSIS use Devel::NYTProf::ReadStream qw(for_chunks); for_chunks { my $tag = shift; print "$tag\n"; # examine @_ .... } # quickly dump content of a file use Data::Dump; for_chunks(\&dd); =head1 DESCRIPTION This module provide a low level interface for reading the contents of F files (Devel::NYTProf data files) as a stream of chunks. Currently the module only provide a single function: =over =item for_chunks( \&callback, %opts ) This function will read the F file and invoke the given callback function for each chunk in the file. The first argument passed to the callback is the chunk tag. The rest of the arguments passed depend on the tag. See L for the details. The return value of the callback function is ignored. The for_chunks() function will croak if the file can't be opened or if the file format isn't recognized. The global C<$.> variable is made to track the chunk sequence numbers and can be inspected in the callback. The behaviour of the function can be modified by passing key/value pairs after the callback. The contents of %opts are passed to L. The function is prototyped as C<(&%)> which means that it can be invoked with a bare block representing the callback function. In that case there should be no comma before any options. Example: for_chunk { say $_[0] } filename => "myprof.out"; =back =head2 Chunks The F file contains a sequence of tagged chunks that are streamed out as the profiled program runs. This documents how the chunks appear when presented to the callback function of the for_chunks() function for version 4.0 of the file format. I =over =item VERSION => $major, $minor The first chunk in the file declare what version of the file format was used for the current file. =item COMMENT => $text This chunk is just some textual content that can be ignored. =item ATTRIBUTE => $key, $value This chunk type is repeated at the beginning of the file and used to declare various facts about the profiling run. The only one that's really interesting is C that tell you how to convert the $ticks values into seconds. The attributes reported are: =over =item basetime => $time The time (epoch based) when the profiled perl process started. It's the same value as C<$^T>. =item xs_version => $ver The version of the Devel::NYTProf used for profiling. =item perl_version => $ver The version of perl used for profiling. This is a string like "5.10.1". =item clock_id => $num What kind of clock was used to profile the program. Will be C<-1> for the default clock. =item ticks_per_sec => $num Divide the $ticks values in TIME_BLOCK/TIME_LINE by this number to convert the time to seconds. =item nv_size => 8 The $Config{nv_size} of the perl that wrote this file. This value must match for the perl that reads the file as well. =item application => $string The path to the program that ran; same as C<$0> in the program itself. =back =item OPTION => $key, $value This chunk type is repeated at the beginning of the file and used to record the options, e.g. set via the NYTPROF env var, that were effect during the profiling run. =item START_DEFLATE This chunk just say that from now on all chunks have been compressed in the file. =item PID_START => $pid, $parent_pid, $start_time The process with the given $pid starts running (under the profiler). Dates from the way forking used to be supported. Likely to get deprecated when we get better support for tracking the time the sub profiler and statement profiler were actually active. (Which is needed to calculate percentages.) =item NEW_FID => $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name Files are represented by integers called 'fid' (File IDs) and this chunk declares the mapping between these numbers and file path names. =item TIME_BLOCK => $ticks, $fid, $line, $block_line, $sub_line =item TIME_LINE => $ticks, $fid, $line A TIME_BLOCK or TIME_LINE chunk is output each time the execution of the program leaves a statement. =item DISCOUNT Indicates that the next TIME_BLOCK or TIME_LINE should not increment the "number of times the statement was executed". See the 'leave' option. =item SUB_INFO => $fid, $first_line, $last_line, $name At the end of the run the profiler will output chunks that report on the perl subroutines defined in all the files visited while profiling. See also C<%DB::sub> in L. =item SUB_CALLERS => $fid, $line, $count, $incl_time, $excl_time, $reci_time, $rec_depth, $name, $caller_name At the end of the run the profiler will output chunks that report on where subroutines were called from. =item SRC_LINE => $fid, $line, $text Used to reproduce the source code of the files and evals profiled. Requires perl 5.8.9+ or 5.10.1+ or 5.12 or later. For earlier versions of perl the source code of C<< perl -e '...' >> and C<< perl - >> 'files' is available if the C option was used when profiling. =item PID_END => $pid, $end_time The process with the given $pid is done running. See the description of PID_START above. =back =head1 SEE ALSO L, L =head1 AUTHOR B =head1 COPYRIGHT AND LICENSE Copyright (C) 2008 by Adam Kaplan and The New York Times Company. Copyright (C) 2008 by Tim Bunce, Ireland. Copyright (C) 2008 by Gisle Aas This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/Util.pm000644 000766 000024 00000017126 12523657114 020657 0ustar00timbostaff000000 000000 # vim: ts=8 sw=4 expandtab: ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################### package Devel::NYTProf::Util; =head1 NAME Devel::NYTProf::Util - general utility functions for L =head1 SYNOPSIS use Devel::NYTProf::Util qw(strip_prefix_from_paths); =head1 DESCRIPTION Contains general utility functions for L B The documentation for this module is currently incomplete and out of date. =head1 FUNCTIONS =encoding ISO8859-1 =cut use warnings; use strict; use base qw'Exporter'; use Carp; use Cwd qw(getcwd); use List::Util qw(sum); use Devel::NYTProf::Core; our $VERSION = '4.00'; our @EXPORT_OK = qw( fmt_float fmt_time fmt_incl_excl_time make_path_strip_editor strip_prefix_from_paths calculate_median_absolute_deviation get_alternation_regex get_abs_paths_alternation_regex html_safe_filename trace_level ); sub get_alternation_regex { my ($strings, $suffix_regex) = @_; $suffix_regex = '' unless defined $suffix_regex; # sort longest string first my @strings = sort { length $b <=> length $a } @$strings; # build string regex for each string my $regex = join "|", map { quotemeta($_) . $suffix_regex } @strings; return qr/(?:$regex)/; } sub get_abs_paths_alternation_regex { my ($inc, $cwd) = @_; my @inc = @$inc or croak "No paths"; # rewrite relative directories to be absolute # the logic here should match that in get_file_id() my $abs_path_regex = ($^O eq "MSWin32") ? qr,^\w:/, : qr,^/,; for (@inc) { next if $_ =~ $abs_path_regex; # already absolute $_ =~ s/^\.\///; # remove a leading './' $cwd ||= getcwd(); $_ = ($_ eq '.') ? $cwd : "$cwd/$_"; } return get_alternation_regex(\@inc, '/?'); } sub make_path_strip_editor { my ($inc_ref, $anchor, $replacement) = @_; $anchor = '^' if not defined $anchor; $replacement = '' if not defined $replacement; my @inc = @$inc_ref or return; our %make_path_strip_editor_cache; my $key = join "\t", $anchor, $replacement, @inc; return $make_path_strip_editor_cache{$key} ||= do { my $inc_regex = get_abs_paths_alternation_regex(\@inc); # anchor at start, capture anchor $inc_regex = qr{($anchor)$inc_regex}; sub { $_[0] =~ s{$inc_regex}{$1$replacement} }; }; } # edit @$paths in-place to remove specified absolute path prefixes sub strip_prefix_from_paths { my ($inc_ref, $paths, $anchor, $replacement) = @_; return if not defined $paths; my $editor = make_path_strip_editor($inc_ref, $anchor, $replacement) or return; # strip off prefix using regex, skip any empty/undef paths if (UNIVERSAL::isa($paths, 'ARRAY')) { for my $path (@$paths) { if (ref $path) { # recurse to process deeper data strip_prefix_from_paths($inc_ref, $path, $anchor, $replacement); } elsif ($path) { $editor->($path); } } } elsif (UNIVERSAL::isa($paths, 'HASH')) { for my $orig (keys %$paths) { $editor->(my $new = $orig) or next; my $value = delete $paths->{$orig}; warn "Stripping prefix from $orig overwrites existing $new" if defined $paths->{$new}; $paths->{$new} = $value; } } else { croak "Can't strip_prefix_from_paths of $paths"; } return; } # eg normalize the width/precision so that the tables look good. sub fmt_float { my ($val, $precision) = @_; $precision ||= 5; if ($val < 10 ** -($precision - 1) and $val > 0) { # Give the same width as a larger value formatted with the %f below. # This gives us 2 digits of precision for $precision == 5 $val = sprintf("%." . ($precision - 4) . "e", $val); # But our exponents will always be e-05 to e-09, never e-10 or smaller # so remove the leading zero to make these small numbers stand out less # on the table. $val =~ s/e-0/e-/; } elsif ($val != int($val)) { $val = sprintf("%.${precision}f", $val); } return $val; } # XXX undocumented hack that may become to an option one day # Useful for making the time data more easily parseable my $fmt_time_opt = $ENV{NYTPROF_FMT_TIME}; # e.g., '%f' for 'raw' times sub fmt_time { my ($sec, $width) = @_; $width = '' unless defined $width; return undef if not defined $sec; return '-'.fmt_time(-$sec, $width) if $sec < 0; # negative value, can happen return sprintf $fmt_time_opt, $sec if $fmt_time_opt; return sprintf "%$width.0fs", 0 unless $sec; return sprintf "%$width.0fns", $sec * 1e9 if $sec < 1e-6; return sprintf "%$width.0fµs", $sec * 1e6 if $sec < 1e-3; return sprintf "%$width.*fms", 3 - length(int($sec * 1e3)), $sec * 1e3 if $sec < 1; return sprintf "%$width.*fs", 3 - length(int($sec )), $sec if $sec < 100; return sprintf "%$width.0fs", $sec; } sub fmt_incl_excl_time { my ($incl, $excl) = @_; my $diff = $incl - $excl; return fmt_time($incl) unless $diff; $_ = fmt_time($_) for $incl, $excl, $diff; if ($incl =~ /(\D+)$/) { # no need to repeat the unit if it's the same for all time stamps my $unit = $1; my $offset = -length($unit); for ($excl, $diff) { if (/(\D+)$/) { substr($_, $offset) = "" if $1 eq $unit } } } return sprintf "%s (%s+%s)", $incl, $excl, $diff; } ## Given a ref to an array of numeric values ## returns median distance from the median value, and the median value. ## See http://en.wikipedia.org/wiki/Median_absolute_deviation sub calculate_median_absolute_deviation { my $values_ref = shift; my ($ignore_zeros) = @_; croak "No array ref given" unless ref $values_ref eq 'ARRAY'; my @values = ($ignore_zeros) ? grep {$_} @$values_ref : @$values_ref; my $median_value = [sort { $a <=> $b } @values]->[@values / 2]; return [0, 0] if not defined $median_value; # no data my @devi = map { abs($_ - $median_value) } @values; my $median_devi = [sort { $a <=> $b } @devi]->[@devi / 2]; return [$median_devi, $median_value]; } sub html_safe_filename { my ($fname) = @_; # replace / and \ with html safe '-', we also do a bunch of other # chars, especially ':' for Windows, to make the namer simpler and safer # also remove dots to keep VMS happy $fname =~ s{ [-/\\:\*\?"'<>|.]+ }{-}xg; # remove any leading or trailing '-' chars $fname =~ s{^-}{}; $fname =~ s{-$}{}; if($^O eq 'VMS'){ # ODS-2 is limited to 39.39 chars (39 filename, 39 extension) # Reader.pm appends -LEVEL onto html safe filename so must # subtract 1 + max length of (sub block line), so 6. $fname = substr($fname,-33); } return $fname; } 1; __END__ =head1 SEE ALSO L and L =head1 AUTHOR B, C<< >> B, L and L B, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (c) 2008 by Tim Bunce, Ireland. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/Test.pm000644 000766 000024 00000000506 12067023751 020650 0ustar00timbostaff000000 000000 package # hide from pause package indexer Devel::NYTProf::Test; # this module is just to test the test suite # see t/test60-subname.p for example require Devel::NYTProf::Core; require Exporter; our @ISA = qw(Exporter); our @EXPORT_OK = qw(example_sub example_xsub example_xsub_eval set_errno); sub example_sub { } 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/Core.pm000644 000766 000024 00000013501 13305236567 020627 0ustar00timbostaff000000 000000 # vim: ts=8 sw=4 expandtab: ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################### package Devel::NYTProf::Core; use XSLoader; our $VERSION = '6.06'; # increment with XS changes too XSLoader::load('Devel::NYTProf', $VERSION); # Fudging for https://rt.cpan.org/Ticket/Display.html?id=82256 $Devel::NYTProf::StrEvalTestPad = ($] <= 5.017004) ? ";\n" : ""; if (my $NYTPROF = $ENV{NYTPROF}) { for my $optval ( $NYTPROF =~ /((?:[^\\:]+|\\.)+)/g) { my ($opt, $val) = $optval =~ /^((?:[^\\=]+|\\.)+)=((?:[^\\=]+|\\.)+)\z/; s/\\(.)/$1/g for $opt, $val; if ($opt eq 'sigexit') { # Intercept sudden process exit caused by signals my @sigs = ($val eq '1') ? qw(INT HUP PIPE BUS SEGV) : split(/,/, $val); $SIG{uc $_} = sub { DB::finish_profile(); exit 1; } for @sigs; next; # no need to tell the XS code about this } if ($opt eq 'posix_exit') { # Intercept sudden process exit caused by POSIX::_exit() call. # Should only be needed if subs=0. We delay till after profiling # has probably started to minimize the effect on the profile. eval q{ INIT { require POSIX; my $orig = \&POSIX::_exit; local $^W = 0; # avoid sub redef warning *POSIX::_exit = sub { DB::finish_profile(); $orig->(@_) }; } 1 } or die if $val; next; # no need to tell the XS code about this } DB::set_option($opt, $val); } } 1; __END__ =head1 NAME Devel::NYTProf::Core - load internals of Devel::NYTProf =head1 DESCRIPTION This module is not meant to be used directly. See L, L, and L. While it's not meant to be used directly, it is a handy place to document some internals. =head1 SUBROUTINE PROFILER The subroutine profiler intercepts the C opcode which perl uses to invoke a subroutine, both XS subs (henceforth xsubs) and pure perl subs. The following sections outline the way the subroutine profiler works: =head2 Before the subroutine call The profiler records the current time, the current value of cumulative_subr_secs (as initial_subr_secs), and the current cumulative_overhead_ticks (as initial_overhead_ticks). The statement profiler measures time at the start and end of processing for each statement (so time spent in the profiler, writing to the file for example, is excluded.) It accumulates the measured overhead into the cumulative_overhead_ticks variable. In a similar way, the subroutine profiler measures the I time spent in subroutines and accumulates it into the cumulative_subr_secs global. =head2 Make the subroutine call The call is made by executing the original perl internal code for the C opcode. =head3 Calling a perl subroutine If the sub being called is a perl sub then when the entersub opcode returns, back into the subroutine profiler, the subroutine has been 'entered' but the first opcode of the subroutine hasn't been executed yet. Crucially though, a new scope has been entered by the entersub opcode. The subroutine profiler then pushes a destructor onto the context stack. The destructor is effectively just I the sub, like a C, and so will be triggered when the subroutine exits by I means. Also, because it was the first thing push onto the context stack, it will be triggered I any activity caused by the subroutines scope exiting. When the destructor is invoked it calls a function which completes the measurement of the time spent in the sub (see below). In this way the profiling of perl subroutines is very accurate and robust. =head3 Calling an xsub If the sub being called is an xsub, then control doesn't return from the entersub opcode until the xsub has returned. The profiler detects this and calls the function which completes the measurement of the time spent in the xsub. So far so good, but there's a problem. What if the xsub doesn't return normally but throws an exception instead? In that case (currently) the profiler acts as if the xsub was never called. Time spent inside the xsub will be allocated to the calling sub. =head2 Completing the measurement The function which completes the timing of a subroutine call does the following: It calculates the time spent in the statement profiler: overhead_ticks = cumulative_overhead_ticks - initial_overhead_ticks and subtracts that from the total time spent 'inside' the subroutine: incl_subr_sec = (time now - time call was made) - overhead_ticks That gives us an accurate I time. To get the I time it calculates the time spent in subroutines called from the subroutine call we're measuring: called_sub_secs = cumulative_subr_secs - initial_subr_secs and subtracts that from the incl_subr_sec: excl_subr_sec = incl_subr_sec - called_sub_secs To make that easier to follow, consider a call to a sub that calls no others. In that case cumulative_subr_secs remains unchanged during the call, so called_sub_secs is zero, and excl_subr_sec is the same as incl_subr_sec. Finally, it adds the exclusive time to the cumulative exclusive time: cumulative_subr_secs += excl_subr_sec =head1 AUTHOR B, L and L =head1 COPYRIGHT AND LICENSE Copyright (C) 2008, 2009 by Tim Bunce. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/Reader.pm000644 000766 000024 00000053227 12523657114 021146 0ustar00timbostaff000000 000000 # vim: ts=8 sw=4 expandtab: ########################################################## ## This script is part of the Devel::NYTProf distribution ## ## Copyright, contact and other information can be found ## at the bottom of this file, or by going to: ## http://metacpan.org/release/Devel-NYTProf/ ## ########################################################### package Devel::NYTProf::Reader; our $VERSION = '4.06'; use warnings; use strict; use Carp; use Config; use List::Util qw(sum max); use Data::Dumper; use Devel::NYTProf::Data; use Devel::NYTProf::Util qw( fmt_float fmt_time html_safe_filename calculate_median_absolute_deviation trace_level ); # These control the limits for what the script will consider ok to severe times # specified in standard deviations from the mean time use constant SEVERITY_SEVERE => 2.0; # above this deviation, a bottleneck use constant SEVERITY_BAD => 1.0; use constant SEVERITY_GOOD => 0.5; # within this deviation, okay # Static class variables our $FLOAT_FORMAT = $Config{nvfformat}; $FLOAT_FORMAT =~ s/"//g; # Class methods sub new { my $class = shift; my $file = shift; my $opts = shift || {}; my $self = { file => $file || 'nytprof.out', output_dir => '.', suffix => '.csv', header => "# Profile data generated by Devel::NYTProf::Reader\n" . "# Version: v$Devel::NYTProf::Core::VERSION\n" . "# More information at http://metacpan.org/release/Devel-NYTProf/\n" . "# Format: time,calls,time/call,code\n", datastart => '', mk_report_source_line => undef, mk_report_xsub_line => undef, mk_report_separator_line => undef, line => [ {}, {value => 'time', end => ',', default => '0'}, {value => 'calls', end => ',', default => '0'}, {value => 'time/call', end => ',', default => '0'}, {value => 'source', end => '', default => ''}, {end => "\n"} ], dataend => '', footer => '', merged_fids => '', taintmsg => "# WARNING!\n" . "# The source file used in generating this report has been modified\n" . "# since generating the profiler database. It might be out of sync\n", sawampersand => "# NOTE!\n" . "# This file uses special regexp match variables that impact the performance\n" . "# of all regular expression in the program!\n" . "# See WARNING in http://perldoc.perl.org/perlre.html#Capture-buffers\n", }; bless($self, $class); $self->{profile} = Devel::NYTProf::Data->new({ %$opts, filename => $self->{file}, }); return $self; } ## sub set_param { my ($self, $param, $value) = @_; if (!exists $self->{$param}) { confess "Attempt to set $param to $value failed: $param is not a valid " . "parameter\n"; } else { return $self->{$param} unless defined($value); $self->{$param} = $value; } undef; } sub get_param { my ($self, $param, $code_args) = @_; my $value = $self->{$param}; if (ref $value eq 'CODE') { $code_args ||= []; $value = $value->(@$code_args); } return $value; } ## sub file_has_been_modified { my $self = shift; my $file = shift; return undef unless -f $file; my $mtime = (stat $file)[9]; return ($mtime > $self->{profile}{attribute}{basetime}); } ## sub _output_additional { my ($self, $fname, $content) = @_; open(OUT, '>', "$self->{output_dir}/$fname") or confess "Unable to open $self->{output_dir}/$fname for writing; $!\n"; print OUT $content; close OUT; } ## sub output_dir { my ($self, $dir) = @_; return $self->{output_dir} unless defined($dir); if (!mkdir $dir) { confess "Unable to create directory $dir: $!\n" if !$! =~ /exists/; } $self->{output_dir} = $dir; } ## sub report { my $self = shift; my ($opts) = @_; my $level_additional_sub = $opts->{level_additional}; my $profile = $self->{profile}; my $modes = $profile->get_profile_levels; my @levels = grep { {reverse %$modes}->{$_} } qw(sub block line); for my $level (@levels) { print "Writing $level reports to $self->{output_dir} directory\n" unless $opts->{quiet}; $self->_generate_report($profile, $level, show_progress => (not $opts->{quiet} and -t STDOUT) ); $level_additional_sub->($profile, $level) if $level_additional_sub; } } sub current_level { my $self = shift; $self->{current_level} = shift if @_; return $self->{current_level} || 'line'; } sub fname_for_fileinfo { my ($self, $fi, $level) = @_; confess "No fileinfo" unless $fi; $level ||= $self->current_level; my $fname = $fi->filename_without_inc; # We want to have descriptive and unambiguous filename # but we don't want to risk failure due to filenames being longer # than MAXPATH (including the length of whatever dir we're writing # the report files into). So we truncate to the last component if # the filenames seems 'dangerously long'. XXX be smarter about this. # This is safe from ambiguity because we add the fid to the filename below. my $max_len = $ENV{NYTPROF_FNAME_TRIM} || 50; $fname =~ s!/.*/!/.../! if length($fname) > $max_len; # remove dir path $fname = "TOOLONG" if length($fname) > $max_len; # just in case $fname = html_safe_filename($fname); $fname .= "-".$fi->fid; # to ensure uniqueness and for info $fname .= "-$level" if $level; return $fname; } ## sub _generate_report { my $self = shift; my ($profile, $LEVEL, %opts) = @_; $self->current_level($LEVEL); my @all_fileinfos = $profile->all_fileinfos or carp "Profile report data contains no files"; #$profile->dump_profile_data({ filehandle => \*STDERR, separator=>"\t", }); my @fis = @all_fileinfos; if ($LEVEL ne 'line') { # we only generate line-level reports for evals # for efficiency and because some data model editing only # is only implemented for line-level data @fis = grep { not $_->is_eval } @fis; } my $progress; foreach my $fi (@fis) { if ($opts{show_progress}) { local $| = 1; ++$progress; printf "\r %3d%% ... ", $progress/@fis*100; } my $meta = $fi->meta; my $filestr = $fi->filename; # { linenumber => { subname => [ count, time ] } } my $subcalls_at_line = { %{ $fi->sub_call_lines } }; my $subcalls_max_line = max( keys %$subcalls_at_line ) || 0; # { linenumber => [ $subinfo, ... ] } my $subdefs_at_line = { %{ $profile->subs_defined_in_file_by_line($filestr) } }; my $subdefs_max_line = max( keys %$subdefs_at_line ) || 0; delete $subdefs_at_line->{0}; # xsubs handled separately # { linenumber => { fid => $fileinfo } } my $evals_at_line = { %{ $fi->evals_by_line } }; my $evals_max_line = max( keys %$evals_at_line ) || 0; # note that a file may have no source lines executed, so no keys here # (but is included because some xsubs in the package were executed) my $lines_array = $fi->line_time_data([$LEVEL]) || []; my $src_max_line = scalar @$lines_array; for ($src_max_line, $subcalls_max_line, $subdefs_max_line, $evals_max_line) { next if $_ < 2**16; warn "Ignoring indication that $filestr has $_ lines! (Possibly corrupt data)\n"; $_ = 0; } my $max_linenum = max( $src_max_line, $subcalls_max_line, $subdefs_max_line, $evals_max_line, ); warn sprintf "%s max lines: %s (stmts %s, subcalls %s, subdefs %s, evals %s)\n", $filestr, $max_linenum, scalar @$lines_array, $subcalls_max_line, $subdefs_max_line, $evals_max_line if trace_level() >= 4 or $max_linenum > 2**15; my %stats_accum; # holds all line times. used to find median my %stats_by_line; # holds individual line stats my $runningTotalTime = 0; # holds the running total # (should equal sum of $stats_accum) my $runningTotalCalls = 0; # holds the running total number of calls. for (my $linenum = 0; $linenum <= $max_linenum; ++$linenum) { if (my $subdefs = delete $subdefs_at_line->{$linenum}) { $stats_by_line{$linenum}->{'subdef_info'} = $subdefs; } if (my $subcalls = delete $subcalls_at_line->{$linenum}) { my $line_stats = $stats_by_line{$linenum} ||= {}; $line_stats->{'subcall_info'} = $subcalls; $line_stats->{'subcall_count'} = sum(map { $_->[0] } values %$subcalls); $line_stats->{'subcall_time'} = sum(map { $_->[1] } values %$subcalls); push @{$stats_accum{$_}}, $line_stats->{$_} for (qw(subcall_count subcall_time)); } if (my $evalcalls = delete $evals_at_line->{$linenum}) { my $line_stats = $stats_by_line{$linenum} ||= {}; # %$evals => { fid => $fileinfo } $line_stats->{'evalcall_info'} = $evalcalls; $line_stats->{'evalcall_count'} = values %$evalcalls; # get list of evals, including nested evals my @eval_fis = map { ($_, $_->has_evals(1)) } values %$evalcalls; $line_stats->{'evalcall_count_nested'} = @eval_fis; $line_stats->{'evalcall_stmts_time_nested'} = sum( map { $_->sum_of_stmts_time } @eval_fis); } if (my $stmts = $lines_array->[$linenum]) { next if !@$stmts; # XXX happens for evals, investigate my ($stmt_time, $stmt_count) = @$stmts; my $line_stats = $stats_by_line{$linenum} ||= {}; # The debugger cannot stop on BEGIN{...} lines. A line in a begin # may set a scalar reference to something that needs to be eval'd later. # as a result, if the variable is expanded outside of the BEGIN, we'll # see the original BEGIN line, but it won't have any calls or times # associated. This will cause a divide by zero error. $stmt_count ||= 1; $line_stats->{'time'} = $stmt_time; $line_stats->{'calls'} = $stmt_count; $line_stats->{'time/call'} = $stmt_time/$stmt_count; push @{$stats_accum{$_}}, $line_stats->{$_} for (qw(time calls time/call)); $runningTotalTime += $stmt_time; $runningTotalCalls += $stmt_count; } warn "$linenum: @{[ %{ $stats_by_line{$linenum} } ]}\n" if trace_level() >= 3 && $stats_by_line{$linenum}; } warn "unprocessed keys in subdefs_at_line: @{[ keys %$subdefs_at_line ]}\n" if %$subdefs_at_line; warn "unprocessed keys in subcalls_at_line: @{[ keys %$subcalls_at_line ]}\n" if %$subcalls_at_line; warn "unprocessed keys in evals_at_line: @{[ keys %$evals_at_line ]}\n" if %$evals_at_line; $meta->{'time'} = $runningTotalTime; $meta->{'calls'} = $runningTotalCalls; $meta->{'time/call'} = ($runningTotalCalls) ? $runningTotalTime / $runningTotalCalls: 0; # Use Median Absolute Deviation Formula to get file deviations for each of # calls, time and time/call values my %stats_for_file = ( 'calls' => calculate_median_absolute_deviation($stats_accum{'calls'}||[]), 'time' => calculate_median_absolute_deviation($stats_accum{'time'}||[]), 'time/call' => calculate_median_absolute_deviation($stats_accum{'time/call'}||[]), subcall_count => calculate_median_absolute_deviation($stats_accum{subcall_count}||[]), subcall_time => calculate_median_absolute_deviation($stats_accum{subcall_time}||[]), ); # the output file name that will be open later. Not including directory at this time. # keep here so that the variable replacement subs can get at it. my $fname = $self->fname_for_fileinfo($fi) . $self->{suffix}; # localize header and footer for variable replacement my $header = $self->get_param('header', [$profile, $fi, $fname, $LEVEL]); my $datastart = $self->get_param('datastart', [$profile, $fi]); my $dataend = $self->get_param('dataend', [$profile, $fi]); my $FILE = $filestr; #warn Dumper(\%stats_by_line); # open output file #warn "$self->{output_dir}/$fname"; open(OUT, ">", "$self->{output_dir}/$fname") or confess "Unable to open $self->{output_dir}/$fname " . "for writing: $!\n"; # begin output print OUT $header; # If we don't have savesrc for the file then we'll be reading the current # file contents which may have changed since the profile was run. # In this case we need to warn the user as the report would be garbled. print OUT $self->get_param('taintmsg', [$profile, $fi]) if !$fi->has_savesrc and $self->file_has_been_modified($filestr); print OUT $self->get_param('sawampersand', [$profile, $fi]) if $profile->{attribute}{sawampersand_fid} && $fi->fid == $profile->{attribute}{sawampersand_fid}; print OUT $self->get_param('merged_fids', [$profile, $fi]) if $fi->meta->{merged_fids}; print OUT $datastart; my $LINE = 1; # line number in source code my $src_lines = $fi->srclines_array; if (!$src_lines) { # no savesrc, and no file available my $msg; if ($fi->is_fake) { # eg the "/unknown-eval-invoker" $msg = "No source code available for synthetic (fake) file $filestr.", } elsif ($fi->is_eval) { $msg = "No source code available for string eval $filestr.\nYou probably need to use a more recent version of perl. See savesrc option in documentation.", } elsif ($filestr =~ m{^/loader/0x[0-9a-zA-Z]+/}) { # a synthetic file name that perl assigns when reading # code returned by a CODE ref in @INC $msg = "No source code available for 'file' loaded via CODE reference in \@INC.\nSee savesrc option in documentation.", } elsif (not $fi->is_file) { $msg = "No source code available for non-file '$filestr'.\nYou probably need to use a more recent version of perl. See savesrc option in documentation.", } else { $msg = "Unable to open '$filestr' for reading: $!"; # clarify some current Moose limitations XXX if ($filestr =~ m!/(accessor .*) defined at /!) { $msg = "Source for generated Moose $1 isn't available ($filestr: $!)"; } elsif ($filestr =~ m!/(generated method \(unknown origin\))!) { $msg = "Source for Moose $1 isn't available ($filestr: $!)"; } # the report will not be complete, but this doesn't need to be fatal my $hint = ''; $hint .= " Try running $0 in the same directory as you ran Devel::NYTProf, " . "or ensure \@INC is correct." if $filestr ne '-e' and $filestr !~ m:^/: and not our $_generate_report_inc_hint++; # only once warn "$msg$hint\n" unless our $_generate_report_filestr_warn->{$filestr}++; # only once per filestr } $src_lines = [ $msg ]; $LINE = 0; # start numbering from 0 to flag fake contents } # ensure we don't have any undef source lines # (to avoid warnings from the code below) my $src_undefs; defined $_ or $_ = '' && ++$src_undefs for @$src_lines; # XXX shouldn't be need but don't have a test case so grumble # about it in the hope of getting a test case warn sprintf "Saw %d missing (undef) lines in the %d lines of source code for %s\n", $src_undefs, scalar @$src_lines, $filestr if $src_undefs; # Since we use @$src_lines to drive the report generation, pad the array to # ensure it has enough lines to include all the available profile info. # Then the report is still useful even if we have no source code. push @$src_lines, '' while @$src_lines < $max_linenum-1; if (my $z = $stats_by_line{0}) { # typically indicates cases where we could do better if (trace_level()) { warn "$filestr has unexpected info for line 0: @{[ %$z ]}\n"; # sub defs: used to be xsubs but they're handled separately now # so there are no known causes of this any more if (my $i = $z->{subdef_info}) { warn "0: @{[ map { $_->subname } @$i ]}\n" } # sub calls: they're typically END blocks that appear to be # invoked from the main .pl script perl ran. # Also some BEGINs and things like main::CORE:ftfile # (see CPANDB's cpangraph script for some examples) if (my $i = $z->{subcall_info}) { warn sprintf "0: called %20s %s\n", $_, join " ", @{ $i->{$_} } for sort keys %$i; } } $LINE = 0; unshift @$src_lines, "Profile data that couldn't be associated with a specific line:"; } my $line_sub = $self->{mk_report_source_line} or die "mk_report_source_line not set"; my $prev_line = '-'; while ( @$src_lines ) { my $line = shift @$src_lines; chomp $line; # detect a series of blank lines, e.g. a chunk of pod savesrc didn't store my $skip_blanks = ( $prev_line eq '' && $line eq '' && # blank behind and here @$src_lines && $src_lines->[0] =~ /^\s*$/ && # blank ahead !$stats_by_line{$LINE} # nothing to report ); if ($line =~ m/^\# \s* line \s+ (\d+) \b/x) { # XXX we should be smarter about this - patches welcome! # We should at least ignore the common AutoSplit case # which we detect and workaround elsewhere. warn "Ignoring '$line' directive at line $LINE - profile data for $filestr will be out of sync with source\n" unless our $line_directive_warn->{$filestr}++; # once per file } print OUT $line_sub->( ($skip_blanks) ? "- -" : $LINE, $line, $stats_by_line{$LINE} || {}, \%stats_for_file, $profile, $fi, ); if ($skip_blanks) { while ( @$src_lines && $src_lines->[0] =~ /^\s*$/ && !$stats_by_line{$LINE+1} ) { shift @$src_lines; $LINE++; } } $prev_line = $line; } continue { $LINE++; } my $separator_sub = $self->{mk_report_separator_line}; # iterate over xsubs $line_sub = $self->{mk_report_xsub_line} or die "mk_report_xsub_line not set"; my $subs_defined_in_file = $profile->subs_defined_in_file($filestr); foreach my $subname (sort keys %$subs_defined_in_file) { my $subinfo = $subs_defined_in_file->{$subname}; my $kind = $subinfo->kind; next if $kind eq 'perl'; next if $subinfo->calls == 0; if ($separator_sub) { print OUT $separator_sub->($profile, $fi); undef $separator_sub; # do mk_report_separator_line just once } print OUT $line_sub->( $subname, "sub $subname; # $kind\n\t", { subdef_info => [ $subinfo ], }, #stats_for_line undef, # stats_for_file $profile, $fi ); } print OUT $dataend; print OUT $self->get_param('footer', [$profile, $filestr]); close OUT; } print "\n" if $opts{show_progress}; } sub url_for_file { my ($self, $file, $anchor, $level) = @_; confess "No file specified" unless $file; $level ||= ''; my $url = $self->{_cache}{"url_for_file,$file,$level"} ||= do { my $fi = $self->{profile}->fileinfo_of($file); $level = 'line' if $fi->is_eval; $self->fname_for_fileinfo($fi, $level) . ".html"; }; $url .= "#$anchor" if defined $anchor; return $url; } sub href_for_file { my $url = shift->url_for_file(@_); return qq{href="$url"} if $url; return $url; } sub url_for_sub { my ($self, $sub, %opts) = @_; my $profile = $self->{profile}; my ($file, $fid, $first, $last, $fi) = $profile->file_line_range_of_sub($sub); return "" unless $file; if (!$first) { # use sanitized subname as label for xsubs # XXX must match what nytprofhtml does for xsubs ($first = $sub) =~ s/\W/_/g; } return $self->url_for_file($fi, $first); } sub href_for_sub { my $url = shift->url_for_sub(@_); return qq{href="$url"} if $url; return $url; } 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/SubInfo.pm000644 000766 000024 00000031462 12130047577 021306 0ustar00timbostaff000000 000000 package Devel::NYTProf::SubInfo; # sub_subinfo use strict; use warnings; use Carp; use List::Util qw(sum min max); use Data::Dumper; use Devel::NYTProf::Util qw( trace_level ); use Devel::NYTProf::Constants qw( NYTP_SIi_FID NYTP_SIi_FIRST_LINE NYTP_SIi_LAST_LINE NYTP_SIi_CALL_COUNT NYTP_SIi_INCL_RTIME NYTP_SIi_EXCL_RTIME NYTP_SIi_SUB_NAME NYTP_SIi_PROFILE NYTP_SIi_REC_DEPTH NYTP_SIi_RECI_RTIME NYTP_SIi_CALLED_BY NYTP_SIi_elements NYTP_SCi_CALL_COUNT NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME NYTP_SCi_RECI_RTIME NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB NYTP_SCi_elements ); # extra constants for private elements use constant { NYTP_SIi_meta => NYTP_SIi_elements + 1, NYTP_SIi_cache => NYTP_SIi_elements + 2, }; sub fid { shift->[NYTP_SIi_FID] || 0 } sub first_line { shift->[NYTP_SIi_FIRST_LINE] } sub last_line { shift->[NYTP_SIi_LAST_LINE] } sub calls { shift->[NYTP_SIi_CALL_COUNT] } sub incl_time { shift->[NYTP_SIi_INCL_RTIME] } sub excl_time { shift->[NYTP_SIi_EXCL_RTIME] } sub subname { shift->[NYTP_SIi_SUB_NAME] } sub subname_without_package { my $subname = shift->[NYTP_SIi_SUB_NAME]; $subname =~ s/.*:://; return $subname; } sub profile { shift->[NYTP_SIi_PROFILE] } sub package { (my $pkg = shift->subname) =~ s/^(.*)::.*/$1/; return $pkg } sub recur_max_depth { shift->[NYTP_SIi_REC_DEPTH] } sub recur_incl_time { shift->[NYTP_SIi_RECI_RTIME] } # general purpose hash - mainly a hack to help kill off Reader.pm sub meta { shift->[NYTP_SIi_meta()] ||= {} } # general purpose cache sub cache { shift->[NYTP_SIi_cache()] ||= {} } # { fid => { line => [ count, incl_time ] } } sub caller_fid_line_places { my ($self, $merge_evals) = @_; carp "caller_fid_line_places doesn't merge evals yet" if $merge_evals; # shallow clone to remove fid 0 is_sub hack my %tmp = %{ $self->[NYTP_SIi_CALLED_BY] || {} }; delete $tmp{0}; return \%tmp; } sub called_by_subnames { my ($self) = @_; my $callers = $self->caller_fid_line_places || {}; my %subnames; for my $sc (map { values %$_ } values %$callers) { my $caller_subnames = $sc->[NYTP_SCi_CALLING_SUB]; @subnames{ keys %$caller_subnames } = (); # viv keys } return \%subnames; } sub is_xsub { my $self = shift; # XXX should test == 0 but some xsubs still have undef first_line etc # XXX shouldn't include opcode my $first = $self->first_line; return undef if not defined $first; return 1 if $first == 0 && $self->last_line == 0; return 0; } sub is_opcode { my $self = shift; return 0 if $self->first_line or $self->last_line; return 1 if $self->subname =~ m/(?:^CORE::|::CORE:)\w+$/; return 0; } sub is_anon { shift->subname =~ m/::__ANON__\b/; } sub kind { my $self = shift; return 'opcode' if $self->is_opcode; return 'xsub' if $self->is_xsub; return 'perl'; } sub fileinfo { my $self = shift; my $fid = $self->fid; if (!$fid) { return undef; # sub not have a known fid } $self->profile->fileinfo_of($fid); } sub clone { # shallow my $self = shift; return bless [ @$self ] => ref $self; } sub _min { my ($a, $b) = @_; $a = $b if not defined $a; $b = $a if not defined $b; # either both are defined or both are undefined here return undef unless defined $a; return min($a, $b); } sub _max { my ($a, $b) = @_; $a = $b if not defined $a; $b = $a if not defined $b; # either both are defined or both are undefined here return undef unless defined $a; return max($a, $b); } sub _alter_fileinfo { my ($self, $remove_fi, $new_fi) = @_; my $remove_fid = ($remove_fi) ? $remove_fi->fid : 0; my $new_fid = ( $new_fi) ? $new_fi->fid : 0; if ($self->fid == $remove_fid) { $self->[NYTP_SIi_FID] = $new_fid; $remove_fi->_remove_sub_defined($self) if $remove_fi; $new_fi->_add_new_sub_defined($self) if $new_fi; } } sub _alter_called_by_fileinfo { my ($self, $remove_fi, $new_fi) = @_; my $remove_fid = ($remove_fi) ? $remove_fi->fid : 0; my $new_fid = ( $new_fi) ? $new_fi->fid : 0; # remove mentions of $remove_fid from called-by details # { fid => { line => [ count, incl, excl, ... ] } } if (my $called_by = $self->[NYTP_SIi_CALLED_BY]) { my $cb = delete $called_by->{$remove_fid}; if ($cb && $new_fid) { my $new_cb = $called_by->{$new_fid} ||= {}; warn sprintf "_alter_called_by_fileinfo: %s from fid %d to fid %d\n", $self->subname, $remove_fid, $new_fid if trace_level() >= 4; # merge $cb into $new_cb while ( my ($line, $cb_li) = each %$cb ) { my $dst_line_info = $new_cb->{$line} ||= []; _merge_in_caller_info($dst_line_info, delete $cb->{$line}, tag => "$line:".$self->subname, ); } } } } # merge details of another sub into this one # there are very few cases where this is sane thing to do # it's meant for merging things like anon-subs in evals # e.g., "PPI::Node::__ANON__[(eval 286)[PPI/Node.pm:642]:4]" sub merge_in { my ($self, $donor, %opts) = @_; my $self_subname = $self->subname; my $donor_subname = $donor->subname; warn sprintf "Merging sub %s into %s (%s)\n", $donor_subname, $self_subname, join(" ", %opts) if trace_level() >= 4; # see also "case NYTP_TAG_SUB_CALLERS:" in load_profile_data_from_stream() push @{ $self->meta->{merged_sub_names} }, $donor->subname; $self->[NYTP_SIi_FIRST_LINE] = _min($self->[NYTP_SIi_FIRST_LINE], $donor->[NYTP_SIi_FIRST_LINE]); $self->[NYTP_SIi_LAST_LINE] = _max($self->[NYTP_SIi_LAST_LINE], $donor->[NYTP_SIi_LAST_LINE]); $self->[NYTP_SIi_CALL_COUNT] += $donor->[NYTP_SIi_CALL_COUNT]; $self->[NYTP_SIi_INCL_RTIME] += $donor->[NYTP_SIi_INCL_RTIME]; $self->[NYTP_SIi_EXCL_RTIME] += $donor->[NYTP_SIi_EXCL_RTIME]; $self->[NYTP_SIi_REC_DEPTH] = max($self->[NYTP_SIi_REC_DEPTH], $donor->[NYTP_SIi_REC_DEPTH]); # adding reci_rtime is correct only if one sub doesn't call the other $self->[NYTP_SIi_RECI_RTIME] += $donor->[NYTP_SIi_RECI_RTIME]; # XXX # { fid => { line => [ count, incl_time, ... ] } } my $dst_called_by = $self ->[NYTP_SIi_CALLED_BY] ||= {}; my $src_called_by = $donor->[NYTP_SIi_CALLED_BY] || {}; $opts{opts} ||= "merge in $donor_subname"; # iterate over src and merge into dst while (my ($fid, $src_line_hash) = each %$src_called_by) { my $dst_line_hash = $dst_called_by->{$fid}; # merge lines in %$src_line_hash into %$dst_line_hash for my $line (keys %$src_line_hash) { my $dst_line_info = $dst_line_hash->{$line} ||= []; my $src_line_info = $src_line_hash->{$line}; delete $src_line_hash->{$line} unless $opts{src_keep}; _merge_in_caller_info($dst_line_info, $src_line_info, %opts); } } return; } sub _merge_in_caller_info { my ($dst_line_info, $src_line_info, %opts) = @_; my $tag = ($opts{tag}) ? " $opts{tag}" : ""; if (!@$src_line_info) { carp sprintf "_merge_in_caller_info%s skipped (empty donor)", $tag if trace_level(); return; } if (trace_level() >= 5) { carp sprintf "_merge_in_caller_info%s merging from $src_line_info -> $dst_line_info:", $tag; warn sprintf " . %s\n", _fmt_sc($src_line_info); warn sprintf " + %s\n", _fmt_sc($dst_line_info); } if (!@$dst_line_info) { @$dst_line_info = (0) x NYTP_SCi_elements; $dst_line_info->[NYTP_SCi_CALLING_SUB] = undef; } # merge @$src_line_info into @$dst_line_info $dst_line_info->[$_] += $src_line_info->[$_] for ( NYTP_SCi_CALL_COUNT, NYTP_SCi_INCL_RTIME, NYTP_SCi_EXCL_RTIME, ); $dst_line_info->[NYTP_SCi_REC_DEPTH] = max($dst_line_info->[NYTP_SCi_REC_DEPTH], $src_line_info->[NYTP_SCi_REC_DEPTH]); # ug, we can't really combine recursive incl_time, but this is better than undef $dst_line_info->[NYTP_SCi_RECI_RTIME] = max($dst_line_info->[NYTP_SCi_RECI_RTIME], $src_line_info->[NYTP_SCi_RECI_RTIME]); my $src_cs = $src_line_info->[NYTP_SCi_CALLING_SUB]|| {}; my $dst_cs = $dst_line_info->[NYTP_SCi_CALLING_SUB]||={}; $dst_cs->{$_} = $src_cs->{$_} for keys %$src_cs; warn sprintf " = %s\n", _fmt_sc($dst_line_info) if trace_level() >= 5; return; } sub _fmt_sc { my ($sc) = @_; return "(empty)" if !@$sc; my $dst_cs = $sc->[NYTP_SCi_CALLING_SUB]||{}; my $by = join " & ", sort keys %$dst_cs; sprintf "calls %d%s", $sc->[NYTP_SCi_CALL_COUNT], ($by) ? ", by $by" : ""; } sub caller_fids { my ($self, $merge_evals) = @_; my $callers = $self->caller_fid_line_places($merge_evals) || {}; my @fids = keys %$callers; return @fids; # count in scalar context } sub caller_count { return scalar shift->caller_places; } # XXX deprecate later # array of [ $fid, $line, $sub_call_info ], ... sub caller_places { my ($self, $merge_evals) = @_; my $callers = $self->caller_fid_line_places || {}; my @callers; for my $fid (sort { $a <=> $b } keys %$callers) { my $lines_hash = $callers->{$fid}; for my $line (sort { $a <=> $b } keys %$lines_hash) { push @callers, [ $fid, $line, $lines_hash->{$line} ]; } } return @callers; # scalar: number of distinct calling locations } sub normalize_for_test { my $self = shift; my $profile = $self->profile; # normalize eval sequence numbers in anon sub names to 0 $self->[NYTP_SIi_SUB_NAME] =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg if $self->[NYTP_SIi_SUB_NAME] =~ m/__ANON__/ && not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM}; # zero subroutine inclusive time $self->[NYTP_SIi_INCL_RTIME] = 0; $self->[NYTP_SIi_EXCL_RTIME] = 0; $self->[NYTP_SIi_RECI_RTIME] = 0; # { fid => { line => [ count, incl, excl, ... ] } } my $callers = $self->[NYTP_SIi_CALLED_BY] || {}; # calls from modules shipped with perl cause problems for tests # because the line numbers vary between perl versions, so here we # edit the line number of calls from these modules for my $fid (keys %$callers) { next if not $fid; my $fileinfo = $profile->fileinfo_of($fid) or next; next if $fileinfo->filename !~ /(AutoLoader|Exporter)\.pm$/; # normalize the lines X,Y,Z to 1,2,3 my %lines = %{ delete $callers->{$fid} }; my @lines = @lines{sort { $a <=> $b } keys %lines}; $callers->{$fid} = { map { $_ => shift @lines } 1..@lines }; } for my $sc (map { values %$_ } values %$callers) { # zero per-call-location subroutine inclusive time $sc->[NYTP_SCi_INCL_RTIME] = $sc->[NYTP_SCi_EXCL_RTIME] = $sc->[NYTP_SCi_RECI_RTIME] = 0; if (not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM}) { # normalize eval sequence numbers in anon sub names to 0 my $names = $sc->[NYTP_SCi_CALLING_SUB]||{}; for my $subname (keys %$names) { (my $newname = $subname) =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg; next if $newname eq $subname; warn "Normalizing $subname to $newname overwrote other calling-sub data\n" if $names->{$newname}; $names->{$newname} = delete $names->{$subname}; } } } return $self->[NYTP_SIi_SUB_NAME]; } sub dump { my ($self, $separator, $fh, $path, $prefix) = @_; my ($fid, $l1, $l2, $calls) = @{$self}[ NYTP_SIi_FID, NYTP_SIi_FIRST_LINE, NYTP_SIi_LAST_LINE, NYTP_SIi_CALL_COUNT ]; my @values = @{$self}[ NYTP_SIi_INCL_RTIME, NYTP_SIi_EXCL_RTIME, NYTP_SIi_REC_DEPTH, NYTP_SIi_RECI_RTIME ]; printf $fh "%s[ %s:%s-%s calls %s times %s ]\n", $prefix, map({ defined($_) ? $_ : 'undef' } $fid, $l1, $l2, $calls), join(" ", map { defined($_) ? $_ : 'undef' } @values); my @caller_places = $self->caller_places; for my $cp (@caller_places) { my ($fid, $line, $sc) = @$cp; my @sc = @$sc; $sc[NYTP_SCi_CALLING_SUB] = join "|", sort keys %{ $sc[NYTP_SCi_CALLING_SUB] }; printf $fh "%s%s%s%d:%d%s[ %s ]\n", $prefix, 'called_by', $separator, $fid, $line, $separator, join(" ", map { defined($_) ? $_ : 'undef' } @sc); } # where a sub has had others merged into it, list them my $merge_subs = $self->meta->{merged_sub_names} || []; for my $ms (sort @$merge_subs) { printf $fh "%s%s%s%s\n", $prefix, 'merge_donor', $separator, $ms; } } # vim:ts=8:sw=4:et 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/SubCallInfo.pm000644 000766 000024 00000001040 12067023751 022064 0ustar00timbostaff000000 000000 package Devel::NYTProf::SubCallInfo; use strict; use warnings; use Carp; use Devel::NYTProf::Constants qw( NYTP_SCi_CALL_COUNT NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME NYTP_SCi_RECI_RTIME NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB NYTP_SCi_elements ); sub calls { shift->[NYTP_SCi_CALL_COUNT] } sub incl_time { shift->[NYTP_SCi_INCL_RTIME] } sub excl_time { shift->[NYTP_SCi_EXCL_RTIME] } sub recur_max_depth { shift->[NYTP_SCi_REC_DEPTH] } sub recur_incl_time { shift->[NYTP_SCi_RECI_RTIME] } # vim:ts=8:sw=4:et 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/FileInfo.pm000644 000766 000024 00000046645 12211321457 021435 0ustar00timbostaff000000 000000 package Devel::NYTProf::FileInfo; # fid_fileinfo use strict; use Carp; use Config; use List::Util qw(sum max); use Devel::NYTProf::Util qw(strip_prefix_from_paths trace_level); use Devel::NYTProf::Constants qw( NYTP_FIDf_HAS_SRC NYTP_FIDf_SAVE_SRC NYTP_FIDf_IS_FAKE NYTP_FIDf_IS_PMC NYTP_FIDf_IS_EVAL NYTP_FIDi_FILENAME NYTP_FIDi_EVAL_FID NYTP_FIDi_EVAL_LINE NYTP_FIDi_FID NYTP_FIDi_FLAGS NYTP_FIDi_FILESIZE NYTP_FIDi_FILEMTIME NYTP_FIDi_PROFILE NYTP_FIDi_EVAL_FI NYTP_FIDi_HAS_EVALS NYTP_FIDi_SUBS_DEFINED NYTP_FIDi_SUBS_CALLED NYTP_FIDi_elements NYTP_SCi_CALL_COUNT NYTP_SCi_INCL_RTIME NYTP_SCi_EXCL_RTIME NYTP_SCi_RECI_RTIME NYTP_SCi_REC_DEPTH NYTP_SCi_CALLING_SUB NYTP_SCi_elements ); # extra constants for private elements use constant { NYTP_FIDi_meta => NYTP_FIDi_elements + 1, NYTP_FIDi_cache => NYTP_FIDi_elements + 2, }; sub filename { shift->[NYTP_FIDi_FILENAME()] } sub eval_fid { shift->[NYTP_FIDi_EVAL_FID()] } sub eval_line { shift->[NYTP_FIDi_EVAL_LINE()] } sub fid { shift->[NYTP_FIDi_FID()] } sub size { shift->[NYTP_FIDi_FILESIZE()] } sub mtime { shift->[NYTP_FIDi_FILEMTIME()] } sub profile { shift->[NYTP_FIDi_PROFILE()] } sub flags { shift->[NYTP_FIDi_FLAGS()] } # if an eval then return fileinfo obj for the fid that executed the eval sub eval_fi { shift->[NYTP_FIDi_EVAL_FI()] } # is_eval is true only for simple string evals (doesn't consider NYTP_FIDf_IS_EVAL) sub is_eval { shift->[NYTP_FIDi_EVAL_FI()] ? 1 : 0 } sub is_fake { shift->flags & NYTP_FIDf_IS_FAKE } sub is_file { my $self = shift; return not ($self->is_fake or $self->is_eval or $self->flags & NYTP_FIDf_IS_EVAL()); } # general purpose hash - mainly a hack to help kill off Reader.pm sub meta { shift->[NYTP_FIDi_meta()] ||= {} } # general purpose cache sub cache { shift->[NYTP_FIDi_cache()] ||= {} } # array of fileinfo's for each string eval in the file sub has_evals { my ($self, $include_nested) = @_; my $eval_fis = $self->[NYTP_FIDi_HAS_EVALS()] or return; return @$eval_fis if !$include_nested; my @eval_fis = @$eval_fis; # walk down tree of nested evals, adding them to @fi for (my $i=0; my $fi = $eval_fis[$i]; ++$i) { push @eval_fis, $fi->has_evals(0); } return @eval_fis; } sub sibling_evals { my ($self) = @_; my $parent_fi = $self->eval_fi or return; # not an eval my $eval_line = $self->eval_line; return grep { $_->eval_line == $eval_line } $parent_fi->has_evals; } sub _nullify { my $self = shift; @$self = (); # Zap! } # return subs defined as list of SubInfo objects sub subs_defined { my ($self, $incl_nested_evals) = @_; return map { $_->subs_defined(0) } $self, $self->has_evals(1) if $incl_nested_evals; return values %{ $self->[NYTP_FIDi_SUBS_DEFINED()] }; } sub subs_defined_sorted { my ($self, $incl_nested_evals) = @_; return sort { $a->subname cmp $b->subname } $self->subs_defined($incl_nested_evals); } sub _remove_sub_defined { my ($self, $si) = @_; my $subname = $si->subname; delete $self->[NYTP_FIDi_SUBS_DEFINED()]->{$subname} or carp sprintf "_remove_sub_defined: sub %s wasn't defined in %d %s", $subname, $self->fid, $self->filename; } sub _add_new_sub_defined { my ($self, $subinfo) = @_; my $subname = $subinfo->subname; my $subs_defined = $self->[NYTP_FIDi_SUBS_DEFINED()] ||= {}; my $existing_si = $subs_defined->{$subname}; croak sprintf "sub %s already defined in fid %d %s", $subname, $self->fid, $self->filename if $existing_si; $subs_defined->{$subname} = $subinfo; } =head2 sub_call_lines $hash = $fi->sub_call_lines; Returns a reference to a hash containing information about subroutine calls made at individual lines within the source file. Returns undef if no subroutine calling information is available. The keys of the returned hash are line numbers. The values are references to hashes with fully qualified subroutine names as keys. Each hash value is an reference to an array containing an integer call count (how many times the sub was called from that line of that file) and an inclusive time (how much time was spent inside the sub when it was called from that line of that file). For example, if the following was line 42 of a file C: ++$wiggle if foo(24) == bar(42); that line was executed once, and foo and bar were imported from pkg1, then sub_call_lines() would return something like: { 42 => { 'pkg1::foo' => [ 1, 0.02093 ], 'pkg1::bar' => [ 1, 0.00154 ], }, } =cut sub sub_call_lines { shift->[NYTP_FIDi_SUBS_CALLED()] } =head2 evals_by_line # { line => { fid_of_eval_at_line => $fi, ... }, ... } $hash = $fi->evals_by_line; Returns a reference to a hash containing information about string evals executed at individual lines within a source file. The keys of the returned hash are line numbers. The values are references to hashes with file id integers as keys and FileInfo objects as values. =cut sub evals_by_line { my ($self) = @_; # find all fids that have this fid as an eval_fid # { line => { fid_of_eval_at_line => $fi, ... } } my %evals_by_line; for my $fi ($self->has_evals) { $evals_by_line{ $fi->eval_line }->{ $fi->fid } = $fi; } return \%evals_by_line; } sub line_time_data { my ($self, $levels) = @_; $levels ||= [ 'line' ]; # XXX this can be optimized once the fidinfo contains directs refs to the data my $profile = $self->profile; my $fid = $self->fid; for my $level (@$levels) { my $fid_ary = $profile->get_fid_line_data($level); return $fid_ary->[$fid] if $fid_ary && $fid_ary->[$fid]; } return undef; } sub excl_time { # total exclusive time for fid my $self = shift; my $line_data = $self->line_time_data([qw(sub block line)]) || return undef; my $excl_time = 0; for (@$line_data) { next unless $_; $excl_time += $_->[0]; } return $excl_time; } sub sum_of_stmts_count { my ($self, $incl_nested_evals) = @_; return sum(map { $_->sum_of_stmts_count(0) } $self, $self->has_evals(1)) if $incl_nested_evals; my $ref = \$self->cache->{NYTP_FIDi_sum_stmts_count}; $$ref = $self->_sum_of_line_time_data(1) if not defined $$ref; return $$ref; } sub sum_of_stmts_time { my ($self, $incl_nested_evals) = @_; return sum(map { $_->sum_of_stmts_time(0) } $self, $self->has_evals(1)) if $incl_nested_evals; my $ref = \$self->cache->{NYTP_FIDi_sum_stmts_times}; $$ref = $self->_sum_of_line_time_data(0) if not defined $$ref; return $$ref; } sub _sum_of_line_time_data { my ($self, $idx) = @_; my $line_time_data = $self->line_time_data; my $sum = 0; $sum += $_->[$idx]||0 for @$line_time_data; return $sum; } sub outer { my ($self, $recurse) = @_; my $fi = $self->eval_fi or return; my $prev = $self; while ($recurse and my $eval_fi = $fi->eval_fi) { $prev = $fi; $fi = $eval_fi; } return $fi unless wantarray; return ($fi, $prev->eval_line); } sub is_pmc { return (shift->flags & NYTP_FIDf_IS_PMC()); } sub collapse_sibling_evals { my ($self, $survivor_fi, @donors) = @_; my $profile = $self->profile; die "Can't collapse_sibling_evals of non-sibling evals" if grep { $_->eval_fid != $survivor_fi->eval_fid or $_->eval_line != $survivor_fi->eval_line } @donors; my $s_ltd = $survivor_fi->line_time_data; # XXX line only my $s_scl = $survivor_fi->sub_call_lines; my %donor_fids; for my $donor_fi (@donors) { # copy data from donor to survivor_fi then delete donor my $donor_fid = $donor_fi->fid; $donor_fids{$donor_fid} = $donor_fi; warn sprintf "collapse_sibling_evals: processing donor fid %d: %s\n", $donor_fid, $donor_fi->filename if trace_level() >= 3; # XXX nested evals not handled yet warn sprintf "collapse_sibling_evals: nested evals in %s not handled", $donor_fi->filename if $donor_fi->has_evals; # for each sub defined in the donor, # move the sub definition to the survivor if (my @subs_defined = $donor_fi->subs_defined) { for my $si (@subs_defined) { warn sprintf " - moving from fid %d: sub %s\n", $donor_fid, $si->subname if trace_level() >= 4; $si->_alter_fileinfo($donor_fi, $survivor_fi); warn sprintf " - moving done\n" if trace_level() >= 4; } } # for each sub call made by the donor, # move the sub calls to the survivor # 1 => { 'main::foo' => [ 1, '1.38e-05', '1.24e-05', ..., { 'main::RUNTIME' => undef } ] } if (my $sub_call_lines = $donor_fi->sub_call_lines) { my %subnames_called_by_donor; # merge details of subs called from $donor_fi while ( my ($line, $sc_hash) = each %$sub_call_lines ) { my $s_sc_hash = $s_scl->{$line} ||= {}; for my $subname (keys %$sc_hash ) { my $s_sc_info = $s_sc_hash->{$subname} ||= []; my $sc_info = delete $sc_hash->{$subname}; Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, $sc_info, tag => "line $line calls to $subname", ); $subnames_called_by_donor{$subname}++; } } %$sub_call_lines = (); # zap # update subinfo (NYTP_SIi_CALLED_BY) $profile->subinfo_of($_)->_alter_called_by_fileinfo($donor_fi, $survivor_fi) for keys %subnames_called_by_donor; } # copy line time data my $d_ltd = $donor_fi->line_time_data || []; # XXX line only for my $line (0..@$d_ltd-1) { my $d_tld_l = $d_ltd->[$line] or next; my $s_tld_l = $s_ltd->[$line] ||= []; $s_tld_l->[$_] += $d_tld_l->[$_] for (0..@$d_tld_l-1); warn sprintf "%d:%d: @$s_tld_l from @$d_tld_l fid:%d\n", $survivor_fi->fid, $line, $donor_fid if 0; } push @{ $survivor_fi->meta->{merged_fids} }, $donor_fid; ++$survivor_fi->meta->{merged_fids_src_varied} if $donor_fi->src_digest ne $survivor_fi->src_digest; $donor_fi->_nullify; } # remove donors from parent NYTP_FIDi_HAS_EVALS if (my $eval_fis = $self->[NYTP_FIDi_HAS_EVALS()]) { my %donors = map { +"$_" => 1 } @donors; my $count = @$eval_fis; @$eval_fis = grep { !$donors{$_} } @$eval_fis; warn "_delete_eval mismatch" if @$eval_fis != $count - @donors; } # update sawampersand_fid if it's one of the now-dead donors if ($donor_fids{ $profile->attributes->{sawampersand_fid} || 0 }) { $profile->attributes->{sawampersand_fid} = $survivor_fi->fid; } # now the fid merging is complete... # look for any anon subs that are effectively duplicates # (ie have the same name except for eval seqn) # if more than one for any given name we merge them if (my @subs_defined = $survivor_fi->subs_defined_sorted) { # bucket anon subs by normalized name my %newname; for my $si (@subs_defined) { next unless $si->is_anon; (my $newname = $si->subname) =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg; push @{ $newname{$newname} }, $si; } while ( my ($newname, $to_merge) = each %newname ) { my $survivor_si = shift @$to_merge; next unless @$to_merge; # nothing to do my $survivor_subname = $survivor_si->subname; warn sprintf "collapse_sibling_evals: merging %d subs into %s: %s\n", scalar @$to_merge, $survivor_subname, join ", ", map { $_->subname } @$to_merge if trace_level() >= 3; for my $delete_si (@$to_merge) { my $delete_subname = $delete_si->subname; # for every file that called this sub, find the lines that made the calls # and change the name to the new sub for my $caller_fid ($delete_si->caller_fids) { my $caller_fi = $profile->fileinfo_of($caller_fid); # sub_call_lines ==> { line => { sub => ... } } for my $subs_called_on_line (values %{ $caller_fi->sub_call_lines }) { my $sc_info = delete $subs_called_on_line->{$delete_subname} or next; my $s_sc_info = $subs_called_on_line->{$survivor_subname} ||= []; Devel::NYTProf::SubInfo::_merge_in_caller_info($s_sc_info, $sc_info, tag => "collapse eval $delete_subname", ); } } $survivor_si->merge_in($delete_si); $survivor_fi->_remove_sub_defined($delete_si); $profile->_disconnect_subinfo($delete_si); } } } warn sprintf "collapse_sibling_evals done for ".$survivor_fi->filename."\n" if trace_level() >= 2; return $survivor_fi; } # Should return the filename that the application used when loading the file # For evals should remove the @INC portion from within the "(eval N)[$path]" # and similarly for Class::MOP #line evals "... defined at $path". # This is a bit of a fudge. Filename handling should be improved in the profiler. sub filename_without_inc { my $self = shift; my $f = [$self->filename]; strip_prefix_from_paths([$self->profile->inc], $f, qr/(?: ^ | \[ | \sdefined\sat\s )/x ); return $f->[0]; } sub abs_filename { my $self = shift; my $filename = $self->filename; # strip of autosplit annotation, if any $filename =~ s/ \(autosplit into .*//; # if it's a .pmc then assume that's the file we want to look at # (because the main use for .pmc's are related to perl6) $filename .= "c" if $self->is_pmc; # search profile @INC if filename is not absolute my @files = ($filename); if ($filename !~ m/^\//) { my @inc = $self->profile->inc; @files = map { "$_/$filename" } @inc; } for my $file (@files) { return $file if -f $file; } # returning the still-relative filename is better than returning an undef return $filename; } # has source code stored within the profile data file sub has_savesrc { my $self = shift; return $self->profile->{fid_srclines}[ $self->fid ]; } sub srclines_array { my $self = shift; if (my $srclines = $self->has_savesrc) { my $copy = [ @$srclines ]; # shallow clone shift @$copy; # line 0 not used return $copy; } my $filename = $self->abs_filename; if (open my $fh, "<", $filename) { return [ <$fh> ]; } return undef; } sub src_digest { my $self = shift; return $self->cache->{src_digest} ||= do { my $srclines_array = $self->srclines_array || []; my $src = join "\n", @$srclines_array; # return empty string for digest if there's no src ($src) ? join ",", ( scalar @$srclines_array, # number of lines length $src, # total length unpack("%32C*",$src) ) # 32-bit checksum : ''; }; } sub normalize_for_test { my $self = shift; # normalize eval sequence numbers in 'file' names to 0 $self->[NYTP_FIDi_FILENAME] =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg if not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM}; # normalize flags to avoid failures due to savesrc and perl version $self->[NYTP_FIDi_FLAGS] &= ~(NYTP_FIDf_HAS_SRC|NYTP_FIDf_SAVE_SRC); # '1' => { 'main::foo' => [ 1, '1.38e-05', '1.24e-05', ..., { 'main::RUNTIME' => undef } ] } for my $subscalled (values %{ $self->sub_call_lines }) { for my $subname (keys %$subscalled) { my $sc = $subscalled->{$subname}; $sc->[NYTP_SCi_INCL_RTIME] = $sc->[NYTP_SCi_EXCL_RTIME] = $sc->[NYTP_SCi_RECI_RTIME] = 0; if (not $ENV{NYTPROF_TEST_SKIP_EVAL_NORM}) { # normalize eval sequence numbers in anon sub names to 0 (my $newname = $subname) =~ s/ \( ((?:re_)?) eval \s \d+ \) /(${1}eval 0)/xg; if ($newname ne $subname) { warn "Normalizing $subname to $newname overwrote other called-by data\n" if $subscalled->{$newname}; $subscalled->{$newname} = delete $subscalled->{$subname}; } } } } } sub summary { my ($fi) = @_; return sprintf "fid%d: %s", $fi->fid, $fi->filename_without_inc; } sub dump { my ($self, $separator, $fh, $path, $prefix, $opts) = @_; my @values = @{$self}[ NYTP_FIDi_FILENAME, NYTP_FIDi_EVAL_FID, NYTP_FIDi_EVAL_LINE, NYTP_FIDi_FID, NYTP_FIDi_FLAGS, NYTP_FIDi_FILESIZE, NYTP_FIDi_FILEMTIME ]; $values[0] = $self->filename_without_inc; # also remove possible remaining perl version seen in some cpantesters # http://www.cpantesters.org/cpan/report/bf913910-bfdd-11df-a657-c9f38a00995b $values[0] =~ s!^$Config{version}/!!o; printf $fh "%s[ %s ]\n", $prefix, join(" ", map { defined($_) ? $_ : 'undef' } @values); if (not $opts->{skip_internal_details}) { for my $si ($self->subs_defined_sorted) { my ($fl, $ll) = ($si->first_line, $si->last_line); defined $_ or $_ = 'undef' for ($fl, $ll); printf $fh "%s%s%s%s%s%s-%s\n", $prefix, 'sub', $separator, $si->subname(' and '), $separator, $fl, $ll; } # { line => { subname => [...] }, ... } my $sub_call_lines = $self->sub_call_lines; for my $line (sort { $a <=> $b } keys %$sub_call_lines) { my $subs_called = $sub_call_lines->{$line}; for my $subname (sort keys %$subs_called) { my @sc = @{$subs_called->{$subname}}; $sc[NYTP_SCi_CALLING_SUB] = join "|", sort keys %{ $sc[NYTP_SCi_CALLING_SUB] }; printf $fh "%s%s%s%s%s%s%s[ %s ]\n", $prefix, 'call', $separator, $line, $separator, $subname, $separator, join(" ", map { defined($_) ? $_ : 'undef' } @sc) } } # string evals, group by the line the eval is on my %eval_lines; for my $eval_fi ($self->has_evals(0)) { push @{ $eval_lines{ $eval_fi->eval_line } }, $eval_fi; } for my $line (sort { $a <=> $b } keys %eval_lines) { my $eval_fis = $eval_lines{$line}; my @has_evals = map { $_->has_evals(1) } @$eval_fis; my @merged_fids = map { @{ $_->meta->{merged_fids}||[]} } @$eval_fis; printf $fh "%s%s%s%d%s[ count %d nested %d merged %d ]\n", $prefix, 'eval', $separator, $eval_fis->[0]->eval_line, $separator, scalar @$eval_fis, # count of evals executed on this line scalar @has_evals, # count of nested evals they executed scalar @merged_fids, # count of evals merged (collapsed) away } } } # vim: ts=8:sw=4:et 1; Devel-NYTProf-6.06/lib/Devel/NYTProf/Data.pm000644 000766 000024 00000061056 12523657232 020615 0ustar00timbostaff000000 000000 # vim: ts=8 sw=4 expandtab: ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################### package Devel::NYTProf::Data; =head1 NAME Devel::NYTProf::Data - L data loading and manipulation =head1 SYNOPSIS use Devel::NYTProf::Data; $profile = Devel::NYTProf::Data->new( { filename => 'nytprof.out' } ); $profile->dump_profile_data(); =head1 DESCRIPTION Reads a profile data file written by L, aggregates the contents, and returns the results as a blessed data structure. Access to the data should be via methods in this class to avoid breaking encapsulation (and thus breaking your code when the data structures change in future versions). B the documentation is out of date and may not be updated soon. It's also likely that the API will change drastically in future. It's possible, for example, that the data model will switch to use SQLite and the http://metacpan.org/pod/ORLite ORM. Let me know if you come to depend on a particular API and I'll try to preserve it if practical. =head1 METHODS =cut use warnings; use strict; use Carp qw(carp croak cluck); use Cwd qw(getcwd); use Scalar::Util qw(blessed); use Devel::NYTProf::Core; use Devel::NYTProf::FileInfo; use Devel::NYTProf::SubInfo; use Devel::NYTProf::Util qw( make_path_strip_editor strip_prefix_from_paths get_abs_paths_alternation_regex trace_level ); our $VERSION = '4.02'; =head2 new $profile = Devel::NYTProf::Data->new( ); $profile = Devel::NYTProf::Data->new( { filename => 'nytprof.out', # default quiet => 0, # default, 1 to silence message } ); Reads the specified file containing profile data written by L, aggregates the contents, and returns the results as a blessed data structure. =cut sub new { my $class = shift; my $args = shift || { }; my $file = $args->{filename} ||= 'nytprof.out'; print "Reading $file\n" unless $args->{quiet}; my $profile = load_profile_data_from_file( $file, $args->{callback}, ); return undef if $args->{callback}; print "Processing $file data\n" unless $args->{quiet}; bless $profile => $class; my $fid_fileinfo = $profile->{fid_fileinfo}; my $sub_subinfo = $profile->{sub_subinfo}; # add profile ref so fidinfo & subinfo objects # XXX circular ref, add weaken $_ and $_->[7] = $profile for @$fid_fileinfo; $_->[7] = $profile for values %$sub_subinfo; # bless sub_subinfo data (my $sub_class = $class) =~ s/\w+$/SubInfo/; $_ and bless $_ => $sub_class for values %$sub_subinfo; # create profiler_active attribute by subtracting from profiler_duration # currently we only subtract cumulative_overhead_ticks my $attribute = $profile->{attribute}; my $overhead_time = $attribute->{cumulative_overhead_ticks} / $attribute->{ticks_per_sec}; $attribute->{profiler_active} = $attribute->{profiler_duration} - $overhead_time; # find subs that have calls but no fid my @homeless_subs = grep { $_->calls and not $_->fid } values %$sub_subinfo; if (@homeless_subs) { # give them a home... # currently just the first existing fileinfo # XXX ought to create a new dummy fileinfo for them my $new_fi = $profile->fileinfo_of(1); $_->_alter_fileinfo(undef, $new_fi) for @homeless_subs; } # Where a given eval() has been invoked more than once # rollup the corresponding fids if they're "uninteresting". if (not $args->{skip_collapse_evals}) { for my $fi ($profile->noneval_fileinfos) { $profile->collapse_evals_in($fi); } } $profile->_clear_caches; # a hack for testing/debugging if (my $env = $ENV{NYTPROF_ONLOAD}) { my %onload = map { split /=/, $_, 2 } split /:/, $env, -1; warn _dumper($profile) if $onload{dump}; exit $onload{exit} if defined $onload{exit}; } return $profile; } sub collapse_evals_in { my ($profile, $parent_fi) = @_; my $parent_fid = $parent_fi->fid; my %evals_on_line; for my $fi ($parent_fi->has_evals) { $profile->collapse_evals_in($fi); # recurse first push @{ $evals_on_line{$fi->eval_line} }, $fi; } while ( my ($line, $siblings) = each %evals_on_line) { next if @$siblings == 1; # compare src code of evals and collapse identical ones my %src_keyed; for my $fi (@$siblings) { my $key = $fi->src_digest; if (!$key) { # include extra info to segregate when there's no src $key .= ',evals' if $fi->has_evals; $key .= ',subs' if $fi->subs_defined; } push @{$src_keyed{$key}}, $fi; } if (trace_level() >= 2) { my @subs = map { $_->subs_defined } @$siblings; my @evals = map { $_->has_evals(0) } @$siblings; warn sprintf "%d:%d: has %d sibling evals (subs %d, evals %d, keys %d) in %s; fids: %s\n", $parent_fid, $line, scalar @$siblings, scalar @subs, scalar @evals, scalar keys %src_keyed, $parent_fi->filename, join(" ", map { $_->fid } @$siblings); if (trace_level() >= 2) { for my $si (@subs) { warn sprintf "%d:%d evals: define sub %s in fid %s\n", $parent_fid, $line, $si->subname, $si->fid; } for my $fi (@evals) { warn sprintf "%d:%d evals: execute eval %s\n", $parent_fid, $line, $fi->filename; } } } # if 'too many' distinct eval source keys then simply collapse all my $max_evals_siblings = $ENV{NYTPROF_MAX_EVAL_SIBLINGS} || 200; if (values %src_keyed > $max_evals_siblings) { $parent_fi->collapse_sibling_evals(@$siblings); } else { # finesse: consider each distinct src in turn while ( my ($key, $src_same_fis) = each %src_keyed ) { next if @$src_same_fis == 1; # unique src key my @fids = map { $_->fid } @$src_same_fis; if (grep { $_->has_evals(0) } @$src_same_fis) { warn "evals($key): collapsing skipped due to evals in @fids\n" if trace_level() >= 3; } else { warn "evals($key): collapsing identical: @fids\n" if trace_level() >= 3; my $fi = $parent_fi->collapse_sibling_evals(@$src_same_fis); @$src_same_fis = ( $fi ); # update list in-place } } } } } sub _caches { return shift->{caches} ||= {} } sub _clear_caches { return delete shift->{caches} } sub attributes { return shift->{attribute} || {}; } sub options { return shift->{option} || {}; } sub subname_subinfo_map { return { %{ shift->{sub_subinfo} } }; # shallow copy } sub _disconnect_subinfo { my ($self, $si) = @_; my $subname = $si->subname; my $si2 = delete $self->{sub_subinfo}{$subname}; # sanity check carp sprintf "disconnect_subinfo: deleted entry %s %s doesn't match argument %s %s", ($si2) ? ($si2, $si2->subname) : ('undef', 'undef'), $si, $subname if $si2 != $si or $si2->subname ne $subname; # do more? } # package_tree_subinfo_map is like package_subinfo_map but returns # nested data instead of flattened. # for "Foo::Bar::Baz" package: # { Foo => { '' => [...], '::Bar' => { ''=>[...], '::Baz'=>[...] } } } # if merged is true then array contains a single 'merged' subinfo sub package_subinfo_map { my $self = shift; my ($merge_subs, $nested_pkgs) = @_; my %pkg; my %to_merge; my $all_subs = $self->subname_subinfo_map; while ( my ($name, $subinfo) = each %$all_subs ) { $name =~ s/^(.*::).*/$1/; # XXX $subinfo->package my $subinfos; if ($nested_pkgs) { my @parts = split /::/, $name; my $node = $pkg{ shift @parts } ||= {}; $node = $node->{ shift @parts } ||= {} while @parts; $subinfos = $node->{''} ||= []; } else { $subinfos = $pkg{$name} ||= []; } push @$subinfos, $subinfo; $to_merge{$subinfos} = $subinfos if $merge_subs; } for my $subinfos (values %to_merge) { my $subinfo = shift(@$subinfos)->clone; $subinfo->merge_in($_, src_keep => 1) for @$subinfos; # replace the many with the one @$subinfos = ($subinfo); } return \%pkg; } # [ # undef, # depth 0 # { # depth 1 # "main::" => [ [ subinfo1, subinfo2 ] ], # 2 subs in 1 pkg # "Foo::" => [ [ subinfo3 ], [ subinfo4 ] ] # 2 subs in 2 pkg # } # { # depth 2 # "Foo::Bar::" => [ [ subinfo3 ] ] # 1 sub in 1 pkg # "Foo::Baz::" => [ [ subinfo4 ] ] # 1 sub in 1 pkg # } # ] sub packages_at_depth_subinfo { my $self = shift; my ($opts) = @_; my $merged = $opts->{merge_subinfos}; my $all_pkgs = $self->package_subinfo_map($merged) || {}; my @packages_at_depth = ({}); while ( my ($fullpkgname, $subinfos) = each %$all_pkgs ) { $subinfos = [ grep { $_->calls } @$subinfos ] if not $opts->{include_unused_subs}; next unless @$subinfos; my @parts = split /::/, $fullpkgname; # drops empty trailing part # accumulate @$subinfos for the full package name # and also for each successive truncation of the package name for (my $depth; $depth = @parts; pop @parts) { my $pkgname = join('::', @parts, ''); my $store = ($merged) ? $subinfos->[0] : $subinfos; # { "Foo::" => [ [sub1,sub2], [sub3,sub4] ] } # subs from 2 packages my $pkgdepthinfo = $packages_at_depth[$depth] ||= {}; push @{ $pkgdepthinfo->{$pkgname} }, $store; last if not $opts->{rollup_packages}; } } # fill in any undef holes at depths with no subs $_ ||= {} for @packages_at_depth; return \@packages_at_depth; } sub all_fileinfos { my @all = @{shift->{fid_fileinfo}}; shift @all; # drop fid 0 # return all non-nullified fileinfos return grep { $_->fid } @all; } sub eval_fileinfos { return grep { $_->eval_line } shift->all_fileinfos; } sub noneval_fileinfos { return grep { !$_->eval_line } shift->all_fileinfos; } sub fileinfo_of { my ($self, $arg, $silent_if_undef) = @_; if (not defined $arg) { carp "Can't resolve fid of undef value" unless $silent_if_undef; return undef; } # check if already a file info object return $arg if ref $arg and UNIVERSAL::can($arg,'fid') and $arg->isa('Devel::NYTProf::FileInfo'); my $fid = $self->resolve_fid($arg); if (not $fid) { carp "Can't resolve fid of '$arg'"; return undef; } my $fi = $self->{fid_fileinfo}[$fid]; return undef unless defined $fi->fid; # nullified? return $fi; } sub subinfo_of { my ($self, $subname) = @_; if (not defined $subname) { cluck "Can't resolve subinfo of undef value"; return undef; } my $si = $self->{sub_subinfo}{$subname} or cluck "Can't resolve subinfo of '$subname'"; return $si; } sub inc { # XXX should return inc from profile data, when it's there return @INC; } =head2 dump_profile_data $profile->dump_profile_data; $profile->dump_profile_data( { filehandle => \*STDOUT, separator => "", } ); Writes the profile data in a reasonably human friendly format to the specified C (default STDOUT). For non-trivial profiles the output can be very large. As a guide, there'll be at least one line of output for each line of code executed, plus one for each place a subroutine was called from, plus one per subroutine. The default format is a Data::Dumper style whitespace-indented tree. The types of data present can depend on the options used when profiling. If C is true then instead of whitespace, each item of data is indented with the I through the structure with C used to separate the elements of the path. This format is especially useful for grep'ing and diff'ing. =cut sub dump_profile_data { my $self = shift; my $args = shift; my $separator = $args->{separator} || ''; my $filehandle = $args->{filehandle} || \*STDOUT; # shallow clone and add sub_caller for migration of tests my $startnode = $self; $self->_clear_caches; my $callback = sub { my ($path, $value) = @_; # not needed currently #if ($path->[0] eq 'attribute' && @$path == 1) { my %v = %$value; return ({}, \%v); } if (my $hook = $args->{skip_fileinfo_hook}) { # for fid_fileinfo elements... if ($path->[0] eq 'fid_fileinfo' && @$path==2) { my $fi = $value; # skip nullified fileinfo return undef unless $fi->fid; # don't dump internal details of lib modules return ({ skip_internal_details => scalar $hook->($fi, $path, $value) }, $value); } # skip sub_subinfo data for 'library modules' if ($path->[0] eq 'sub_subinfo' && @$path==2 && $value->[0]) { my $fi = $self->fileinfo_of($value->[0]); return undef if !$fi or $hook->($fi, $path, $value); } # skip fid_*_time data for 'library modules' if ($path->[0] =~ /^fid_\w+_time$/ && @$path==2) { my $fi = $self->fileinfo_of($path->[1]); return undef if !$fi or $hook->($fi, $path, $value); } } return ({}, $value); }; _dump_elements($startnode, $separator, $filehandle, [], $callback); } sub _dump_elements { my ($r, $separator, $fh, $path, $callback) = @_; my $pad = " "; my $padN; my $is_hash = (UNIVERSAL::isa($r, 'HASH')); my ($start, $end, $colon, $keys) = ($is_hash) ? ('{', '}', ' => ', [sort keys %$r]) : ('[', ']', ': ', [0 .. @$r - 1]); if ($separator) { ($start, $end, $colon) = (undef, undef, $separator); $padN = join $separator, @$path, ''; } else { $padN = $pad x (@$path + 1); } my $format = {sub_subinfo => {compact => 1},}; print $fh "$start\n" if $start; my $key1 = $path->[0] || $keys->[0]; for my $key (@$keys) { next if $key eq 'fid_srclines'; my $value = ($is_hash) ? $r->{$key} : $r->[$key]; # skip undef elements in array next if !$is_hash && !defined($value); # skip refs to empty arrays in array next if !$is_hash && ref $value eq 'ARRAY' && !@$value; my $dump_opts = {}; if ($callback) { ($dump_opts, $value) = $callback->([ @$path, $key ], $value); next if not $dump_opts; } my $prefix = "$padN$key$colon"; if (UNIVERSAL::can($value,'dump')) { $value->dump($separator, $fh, [ @$path, $key ], $prefix, $dump_opts); } else { # special case some common cases to be more compact: # fid_*_time [fid][line] = [N,N] # sub_subinfo {subname} = [fid,startline,endline,calls,incl_time] my $as_compact = $format->{$key1}{compact}; if (not defined $as_compact) { # so guess... $as_compact = (UNIVERSAL::isa($value, 'ARRAY') && @$value <= 9 && !grep { ref or !defined } @$value); } $as_compact = 0 if not ref $value eq 'ARRAY'; if ($as_compact) { no warnings qw(uninitialized); printf $fh "%s[ %s ]\n", $prefix, join(" ", map { defined($_) ? $_ : 'undef' } @$value); } elsif (ref $value) { _dump_elements($value, $separator, $fh, [ @$path, $key ], $callback); } else { print $fh "$prefix$value\n"; } } } printf $fh "%s$end\n", ($pad x (@$path - 1)) if $end; } sub get_profile_levels { return shift->{profile_modes}; } sub get_fid_line_data { my ($self, $level) = @_; $level ||= 'line'; my $fid_line_data = $self->{"fid_${level}_time"}; return $fid_line_data; } =head2 normalize_variables $profile->normalize_variables; Traverses the profile data structure and normalizes highly variable data, such as the time, in order that the data can more easily be compared. This is mainly of use to the test suite. The data normalized is: =over =item * profile timing data: set to 0 =item * subroutines: timings are set to 0 =item * attributes, like basetime, xs_version, etc., are set to 0 =item * filenames: path prefixes matching absolute paths in @INC are changed to "/.../" =item * filenames: eval sequence numbers, like "(re_eval 2)" are changed to 0 =back =cut sub normalize_variables { my ($self, $normalize_options) = @_; if ($normalize_options) { %{ $self->options } = (); } my $attributes = $self->attributes; for my $attr (qw( basetime xs_version perl_version clock_id ticks_per_sec nv_size profiler_duration profiler_end_time profiler_start_time cumulative_overhead_ticks profiler_active total_stmts_duration total_stmts_measured total_stmts_discounted total_sub_calls sawampersand_line )) { $attributes->{$attr} = 0 if exists $attributes->{$attr}; } for my $attr (qw(PL_perldb cumulative_overhead_ticks)) { delete $attributes->{$attr}; } # normalize line data for my $level (qw(line block sub)) { my $fid_line_data = $self->get_fid_line_data($level) || []; # zero the statement timing data for my $of_fid (@$fid_line_data) { _zero_array_elem($of_fid, 0) if $of_fid; } } my $sub_subinfo = $self->{sub_subinfo}; for my $subname (keys %$sub_subinfo) { my $si = $self->{sub_subinfo}{$subname}; # zero sub info and sub caller times etc. my $newname = $si->normalize_for_test; if ($newname ne $subname) { warn "Normalizing $subname to $newname overwrote other data\n" if $sub_subinfo->{$newname}; $sub_subinfo->{$newname} = delete $sub_subinfo->{$subname}; } } $_->normalize_for_test for $self->all_fileinfos; return; } sub _zero_array_elem { my ($ary_of_line_data, $index) = @_; for my $line_data (@$ary_of_line_data) { next unless $line_data; $line_data->[$index] = 0; # if line was a string eval # then recurse to zero the times within the eval lines if (my $eval_lines = $line_data->[2]) { _zero_array_elem($eval_lines, $index); # recurse } } } sub _filename_to_fid { my $self = shift; my $caches = $self->_caches; return $caches->{_filename_to_fid_cache} ||= do { my $filename_to_fid = {}; $filename_to_fid->{$_->filename} = $_->fid for $self->all_fileinfos; $filename_to_fid; }; } =head2 subs_defined_in_file $subs_defined_hash = $profile->subs_defined_in_file( $file, $include_lines ); Returns a reference to a hash containing information about subroutines defined in a source file. The $file argument can be an integer file id (fid) or a file path. Returns undef if the profile contains no C data for the $file. The keys of the returned hash are fully qualified subroutine names and the corresponding value is a hash reference containing L objects. If $include_lines is true then the hash also contains integer keys corresponding to the first line of the subroutine. The corresponding value is a reference to an array. The array contains a hash ref for each of the subroutines defined on that line, typically just one. =cut sub subs_defined_in_file { my ($self, $fid, $incl_lines) = @_; croak "incl_lines is deprecated in subs_defined_in_file, use subs_defined_in_file_by_line instead" if $incl_lines; my $fi = $self->fileinfo_of($fid) or return; $fid = $fi->fid; my $caches = $self->_caches; my $cache_key = "subs_defined_in_file:$fid"; return $caches->{$cache_key} if $caches->{$cache_key}; my %subs = map { $_->subname => $_ } $fi->subs_defined; $caches->{$cache_key} = \%subs; return $caches->{$cache_key}; } sub subs_defined_in_file_by_line { my $subs = shift->subs_defined_in_file(@_); my %line2subs; for (values %$subs) { my $first_line = $_->first_line || 0; # 0 = xsub? push @{$line2subs{$first_line}}, $_; } return \%line2subs; } =head2 file_line_range_of_sub ($file, $fid, $first, $last, $fi) = $profile->file_line_range_of_sub("main::foo"); Returns the filename, fid, and first and last line numbers, and fileinfo object for the specified subroutine (which must be fully qualified with a package name). Returns an empty list if the subroutine name is not in the profile data. The $fid return is the 'original' fid associated with the file the subroutine was created in. The $file returned is the source file that defined the subroutine. Subroutines that are implemented in XS have a line range of 0,0 and a possibly unknown file (if NYTProf couldn't find a good match based on the package name). Subroutines that were called but only returned via an exception may have a line range of undef,undef if they're xsubs or were defined before NYTProf was enabled. =cut sub file_line_range_of_sub { my ($self, $sub) = @_; my $sub_subinfo = $self->subinfo_of($sub) or return; # no such sub my ($fid, $first, $last) = @$sub_subinfo; return if not $fid; # sub has no known file my $fileinfo = $fid && $self->fileinfo_of($fid) or croak "No fid_fileinfo for sub $sub fid '$fid'"; return ($fileinfo->filename, $fid, $first, $last, $fileinfo); } =head2 resolve_fid $fid = $profile->resolve_fid( $file ); Returns the integer I that corresponds to $file. If $file can't be found and $file looks like a positive integer then it's presumed to already be a fid and is returned. This is used to enable other methods to work with fid or file arguments. If $file can't be found but it uniquely matches the suffix of one of the files then that corresponding fid is returned. =cut sub resolve_fid { my ($self, $file) = @_; Carp::confess("No file specified") unless defined $file; my $resolve_fid_cache = $self->_filename_to_fid; # exact match return $resolve_fid_cache->{$file} if exists $resolve_fid_cache->{$file}; # looks like a fid already return $file if $file =~ m/^\d+$/; # XXX hack needed to because of how _map_new_to_old deals # with .pmc files because of how ::Reporter works return $self->resolve_fid($file) if $file =~ s/\.pmc$/.pm/; # unfound absolute path, so we're sure we won't find it return undef # XXX carp? if $file =~ m/^\//; # prepend '/' and grep for trailing matches - if just one then use that my $match = qr{/\Q$file\E$}; my @matches = grep {m/$match/} keys %$resolve_fid_cache; return $self->resolve_fid($matches[0]) if @matches == 1; carp "Can't resolve '$file' to a unique file id (matches @matches)" if @matches >= 2; return undef; } sub package_fids { my ($self, $package) = @_; my @fids; #warn "package_fids '$package'"; return @fids if wantarray; warn "Package 'package' has items defined in multiple fids: @fids\n" if @fids > 1; return $fids[0]; } sub _dumper { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 1; return Data::Dumper::Dumper(@_); } 1; __END__ =head1 PROFILE DATA STRUTURE XXX =head1 LIMITATION There's currently no way to merge profile data from multiple files. =head1 SEE ALSO L =head1 AUTHOR B, C<< >> B, L and L B, C<< >> =head1 COPYRIGHT AND LICENSE Copyright (C) 2008 by Adam Kaplan and The New York Times Company. Copyright (C) 2008,2009 by Tim Bunce, Ireland. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/lib/Devel/NYTProf/js/jit/000750 000766 000024 00000000000 13305245314 020564 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/lib/Devel/NYTProf/js/style-tablesorter.css000644 000766 000024 00000000524 12067023751 024205 0ustar00timbostaff000000 000000 /* tables */ table.tablesorter thead tr .header { /* background-image: url(bg.png); */ background-repeat: no-repeat; background-position: 0% 80%; cursor: pointer; } table.tablesorter thead tr .headerSortUp { background-image: url(asc.png); } table.tablesorter thead tr .headerSortDown { background-image: url(desc.png); } Devel-NYTProf-6.06/lib/Devel/NYTProf/js/desc.png000644 000766 000024 00000006046 12067023751 021440 0ustar00timbostaff000000 000000 PNG  IHDR \ iCCPICC ProfilexToBлT"JB X)*TAiʂ  ż eoyo9;'}\h? % :Y={MhjkӺJyMĿ֍BupdCz_E gB4'lN&P.2&p%ҳJ~D1@ؗ0‰0}F")_H$Aׅ1w,KP(K t/4yz~E!x>nGߴE-OCѦ9XʥNhKg@p7MY>!o^@ Y$„dfE12Y1lX,;Ήqs   E%$$$edd)++khh۠QjfggW777wwOO//oo__߭[ D"D  ޶-4 BP"Tj$5**:*&&..>n;vLLLJJNNIٕ;mϞ􌌽{ڿ?;;'ܼ:|8?ȑG +,<~ĉ'N*.>}̙gϝ;/u %%ee/^trEŕ+UUWVW_Ӹvں7nެu;wܽ{^CMM<|QesO<}j]]./^|kׯ{zz{}m``p͛!o߽{~xx$pdÇѱ'&&&'?}y:==3ׯss߾/,,..-}NKV#( H# 3 ĊBc ˁqprpqr@pC x11Hq))iY9YyyH%eeU555u5ȁZ::z L,--7YCp$pq$pw$زI@"@'rD5"2rł_,H޵+55-mۃ+h-0[`ȃ5 ;V-t:f@LLnU~'! 72y3P],ŬT6ݑCcWǙ-=s7ϑ_@L0Z@)X$G/+'KHJIm ]lihY`Zw~KIv6N7;WĻ=w?SWw_oӖ~~["T?(38!$z[h(%lkٌHBFEtǝ?=5nVd:i23~WQjbZn={ggy^=p;8/ a|\ܑ NK. x^^>w2EbK)BVBs%"^X&N1-W$dIi҉22첽r ֊BSJJםRWqQUWéMwiXhԭ?c'A@1iѨɈS4k&.1[;C{'M.4wO?> [@!2aq*)4j2F3y;waGU""%4VѰO,3%k("b../ IE!O{:VbWZxٳb2s :7n މih0Sf/^+o ,}Мb<Ad!22#dd &mk̚u(Cc Brs_9  /<-gQ$t$Yd&dP8(TDU5C4rWijsRJ6mT27iD3q2j4o+daϩds {G眷O?s8I/`OPiH6ZضP8+z.6{MhjkӺJyMĿ֍BupdCz_E gB4'lN&P.2&p%ҳJ~D1@ؗ0‰0}F")_H$Aׅ1w,KP(K t/4yz~E!x>nGߴE-OCѦ9XʥNhKg@p7MY>!o^@ Y$„dfE12Y1lX,;Ήqs   E%$$$edd)++khh۠QjfggW777wwOO//oo__߭[ D"D  ޶-4 BP"Tj$5**:*&&..>n;vLLLJJNNIٕ;mϞ􌌽{ڿ?;;'ܼ:|8?ȑG +,<~ĉ'N*.>}̙gϝ;/u %%ee/^trEŕ+UUWVW_Ӹvں7nެu;wܽ{^CMM<|QesO<}j]]./^|kׯ{zz{}m``p͛!o߽{~xx$pdÇѱ'&&&'?}y:==3ׯss߾/,,..-}NKV#( H# 3 ĊBc ˁqprpqr@pC x11Hq))iY9YyyH%eeU555u5ȁZ::z L,--7YCp$pq$pw$زI@"@'rD5"2rł_,H޵+55-mۃ+h-0[`ȃ5 ;V-t:f@LLnU~'! 72y3P],ŬT6ݑCcWǙ-=s7ϑ_@L0Z@)X$G/+'KHJIm ]lihY`Zw~KIv6N7;WĻ=w?SWw_oӖ~~["T?(38!$z[h(%lkٌHBFEtǝ?=5nVd:i23~WQjbZn={ggy^=p;8/ a|\ܑ NK. x^^>w2EbK)BVBs%"^X&N1-W$dIi҉22첽r ֊BSJJםRWqQUWéMwiXhԭ?c'A@1iѨɈS4k&.1[;C{'M.4wO?> [@!2aq*)4j2F3y;waGU""%4VѰO,3%k("b../ IE!O{:VbWZxٳb2s :7n މih0Sf/^+o ,}Мb<Ad!22#dd &mk̚u(Cc Brs_9  /<-gQ$t$Yd&dP8(TDU5C4rWijsRJ6mT27iD3q2j4o+daϩds {G眷O?s8I/`OPiH6ZضP8+z.6{MhjkӺJyMĿ֍BupdCz_E gB4'lN&P.2&p%ҳJ~D1@ؗ0‰0}F")_H$Aׅ1w,KP(K t/4yz~E!x>nGߴE-OCѦ9XʥNhKg@p7MY>!o^@ Y$„dfE12Y1lX,;Ήqs   E%$$$edd)++khh۠QjfggW777wwOO//oo__߭[ D"D  ޶-4 BP"Tj$5**:*&&..>n;vLLLJJNNIٕ;mϞ􌌽{ڿ?;;'ܼ:|8?ȑG +,<~ĉ'N*.>}̙gϝ;/u %%ee/^trEŕ+UUWVW_Ӹvں7nެu;wܽ{^CMM<|QesO<}j]]./^|kׯ{zz{}m``p͛!o߽{~xx$pdÇѱ'&&&'?}y:==3ׯss߾/,,..-}NKV#( H# 3 ĊBc ˁqprpqr@pC x11Hq))iY9YyyH%eeU555u5ȁZ::z L,--7YCp$pq$pw$زI@"@'rD5"2rł_,H޵+55-mۃ+h-0[`ȃ5 ;V-t:f@LLnU~'! 72y3P],ŬT6ݑCcWǙ-=s7ϑ_@L0Z@)X$G/+'KHJIm ]lihY`Zw~KIv6N7;WĻ=w?SWw_oӖ~~["T?(38!$z[h(%lkٌHBFEtǝ?=5nVd:i23~WQjbZn={ggy^=p;8/ a|\ܑ NK. x^^>w2EbK)BVBs%"^X&N1-W$dIi҉22첽r ֊BSJJםRWqQUWéMwiXhԭ?c'A@1iѨɈS4k&.1[;C{'M.4wO?> [@!2aq*)4j2F3y;waGU""%4VѰO,3%k("b../ IE!O{:VbWZxٳb2s :7n މih0Sf/^+o ,}Мb<Ad!22#dd &mk̚u(Cc Brs_9  /<-gQ$t$Yd&dP8(TDU5C4rWijsRJ6mT27iD3q2j4o+daϩds {G眷O?s8I/`OPiH6ZضP8+z.6:Ed.uxB-RiWqoptL<DAcr8CYgtt"pӈx"gӏLzF!ƅ\6`we&DK8QЫi50pLʋ{K HE0}Aྫྷ %͉"h9jũOҹx4^꓁D*OA tPPsrI\Ȭw%Qy#GDϗQyhF(.(D;_54-p9h %@r]b}"ie\JzQ#sŃBG٫Wn!ml;tYl!٣0p>(Tn /y/Dn\SOy5RDB]4\"g8qUv.%Ѕ*YC}=Bjva%;2!NWՆ9ȴ_xCr%ȏ SZUR!uPٸuK}bo@K=ɥ pݮo$aR-Y\j0HAU'wLʓ$zQ 9!$Z [POM Q]hdn&@Rsό\}Ϋ(8Qӄ0.NU 7kWUTD^'Ȑ~3D0 ھ8"0|Ǒ <]gB323"%m뱜j`TVo )7Y&ސpNr $s-յQN12rIFe/C! A_ /mq kTKr%KTd<hׯ9To|L0!#&.zl-4Q`*kVB1 H6;0:Wt)] Gr)|&D9ͧSd൫뮙J|c@Djuuu^٩q4C>u [5 ?I'&VmUy<:1z xL+Ф@ T' Huh:]S%VA4TtUOD.IR('T'xRl 'QD.:u*)ҸĉL]捑_ŊnQ&r.%oz]GAOjPz+O[2DuYZ:89N~*>=߾vREr:Ѻ s3kl PsuXdETx67XWꦐ+oA(4PAv3kIRj8 #lwd"Vbp'/u :>2)I#4&J5GuIK:M&4"eH7 5(-xLGB!6K떐LM!&KO u(W}S~r)FIFJzP]2r;K*PM?aw(e-? 2dɌĐB: %OQ\Y0)ZIā!ڧRWXx7GKX #Crbk9^/ ~PɸJ^7  W{BNzU @/7/} t,XMWɪZ񤋑z#D KKOXy.[2ݕz-0.(?%ydlG}z{ x,,<;`2UȾ+8O՝tu5G|Z%Rp*YQpMr>=ty4C7*k}MA5]_ Ndcd{ϥ%dt "E9nG(l)%%t;xɴҿneGy75fUV\slQ)*>?E0}Ÿ*9]G}=(|'cY #zxKRig]4:qİui*{$+n~\s$$NM#L7Y|G)Rq0Q(C!"lxu'S۩\E/ %2FQΒߙvk <$],h| ?5+WI (T&[R "thIRCJ55d &!u'aW0;9!;hRp2MGz2s(/`-/QUxW2[F1i?(ۏט O 'xdgg 8Hd|>ksSN9tIO"M5=>q\`7&n!&q=A>!]$]}U';$x4&Ӓa76ktdJ%ڜ"r{;ԎW!|R}.& AgϑZom|@iTr*х8Y&*%;wtuNE@;<3\U4$`W+G$8]DY18G>\Z>5R2B,jn#)qYW کtٍ#J궈|MA>d2_r؝&" C,aF=$70]dz?h5'ᇘ0Hz[ӎ!γNh(r80\hCDZ$Z{(wpa/ݪr'")Fctw> cC#C-RpjM8h|q ㌇& 6GuSSЭ pDZU,׵TcyϞ@aTA38Vhǿg8xtSI|2܅^w$z #πJD"($rUw9r)_Hx]Cs;qwi(^شΫC.=3pDq\z6 att1u{G9@D^~"0bjcB?hht \tPNJ4pA LH.:D!8 l|9o1r7|Nu>nzMx wPU#|ۺcH8etJVo`DM!'Q%:>%ޞsB7FHBcqiޤ{C$|)ǻ˷."(c$j NQzvU gsiwSxfҔKuyPn׀ʭD~6w7ÈBwwܨKe@d8R<b%V~|%kVAɂd;0>PC< 1Vj<*L;O頏j?#؜$$'<$ʤ @y>sr2`@ \ADLʢ)xH(6h~8ÐJnnۿ=JՍ]bF$v2SH~޿hi35Z*(t =5qTmrFHk(`xS#q`]WI /8G@ G$FB}MQə\GCH .m_iQO'iDXH>-cdcneR!5'C29ykGwp@iIb$9BQ8wM> {D$bl XNwS}]Ұz|kLțvZu8%: `dSCEf]%>CxI%UJZ/z?f,j-_ܡQVԩG[M;qI 3ƄkFtjUKO$�al>1Hjx﯒{{ HL2}#U!t7A#i.CEP*{C%j'7>#tde~B)gp( Far{Lp&sS8Z)fVU#̂JU2Q&1 l2a)Wk4A8CrA6w@6?QcrXg :#L v(.$FC>sw$aV:>ANCF:ޜ$N%$bSbP2> #PlWJNȁM(r3e8y"X~J vjJ݌b2΋'4NhY,RIEte̴ {O>"?@WaU΅^d#QBh;{Tvy3vG+2?NeTp<$2lU. D%*gˉ'u)8ӱ;.ڤ^TxJU-gɗߓ ꜌*]IDAT8|遥NPS]#t}`Dzu Qgk CO*ǝm#~%;Od\b{GY࢈SnSψmj}f)l&é\2Dv`JItȐp v]}lc@2/ TE/ATpC @=~}~'܀KWqhT椢UH<%"̧X4.I2)[uCL$tW`SI{ ҲSNIn'HSJ]rSB$]JѨ [)U c*kR8fy3IzIR.}D\{ʸI΂yRû &L,Umz4J z9MKICTa{_I2LFIM%ߍv]4IuO3g%Uhd"ˮ+NwL*sne"H*0I w&x\GƷ\ٿ#jt,HG<9 T5N%[(I ?Fr%ccI{mCNdmȘ=I,yN*T3p.LnG=@"}gŁwJQr~`X5L973H-%IKb Z5쒞R>[Zo$.qVR܁X9k+WatتtGyD$L[}EiEiWoW!9i_Zp2nr*Q;x}tHRq*˞>tÍސyEZVBsjvHa:wIRݩxUrq'Sy tKIeK$BzT=Ζ?&@D#\R?UkúET+'Vs vhN[7]^&"86O 5!8$אۮ2ݛZ[t@"2N{cIZ(8/ uSp2t_Gy/m:I Lu0wody$ FV&ddU*|yiO8 S*8"(3O7gA%<. ڹO2U*tD#t(T`nT9\[^1޷\-M^&W1Hȧ{aHQL,5USnELq -i'ӵ&$dc ]@oȦXAeA1!L|vkUӖnvs}r%v.x+!YxLn#Y@dM0}vxpXGy)$m'Kyb/o8~=AGap;9 P8ͺoOg$T{Sv-ȥA=0 ; K{0:=҉#[%'R͵78@M!г>Qt}2"7ԈC"%!ҵn6+y uD& O:vkYSd}zM`dnf"V_^'J޿Tsx e$?SՒDtRyГ72&T$27zHOmU R쒨ӡT"«7ԙGW%Qf;ӐInTQtlJ} a8߃D㙀P'X?i՗)qHiCA *"!20d[Pv"I}`JEvSI31T iuu5T8~5ĪxOnېel"M2D`McUuM=WV:eO%預 =$}<%nR:;-?A6 *G dotư&2;9c7Se !}j8щ8`nq; N ( hŽv|e##MNoIn$hu:0)b:?!l/YM۫R!6NU) Yg!d<켨L,Tɕ4 8cP]|1i`U V$+ЈD;O0:i80u'1`wN?%*TɼN%mtnSV/WEHv#W݈#Q]Lroh#d+ݕrw;z[2p9F"QOjJ(3 $4*U>&yӦ4' 8(N.;pɱ(`nTfoH:wfé0.Y& ?Mg(I 2,wp]SWYW n~FIM(Sy/y $E78(QaDtw/s$zrDܨj!f9t( %K= <(4"a{Jd25 y&r}2PzHuK(d[1*COJ;AuI*z$q7dBdb#QvGғe8{K̩KlxpCoVу(K"##AE4 ALrsnH,ay! p T9zars-UN֦%!' 0ܰ[cHIo%L`ټtj⼺y],y|N*p!vKT2I|R[Y =7kS?0 f4/XlMhxF᯸IbC@Sxi:D&!"R@В&Lq3`6 ='n̎KOymTrs2% 'ii=!ӷ5J]vTu3Õ7!V^*^M9!`X9gl68bNћJZ :j*9Y>yS^`7_hײJ&8S$5TyUo&HyV8ӛ֘K`!-ī ZzyӽA> "S~<\Vڬ??+-u,:xdW:Vgٙf%G>|\SUu Tnn98ρfmsYiy8֋וW7Nk\{0db9|Ró[{lFY ~x 6chxvj8g85ZGWz/;Jެwo#=#6q;<󨞁JSK7)ArƌCU?|@4<fn~5{},\❾yig_`7wvk>8o?+W:hxfuWs.Nz-_gڻs`/1vni9C,Uc}5AT?MU?{x<7é\~w~gYJ&+zs`jfztţm)Nm纰Js'OxlgdM;ZV,/@?یFZm٦9ӧ^ו=oOF'4<^3X7OqyT|8}qY\n2MO.6Ȍ{āq_N'͛q;V]s[?=\koZp;f8*i%O<UcýCoT3}3NeoW{kraqMygFF>b̛ T&ܴQ&6chxfi+ua-~̓7kJo^jo{79CpTi:=eyj|bjû̯rMU?{xܿb]sqzu4q&_{?1>jYѽqTvL7Cx6wj87é~ĉY;?;~dd9wy{y{A`gZ7g4.k˥G4焵'n8-\w_N4t?rTϯ8t;x=yZ2p|WmnaOLsR׹N8}5o(k4.5/uS=s+JxgxĶY~ߓWJ^5Msc΁UyON|{ T!'?y2qh;uqmSSyJƵlRksਚҵ>:7Jw_zA2dԋ)3#549a-Wo+}'8oe<3g<#OfprVj?zAy]93S[ƹwze|qͰؙ->5h\Ɠqʢ>Ԇ7ؘ5.rpT?ܬ6m9#N<ҏY߸zrT8?3xߥiMo<)ν3zvWZZ&oȳg3fŷ[gYi9ǹo`^Zރ7oBȨ=XU{>Ź￣y_ӗ7^<|΁][aTrTϬ8`{y kv_5N׵OqS>- ^]ݙ\pM&sb=YOOAd^Qֵ;8>9 Nm']gj8Ϝb?XkZqudz˚`x1ƭ2;Y6cơĭk4\~Df-@` k2ϼ_ԖqNX}gW &{3ڪfţ.V73jϿbdȷzrmLES[ƹNM=˯O| eS5Y3'~n Bȃ­C^7oyLpޑO9^QG${GK_UMnq ϥ>rl4M_GM 9Zf9OοADtsey]aUVԖqNXg߼9w3ڨfX:]Rӷ {gj].s'}'nCզ9'޵o`Ff>i3NY>IN2'\Cƅ\싧y[,={'y~8:7ҴH3ɍjW\t?W^ ~I_yo:6Yk_y.=\KꊓŹzm+ʏi|ׅnƧc46s#o oxg}#OfԻLc/'&zfiq+&;f'J.e^;yO9f;'!7(Ȃc.O3.=Ky}▝qh8Z~ڬ&Ofԓ:ԥqΑ䲺ipUx%N} ywFO <>U85g85s޽Χߵ<5Kds^MbI/\+Nf55ψ'i~ə=/^h\zG3eZ~^&_# ャ'G.1zܷ'ս3,gvN88uQůnq~O9aϩggFjK'C!T3^u\r#<{*9?85盦~iIUVs+5ꥹ2rs>+ ژ5ZwYNzb*sZ]ۦA@ v짌֪?ž_i?s|@$ji8?"^hdT}8<#wһw5;uYu-qŝ,8ѨpTVX:Q^kwisV{&'yf~ ehM|SgEWΫc㜰kWgӛϹ\}[~Z>b9 k__8=u "3Vgd>]s`U-w68-pu{͇RFwn8OXw9rԣ%7>l.S+8qd޵V6uVKzq;K7T`eSRreF8'Y8r h͜4-frٯBhwtRqzfsT߮U}a隭%֪o焙soPل}zXTy }so΂_yGC[O{2 \b̛iIz-fk 9iQFu5s}N3ix'ʏʫxwƣyXynxxĽ x5t~ಢYhQ6˥6|F+_,#fUeʻ[yU}y?3v͠*3.8,4<'>kwi}@+HnUw2;f4\h' ktc556ν3Zow|ݹ[H 7;wTGk鍇c/#N!~^81_0܌5]πuǻ3} H#Ϯlkx8a4ʹp>trxUFt ͻ?=d9}@]w2'O˻DIʊc9˚2<ٓф# Cī̩}v=7VX;\'|hOG9`ׅ]㥗/tϸ3=wΣ={ ܮ(s;]򡷳3=ΑWՍOuNXy3af80駾fΉUދ9@0dhW^v>N4T}K>d?pxT}{u_==V\5_"M܉7;ȿ7{Uf9OYernd4$ws ;xQv2̋麜t_ >OKNv>T;2Y7Bp=V3v;s-#t2GLw_~9͎> ~T<ɡVNi~o ǣ῝kgp7Er=~Mr;uޙw'N'doi}@r?_^?:'4ߊOouOw{ ~Ot?}@>[o=;̮μ;pz>'{xLi[93kg3㞆v?> w]Ioi\'ݵ̑7WguosN'l^x ݃oI$3,g̊*]޴fsK'rwIĻ} rw܉/N4#NȋW3<9fs˹̓܉;7Unq'w|hzŁ=:+z~δ;>2sɜǝUstnn{ssdj+πc64x8y0*Xsw}Y-uק̉=FC9{;> "2;p3wxtvԒa-ӫy/N+}{\97ɟ3W3 Lc|8n7;Wٹgi1Ҥk;Sm]DxF3<׹|;)6dNFxwxgsCXUW?=syh<2's3<|04v2;Fz)7:3^'BV6x4ҴK^wyxϰeP8IDAT<Ӱ8^7y};> ̢zv|38 `n4'ygwgf4]Vy8ɷʱF~V/ ܪs .NqΧ}s 9#3k+CayW3sAslx7,sl{a4fy\ 璟lA?[ 0fϼ3Lc?@#ɝj8皮c:Su[FVξuG㬞lgGy<(졙w7ۏ|MI}5~1Ot-y{_\wģy΃gipSxo|V+uL|kl9bRekw|#}O\aVK/ZQȻxϲ;>Fu/+r@ݼ#}yZi+}N{x-ԋ}~7 ձ櫇~ksߌ_i uꑟY}3nh&|ь͆י2k0=>u㼰6kOm;,i *=6/涵+fY>νpЧ޵Įkj߱rٯfs֣ݩiXO>u0;^e9o3$M:Y8ŗfk s-}Ur6z0\+u>[90+L>g|Kלx،:Js?l|#Ͱde6Y9۩Ya7ǹS? l|YA|(gL8<5i6};T8-ٙ=*zQ~Z>b9ϳ/3Vq8[~@|# ?F3}Vr'޽3[ zﯮ9{syΪ]s<0Y~isx-qjnj.4hf;ݻKKg*<յS8sԼonV lO=>eiq4ׅ?n74;弼tvzbjȏy0Iu Y'3#/+gx>/5A|nZ.6I ^|'GONV^ ^]o3M:RK{0UY6͹]|As{}1?<7i#^s\c'3̦o~vyF|9:+~R{u~3C:*;Ϟ1{yj Åu}=ȑ^{98Q,eOi[}`!g$=,xV fO2^|<ҋs5˃~Co mZùnM}ֻvNܬ}i+9۩ uO&Rg8/b^zX2#yײȠ5\2'vݯW>4*nmunX{x?œ%L4dF܈g|Qxqn/5)q+ӻsШMV:b69?ӟ1yfMK{0pڴ|$^~-q29/y>x> n2.f8CsS<UrrL;i ,nT8f_ŧfYx8w+n/xw?<z:<kVrʰw+9U2MuSYqEpf=q} 3Uo>T7W^x35|\Cӝ÷Sv.ϔ6]R=XgTi<<_97QX7fkkY8rރK' 3sz|wtѳέp:^;Fsa|Tyf>wN3yҚ Z,7Nx|y2C~Π幋yqMs9JǷ[v 6saΒڨOdF,S}p|@w̝]+ė+x2s~xιFjث49ǜS`fҷ'\+n* 8g'3,Xʫ0䚆GOufi_z۩s¹ae|N9RdwqIps>3_sSW~٥zq r:2G98Л~#M|y+\SW:׌?kޯpfiYŻid+E`YqDA8-?5SsS?|0Yr9ޝo7uڬGj:˺0g8fvַ̊{ jtXO̝3k snCUfx\2\3yj[atqzw5E NN2[P dqP8zײ5NW0>jp_ӗ'Iy\ú6;Zzg=g7yZ>0O9~M|Шz;s93YF,pRMsn;}˧%I"4ާ5~+ռpz%_{)wL.^7yWpwgꝛᦍf>r&;=мͰ?}pu5黳?'YFyl˭8nIf>7z(k+|=^UeW2%NOGMs.u+K>{4jA=c?DXy}Frޯp>-]VS;Quϼ׉ne*f?#Qm? 7b?ʶ|j;EhCc㦻kV\ 9ϜyơQ}9zs~?-\?\_fϏg}@7;Oqyqpܨ23;wyCkqhsWڃiZo0-UojyqM3-8+JϹ>>޽`φS[fŹ~ ׃Uu]}w?H`uWQ}w_^לs,Ϫ9 gy֣Q8L7_qŜS lPU bvrEEՙo1/=8Tь' S/Nm]̹[>= e콰Ԝ癙߳,]+sgݲ+ݽ 5M\ӝ}f6\;:Mȗ޷o8 rKꏃ~KixVg4L^rkkf%?]Su60qhz1;i|{0@>1g>iZ\LԖoά,ϐwv2YZgc!zx33-/50ڪJf5ojُ|ߪ9/y+=:uQu<4s\3߶D-Zl<# ɡQW?s]xL>OnֻCS[=ŨA ?w}z s8YeMxşdG{h|\Kܼ+7ΔƝx=5|77AHfWs\+Z֗HW?xqh^=9.|zT6m} ~s3@55fxez礶9;wwo^͓ܬwIe]sCs+y7naUy+I~?6=7*yds ~sv_~ ٩䩞q'xj&fk 8O,c;Co>o]ٷy}nrܧ7>Yfr1s.~o G9mN 03Uzggfq~lӒ7/Ugԙi+[.o'X .4<;<3+鞿\M6>9k`3:˺9w_pkQ/mUSYg3#707?g%һFչ:Ә<+c7O07gpdV?gZ;ܿyo6mD7.ngj誻gIپ?;N۴o]rq6qJwoQvg^Zܬ{FgHs:4na> zfM&&״朗Jf5]|]iW7~+JgΪrFp9;Yi+ngvkxqQ[Cm䚷q[M|'{'zύu<Ғ#gZV9ǩe?6͹fD$7\bZ2 +tyGJԽ_QuV'umڊw LGu<7V{+Ϳis&~%?];x~o٬9s:kr1IENDB`Devel-NYTProf-6.06/lib/Devel/NYTProf/js/jit/gradient40.png000644 000766 000024 00000032422 12067023751 023246 0ustar00timbostaff000000 000000 PNG  IHDRX pHYs   IDATx r#I{UGW`'GDRl8L&YGR^Ood2hq9^WҼ' .>onw6kɳfZ3z0hU}tu^>ϯXixV3?gps^Ev5cʸ眙M~z 2aVҴ:ޕw!~9cݨw{TJs?y+]+K=fzfzYȤ~x(s^w|S~x[ ̟B۫Vɳf_]mu{AVOjo[F*s2oʺ]KZ3|KauxȁeWԏ8yUVne~,][INFg2C]eWZռy2eV:~~zӪ9ГJ硠߳ΫY !Zߕe?A876Jk=UrvYi5Ӥk>zҫ7\J}>;>iS<șh۫ps+4;'8e+\Sŵ^Zi'gwLV7{j\Z2#<-Wqg֔K8ydw2dOq]yٳS+ŵ]U:аd灣?sU MyʥҦ<+fMo ZGd}ʺ*Z-Uf\I`gn;圃>]nܙe^?7ހD:w9 vy檺&]jYWYZSP:'PUZ[\m7J?s=|XML7jk)Ծ^'] 214VXiwQeVUwSkx~Ūy{}\DMW,+f0S5^וRiuWzM PV{Iqb! x#{y3s2ʺvGs]Zi''7Zwi hV9 ٟuM:7S*7L]OqmgiqZ hers*/U͵zwZh "A?Zl̩z}w2dsmg8]75gРO{+^h { VxeV#]P5G>7P |EcFVM=٣Z3]וҫ^|x)ydVU}uj9a7tyKCOz3C}i{Ι%Mk=‘Gzs᥮ŽԼvx{wRkoJ*svXB-Wϩfs5s+t9{J>Wa5|!:*C>QݭW8kSF>jPkjq(當,ZF;s"MkepAU5f }޺瞑>i'g|+ B-5畏V̫XkUkr`wU!O< ;Pw5s滶WBXoVwb5{Ts/8˅jDg~@́.W^j9 [`e{=]uˠ{ֹ'jiZ9Rם,_Ȫ,HI.37վuzsk1.A?Z)CmnC}o +ꭴsrҴv#l/5kЪshJZ>|Bt=US ]sIWMxWL4݌J<ϋkU˹^w]|2ZoVWyq^թOT^W+y]FP+5I[};.:}`j:'*eO^MT6U%G/O3pWռ]ٞ}+`S<-`j艙yլ&_k]eViϟ;5YP=pNPstMUOI|bsO]+MB-6q^i+_=UO#y^y+M纪J_`܏7r?& *+ Y']^K_9ל3ǵm~A \6^E+Nw9wC$o*WPtՌ[i|ij#ʿP7U=w>RUgYu1 ldVZ%z%74W3s@Wi+_=%VڹzR˺ʸ&E_>Z>k1+=铆> G:\9ל[iYNԧYU듮=ꪇ.DOj+oLWՙXx z|צT4W=UJ;=+\wx !mcq7g'ާZ5;Xe^Z|FreRJ=kBOh9{v8;Ye _9'z;k}.=%jiZ){kwk w-{NP3tM#})b'?/+^i꿫*MqGz\KN;E+5_>Ⓠw:ճN|p4e'+GPbUkPǀ;X,sM1uzȸ;Z{^bz~ua]wj4ꌙ9k;59GU˵gf@̓Os;8gl-wb/Chɿ#/tsVu5d|~SW&88kyr?}<?C+O)O ]\sY;=ATW: uN8XixB_eVjUk8X+rUx{~"2ujI :ZyrXx vV=xVft8_Og; t^a&\KN\Տ|Cu}w*Os:s?:3?uh䑩p3_5YU|&<ԧ3\Gݿ|q?ܟ=фu쓺ʺ&EfBe<3xmުߵvMuW}doo73$Se' oksM=>\E<5+wP/k$^;WS uy x~>;=ɫZy]q;X4w>ci_^;W맿%Ӎf<]2lǓw3wGKdFY+w^Ᾰ{Gt9Z=Au,8:5Y 땯E+5w-gpkv-y֯hy]njK7|LMnܜ^iBgLZ5sfwOE$ure: T蜌kΫOjZ]n=?{Ȁ{7H7󜙞uӼ||2˙]Mk8 |~9''g)=xkG]~<_yh+y93=*4zs9]<_d>94p3T7ȓbHvΧ<GA$foݏ2Z{]qrDsNεO^7k.OsY~.iO%FIO<:fzιz^qd@1ix\59P`I3O||rsL]ٗ3އ 9}k站u}9yzG=Z+\i/?t3oU+s0u&'<<<|7=pj 9 ;=9kڗu#Ktgkzwr:,yM2C]ԃf?z׵]~u}2'?ܜُH6d$sۧ;wtkΜ~OyΫٓAO>y_͛f,pcˌ*47TܛWTh'ejOs}xOUBĩp|2]W|gvL/k&l֙߭sNYd^o/t՛HkyⓆ\ټ•i/mUpջO> 9)"dgB]:|>[Y-?=&?7esnٛuUS}|wڹ_9`Z^S;d\2s#xO=_޻Y+5dk!Q_v=UЅӏ΄jKONdczY{vųwU'ﾈYҟΓYk+.crr xЅZ$s驞֪7iֻ;k/7ʟ65xY=*&L^is~rjށNw1;> o;A7''gy\{xBu|pw)}٪+Ξ?wz#Voʟzݫ8Ѿh'j+Uʯf# WߨÑ^]>q<е}yUr~@fN{λ=qWq7k派qlK޻ ӳ3{sR/Λ ?s:n5'~{k:i7nwzv2yoNe? W馻;g:^Y7MˇoUDV5]KڗH_/;z8Vݮ/tuhGyO^W3ޕ_GhYQ]spGSzrh?}ey4~eoYyV{{z80y Lh'' zުǙ3d;,OgȬ5O199}WU{f-LOֆCh5;aC:Mxp6ϡM.r'ZȬjrwp=yO{'듭7kgT\z ule&ڋ'ޔ͹Ygo֙WO m;pZws2k}3*>ixUO?Cp?wy@[*\j擖>M,^{қ<3 h&N㓡ZU4'8czY{6yfns:? o +bx0<\;UBSuȓosm+狳Hs۩O޻AY/d_Ӝz\3v~v}fv3=P ?ii9zu/Owқ:/gx}«=U?s]iO|gh7efk; ٔu; y\=^;;99}9\}d`kiFz}q h\$=Sz\Y]N{B%5Փ>Zf+zG05˯Wdgb[yucs2Q?A2O<:<;+០gūB~9sm#3T.^֙G ά9/ksn{ϐ~|ջ?"_q]<`.GN3|{<=|/? >d7y>ǹB2Sծ%Wشy!*6q2qFORΗ{Εɺs=rF ΜO9^]й'ݽR(G*<y>K9_9Wku sA>yny49׃3&C9]'uy":2*wtN5^'z5_y.џ=d i^-S:];1jѺ^Z;R_s[qr{ WιfגgjڝHorGrIgI~Bhy늣%2#[i;p_\=v^g-e(wgc ?Zwʟ4l?~-;м8zVλzz䱴/+]lPtUߤ2pWyZÅZS;* ~g>qӹ^;4~{Wф;zqMً̄jyf@?.vUk?͵/횸[_rP;p~ =kA'L+ XrⓆ7ק>-澟}=⃜{xgjOiV_c4ũ(_+us{*>ixj]ʹ\jG+w7?B6ͽ2i;=AGz#ON DwJ ]+L_/jjܟ'~I:~U>kV晊U/ -gx_9҅Peޭ t e/kΕjK}wv% >zv <е> ݩwjr:kTずv3r*wpΠZ^G݆N_ݵwp`FV=9j4r\GwL2AejƎW㪞_wo܃;ٝj^ ~wǵ쫚iZ+_s+>ixW=+LSv> {sh^Ox`u0~a/L^hBCΪSh?ŮZ-=Wb-(kqе>zA;ժy*Lw53+zW9}^;g(~]o5gGy޳*ҙc+W栃yhWW£6x`uVډYqRۜpPWMI*[hB-~p7V̫]˾S`ՓT8yf+Mss99:~}=fDy'&U}A31B式sHJ\ʼ4Ckrﵚt-13wuy\9WկG? 7U^ͫ4.,ݯM|U3_̸OU]>\9-f]UZRⓆ*5,\UsVw;:WS͌w`8?~UYyv<2BVj]{@7>>9>}{ Sls8O3UTxwq/\J8G]/u8Xix8ͪ8<}KD C̠̬*u3VNkwU_k2BM.VsRj<6ix'8e;/ϓN|~hd<kj~5u:9LrJ˹'5YP`4rv".O sh͠\͜rxBɧʬ4zٓhdE&uxK $+D;Uo5oWcwv+CSx'-{&mAnƱ壑48'+|,e*rש/=W-Օ]&s|jz}+ap3wfTYR PϜޕ3i=^G .SkUw\Y7͝FGI\q_j8&ԾZU5niNJj<4wafOӫfv-'zvVwb5{Ts/8˅jDg~@́.W^j9AbƧ>=NWPu~8\U=|4!Yq{wusM ޅ~><：~7pKT&Wkd,h]s=j̣ u޹y+-}jP89WpQY\s^_1&;g(o^ͥ? hwqss5~W zNpy̝K:I<yVIy2wTv\5~ΫӤ4#ޭSO]N{Ɍ.{V9ל~R#odߡ1B^t!=B]O.Ū|NM{+^h ?,&{Wږb) ot4 W~U}t=s/{eG-3WҴ^>x%W{r?}̃otrmi; uEY_e줹}JgIܥԯyTW'ʢusSҴ4[뿪4Ϥn~SފWYx" J0+Vg[iO>C~z٣Z}U[y}W}h֫YܪoQ7T4)O6k.jkգ\f\óG\*M{vU&Vh˫>uWn~ח\ xG4mpɞ=#{+vgZϥ<ʯV]?ڽNቓٮޙQe*M{>9> h ͬft"YV}ʳфGUW>]fT^jSފWFw]2ƯX<4j\idy _iVynn4W\_٫j{U&vTzj^Uߤၺ3lDa@4FqT~gU{Z>Q>Wu\wN5q]ǴVz̎晻|ՇS#}od5"q2Z{vgiY:Nq5SjNx4if}x <\w=msQ,L(dS}ʳ; ]Mv+=voE'̻pk&"Ghh>t_j?bF'}~q{ϯdϳ5gN.+Ah:\eIȿS]W|v<2߁'Uv*5p-yޓ^UO< \ڋ5ά*ek:4|Ī/3{<0ߍڴC+3ќWZ].΍*}iKA]s@ϡGD5͖=%'CoҵaKkqϫʙzNӇywq꫼3u&+^iWV^^K@ZR.3+WV=WFVȍPU=3u.+^iWXNzxvQdz 3N|e#yWKFImii__>|5+=ȁΊOڎG}vKƿA! C된ˤ>e+5u-yޓ^UOeky.[hp3|i(IENDB`Devel-NYTProf-6.06/lib/Devel/NYTProf/js/jit/gradient30.png000644 000766 000024 00000031044 12067023751 023244 0ustar00timbostaff000000 000000 PNG  IHDRX pHYs   IDATx v#IvǙ@GAEPʬh02Rug9£-+}/MÓY{={-k6¥gyW5_bE\Ɍ{2# ׊n]~asqݵq9Y䥿2*QSwT8髙Ҵ|OwI|(*#qݵq9}ֱU(ӵĞ5š3 0GVUO˺ə~og?=Vp.=+}5[͹kžUq!XU<Ͻk+8|&t܈isS0\i#k33|x\˯A2լ/8]`vyfsŇJ{\x+\z~uͱG9gFx.wGKz-~25yg3^=]?ż9_^6V>xX1Z龫XJ/W,.@]8s}RS|bﬣ=y?6V>i:ٜg`|/ ڔ 8\1Xfܳ˹՞73ysݵ_+<݁9,_7%Τ勞f:nK~2Su*~1ԫ޽uv>Qf<'y>zUǿB鋞*.>q< bU俋eWdxN,'Lz\GrnWv=Gx5rѩ+Xڧ#i^dƯLOuz*m#_wwDo 7qŹxҫ^djnEZ^W.G&s;Y0>K&_'< jX` W\wis=unGZ헞7=U{S]L;w6a~79 40uoB*\qgV4䲯{7t܈+̇3zŏ8fs_b 뇧:+N3,t**ܧ.,0U|+#_j+}2#uNsGxFUGN|1Oa*;qWX~pw|{ǵqsW g{LG}_dfgxgF|V#Ny2#U lIYV#Y<5ǜ3FgGXp:_.rý~SŃuxeRq~WPx^κǵqJ|&fӵV }c{|_HHrCށV7g\~ԼH{\,l_žp#uIk``j=W,0Y`w3=̬L~],¹8Nuqc_kgrܓU/N+slϣ{2Sa>pUyu}|p8yw##g>ٯYxeТ:^f3/|2#uT%vZ'ӏw^SeSg܎3'}5# WU_5+7$u_9f=+s4W3{ G4cw98'>J|,rfHGNz4˺w+UGze>;Zzkq]'?Nh#.=Ȗ='2y. r|`X,0U< Sd93(tV_7ړUỸ܃\**{Y SŃ3nGw*RX~Ti{\qޱ*֙F>GpY+OǿACiss?1K#E4x'7+,g5ǪYhy>/ M8fU:o{VjUq#^+?Ss?c,G8ueSfk̨4|7\pT` 7q}s0ǹ&we5: U=VwqTtU)6ePiwpڞx4/MS3j]N's}QGZq'eqď3sxKmGd>^GڇGy>l$ߵ÷ҏ%l9j;pTf*k`溊h|J8|j}I_9ko>S;^O=O%@PP4|.;p O U_՜wkowUX`x0Fxh]_wDjAU\Wݬx-ϨX?ZrkoW%vk.«Q]eEjz~vü'7੮WxK#_܈GOWg8/UOسYq9;Uw4_Se0SͭYw}G3yOU^3Z̜gWrecS;wZ5ʿe2QGi9fR{?ШNuL<ίpqԓ7>XbdpTh]Wn7$he}諹Vs\^ьk:'̏t_^]?xUjr#jT|űW &] .S_ӛ}=e °/ejN`s;'#u#>JǷ[++ /8V꩹ogs\fhK7x˚ *uۊVUp_^G3 ʂ{s2'uU^*Y_ʌսpׅg-󻾋=9?kp+}O,U3zFEUp0ET'*{˽|[sS 5Q]Se?ȬśjW_ BT<򺁕y0uƹ3ԓ+kwx|'WһT偩11G*V3#nsx|pYGVeGv=> v?g9Yv.}25=0<H)CfWϡuJw/8}g'^Kc^_Ჺ'qzg}ο.JOȻp Nʓ,rdЫા'Y+:3Tρ w{/i]٬ˮfCʷ=99/GqQϚNY4*ZVQ͙h/iK< Yͺ==v9a8ϕCCʂg2f\mV}?gs1d2FJqwS>9ѽJr.|rb$ ΍hT沢Ԝٽ/2;9 7{IKyf<}^r|9ǞYa288*LV~y=;6᲎<*?|x]wNH{>9ճfҝ4**\WGbA _Iݞ>J8fpjU\'q/ؽɍzfғ .+3k_^H)\99JqWXѪ9^-ݗܨw-1⵨{WioV{s?;H/orwӺL ÄG;TWq;GJ yʀ-{dE&ߥXnMOs Gz~V+s]&9ԏT«euOtҿJ;f_ȓF`;ُfXM󀩚g%sO<_G'Y6\0Ҵ 6^2r}+ݹDTfO^lüvpQdθˣE4z@R~'svϚJWGX =OezШ|<Z9gW8#{ rIww3v{j&ܨgGYZ/FE_tu%.;ΐ_AnmyG^]s̹>}>Ί5=g+<*=Ns4G+EBDe$ϕoq W}%NEzTsu5?տ|}r5kGt3d]^3u0ԏ~_/<3]s+}w;22FHh~[dUsּx~<Ȓd33sޱWfdeTA'`[s`s`ל_B>烳2<'s~[6YIFΐ]5W{;Wa-|a3jY:ܿ) E6MF֥M?o\69$kzeo~*!zr1RO22OkY8ʫ|aϫp.5y;3]}@8ɆܙAVV:r;G-gg*sw4S\ryN'7Z%~ ;|9'{2KS_ٟ *YwUrUɬG~n~VrTSWߞd;wf\ɲɥV38qW%7IW?]dyJO֬WM/xYS#;gY(Nqe[ls^+вj*l]|< Scar?q_(.Y%FލgwQu^y@rAbk> ˃i3JVqy/\*~0*YO̸L> r;,ܑYd^䪒UaiݏZS]^2== \v Tf&-Cf˃o2rI}w yWa纜9dOfW2uvp+ ΓNke܎ǣG xi]=Ttcva6Tf;3/,y{_U>0GU8ӚyW !NOF֝;?g;a~N2ɭ}ڳ^ٛ(@=9 ԓ!j>v3#[;îg.wϳtF ˁEns `s`ל_B>烳2<'s~[FppARlQU+uqG|p&?Qut2$(c!r]ɼΔ{;\W~0zYqde\黳ݑyt㢺N|9\=_^j2_< 'a ˃#9{>iNE'gEYwzu9#!+w;3,gQUX\U5s Z{Vya4*Je+wyqr|@~վhTyT*>gxpUZbY`*W;pw8vz<ѹ5ڌCgn˳,-f]ݻg.+調}wl= m~m;7Q+M:.G9hTGNcww=6r;~_θˣE4 qn?nGڈsJRσxa$t2S=;{z kYv^yRqU?۩<zWk59fRr^Af߭nzwIOs Gz~V+s]&9ԏT«euOtҿwշHuuOɷB3,8Σj69w{9+ZV8uM|76_QYGڈs̢yԤw ?}U=~i ϸOEZ}x-q+? 4ܨw-Y`xpVfV=p濫}7zcYTڌsœꝓϫFk}^X: LWFU{-驴cVV~Һݛܨwm+=2;95 m;#-眛afGsGZؽѧ5Õ\QU?t7yR9f8ٻOZp3[9 jؖIDAT|vy^7Wyf^f2S5/ӭ;eVuO8ͺ^aR^k9xE`>a?{gtF~4*sYWj~ww|(tB`0̗ O}9/M]=*zU'831rTth3 ~\PQͦ=hNo{rs^ɏ2|1ң5Ý^'hT裚3W^Җy@fa+l*wGsc2S'*,4 g֊ syE{^K& ?pe&=Wi#NZxy/ҙwmW^8^.{w;\P#m&_;>I_]S}Uk8܌lTtBٷo.juA:t59;_3jq=v]N;{+\q~Ti`hYѽ}혿AfgvM/:&#y<̮9SgQY<ߨ49/̪ss wO.y@J9;H5͸7=3i*>]x2S< m2g+>WLɻ'qunj~0ZZAm'k53T.=a|`fV2Y8qE'G=kWU799@7K;8ϩ0{4t;4Y}5'+/q=\CE*e,?9ȓhgW<4v{|cu/QcGOu.z->5pVf_qkO+3?>jO~w3.hT4*|Ut7H1ouVgHLzqԤGM={|TTYp+}===2k}fųZsw fIMѻ\ΨLv?J߹wzjns?.+dW_}_&hTQ+㘡wJ ߱<p,޽'8'zrZ7_UeڄR{uozfZ,Wg,zU׽wgJ-{9xyZp'|pz79oO?\Vy\]iY~ ,pUS#+:fਕ5ZpYj)co^P>ڸ\gofTV`s^spWkY+{Uތ«Q]u_U /WQg>jNu &yM]y˳{W^88y|vj/OWqבGZέY\a85|Z>dv|wwmwt3T߹ο㩼R5ŒC0U8K]zhU׮s:]=ϰy;O'7W5|Ts+9pTfV=*/}W#N;Ź*,.gz/kqgwuiW3; Gu z8Uz)עhz3|j}sJwV|r;{Oq5wqRUᲺyofdf|fsv03;\kFN?6Õ^q~Щԑ< nֆ|9~{S\8>*yEA‡2?vi܃i'j5t˯y鮩O];hJ[X*}qoQh{< r'lLjWқ#ߕE4x'WgFX9 RUᲺկX ៖`8tf+,NkjfV3N:*Zy*B0'ٌ3,=LjqNXҒG^fDff _VtJOI:h/~F0;}5㜰7}~`GeW Qݸʻ 8*j˭AOU:)9cgOqNXgWʇVoP5;UZrWzw\+?V< ݇[|XTu<;9u ||\GV#k;x}GWvkF̼`*|8W|9woYsF}.O]oTq9{#}`\FJӹX7\0U`sݱx`fXzLCOz-WsxiZ>d>^==CN=uz߉;,>+zOK790UݍrԼ_yaZΩ{|GNFS\Ut40||׼ V8o`sѼgbYs^&z-}2S+\zw+q*ss L󏸇vǯXlȇFNxq̂G>z_y⵸g||]Nvz:V2*S>sïtK?%򆂩S밼ZxyGd[+s|j굸OϮ:{Gu_3]{'O.CuW,|ygi̟b͑&kfSS |v:ڳ*>~u*}gx_0W9Jm< MaoZ=k\2U QoOuW:Up֗6 > CQa6Y񒫊{ӓ3΍xiZ=_^ޅg{uz'wYǺW⺹+tj "T> pzEOz* 3vW3y}~*k'zV*t~oa>|@dN\q>V={}q.U8O7IuOW|ru>]2**9bD>8'Lu~Z9fZSWMk;xG挼vc{#}3|߳[,Lzeͯ0!+^rU|ͽdpj0&rN~Gzpq^kW|N{gp8ꃯ~"2 0)'gW-Ofj?ʮ2FJ;r{:;ٕwqW,.8 k.7Q/@ތUǫ{>؏=s-VU}xgns|h7SzWyy|j+}qҵgq?+k>|f*˹Qc}9#:&zU.(?};=>3kq x*j]y*mKNTZu/MsĭF|8Ab6x6+A#c<05=%|]+\zFw*{Du.7Jmϯ^ N}G|jY>WU߳g|{ͺv}N{0# U^s䀫Nj9aQy}pUg{wzůpX.=`,qA>P{vT,<{_e8yk^&g#_U|rk_{¾,ӕ^A!F(N==7NZx&Zbg}};}|y︺/߅}Y37l&^rT9k#oħs}yWu5vZůpޱ;,ҿp "7*MPuTsԪKoħ^3^ٯ/Q|fOjKo|0KF`b9YҽwڨgVQ+g̞wԑ*~KϨ_a]wU|yFF8l6e溙VG_4&&NpnigHny]p\˯_D ilB]^j;3S9Z>rmnG6wzůpX㑆zBFTIENDB`Devel-NYTProf-6.06/lib/Devel/NYTProf/js/jit/gradient-cushion1.png000644 000766 000024 00000003130 12067023751 024623 0ustar00timbostaff000000 000000 PNG  IHDRXsBIT|dIDATx^nGQ@ynR/*͉%۽Քߟ>A?o_c^'^%^O{׏?֋[޿.G_v>Ws>bO.q#@&w'rB˵ u9 rurnANh:nr7|B '\{\7>!@ZA  -^G MO䄖k#@&w'rB˵ u9 rurnANh:nr7|Be object for manipulating JSON tree structures Some of the Basic utility functions and the Class system are based in the MooTools Framework . Copyright (c) 2006-2009 Valerio Proietti, . MIT license . Author: Nicolas Garcia Belmonte Copyright: Copyright 2008-2009 by Nicolas Garcia Belmonte. Homepage: Version: 1.1.3 License: BSD License > Redistribution and use in source and binary forms, with or without > modification, are permitted provided that the following conditions are met: > * Redistributions of source code must retain the above copyright > notice, this list of conditions and the following disclaimer. > * Redistributions in binary form must reproduce the above copyright > notice, this list of conditions and the following disclaimer in the > documentation and/or other materials provided with the distribution. > * Neither the name of the organization nor the > names of its contributors may be used to endorse or promote products > derived from this software without specific prior written permission. > > THIS SOFTWARE IS PROVIDED BY Nicolas Garcia Belmonte ``AS IS'' AND ANY > EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED > WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE > DISCLAIMED. IN NO EVENT SHALL Nicolas Garcia Belmonte BE LIABLE FOR ANY > DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES > (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; > LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND > ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT > (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS > SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ function $empty() {}; function $extend(original, extended){ for (var key in (extended || {})) original[key] = extended[key]; return original; }; function $lambda(value){ return (typeof value == 'function') ? value : function(){ return value; }; }; var $time = Date.now || function(){ return +new Date; }; function $splat(obj){ var type = $type(obj); return (type) ? ((type != 'array') ? [obj] : obj) : []; }; var $type = function(elem) { return $type.s.call(elem).match(/^\[object\s(.*)\]$/)[1].toLowerCase(); }; $type.s = Object.prototype.toString; function $each(iterable, fn){ var type = $type(iterable); if(type == 'object') { for (var key in iterable) fn(iterable[key], key); } else { for(var i=0; i < iterable.length; i++) fn(iterable[i], i); } }; function $merge(){ var mix = {}; for (var i = 0, l = arguments.length; i < l; i++){ var object = arguments[i]; if ($type(object) != 'object') continue; for (var key in object){ var op = object[key], mp = mix[key]; mix[key] = (mp && $type(op) == 'object' && $type(mp) == 'object') ? $merge(mp, op) : $unlink(op); } } return mix; }; function $unlink(object){ var unlinked; switch ($type(object)){ case 'object': unlinked = {}; for (var p in object) unlinked[p] = $unlink(object[p]); break; case 'array': unlinked = []; for (var i = 0, l = object.length; i < l; i++) unlinked[i] = $unlink(object[i]); break; default: return object; } return unlinked; }; function $rgbToHex(srcArray, array){ if (srcArray.length < 3) return null; if (srcArray.length == 4 && srcArray[3] == 0 && !array) return 'transparent'; var hex = []; for (var i = 0; i < 3; i++){ var bit = (srcArray[i] - 0).toString(16); hex.push((bit.length == 1) ? '0' + bit : bit); } return (array) ? hex : '#' + hex.join(''); }; function $destroy(elem) { $clean(elem); if(elem.parentNode) elem.parentNode.removeChild(elem); if(elem.clearAttributes) elem.clearAttributes(); }; function $clean(elem) { for(var ch = elem.childNodes, i=0; i < ch.length; i++) { $destroy(ch[i]); } }; function $addEvent(obj, type, fn) { if (obj.addEventListener) obj.addEventListener(type, fn, false); else obj.attachEvent('on' + type, fn); }; function $hasClass(obj, klass) { return (' ' + obj.className + ' ').indexOf(' ' + klass + ' ') > -1; }; function $addClass(obj, klass) { if(!$hasClass(obj, klass)) obj.className = (obj.className + " " + klass); }; function $removeClass(obj, klass) { obj.className = obj.className.replace(new RegExp('(^|\\s)' + klass + '(?:\\s|$)'), '$1'); }; function $get(id) { return document.getElementById(id); }; var Class = function(properties){ properties = properties || {}; var klass = function(){ // not defining any attributes in Class properties. // for (var key in this){ // if (typeof this[key] != 'function') this[key] = $unlink(this[key]); // } this.constructor = klass; if (Class.prototyping) return this; var instance = (this.initialize) ? this.initialize.apply(this, arguments) : this; return instance; }; for (var mutator in Class.Mutators){ if (!properties[mutator]) continue; properties = Class.Mutators[mutator](properties, properties[mutator]); delete properties[mutator]; } $extend(klass, this); klass.constructor = Class; klass.prototype = properties; return klass; }; Class.Mutators = { Extends: function(self, klass){ Class.prototyping = klass.prototype; var subclass = new klass; delete subclass.parent; subclass = Class.inherit(subclass, self); delete Class.prototyping; return subclass; }, Implements: function(self, klasses){ $each($splat(klasses), function(klass){ Class.prototying = klass; $extend(self, ($type(klass) == 'function') ? new klass : klass); delete Class.prototyping; }); return self; } }; $extend(Class, { inherit: function(object, properties){ var caller = arguments.callee.caller; for (var key in properties){ var override = properties[key]; var previous = object[key]; var type = $type(override); if (previous && type == 'function'){ if (override != previous){ if (caller){ override.__parent = previous; object[key] = override; } else { Class.override(object, key, override); } } } else if(type == 'object'){ object[key] = $merge(previous, override); } else { object[key] = override; } } if (caller) object.parent = function(){ return arguments.callee.caller.__parent.apply(this, arguments); }; return object; }, override: function(object, name, method){ var parent = Class.prototyping; if (parent && object[name] != parent[name]) parent = null; var override = function(){ var previous = this.parent; this.parent = parent ? parent[name] : object[name]; var value = method.apply(this, arguments); this.parent = previous; return value; }; object[name] = override; } }); Class.prototype.implement = function(){ var proto = this.prototype; $each(Array.prototype.slice.call(arguments || []), function(properties){ Class.inherit(proto, properties); }); return this; }; /* Object: TreeUtil Some common JSON tree manipulation methods. */ this.TreeUtil = { /* Method: prune Clears all tree nodes having depth greater than maxLevel. Parameters: tree - A JSON tree object. For more information please see . maxLevel - An integer specifying the maximum level allowed for this tree. All nodes having depth greater than max level will be deleted. */ prune: function(tree, maxLevel) { this.each(tree, function(elem, i) { if(i == maxLevel && elem.children) { delete elem.children; elem.children = []; } }); }, /* Method: getParent Returns the parent node of the node having _id_ as id. Parameters: tree - A JSON tree object. See also . id - The _id_ of the child node whose parent will be returned. Returns: A tree JSON node if any, or false otherwise. */ getParent: function(tree, id) { if(tree.id == id) return false; var ch = tree.children; if(ch && ch.length > 0) { for(var i=0; i. id - A node *unique* identifier. Returns: A subtree having a root node matching the given id. Returns null if no subtree matching the id is found. */ getSubtree: function(tree, id) { if(tree.id == id) return tree; for(var i=0, ch=tree.children; i. maxLevel - _optional_ A subtree's max level. Returns: An array having objects with two properties. - The _node_ property contains the leaf node. - The _level_ property specifies the depth of the node. */ getLeaves: function (node, maxLevel) { var leaves = [], levelsToShow = maxLevel || Number.MAX_VALUE; this.each(node, function(elem, i) { if(i < levelsToShow && (!elem.children || elem.children.length == 0 )) { leaves.push({ 'node':elem, 'level':levelsToShow - i }); } }); return leaves; }, /* Method: eachLevel Iterates on tree nodes with relative depth less or equal than a specified level. Parameters: tree - A JSON tree or subtree. See also . initLevel - An integer specifying the initial relative level. Usually zero. toLevel - An integer specifying a top level. This method will iterate only through nodes with depth less than or equal this number. action - A function that receives a node and an integer specifying the actual level of the node. Example: (start code js) TreeUtil.eachLevel(tree, 0, 3, function(node, depth) { alert(node.name + ' ' + depth); }); (end code) */ eachLevel: function(tree, initLevel, toLevel, action) { if(initLevel <= toLevel) { action(tree, initLevel); for(var i=0, ch = tree.children; i. action - A function that receives a node. Example: (start code js) TreeUtil.each(tree, function(node) { alert(node.name); }); (end code) */ each: function(tree, action) { this.eachLevel(tree, 0, Number.MAX_VALUE, action); }, /* Method: loadSubtrees Appends subtrees to leaves by requesting new subtrees with the _request_ method. Parameters: tree - A JSON tree node. . controller - An object that implements a request method. Example: (start code js) TreeUtil.loadSubtrees(leafNode, { request: function(nodeId, level, onComplete) { //Pseudo-code to make an ajax request for a new subtree // that has as root id _nodeId_ and depth _level_ ... Ajax.request({ 'url': 'http://subtreerequesturl/', onSuccess: function(json) { onComplete.onComplete(nodeId, json); } }); } }); (end code) */ loadSubtrees: function(tree, controller) { var maxLevel = controller.request && controller.levelsToShow; var leaves = this.getLeaves(tree, maxLevel), len = leaves.length, selectedNode = {}; if(len == 0) controller.onComplete(); for(var i=0, counter=0; i, , */ /* Class: Canvas A multi-purpose Canvas Class. This Class can be used with the ExCanvas library to provide cross browser Canvas based visualizations. Parameters: id - The canvas id. This id will be used as prefix for the canvas widget DOM elements ids. options - An object containing multiple options such as - _injectInto_ This property is _required_ and it specifies the id of the DOM element to which the Canvas widget will be appended - _width_ The width of the Canvas widget. Default's to 200px - _height_ The height of the Canvas widget. Default's to 200px - _backgroundColor_ Used for compatibility with IE. The canvas' background color. Default's to '#333' - _styles_ A hash containing canvas specific style properties such as _fillStyle_ and _strokeStyle_ among others. Example: Suppose we have this HTML (start code xml)
(end code) Now we create a new Canvas instance (start code js) //Create a new canvas instance var canvas = new Canvas('mycanvas', { //Where to inject the canvas. Any div container will do. 'injectInto':'infovis', //width and height for canvas. Default's to 200. 'width': 900, 'height':500, //Canvas styles 'styles': { 'fillStyle': '#ccddee', 'strokeStyle': '#772277' } }); (end code) The generated HTML will look like this (start code xml)
(end code) As you can see, the generated HTML consists of a canvas DOM element of id _mycanvas-canvas_ and a div label container of id _mycanvas-label_, wrapped in a main div container of id _mycanvas_. You can also add a background canvas, for making background drawings. This is how the background concentric circles are drawn Example: (start code js) //Create a new canvas instance. var canvas = new Canvas('mycanvas', { //Where to inject the canvas. Any div container will do. 'injectInto':'infovis', //width and height for canvas. Default's to 200. 'width': 900, 'height':500, //Canvas styles 'styles': { 'fillStyle': '#ccddee', 'strokeStyle': '#772277' }, //Add a background canvas for plotting //concentric circles. 'backgroundCanvas': { //Add Canvas styles for the bck canvas. 'styles': { 'fillStyle': '#444', 'strokeStyle': '#444' }, //Add the initialization and plotting functions. 'impl': { 'init': function() {}, 'plot': function(canvas, ctx) { var times = 6, d = 100; var pi2 = Math.PI*2; for(var i=1; i<=times; i++) { ctx.beginPath(); ctx.arc(0, 0, i * d, 0, pi2, true); ctx.stroke(); ctx.closePath(); } } } } }); (end code) The _backgroundCanvas_ object contains a canvas _styles_ property and an _impl_ key to be used for implementing background canvas specific code. The _init_ method is only called once, at the instanciation of the background canvas. The _plot_ method is called for plotting a Canvas image. */ this.Canvas = (function(){ var config = { 'injectInto': 'id', 'width': 200, 'height': 200, //deprecated 'backgroundColor': '#333333', 'styles': { 'fillStyle': '#000000', 'strokeStyle': '#000000' }, 'backgroundCanvas': false }; function hasCanvas(){ hasCanvas.t = hasCanvas.t || typeof(HTMLCanvasElement); return "function" == hasCanvas.t || "object" == hasCanvas.t; }; function create(tag, prop, styles){ var elem = document.createElement(tag); (function(obj, prop){ if (prop) { for (var p in prop) { obj[p] = prop[p]; } } return arguments.callee; })(elem, prop)(elem.style, styles); //feature check if (tag == "canvas" && !hasCanvas() && G_vmlCanvasManager) { elem = G_vmlCanvasManager.initElement(document.body.appendChild(elem)); } return elem; }; function get(id){ return document.getElementById(id); }; function translateToCenter(canvas, ctx, w, h){ var width = w ? (canvas.width - w) : canvas.width; var height = h ? (canvas.height - h) : canvas.height; ctx.translate(width / 2, height / 2); }; return function(id, opt){ var ctx, bkctx, mainContainer, labelContainer, canvas, bkcanvas; if (arguments.length < 1) throw "Arguments missing"; var idLabel = id + "-label", idCanvas = id + "-canvas", idBCanvas = id + "-bkcanvas"; opt = $merge(config, opt || {}); //create elements var dim = { 'width': opt.width, 'height': opt.height }; mainContainer = create("div", { 'id': id }, $merge(dim, { 'position': 'relative' })); labelContainer = create("div", { 'id': idLabel }, { 'overflow': 'visible', 'position': 'absolute', 'top': 0, 'left': 0, 'width': dim.width + 'px', 'height': 0 }); var dimPos = { 'position': 'absolute', 'top': 0, 'left': 0, 'width': dim.width + 'px', 'height': dim.height + 'px' }; canvas = create("canvas", $merge({ 'id': idCanvas }, dim), dimPos); var bc = opt.backgroundCanvas; if (bc) { bkcanvas = create("canvas", $merge({ 'id': idBCanvas }, dim), dimPos); //append elements mainContainer.appendChild(bkcanvas); } mainContainer.appendChild(canvas); mainContainer.appendChild(labelContainer); get(opt.injectInto).appendChild(mainContainer); //create contexts ctx = canvas.getContext('2d'); translateToCenter(canvas, ctx); var st = opt.styles; var s; for (s in st) ctx[s] = st[s]; if (bc) { bkctx = bkcanvas.getContext('2d'); st = bc.styles; for (s in st) { bkctx[s] = st[s]; } translateToCenter(bkcanvas, bkctx); bc.impl.init(bkcanvas, bkctx); bc.impl.plot(bkcanvas, bkctx); } //create methods return { 'id': id, /* Method: getCtx Returns the main canvas context object Returns: Main canvas context Example: (start code js) var ctx = canvas.getCtx(); //Now I can use the native canvas context //and for example change some canvas styles ctx.globalAlpha = 1; (end code) */ getCtx: function(){ return ctx; }, /* Method: getElement Returns the main Canvas DOM wrapper Returns: DOM canvas wrapper generated, (i.e the div wrapper element with id _mycanvas_) Example: (start code js) var wrapper = canvas.getElement(); //Returns
...
as element (end code) */ getElement: function(){ return mainContainer; }, /* Method: resize Resizes the canvas. Parameters: width - New canvas width. height - New canvas height. This method can be used with the , or visualizations to resize the visualizations Example: (start code js) function resizeViz(width, height) { canvas.resize(width, height); rgraph.refresh(); //ht.refresh or st.refresh() also work. rgraph.onAfterCompute(); } (end code) */ resize: function(width, height){ var pwidth = canvas.width, pheight = canvas.height; canvas.width = width; canvas.height = height; canvas.style.width = width + "px"; canvas.style.height = height + "px"; if (bc) { bkcanvas.width = width; bkcanvas.height = height; bkcanvas.style.width = width + "px"; bkcanvas.style.height = height + "px"; } //small ExCanvas fix if(!hasCanvas()) { translateToCenter(canvas, ctx, pwidth, pheight); } else { translateToCenter(canvas, ctx); } var st = opt.styles; var s; for (s in st) { ctx[s] = st[s]; } if (bc) { st = bc.styles; for (s in st) bkctx[s] = st[s]; //same ExCanvas fix here if(!hasCanvas()) { translateToCenter(bkcanvas, bkctx, pwidth, pheight); } else { translateToCenter(bkcanvas, bkctx); } bc.impl.init(bkcanvas, bkctx); bc.impl.plot(bkcanvas, bkctx); } }, /* Method: getSize Returns canvas dimensions. Returns: An object with _width_ and _height_ properties. Example: (start code js) canvas.getSize(); //returns { width: 900, height: 500 } (end code) */ getSize: function(){ return { 'width': canvas.width, 'height': canvas.height }; }, path: function(type, action){ ctx.beginPath(); action(ctx); ctx[type](); ctx.closePath(); }, /* Method: clear Clears the canvas object. */ clear: function(){ var size = this.getSize(); ctx.clearRect(-size.width / 2, -size.height / 2, size.width, size.height); }, /* Method: clearReactangle Same as but only clears a section of the canvas. Parameters: top - An integer specifying the top of the rectangle. right - An integer specifying the right of the rectangle. bottom - An integer specifying the bottom of the rectangle. left - An integer specifying the left of the rectangle. */ clearRectangle: function(top, right, bottom, left){ //if using excanvas if (!hasCanvas()) { var f0 = ctx.fillStyle; ctx.fillStyle = opt.backgroundColor; ctx.fillRect(left, top, Math.abs(right - left), Math.abs(bottom - top)); ctx.fillStyle = f0; } else { ctx.clearRect(left, top, Math.abs(right - left), Math.abs(bottom - top)); } } }; }; })(); /* * File: Polar.js * * Defines the class. * * Description: * * The class, just like the class, is used by the , and as a 2D point representation. * * See also: * * * */ /* Class: Polar A multi purpose polar representation. Description: The class, just like the class, is used by the , and as a 2D point representation. See also: Parameters: theta - An angle. rho - The norm. */ this.Polar = function(theta, rho) { this.theta = theta; this.rho = rho; }; Polar.prototype = { /* Method: getc Returns a complex number. Parameters: simple - _optional_ If *true*, this method will return only an object holding x and y properties and not a instance. Default's *false*. Returns: A complex number. */ getc: function(simple) { return this.toComplex(simple); }, /* Method: getp Returns a representation. Returns: A variable in polar coordinates. */ getp: function() { return this; }, /* Method: set Sets a number. Parameters: v - A or instance. */ set: function(v) { v = v.getp(); this.theta = v.theta; this.rho = v.rho; }, /* Method: setc Sets a number. Parameters: x - A number real part. y - A number imaginary part. */ setc: function(x, y) { this.rho = Math.sqrt(x * x + y * y); this.theta = Math.atan2(y, x); if(this.theta < 0) this.theta += Math.PI * 2; }, /* Method: setp Sets a polar number. Parameters: theta - A number angle property. rho - A number rho property. */ setp: function(theta, rho) { this.theta = theta; this.rho = rho; }, /* Method: clone Returns a copy of the current object. Returns: A copy of the real object. */ clone: function() { return new Polar(this.theta, this.rho); }, /* Method: toComplex Translates from polar to cartesian coordinates and returns a new instance. Parameters: simple - _optional_ If *true* this method will only return an object with x and y properties (and not the whole instance). Default's *false*. Returns: A new instance. */ toComplex: function(simple) { var x = Math.cos(this.theta) * this.rho; var y = Math.sin(this.theta) * this.rho; if(simple) return { 'x': x, 'y': y}; return new Complex(x, y); }, /* Method: add Adds two instances. Parameters: polar - A number. Returns: A new Polar instance. */ add: function(polar) { return new Polar(this.theta + polar.theta, this.rho + polar.rho); }, /* Method: scale Scales a polar norm. Parameters: number - A scale factor. Returns: A new Polar instance. */ scale: function(number) { return new Polar(this.theta, this.rho * number); }, /* Method: equals Comparison method. Returns *true* if the theta and rho properties are equal. Parameters: c - A number. Returns: *true* if the theta and rho parameters for these objects are equal. *false* otherwise. */ equals: function(c) { return this.theta == c.theta && this.rho == c.rho; }, /* Method: $add Adds two instances affecting the current object. Paramters: polar - A instance. Returns: The changed object. */ $add: function(polar) { this.theta = this.theta + polar.theta; this.rho += polar.rho; return this; }, /* Method: $madd Adds two instances affecting the current object. The resulting theta angle is modulo 2pi. Parameters: polar - A instance. Returns: The changed object. */ $madd: function(polar) { this.theta = (this.theta + polar.theta) % (Math.PI * 2); this.rho += polar.rho; return this; }, /* Method: $scale Scales a polar instance affecting the object. Parameters: number - A scaling factor. Returns: The changed object. */ $scale: function(number) { this.rho *= number; return this; }, /* Method: interpolate Calculates a polar interpolation between two points at a given delta moment. Parameters: elem - A instance. delta - A delta factor ranging [0, 1]. Returns: A new instance representing an interpolation between _this_ and _elem_ */ interpolate: function(elem, delta) { var pi = Math.PI, pi2 = pi * 2; var ch = function(t) { return (t < 0)? (t % pi2) + pi2 : t % pi2; }; var tt = this.theta, et = elem.theta; var sum; if(Math.abs(tt - et) > pi) { if(tt > et) { sum =ch((et + ((tt - pi2) - et) * delta)) ; } else { sum =ch((et - pi2 + (tt - (et - pi2)) * delta)); } } else { sum =ch((et + (tt - et) * delta)) ; } var r = (this.rho - elem.rho) * delta + elem.rho; return { 'theta': sum, 'rho': r }; } }; var $P = function(a, b) { return new Polar(a, b); }; Polar.KER = $P(0, 0); /* * File: Complex.js * * Defines the class. * * Description: * * The class, just like the class, is used by the , and as a 2D point representation. * * See also: * * * */ /* Class: Complex A multi-purpose Complex Class with common methods. Description: The class, just like the class, is used by the , and as a 2D point representation. See also: Parameters: x - _optional_ A Complex number real part. y - _optional_ A Complex number imaginary part. */ this.Complex = function(x, y) { this.x = x; this.y = y; }; Complex.prototype = { /* Method: getc Returns a complex number. Returns: A complex number. */ getc: function() { return this; }, /* Method: getp Returns a representation of this number. Parameters: simple - _optional_ If *true*, this method will return only an object holding theta and rho properties and not a instance. Default's *false*. Returns: A variable in coordinates. */ getp: function(simple) { return this.toPolar(simple); }, /* Method: set Sets a number. Parameters: c - A or instance. */ set: function(c) { c = c.getc(true); this.x = c.x; this.y = c.y; }, /* Method: setc Sets a complex number. Parameters: x - A number Real part. y - A number Imaginary part. */ setc: function(x, y) { this.x = x; this.y = y; }, /* Method: setp Sets a polar number. Parameters: theta - A number theta property. rho - A number rho property. */ setp: function(theta, rho) { this.x = Math.cos(theta) * rho; this.y = Math.sin(theta) * rho; }, /* Method: clone Returns a copy of the current object. Returns: A copy of the real object. */ clone: function() { return new Complex(this.x, this.y); }, /* Method: toPolar Transforms cartesian to polar coordinates. Parameters: simple - _optional_ If *true* this method will only return an object with theta and rho properties (and not the whole instance). Default's *false*. Returns: A new instance. */ toPolar: function(simple) { var rho = this.norm(); var atan = Math.atan2(this.y, this.x); if(atan < 0) atan += Math.PI * 2; if(simple) return { 'theta': atan, 'rho': rho }; return new Polar(atan, rho); }, /* Method: norm Calculates a number norm. Returns: A real number representing the complex norm. */ norm: function () { return Math.sqrt(this.squaredNorm()); }, /* Method: squaredNorm Calculates a number squared norm. Returns: A real number representing the complex squared norm. */ squaredNorm: function () { return this.x*this.x + this.y*this.y; }, /* Method: add Returns the result of adding two complex numbers. Does not alter the original object. Parameters: pos - A instance. Returns: The result of adding two complex numbers. */ add: function(pos) { return new Complex(this.x + pos.x, this.y + pos.y); }, /* Method: prod Returns the result of multiplying two numbers. Does not alter the original object. Parameters: pos - A instance. Returns: The result of multiplying two complex numbers. */ prod: function(pos) { return new Complex(this.x*pos.x - this.y*pos.y, this.y*pos.x + this.x*pos.y); }, /* Method: conjugate Returns the conjugate of this number. Does not alter the original object. Returns: The conjugate of this number. */ conjugate: function() { return new Complex(this.x, -this.y); }, /* Method: scale Returns the result of scaling a instance. Does not alter the original object. Parameters: factor - A scale factor. Returns: The result of scaling this complex to a factor. */ scale: function(factor) { return new Complex(this.x * factor, this.y * factor); }, /* Method: equals Comparison method. Returns *true* if both real and imaginary parts are equal. Parameters: c - A instance. Returns: A boolean instance indicating if both numbers are equal. */ equals: function(c) { return this.x == c.x && this.y == c.y; }, /* Method: $add Returns the result of adding two numbers. Alters the original object. Parameters: pos - A instance. Returns: The result of adding two complex numbers. */ $add: function(pos) { this.x += pos.x; this.y += pos.y; return this; }, /* Method: $prod Returns the result of multiplying two numbers. Alters the original object. Parameters: pos - A instance. Returns: The result of multiplying two complex numbers. */ $prod:function(pos) { var x = this.x, y = this.y; this.x = x*pos.x - y*pos.y; this.y = y*pos.x + x*pos.y; return this; }, /* Method: $conjugate Returns the conjugate for this . Alters the original object. Returns: The conjugate for this complex. */ $conjugate: function() { this.y = -this.y; return this; }, /* Method: $scale Returns the result of scaling a instance. Alters the original object. Parameters: factor - A scale factor. Returns: The result of scaling this complex to a factor. */ $scale: function(factor) { this.x *= factor; this.y *= factor; return this; }, /* Method: $div Returns the division of two numbers. Alters the original object. Parameters: pos - A number. Returns: The result of scaling this complex to a factor. */ $div: function(pos) { var x = this.x, y = this.y; var sq = pos.squaredNorm(); this.x = x * pos.x + y * pos.y; this.y = y * pos.x - x * pos.y; return this.$scale(1 / sq); } }; var $C = function(a, b) { return new Complex(a, b); }; Complex.KER = $C(0, 0); /* * File: Graph.js * * Generic , and classes. * * Used by: * * , and . * */ /* Class: Graph A generic Graph class. Description: When a json graph/tree structure is loaded by , an internal representation is created. In most cases you'll be dealing with an already created structure, so methods like or won't be of many use. However methods like and are pretty useful. provides also iterators for and advanced and useful graph operations and methods. Used by: , , and . Access: An instance of this class can be accessed by using the _graph_ parameter of a , or instance Example: (start code js) var st = new ST(canvas, config); st.graph.getNode //or any other method. var ht = new Hypertree(canvas, config); ht.graph.getNode //or any other method. var rg = new RGraph(canvas, config); rg.graph.getNode //or any other method. (end code) */ this.Graph = new Class({ initialize: function(opt) { var innerOptions = { 'complex': false, 'Node': {} }; this.opt = $merge(innerOptions, opt || {}); this.nodes= {}; }, /* Method: getNode Returns a by _id_. Parameters: id - A id. Returns: A having _id_ as id. Returns *false* otherwise. Example: (start code js) var node = graph.getNode('someid'); (end code) */ getNode: function(id) { if(this.hasNode(id)) return this.nodes[id]; return false; }, /* Method: getAdjacence Returns an array of objects connecting nodes with ids _id_ and _id2_. Parameters: id - A id. id2 - A id. Returns: An Array of objects. Returns *false* if there's not a connecting those two nodes. */ getAdjacence: function (id, id2) { var adjs = []; if(this.hasNode(id) && this.hasNode(id2) && this.nodes[id].adjacentTo({ 'id':id2 }) && this.nodes[id2].adjacentTo({ 'id':id })) { adjs.push(this.nodes[id].getAdjacency(id2)); adjs.push(this.nodes[id2].getAdjacency(id)); return adjs; } return false; }, /* Method: addNode Adds a node. Parameters: obj - An object containing as properties - _id_ node's id - _name_ node's name - _data_ node's data hash See also: */ addNode: function(obj) { if(!this.nodes[obj.id]) { this.nodes[obj.id] = new Graph.Node($extend({ 'id': obj.id, 'name': obj.name, 'data': obj.data }, this.opt.Node), this.opt.complex); } return this.nodes[obj.id]; }, /* Method: addAdjacence Connects nodes specified by _obj_ and _obj2_. If not found, nodes are created. Parameters: obj - a object. obj2 - Another object. data - A DataSet object. Used to store some extra information in the object created. See also: , */ addAdjacence: function (obj, obj2, data) { var adjs = []; if(!this.hasNode(obj.id)) { this.addNode(obj); } if(!this.hasNode(obj2.id)) { this.addNode(obj2); } obj = this.nodes[obj.id]; obj2 = this.nodes[obj2.id]; for(var i in this.nodes) { if(this.nodes[i].id == obj.id) { if(!this.nodes[i].adjacentTo(obj2)) { adjs.push(this.nodes[i].addAdjacency(obj2, data)); } } if(this.nodes[i].id == obj2.id) { if(!this.nodes[i].adjacentTo(obj)) { adjs.push(this.nodes[i].addAdjacency(obj, data)); } } } return adjs; }, /* Method: removeNode Removes a matching the specified _id_. Parameters: id - A node's id. */ removeNode: function(id) { if(this.hasNode(id)) { var node = this.nodes[id]; for(var i=0 in node.adjacencies) { var adj = node.adjacencies[i]; this.removeAdjacence(id, adj.nodeTo.id); } delete this.nodes[id]; } }, /* Method: removeAdjacence Removes a matching _id1_ and _id2_. Parameters: id1 - A id. id2 - A id. */ removeAdjacence: function(id1, id2) { if(this.hasNode(id1)) this.nodes[id1].removeAdjacency(id2); if(this.hasNode(id2)) this.nodes[id2].removeAdjacency(id1); }, /* Method: hasNode Returns a Boolean instance indicating if the node belongs to the or not. Parameters: id - Node id. Returns: A Boolean instance indicating if the node belongs to the graph or not. */ hasNode: function(id) { return id in this.nodes; } }); /* Class: Graph.Node A node. Parameters: obj - An object containing an 'id', 'name' and 'data' properties as described in . complex - Whether node position properties should contain or instances. See also: Description: An instance of is usually passed as parameter for most configuration/controller methods in the , and classes. A object has as properties id - Node id. name - Node name. data - Node data property containing a hash (i.e {}) with custom options. For more information see . selected - Whether the node is selected or not. Used by for selecting nodes that are between the root node and the selected node. angleSpan - For radial layouts such as the ones performed by the and the . Contains _begin_ and _end_ properties containing angle values describing the angle span for this subtree. alpha - Current opacity value. startAlpha - Opacity begin value. Used for interpolation. endAlpha - Opacity end value. Used for interpolation. pos - Current position. Can be a or instance. startPos - Starting position. Used for interpolation. endPos - Ending position. Used for interpolation. */ Graph.Node = new Class({ initialize: function(opt, complex) { var innerOptions = { 'id': '', 'name': '', 'data': {}, 'adjacencies': {}, 'selected': false, 'drawn': false, 'exist': false, 'angleSpan': { 'begin': 0, 'end' : 0 }, 'alpha': 1, 'startAlpha': 1, 'endAlpha': 1, 'pos': (complex && $C(0, 0)) || $P(0, 0), 'startPos': (complex && $C(0, 0)) || $P(0, 0), 'endPos': (complex && $C(0, 0)) || $P(0, 0) }; $extend(this, $extend(innerOptions, opt)); }, /* Method: adjacentTo Indicates if the node is adjacent to the node specified by id Parameters: id - A node id. Returns: A Boolean instance indicating whether this node is adjacent to the specified by id or not. Example: (start code js) node.adjacentTo('mynodeid'); (end code) */ adjacentTo: function(node) { return node.id in this.adjacencies; }, /* Method: getAdjacency Returns a object connecting the current and the node having _id_ as id. Parameters: id - A node id. Returns: A object or undefined. */ getAdjacency: function(id) { return this.adjacencies[id]; }, /* Method: addAdjacency Connects the current node and the given node. Parameters: node - A . data - Some custom hash information. */ addAdjacency: function(node, data) { var adj = new Graph.Adjacence(this, node, data); return this.adjacencies[node.id] = adj; }, /* Method: removeAdjacency Removes a by _id_. Parameters: id - A node id. */ removeAdjacency: function(id) { delete this.adjacencies[id]; } }); /* Class: Graph.Adjacence A adjacence (or edge). Connects two . Parameters: nodeFrom - A . nodeTo - A . data - Some custom hash data. See also: Description: An instance of is usually passed as parameter for some configuration/controller methods in the , and classes. A object has as properties nodeFrom - A connected by this edge. nodeTo - Another connected by this edge. data - Node data property containing a hash (i.e {}) with custom options. For more information see . alpha - Current opacity value. startAlpha - Opacity begin value. Used for interpolation. endAlpha - Opacity end value. Used for interpolation. */ Graph.Adjacence = function(nodeFrom, nodeTo, data) { this.nodeFrom = nodeFrom; this.nodeTo = nodeTo; this.data = data || {}; this.alpha = 1; this.startAlpha = 1; this.endAlpha = 1; }; /* Object: Graph.Util traversal and processing utility object. */ Graph.Util = { /* filter For internal use only. Provides a filtering function based on flags. */ filter: function(param) { if(!param || !($type(param) == 'string')) return function() { return true; }; var props = param.split(" "); return function(elem) { for(var i=0; i by _id_. Parameters: graph - A instance. id - A id. Returns: A node. Example: (start code js) Graph.Util.getNode(graph, 'nodeid'); (end code) */ getNode: function(graph, id) { return graph.getNode(id); }, /* Method: eachNode Iterates over nodes performing an _action_. Parameters: graph - A instance. action - A callback function having a as first formal parameter. Example: (start code js) Graph.Util.each(graph, function(node) { alert(node.name); }); (end code) */ eachNode: function(graph, action, flags) { var filter = this.filter(flags); for(var i in graph.nodes) { if(filter(graph.nodes[i])) action(graph.nodes[i]); } }, /* Method: eachAdjacency Iterates over adjacencies applying the _action_ function. Parameters: node - A . action - A callback function having as first formal parameter. Example: (start code js) Graph.Util.eachAdjacency(node, function(adj) { alert(adj.nodeTo.name); }); (end code) */ eachAdjacency: function(node, action, flags) { var adj = node.adjacencies, filter = this.filter(flags); for(var id in adj) { if(filter(adj[id])) { action(adj[id], id); } } }, /* Method: computeLevels Performs a BFS traversal setting the correct depth for each node. The depth of each node can then be accessed by >node._depth Parameters: graph - A . id - A starting node id for the BFS traversal. startDepth - _optional_ A minimum depth value. Default's 0. */ computeLevels: function(graph, id, startDepth, flags) { startDepth = startDepth || 0; var filter = this.filter(flags); this.eachNode(graph, function(elem) { elem._flag = false; elem._depth = -1; }, flags); var root = graph.getNode(id); root._depth = startDepth; var queue = [root]; while(queue.length != 0) { var node = queue.pop(); node._flag = true; this.eachAdjacency(node, function(adj) { var n = adj.nodeTo; if(n._flag == false && filter(n)) { if(n._depth < 0) n._depth = node._depth + 1 + startDepth; queue.unshift(n); } }, flags); } }, /* Method: eachBFS Performs a BFS traversal applying _action_ to each . Parameters: graph - A . id - A starting node id for the BFS traversal. action - A callback function having a as first formal parameter. Example: (start code js) Graph.Util.eachBFS(graph, 'mynodeid', function(node) { alert(node.name); }); (end code) */ eachBFS: function(graph, id, action, flags) { var filter = this.filter(flags); this.clean(graph); var queue = [graph.getNode(id)]; while(queue.length != 0) { var node = queue.pop(); node._flag = true; action(node, node._depth); this.eachAdjacency(node, function(adj) { var n = adj.nodeTo; if(n._flag == false && filter(n)) { n._flag = true; queue.unshift(n); } }, flags); } }, /* Method: eachLevel Iterates over a node's subgraph applying _action_ to the nodes of relative depth between _levelBegin_ and _levelEnd_. Parameters: node - A . levelBegin - A relative level value. levelEnd - A relative level value. action - A callback function having a as first formal parameter. */ eachLevel: function(node, levelBegin, levelEnd, action, flags) { var d = node._depth, filter = this.filter(flags), that = this; levelEnd = levelEnd === false? Number.MAX_VALUE -d : levelEnd; (function loopLevel(node, levelBegin, levelEnd) { var d = node._depth; if(d >= levelBegin && d <= levelEnd && filter(node)) action(node, d); if(d < levelEnd) { that.eachAdjacency(node, function(adj) { var n = adj.nodeTo; if(n._depth > d) loopLevel(n, levelBegin, levelEnd); }); } })(node, levelBegin + d, levelEnd + d); }, /* Method: eachSubgraph Iterates over a node's children recursively. Parameters: node - A . action - A callback function having a as first formal parameter. Example: (start code js) Graph.Util.eachSubgraph(node, function(node) { alert(node.name); }); (end code) */ eachSubgraph: function(node, action, flags) { this.eachLevel(node, 0, false, action, flags); }, /* Method: eachSubnode Iterates over a node's children (without deeper recursion). Parameters: node - A . action - A callback function having a as first formal parameter. Example: (start code js) Graph.Util.eachSubnode(node, function(node) { alert(node.name); }); (end code) */ eachSubnode: function(node, action, flags) { this.eachLevel(node, 1, 1, action, flags); }, /* Method: anySubnode Returns *true* if any subnode matches the given condition. Parameters: node - A . cond - A callback function returning a Boolean instance. This function has as first formal parameter a . Returns: A boolean value. Example: (start code js) Graph.Util.anySubnode(node, function(node) { return node.name == "mynodename"; }); (end code) */ anySubnode: function(node, cond, flags) { var flag = false; cond = cond || $lambda(true); var c = $type(cond) == 'string'? function(n) { return n[cond]; } : cond; this.eachSubnode(node, function(elem) { if(c(elem)) flag = true; }, flags); return flag; }, /* Method: getSubnodes Collects all subnodes for a specified node. The _level_ parameter filters nodes having relative depth of _level_ from the root node. Parameters: node - A . level - _optional_ A starting relative depth for collecting nodes. Default's 0. Returns: An array of nodes. */ getSubnodes: function(node, level, flags) { var ans = [], that = this; level = level || 0; var levelStart, levelEnd; if($type(level) == 'array') { levelStart = level[0]; levelEnd = level[1]; } else { levelStart = level; levelEnd = Number.MAX_VALUE - node._depth; } this.eachLevel(node, levelStart, levelEnd, function(n) { ans.push(n); }, flags); return ans; }, /* Method: getParents Returns an Array of wich are parents of the given node. Parameters: node - A . Returns: An Array of . Example: (start code js) var pars = Graph.Util.getParents(node); if(pars.length > 0) { //do stuff with parents } (end code) */ getParents: function(node) { var ans = []; this.eachAdjacency(node, function(adj) { var n = adj.nodeTo; if(n._depth < node._depth) ans.push(n); }); return ans; }, /* Method: isDescendantOf Returns a Boolean instance indicating if some node is descendant of the node with the given id. Parameters: node - A . id - A id. Returns: Ture if _node_ is descendant of the node with the given _id_. False otherwise. Example: (start code js) var pars = Graph.Util.isDescendantOf(node, "nodeid"); (end code) */ isDescendantOf: function(node, id) { if(node.id == id) return true; var pars = this.getParents(node), ans = false; for ( var i = 0; !ans && i < pars.length; i++) { ans = ans || this.isDescendantOf(pars[i], id); } return ans; }, /* Method: clean Cleans flags from nodes (by setting the _flag_ property to false). Parameters: graph - A instance. */ clean: function(graph) { this.eachNode(graph, function(elem) { elem._flag = false; }); } }; /* * File: Graph.Op.js * * Defines an abstract class for performing Operations. */ /* Object: Graph.Op Generic Operations. Description: An abstract class holding unary and binary powerful graph operations such as removingNodes, removingEdges, adding two graphs and morphing. Implemented by: , and . Access: The subclasses for this abstract class can be accessed by using the _op_ property of the , or instances created. See also: , , , , , , . */ Graph.Op = { options: { type: 'nothing', duration: 2000, hideLabels: true, fps:30 }, /* Method: removeNode Removes one or more from the visualization. It can also perform several animations like fading sequentially, fading concurrently, iterating or replotting. Parameters: node - The node's id. Can also be an array having many ids. opt - Animation options. It's an object with optional properties - _type_ Type of the animation. Can be "nothing", "replot", "fade:seq", "fade:con" or "iter". Default's "nothing". - _duration_ Duration of the animation in milliseconds. Default's 2000. - _fps_ Frames per second for the animation. Default's 30. - _hideLabels_ Hide labels during the animation. Default's *true*. - _transition_ Transitions defined in the class. Default's the default transition option of the , or instance created. Example: (start code js) var rg = new RGraph(canvas, config); //could be new ST or new Hypertree also. rg.op.removeNode('nodeid', { type: 'fade:seq', duration: 1000, hideLabels: false, transition: Trans.Quart.easeOut }); //or also rg.op.removeNode(['someid', 'otherid'], { type: 'fade:con', duration: 1500 }); (end code) */ removeNode: function(node, opt) { var viz = this.viz; var options = $merge(this.options, viz.controller, opt); var n = $splat(node); var i, that, nodeObj; switch(options.type) { case 'nothing': for(i=0; i class. Default's the default transition option of the , or instance created. Example: (start code js) var rg = new RGraph(canvas, config); //could be new ST or new Hypertree also. rg.op.removeEdge(['nodeid', 'otherid'], { type: 'fade:seq', duration: 1000, hideLabels: false, transition: Trans.Quart.easeOut }); //or also rg.op.removeEdge([['someid', 'otherid'], ['id3', 'id4']], { type: 'fade:con', duration: 1500 }); (end code) */ removeEdge: function(vertex, opt) { var viz = this.viz; var options = $merge(this.options, viz.controller, opt); var v = ($type(vertex[0]) == 'string')? [vertex] : vertex; var i, that, adjs; switch(options.type) { case 'nothing': for(i=0; i Parameters: json - A json tree or graph structure. See also . opt - Animation options. It's an object with optional properties - _type_ Type of the animation. Can be "nothing", "replot", "fade:seq" or "fade:con". Default's "nothing". - _duration_ Duration of the animation in milliseconds. Default's 2000. - _fps_ Frames per second for the animation. Default's 30. - _hideLabels_ Hide labels during the animation. Default's *true*. - _transition_ Transitions defined in the class. Default's the default transition option of the , or instance created. Example: (start code js) //json contains a tree or graph structure. var rg = new RGraph(canvas, config); //could be new ST or new Hypertree also. rg.op.sum(json, { type: 'fade:seq', duration: 1000, hideLabels: false, transition: Trans.Quart.easeOut }); //or also rg.op.sum(json, { type: 'fade:con', duration: 1500 }); (end code) */ sum: function(json, opt) { var viz = this.viz; var options = $merge(this.options, viz.controller, opt), root = viz.root; var GUtil, graph; viz.root = opt.id || viz.root; switch(options.type) { case 'nothing': graph = viz.construct(json); GUtil = Graph.Util; GUtil.eachNode(graph, function(elem) { GUtil.eachAdjacency(elem, function(adj) { viz.graph.addAdjacence(adj.nodeFrom, adj.nodeTo, adj.data); }); }); break; case 'replot': viz.refresh(true); this.sum(json, { type: 'nothing' }); viz.refresh(true); break; case 'fade:seq': case 'fade': case 'fade:con': GUtil = Graph.Util; that = this; graph = viz.construct(json); //set alpha to 0 for nodes to add. var fadeEdges = this.preprocessSum(graph); var modes = !fadeEdges? ['fade:nodes'] : ['fade:nodes', 'fade:vertex']; viz.reposition(); if(options.type != 'fade:con') { viz.fx.animate($merge(options, { modes: ['linear'], onComplete: function() { viz.fx.animate($merge(options, { modes: modes, onComplete: function() { options.onComplete(); } })); } })); } else { GUtil.eachNode(viz.graph, function(elem) { if (elem.id != root && elem.pos.getp().equals(Polar.KER)) { elem.pos.set(elem.endPos); elem.startPos.set(elem.endPos); } }); viz.fx.animate($merge(options, { modes: ['linear'].concat(modes) })); } break; default: this.doError(); } }, /* Method: morph This method will _morph_ the current visualized graph into the new _json_ representation passed in the method. Can also perform multiple animations. The _json_ object must at least have the root node in common with the current visualized graph. Parameters: json - A json tree or graph structure. See also . opt - Animation options. It's an object with optional properties - _type_ Type of the animation. Can be "nothing", "replot", or "fade". Default's "nothing". - _duration_ Duration of the animation in milliseconds. Default's 2000. - _fps_ Frames per second for the animation. Default's 30. - _hideLabels_ Hide labels during the animation. Default's *true*. - _transition_ Transitions defined in the class. Default's the default transition option of the , or instance created. Example: (start code js) //json contains a tree or graph structure. var rg = new RGraph(canvas, config); //could be new ST or new Hypertree also. rg.op.morph(json, { type: 'fade', duration: 1000, hideLabels: false, transition: Trans.Quart.easeOut }); //or also rg.op.morph(json, { type: 'fade', duration: 1500 }); (end code) */ morph: function(json, opt) { var viz = this.viz; var options = $merge(this.options, viz.controller, opt), root = viz.root; var GUtil, graph; viz.root = opt.id || viz.root; switch(options.type) { case 'nothing': graph = viz.construct(json); GUtil = Graph.Util; GUtil.eachNode(graph, function(elem) { GUtil.eachAdjacency(elem, function(adj) { viz.graph.addAdjacence(adj.nodeFrom, adj.nodeTo, adj.data); }); }); GUtil.eachNode(viz.graph, function(elem) { GUtil.eachAdjacency(elem, function(adj) { if(!graph.getAdjacence(adj.nodeFrom.id, adj.nodeTo.id)) { viz.graph.removeAdjacence(adj.nodeFrom.id, adj.nodeTo.id); } }); if(!graph.hasNode(elem.id)) viz.graph.removeNode(elem.id); }); break; case 'replot': viz.fx.clearLabels(true); this.morph(json, { type: 'nothing' }); viz.refresh(true); viz.refresh(true); break; case 'fade:seq': case 'fade': case 'fade:con': GUtil = Graph.Util; that = this; graph = viz.construct(json); //preprocessing for adding nodes. var fadeEdges = this.preprocessSum(graph); //preprocessing for nodes to delete. GUtil.eachNode(viz.graph, function(elem) { if(!graph.hasNode(elem.id)) { elem.alpha = 1; elem.startAlpha = 1; elem.endAlpha = 0; elem.ignore = true; } }); GUtil.eachNode(viz.graph, function(elem) { if(elem.ignore) return; GUtil.eachAdjacency(elem, function(adj) { if(adj.nodeFrom.ignore || adj.nodeTo.ignore) return; var nodeFrom = graph.getNode(adj.nodeFrom.id); var nodeTo = graph.getNode(adj.nodeTo.id); if(!nodeFrom.adjacentTo(nodeTo)) { var adjs = viz.graph.getAdjacence(nodeFrom.id, nodeTo.id); fadeEdges = true; adjs[0].alpha = 1; adjs[0].startAlpha = 1; adjs[0].endAlpha = 0; adjs[0].ignore = true; adjs[1].alpha = 1; adjs[1].startAlpha = 1; adjs[1].endAlpha = 0; adjs[1].ignore = true; } }); }); var modes = !fadeEdges? ['fade:nodes'] : ['fade:nodes', 'fade:vertex']; viz.reposition(); GUtil.eachNode(viz.graph, function(elem) { if (elem.id != root && elem.pos.getp().equals(Polar.KER)) { elem.pos.set(elem.endPos); elem.startPos.set(elem.endPos); } }); viz.fx.animate($merge(options, { modes: ['polar'].concat(modes), onComplete: function() { GUtil.eachNode(viz.graph, function(elem) { if(elem.ignore) viz.graph.removeNode(elem.id); }); GUtil.eachNode(viz.graph, function(elem) { GUtil.eachAdjacency(elem, function(adj) { if(adj.ignore) viz.graph.removeAdjacence(adj.nodeFrom.id, adj.nodeTo.id); }); }); options.onComplete(); } })); break; default: this.doError(); } }, preprocessSum: function(graph) { var viz = this.viz; var GUtil = Graph.Util; GUtil.eachNode(graph, function(elem) { if(!viz.graph.hasNode(elem.id)) { viz.graph.addNode(elem); var n = viz.graph.getNode(elem.id); n.alpha = 0; n.startAlpha = 0; n.endAlpha = 1; } }); var fadeEdges = false; GUtil.eachNode(graph, function(elem) { GUtil.eachAdjacency(elem, function(adj) { var nodeFrom = viz.graph.getNode(adj.nodeFrom.id); var nodeTo = viz.graph.getNode(adj.nodeTo.id); if(!nodeFrom.adjacentTo(nodeTo)) { var adjs = viz.graph.addAdjacence(nodeFrom, nodeTo, adj.data); if(nodeFrom.startAlpha == nodeFrom.endAlpha && nodeTo.startAlpha == nodeTo.endAlpha) { fadeEdges = true; adjs[0].alpha = 0; adjs[0].startAlpha = 0; adjs[0].endAlpha = 1; adjs[1].alpha = 0; adjs[1].startAlpha = 0; adjs[1].endAlpha = 1; } } }); }); return fadeEdges; } }; /* * File: Graph.Plot.js * * Defines an abstract class for performing rendering and animation. * */ /* Object: Graph.Plot Generic rendering and animation methods. Description: An abstract class for plotting a generic graph structure. Implemented by: , , . Access: The subclasses for this abstract class can be accessed by using the _fx_ property of the , , or instances created. See also: , , , , , , . */ Graph.Plot = { Interpolator: { 'moebius': function(elem, delta, vector) { if(delta <= 1 || vector.norm() <= 1) { var x = vector.x, y = vector.y; var ans = elem.startPos.getc().moebiusTransformation(vector); elem.pos.setc(ans.x, ans.y); vector.x = x; vector.y = y; } }, 'linear': function(elem, delta) { var from = elem.startPos.getc(true); var to = elem.endPos.getc(true); elem.pos.setc((to.x - from.x) * delta + from.x, (to.y - from.y) * delta + from.y); }, 'fade:nodes': function(elem, delta) { if(delta <= 1 && (elem.endAlpha != elem.alpha)) { var from = elem.startAlpha; var to = elem.endAlpha; elem.alpha = from + (to - from) * delta; } }, 'fade:vertex': function(elem, delta) { var adjs = elem.adjacencies; for(var id in adjs) this['fade:nodes'](adjs[id], delta); }, 'polar': function(elem, delta) { var from = elem.startPos.getp(true); var to = elem.endPos.getp(); var ans = to.interpolate(from, delta); elem.pos.setp(ans.theta, ans.rho); } }, //A flag value indicating if node labels are being displayed or not. labelsHidden: false, //Label DOM element labelContainer: false, //Label DOM elements hash. labels: {}, /* Method: getLabelContainer Lazy fetcher for the label container. Returns: The label container DOM element. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST var labelContainer = rg.fx.getLabelContainer(); alert(labelContainer.innerHTML); (end code) */ getLabelContainer: function() { return this.labelContainer? this.labelContainer : this.labelContainer = document.getElementById(this.viz.config.labelContainer); }, /* Method: getLabel Lazy fetcher for the label DOM element. Parameters: id - The label id (which is also a id). Returns: The label DOM element. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST var label = rg.fx.getLabel('someid'); alert(label.innerHTML); (end code) */ getLabel: function(id) { return (id in this.labels && this.labels[id] != null)? this.labels[id] : this.labels[id] = document.getElementById(id); }, /* Method: hideLabels Hides all labels (by hiding the label container). Parameters: hide - A boolean value indicating if the label container must be hidden or not. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.hideLabels(true); (end code) */ hideLabels: function (hide) { var container = this.getLabelContainer(); if(hide) container.style.display = 'none'; else container.style.display = ''; this.labelsHidden = hide; }, /* Method: clearLabels Clears the label container. Useful when using a new visualization with the same canvas element/widget. Parameters: force - Forces deletion of all labels. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.clearLabels(); (end code) */ clearLabels: function(force) { for(var id in this.labels) { if (force || !this.viz.graph.hasNode(id)) { this.disposeLabel(id); delete this.labels[id]; } } }, /* Method: disposeLabel Removes a label. Parameters: id - A label id (which generally is also a id). Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.disposeLabel('labelid'); (end code) */ disposeLabel: function(id) { var elem = this.getLabel(id); if(elem && elem.parentNode) { elem.parentNode.removeChild(elem); } }, /* Method: hideLabel Hides the corresponding label. Parameters: node - A . Can also be an array of . flag - If *true*, nodes will be shown. Otherwise nodes will be hidden. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.hideLabel(rg.graph.getNode('someid'), false); (end code) */ hideLabel: function(node, flag) { node = $splat(node); var st = flag? "" : "none", lab, that = this; $each(node, function(n) { var lab = that.getLabel(n.id); if (lab) { lab.style.display = st; } }); }, /* Method: sequence Iteratively performs an action while refreshing the state of the visualization. Parameters: options - Some sequence options like - _condition_ A function returning a boolean instance in order to stop iterations. - _step_ A function to execute on each step of the iteration. - _onComplete_ A function to execute when the sequence finishes. - _duration_ Duration (in milliseconds) of each step. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST var i = 0; rg.fx.sequence({ condition: function() { return i == 10; }, step: function() { alert(i++); }, onComplete: function() { alert('done!'); } }); (end code) */ sequence: function(options) { var that = this; options = $merge({ condition: $lambda(false), step: $empty, onComplete: $empty, duration: 200 }, options || {}); var interval = setInterval(function() { if(options.condition()) { options.step(); } else { clearInterval(interval); options.onComplete(); } that.viz.refresh(true); }, options.duration); }, /* Method: animate Animates a by interpolating some properties. Parameters: opt - Animation options. This object contains as properties - _modes_ (required) An Array of animation types. Possible values are "linear", "polar", "moebius", "fade:nodes" and "fade:vertex". "linear", "polar" and "moebius" animation options will interpolate "startPos" and "endPos" properties, storing the result in "pos". "fade:nodes" and "fade:vertex" animation options will interpolate and/or "startAlpha" and "endAlpha" properties, storing the result in "alpha". - _duration_ Duration (in milliseconds) of the Animation. - _fps_ Frames per second. - _hideLabels_ hide labels or not during the animation. ...and other , or controller methods. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.animate({ modes: ['linear'], hideLabels: false }); (end code) */ animate: function(opt, versor) { var that = this, viz = this.viz, graph = viz.graph, GUtil = Graph.Util; opt = $merge(viz.controller, opt || {}); if(opt.hideLabels) this.hideLabels(true); this.animation.setOptions($merge(opt, { $animating: false, compute: function(delta) { var vector = versor? versor.scale(-delta) : null; GUtil.eachNode(graph, function(node) { for(var i=0; i. Parameters: opt - _optional_ Plotting options. Example: (start code js) var rg = new RGraph(canvas, config); //can be also Hypertree or ST rg.fx.plot(); (end code) */ plot: function(opt, animating) { var viz = this.viz, aGraph = viz.graph, canvas = viz.canvas, id = viz.root, that = this, ctx = canvas.getCtx(), GUtil = Graph.Util; opt = opt || this.viz.controller; opt.clearCanvas && canvas.clear(); var T = !!aGraph.getNode(id).visited; GUtil.eachNode(aGraph, function(node) { GUtil.eachAdjacency(node, function(adj) { var nodeTo = adj.nodeTo; if(!!nodeTo.visited === T && node.drawn && nodeTo.drawn) { !animating && opt.onBeforePlotLine(adj); ctx.save(); ctx.globalAlpha = Math.min(Math.min(node.alpha, nodeTo.alpha), adj.alpha); that.plotLine(adj, canvas, animating); ctx.restore(); !animating && opt.onAfterPlotLine(adj); } }); ctx.save(); if(node.drawn) { ctx.globalAlpha = node.alpha; !animating && opt.onBeforePlotNode(node); that.plotNode(node, canvas, animating); !animating && opt.onAfterPlotNode(node); } if(!that.labelsHidden && opt.withLabels) { if(node.drawn && ctx.globalAlpha >= 0.95) { that.plotLabel(canvas, node, opt); } else { that.hideLabel(node, false); } } ctx.restore(); node.visited = !T; }); }, /* Method: plotLabel Plots a label for a given node. Parameters: canvas - A instance. node - A . controller - A configuration object. See also , , . */ plotLabel: function(canvas, node, controller) { var id = node.id, tag = this.getLabel(id); if(!tag && !(tag = document.getElementById(id))) { tag = document.createElement('div'); var container = this.getLabelContainer(); container.appendChild(tag); tag.id = id; tag.className = 'node'; tag.style.position = 'absolute'; controller.onCreateLabel(tag, node); this.labels[node.id] = tag; } this.placeLabel(tag, node, controller); }, /* Method: plotNode Plots a . Parameters: node - A . canvas - A element. */ plotNode: function(node, canvas, animating) { var nconfig = this.node, data = node.data; var cond = nconfig.overridable && data; var width = cond && data.$lineWidth || nconfig.lineWidth; var color = cond && data.$color || nconfig.color; var ctx = canvas.getCtx(); ctx.lineWidth = width; ctx.fillStyle = color; ctx.strokeStyle = color; var f = node.data && node.data.$type || nconfig.type; this.nodeTypes[f].call(this, node, canvas, animating); }, /* Method: plotLine Plots a line. Parameters: adj - A . canvas - A instance. */ plotLine: function(adj, canvas, animating) { var econfig = this.edge, data = adj.data; var cond = econfig.overridable && data; var width = cond && data.$lineWidth || econfig.lineWidth; var color = cond && data.$color || econfig.color; var ctx = canvas.getCtx(); ctx.lineWidth = width; ctx.fillStyle = color; ctx.strokeStyle = color; var f = adj.data && adj.data.$type || econfig.type; this.edgeTypes[f].call(this, adj, canvas, animating); }, /* Method: fitsInCanvas Returns _true_ or _false_ if the label for the node is contained in the canvas dom element or not. Parameters: pos - A instance (I'm doing duck typing here so any object with _x_ and _y_ parameters will do). canvas - A instance. Returns: A boolean value specifying if the label is contained in the DOM element or not. */ fitsInCanvas: function(pos, canvas) { var size = canvas.getSize(); if(pos.x >= size.width || pos.x < 0 || pos.y >= size.height || pos.y < 0) return false; return true; } }; /* * File: Loader.js * * Provides methods for loading JSON data. * * Description: * * Provides the method implemented by the main visualization classes to load JSON Trees and Graphs. * * Implemented By: * * , , and classes * */ /* Object: Loader Provides static methods for loading JSON data. Description: This object is extended by the main Visualization classes (, , and ) in order to implement the method. The method accepts JSON Trees and Graph objects. This will be explained in detail in the method definition. */ var Loader = { construct: function(json) { var isGraph = ($type(json) == 'array'); var ans = new Graph(this.graphOptions); if(!isGraph) //make tree (function (ans, json) { ans.addNode(json); for(var i=0, ch = json.children; i and transition classes. * */ /* Object: Trans An object containing multiple type of transformations. Based on: Easing and Transition animation methods are based in the MooTools Framework . Copyright (c) 2006-2009 Valerio Proietti, . MIT license . Used by: , and classes. Description: This object is used for specifying different animation transitions in the , and classes. There are many different type of animation transitions. linear: Displays a linear transition >Trans.linear (see Linear.png) Quad: Displays a Quadratic transition. >Trans.Quad.easeIn >Trans.Quad.easeOut >Trans.Quad.easeInOut (see Quad.png) Cubic: Displays a Cubic transition. >Trans.Cubic.easeIn >Trans.Cubic.easeOut >Trans.Cubic.easeInOut (see Cubic.png) Quart: Displays a Quartetic transition. >Trans.Quart.easeIn >Trans.Quart.easeOut >Trans.Quart.easeInOut (see Quart.png) Quint: Displays a Quintic transition. >Trans.Quint.easeIn >Trans.Quint.easeOut >Trans.Quint.easeInOut (see Quint.png) Expo: Displays an Exponential transition. >Trans.Expo.easeIn >Trans.Expo.easeOut >Trans.Expo.easeInOut (see Expo.png) Circ: Displays a Circular transition. >Trans.Circ.easeIn >Trans.Circ.easeOut >Trans.Circ.easeInOut (see Circ.png) Sine: Displays a Sineousidal transition. >Trans.Sine.easeIn >Trans.Sine.easeOut >Trans.Sine.easeInOut (see Sine.png) Back: >Trans.Back.easeIn >Trans.Back.easeOut >Trans.Back.easeInOut (see Back.png) Bounce: Bouncy transition. >Trans.Bounce.easeIn >Trans.Bounce.easeOut >Trans.Bounce.easeInOut (see Bounce.png) Elastic: Elastic curve. >Trans.Elastic.easeIn >Trans.Elastic.easeOut >Trans.Elastic.easeInOut (see Elastic.png) */ this.Trans = { linear: function(p) { return p; } }; (function() { var makeTrans = function(transition, params){ params = $splat(params); return $extend(transition, { easeIn: function(pos){ return transition(pos, params); }, easeOut: function(pos){ return 1 - transition(1 - pos, params); }, easeInOut: function(pos){ return (pos <= 0.5) ? transition(2 * pos, params) / 2 : (2 - transition(2 * (1 - pos), params)) / 2; } }); }; var transitions = { Pow: function(p, x){ return Math.pow(p, x[0] || 6); }, Expo: function(p){ return Math.pow(2, 8 * (p - 1)); }, Circ: function(p){ return 1 - Math.sin(Math.acos(p)); }, Sine: function(p){ return 1 - Math.sin((1 - p) * Math.PI / 2); }, Back: function(p, x){ x = x[0] || 1.618; return Math.pow(p, 2) * ((x + 1) * p - x); }, Bounce: function(p){ var value; for (var a = 0, b = 1; 1; a += b, b /= 2){ if (p >= (7 - 4 * a) / 11){ value = b * b - Math.pow((11 - 6 * a - 11 * p) / 4, 2); break; } } return value; }, Elastic: function(p, x){ return Math.pow(2, 10 * --p) * Math.cos(20 * p * Math.PI * (x[0] || 1) / 3); } }; $each(transitions, function(val, key) { Trans[key] = makeTrans(val); }); $each(['Quad', 'Cubic', 'Quart', 'Quint'], function(elem, i) { Trans[elem] = makeTrans(function(p){ return Math.pow(p, [i + 2]); }); }); })(); /* Class: Animation A Class that can perform animations for generic objects. If you are looking for animation transitions please take a look at the object. Used by: Based on: The Animation class is based in the MooTools Framework . Copyright (c) 2006-2009 Valerio Proietti, . MIT license . */ var Animation = new Class({ initalize: function(options) { this.setOptions(options); }, setOptions: function(options) { var opt = { duration: 2500, fps: 40, transition: Trans.Quart.easeInOut, compute: $empty, complete: $empty }; this.opt = $merge(opt, options || {}); return this; }, getTime: function() { return $time(); }, step: function(){ var time = this.getTime(), opt = this.opt; if (time < this.time + opt.duration){ var delta = opt.transition((time - this.time) / opt.duration); opt.compute(delta); } else { this.timer = clearInterval(this.timer); opt.compute(1); opt.complete(); } }, start: function(){ this.time = 0; this.startTimer(); return this; }, startTimer: function(){ var that = this, opt = this.opt; if (this.timer) return false; this.time = this.getTime() - this.time; this.timer = setInterval((function () { that.step(); }), Math.round(1000 / opt.fps)); return true; } }); /* * File: Spacetree.js * * Implements the class and other derived classes. * * Description: * * The main idea of the spacetree algorithm is to take the most common tree layout, and to expand nodes that are "context-related" .i.e lying on the path between the root node and a selected node. Useful animations to contract and expand nodes are also included. * * Inspired by: * * SpaceTree: Supporting Exploration in Large Node Link Tree, Design Evolution and Empirical Evaluation (Catherine Plaisant, Jesse Grosjean, Benjamin B. Bederson) * * * * Disclaimer: * * This visualization was built from scratch, taking only the paper as inspiration, and only shares some features with the Spacetree. * */ /* Class: ST The main ST class Extends: Parameters: canvas - A Class config - A configuration/controller object. Configuration: The configuration object can have the following properties (all properties are optional and have a default value) *General* - _levelsToShow_ Depth of the plotted tree. The plotted tree will be pruned in order to fit the specified depth if constrained=true. Default's 2. - _constrained_ If true, the algorithm will try to plot only the part of the tree that fits the Canvas. - _subtreeOffset_ Separation offset between subtrees. Default's 8. - _siblingOffset_ Separation offset between siblings. Default's 5. - _levelDistance_ Distance between levels. Default's 30. - _orientation_ Sets the orientation layout. Implemented orientations are _left_ (the root node will be placed on the left side of the screen), _top_ (the root node will be placed on top of the screen), _bottom_ and _right_. Default's "left". - _align_ Whether the tree alignment is left, center or right. - _indent_ Used when alignment is left or right and shows an indentation between parent and children. Default's 10. - _withLabels_ Whether the visualization should use/create labels or not. Default's *true*. *Node* Customize the visualization nodes' shape, color, and other style properties. - _Node_ This object has as properties - _overridable_ Determine whether or not nodes properties can be overriden by a particular node. Default's false. If given a JSON tree or graph, a node _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the node properties will override the global node properties. - _type_ Node type (shape). Possible options are "none", "square", "rectangle", "ellipse" and "circle". Default's "rectangle". - _color_ Node color. Default's '#ccb'. - _lineWidth_ Line width. If nodes aren't drawn with strokes then this property won't be of any use. Default's 1. - _height_ Node height. Used for plotting rectangular nodes. _Width_ and _height_ properties are also used as bounding box for nodes of different shapes. This means that for all shapes you'd have to make sure that the node's shape is contained in the bounding box defined by _width_ and _height_ parameters. Default's 20. - _width_ Node width. Used for plotting rectangular nodes and for calculating a node's bounding box. Default's 90. - _dim_ An extra parameter used by other complex shapes such as square and circle to determine the shape's diameter. Please notice that even if these complex shapes (square, circle) only use _dim_ for calculating it's diameter property, the complex shape must be contained in the bounding box calculated with the _width_ and _height_ parameters. Default's 15. - _align_ Defines a node's alignment. Possible values are "center", "left", "right". Default's "center". *Edge* Customize the visualization edges' shape, color, and other style properties. - _Edge_ This object has as properties - _overridable_ Determine whether or not edges properties can be overriden by a particular edge object. Default's false. If given a JSON _complex_ graph (defined in ), an adjacency _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the adjacency properties will override the global edge properties. - _type_ Edge type (shape). Possible options are "none", "line", "quadratic:begin", "quadratic:end", "bezier" and "arrow". Default's "line". - _color_ Edge color. Default's '#ccb'. - _lineWidth_ Line width. If edges aren't drawn with strokes then this property won't be of any use. Default's 1. - _dim_ An extra parameter used by other complex shapes such as quadratic, arrow and bezier to determine the shape's diameter. *Animations* - _duration_ Duration of the animation in milliseconds. Default's 700. - _fps_ Frames per second. Default's 25. - _transition_ One of the transitions defined in the class. Default's Quart.easeInOut. - _clearCanvas_ Whether to clear canvas on each animation frame or not. Default's true. *Controller options* You can also implement controller functions inside the configuration object. This functions are - _onBeforeCompute(node)_ This method is called right before performing all computation and animations to the JIT visualization. - _onAfterCompute()_ This method is triggered right after all animations or computations for the JIT visualizations ended. - _onCreateLabel(domElement, node)_ This method receives the label dom element as first parameter, and the corresponding as second parameter. This method will only be called on label creation. Note that a is a node from the input tree/graph you provided to the visualization. If you want to know more about what kind of JSON tree/graph format is used to feed the visualizations, you can take a look at . This method proves useful when adding events to the labels used by the JIT. - _onPlaceLabel(domElement, node)_ This method receives the label dom element as first parameter and the corresponding as second parameter. This method is called each time a label has been placed on the visualization, and thus it allows you to update the labels properties, such as size or position. Note that onPlaceLabel will be triggered after updating the labels positions. That means that, for example, the left and top css properties are already updated to match the nodes positions. - _onBeforePlotNode(node)_ This method is triggered right before plotting a given node. The _node_ parameter is the to be plotted. This method is useful for changing a node style right before plotting it. - _onAfterPlotNode(node)_ This method is triggered right after plotting a given node. The _node_ parameter is the plotted. - _onBeforePlotLine(adj)_ This method is triggered right before plotting an edge. The _adj_ parameter is a object. This method is useful for adding some styles to a particular edge before being plotted. - _onAfterPlotLine(adj)_ This method is triggered right after plotting an edge. The _adj_ parameter is the plotted. - _request(nodeId, level, onComplete)_ This method is used for buffering information into the visualization. When clicking on an empty node, the visualization will make a request for this node's subtree, specifying a given level for this subtree. Once this request is completed the _onComplete_ object must be called with the given result. Example: Here goes a complete example. In most cases you won't be forced to implement all properties and methods. In fact, all configuration properties have the default value assigned. I won't be instanciating a class here. If you want to know more about instanciating a class please take a look at the class documentation. (start code js) var st = new ST(canvas, { orientation: "left", levelsToShow: 2, subtreeOffset: 8, siblingOffset: 5, levelDistance: 30, withLabels: true, align: "center", multitree: false, indent: 10, Node: { overridable: false, type: 'rectangle', color: '#ccb', lineWidth: 1, height: 20, width: 90, dim: 15, align: "center" }, Edge: { overridable: false, type: 'line', color: '#ccc', dim: 15, lineWidth: 1 }, duration: 700, fps: 25, transition: Trans.Quart.easeInOut, clearCanvas: true, onBeforeCompute: function(node) { //do something onBeforeCompute }, onAfterCompute: function () { //do something onAfterCompute }, onCreateLabel: function(domElement, node) { //do something onCreateLabel }, onPlaceLabel: function(domElement, node) { //do something onPlaceLabel }, onBeforePlotNode:function(node) { //do something onBeforePlotNode }, onAfterPlotNode: function(node) { //do something onAfterPlotNode }, onBeforePlotLine:function(adj) { //do something onBeforePlotLine }, onAfterPlotLine: function(adj) { //do something onAfterPlotLine }, request: false }); (end code) Instance Properties: - _graph_ Access a instance. - _op_ Access a instance. - _fx_ Access a instance. */ (function () { //Layout functions var slice = Array.prototype.slice; /* Calculates the max width and height nodes for a tree level */ function getBoundaries(graph, config, level, orn) { var dim = config.Node, GUtil = Graph.Util; var multitree = config.multitree; if(dim.overridable) { var w = -1, h = -1; GUtil.eachNode(graph, function(n) { if(n._depth == level && (!multitree || ('$orn' in n.data) && n.data.$orn == orn)) { var dw = n.data.$width || dim.width; var dh = n.data.$height || dim.height; w = (w < dw)? dw : w; h = (h < dh)? dh : h; } }); return { 'width': w < 0? dim.width : w, 'height': h < 0? dim.height : h }; } else { return dim; } }; function movetree(node, prop, val, orn) { var p = (orn == "left" || orn == "right")? "y" : "x"; node[prop][p] += val; }; function moveextent(extent, val) { var ans = []; $each(extent, function(elem) { elem = slice.call(elem); elem[0] += val; elem[1] += val; ans.push(elem); }); return ans; }; function merge(ps, qs) { if(ps.length == 0) return qs; if(qs.length == 0) return ps; var p = ps.shift(), q = qs.shift(); return [[p[0], q[1]]].concat(merge(ps, qs)); }; function mergelist(ls, def) { def = def || []; if(ls.length == 0) return def; var ps = ls.pop(); return mergelist(ls, merge(ps, def)); }; function fit(ext1, ext2, subtreeOffset, siblingOffset, i) { if(ext1.length <= i || ext2.length <= i) return 0; var p = ext1[i][1], q = ext2[i][0]; return Math.max(fit(ext1, ext2, subtreeOffset, siblingOffset, ++i) + subtreeOffset, p - q + siblingOffset); }; function fitlistl(es, subtreeOffset, siblingOffset) { function $fitlistl(acc, es, i) { if(es.length <= i) return []; var e = es[i], ans = fit(acc, e, subtreeOffset, siblingOffset, 0); return [ans].concat($fitlistl(merge(acc, moveextent(e, ans)), es, ++i)); }; return $fitlistl([], es, 0); }; function fitlistr(es, subtreeOffset, siblingOffset) { function $fitlistr(acc, es, i) { if(es.length <= i) return []; var e = es[i], ans = -fit(e, acc, subtreeOffset, siblingOffset, 0); return [ans].concat($fitlistr(merge(moveextent(e, ans), acc), es, ++i)); }; es = slice.call(es); var ans = $fitlistr([], es.reverse(), 0); return ans.reverse(); }; function fitlist(es, subtreeOffset, siblingOffset, align) { var esl = fitlistl(es, subtreeOffset, siblingOffset), esr = fitlistr(es, subtreeOffset, siblingOffset); if(align == "left") esr = esl; else if(align == "right") esl = esr; for(var i = 0, ans = []; i < esl.length; i++) { ans[i] = (esl[i] + esr[i]) / 2; } return ans; }; function design(graph, node, prop, config, orn) { var multitree = config.multitree; var auxp = ['x', 'y'], auxs = ['width', 'height']; var ind = +(orn == "left" || orn == "right"); var p = auxp[ind], notp = auxp[1 - ind]; var cnode = config.Node; var s = auxs[ind], nots = auxs[1 - ind]; var siblingOffset = config.siblingOffset; var subtreeOffset = config.subtreeOffset; var align = config.align; var GUtil = Graph.Util; function $design(node, maxsize, acum) { var sval = (cnode.overridable && node.data["$" + s]) || cnode[s]; var notsval = maxsize || ((cnode.overridable && node.data["$" + nots]) || cnode[nots]); var trees = [], extents = [], chmaxsize = false; var chacum = notsval + config.levelDistance; GUtil.eachSubnode(node, function(n) { if(n.exist && (!multitree || ('$orn' in n.data) && n.data.$orn == orn)) { if(!chmaxsize) chmaxsize = getBoundaries(graph, config, n._depth, orn); var s = $design(n, chmaxsize[nots], acum + chacum); trees.push(s.tree); extents.push(s.extent); } }); var positions = fitlist(extents, subtreeOffset, siblingOffset, align); for(var i=0, ptrees = [], pextents = []; i < trees.length; i++) { movetree(trees[i], prop, positions[i], orn); pextents.push(moveextent(extents[i], positions[i])); } var resultextent = [[-sval/2, sval/2]].concat(mergelist(pextents)); node[prop][p] = 0; if (orn == "top" || orn == "left") { node[prop][notp] = acum; } else { node[prop][notp] = -acum; } return { tree: node, extent: resultextent }; }; $design(node, false, 0); }; this.ST= (function() { //Define some private methods first... //Nodes in path var nodesInPath = []; //Nodes to contract function getNodesToHide(node) { node = node || this.clickedNode; var Geom = this.geom, GUtil = Graph.Util; var graph = this.graph; var canvas = this.canvas; var level = node._depth, nodeArray = []; GUtil.eachNode(graph, function(n) { if(n.exist && !n.selected) { if(GUtil.isDescendantOf(n, node.id)) { if(n._depth <= level) nodeArray.push(n); } else { nodeArray.push(n); } } }); var leafLevel = Geom.getRightLevelToShow(node, canvas); GUtil.eachLevel(node, leafLevel, leafLevel, function(n) { if(n.exist && !n.selected) nodeArray.push(n); }); for (var i = 0; i < nodesInPath.length; i++) { var n = this.graph.getNode(nodesInPath[i]); if(!GUtil.isDescendantOf(n, node.id)) { nodeArray.push(n); } } return nodeArray; }; //Nodes to expand function getNodesToShow(node) { var nodeArray= [], GUtil = Graph.Util, config = this.config; node = node || this.clickedNode; GUtil.eachLevel(this.clickedNode, 0, config.levelsToShow, function(n) { if(config.multitree && !('$orn' in n.data) && GUtil.anySubnode(n, function(ch){ return ch.exist && !ch.drawn; })) { nodeArray.push(n); } else if(n.drawn && !GUtil.anySubnode(n, "drawn")) { nodeArray.push(n); } }); return nodeArray; }; //Now define the actual class. return new Class({ Implements: Loader, initialize: function(canvas, controller) { var innerController = { onBeforeCompute: $empty, onAfterCompute: $empty, onCreateLabel: $empty, onPlaceLabel: $empty, onComplete: $empty, onBeforePlotNode:$empty, onAfterPlotNode: $empty, onBeforePlotLine:$empty, onAfterPlotLine: $empty, request: false }; var config= { orientation: "left", labelContainer: canvas.id + '-label', levelsToShow: 2, subtreeOffset: 8, siblingOffset: 5, levelDistance: 30, withLabels: true, clearCanvas: true, align: "center", indent:10, multitree: false, constrained: true, Node: { overridable: false, type: 'rectangle', color: '#ccb', lineWidth: 1, height: 20, width: 90, dim: 15, align: "center" }, Edge: { overridable: false, type: 'line', color: '#ccc', dim: 15, lineWidth: 1 }, duration: 700, fps: 25, transition: Trans.Quart.easeInOut }; this.controller = this.config = $merge(config, innerController, controller); this.canvas = canvas; this.graphOptions = { 'complex': true }; this.graph = new Graph(this.graphOptions); this.fx = new ST.Plot(this); this.op = new ST.Op(this); this.group = new ST.Group(this); this.geom = new ST.Geom(this); this.clickedNode= null; }, /* Method: plot Plots the tree. Usually this method is called right after computing nodes' positions. */ plot: function() { this.fx.plot(this.controller); }, /* Method: switchPosition Switches the tree orientation. Parameters: pos - The new tree orientation. Possible values are "top", "left", "right" and "bottom". method - Set this to "animate" if you want to animate the tree when switching its position. You can also set this parameter to "replot" to just replot the subtree. onComplete - _optional_ This callback is called once the "switching" animation is complete. Example: (start code js) st.switchPosition("right", "animate", { onComplete: function() { alert('completed!'); } }); (end code) */ switchPosition: function(pos, method, onComplete) { var Geom = this.geom, Plot = this.fx, that = this; if(!Plot.busy) { Plot.busy = true; this.contract({ onComplete: function() { Geom.switchOrientation(pos); that.compute('endPos', false); Plot.busy = false; if(method == 'animate') { that.onClick(that.clickedNode.id, onComplete); } else if(method == 'replot') { that.select(that.clickedNode.id, onComplete); } } }, pos); } }, /* Method: switchAlignment Switches the tree alignment. Parameters: align - The new tree alignment. Possible values are "left", "center" and "right". method - Set this to "animate" if you want to animate the tree after aligning its position. You can also set this parameter to "replot" to just replot the subtree. onComplete - _optional_ This callback is called once the "switching" animation is complete. Example: (start code js) st.switchAlignment("right", "animate", { onComplete: function() { alert('completed!'); } }); (end code) */ switchAlignment: function(align, method, onComplete) { this.config.align = align; if(method == 'animate') { this.select(this.clickedNode.id, onComplete); } else if(method == 'replot') { this.onClick(this.clickedNode.id, onComplete); } }, /* Method: addNodeInPath Adds a node to the current path as selected node. This node will be visible (as in non-collapsed) at all times. Parameters: id - A id. Example: (start code js) st.addNodeInPath("somenodeid"); (end code) */ addNodeInPath: function(id) { nodesInPath.push(id); this.select((this.clickedNode && this.clickedNode.id) || this.root); }, /* Method: clearNodesInPath Removes all nodes tagged as selected by the method. See also: Example: (start code js) st.clearNodesInPath(); (end code) */ clearNodesInPath: function(id) { nodesInPath.length = 0; this.select((this.clickedNode && this.clickedNode.id) || this.root); }, /* Method: refresh Computes nodes' positions and replots the tree. */ refresh: function() { this.reposition(); this.select((this.clickedNode && this.clickedNode.id) || this.root); }, reposition: function() { Graph.Util.computeLevels(this.graph, this.root, 0, "ignore"); this.geom.setRightLevelToShow(this.clickedNode, this.canvas); Graph.Util.eachNode(this.graph, function(n) { if(n.exist) n.drawn = true; }); this.compute('endPos'); }, /* Method: compute Computes nodes' positions. */ compute: function (property, computeLevels) { var prop = property || 'startPos'; var node = this.graph.getNode(this.root); $extend(node, { 'drawn':true, 'exist':true, 'selected':true }); if(!!computeLevels || !("_depth" in node)) Graph.Util.computeLevels(this.graph, this.root, 0, "ignore"); this.computePositions(node, prop); }, computePositions: function(node, prop) { var config = this.config; var multitree = config.multitree; var align = config.align; var indent = align !== 'center' && config.indent; var orn = config.orientation; var orns = multitree? ['top', 'right', 'bottom', 'left'] : [orn]; var that = this; $each(orns, function(orn) { //calculate layout design(that.graph, node, prop, that.config, orn); var i = ['x', 'y'][+(orn == "left" || orn == "right")]; //absolutize (function red(node) { Graph.Util.eachSubnode(node, function(n) { if(n.exist && (!multitree || ('$orn' in n.data) && n.data.$orn == orn)) { n[prop][i] += node[prop][i]; if(indent) { n[prop][i] += align == 'left'? indent : -indent; } red(n); } }); })(node); }); }, requestNodes: function(node, onComplete) { var handler = $merge(this.controller, onComplete), lev = this.config.levelsToShow, GUtil = Graph.Util; if(handler.request) { var leaves = [], d = node._depth; GUtil.eachLevel(node, 0, lev, function(n) { if(n.drawn && !GUtil.anySubnode(n)) { leaves.push(n); n._level = lev - (n._depth - d); } }); this.group.requestNodes(leaves, handler); } else handler.onComplete(); }, contract: function(onComplete, switched) { var orn = this.config.orientation; var Geom = this.geom, Group = this.group; if(switched) Geom.switchOrientation(switched); var nodes = getNodesToHide.call(this); if(switched) Geom.switchOrientation(orn); Group.contract(nodes, $merge(this.controller, onComplete)); }, move: function(node, onComplete) { this.compute('endPos', false); var move = onComplete.Move, offset = { 'x': move.offsetX, 'y': move.offsetY }; if(move.enable) { this.geom.translate(node.endPos.add(offset).$scale(-1), "endPos"); } this.fx.animate($merge(this.controller, { modes: ['linear'] }, onComplete)); }, expand: function (node, onComplete) { var nodeArray = getNodesToShow.call(this, node); this.group.expand(nodeArray, $merge(this.controller, onComplete)); }, selectPath: function(node) { var GUtil = Graph.Util, that = this; GUtil.eachNode(this.graph, function(n) { n.selected = false; }); function path(node) { if(node == null || node.selected) return; node.selected = true; $each(that.group.getSiblings([node])[node.id], function(n) { n.exist = true; n.drawn = true; }); var parents = GUtil.getParents(node); parents = (parents.length > 0)? parents[0] : null; path(parents); }; for(var i=0, ns = [node.id].concat(nodesInPath); i < ns.length; i++) { path(this.graph.getNode(ns[i])); } }, /* Method: setRoot Switches the current root node. Parameters: id - The id of the node to be set as root. method - Set this to "animate" if you want to animate the tree after adding the subtree. You can also set this parameter to "replot" to just replot the subtree. onComplete - _optional_ An action to perform after the animation (if any). Example: (start code js) st.setRoot('my_node_id', 'animate', { onComplete: function() { alert('complete!'); } }); (end code) */ setRoot: function(id, method, onComplete) { var that = this, canvas = this.canvas; var rootNode = this.graph.getNode(this.root); var clickedNode = this.graph.getNode(id); function $setRoot() { if(this.config.multitree && clickedNode.data.$orn) { var orn = clickedNode.data.$orn; var opp = { 'left': 'right', 'right': 'left', 'top': 'bottom', 'bottom': 'top' }[orn]; rootNode.data.$orn = opp; (function tag(rootNode) { Graph.Util.eachSubnode(rootNode, function(n) { if(n.id != id) { n.data.$orn = opp; tag(n); } }); })(rootNode); delete clickedNode.data.$orn; } this.root = id; this.clickedNode = clickedNode; Graph.Util.computeLevels(this.graph, this.root, 0, "ignore"); } //delete previous orientations (if any) delete rootNode.data.$orns; if(method == 'animate') { this.onClick(id, { onBeforeMove: function() { $setRoot.call(that); that.selectPath(clickedNode); } }); } else if(method == 'replot') { $setRoot.call(this); this.select(this.root); } }, /* Method: addSubtree Adds a subtree, performing optionally an animation. Parameters: subtree - A JSON Tree object. See also . method - Set this to "animate" if you want to animate the tree after adding the subtree. You can also set this parameter to "replot" to just replot the subtree. onComplete - _optional_ An action to perform after the animation (if any). Example: (start code js) st.addSubtree(json, 'animate', { onComplete: function() { alert('complete!'); } }); (end code) */ addSubtree: function(subtree, method, onComplete) { if(method == 'replot') { this.op.sum(subtree, $extend({ type: 'replot' }, onComplete || {})); } else if (method == 'animate') { this.op.sum(subtree, $extend({ type: 'fade:seq' }, onComplete || {})); } }, /* Method: removeSubtree Removes a subtree, performing optionally an animation. Parameters: id - The _id_ of the subtree to be removed. removeRoot - Remove the root of the subtree or only its subnodes. method - Set this to "animate" if you want to animate the tree after removing the subtree. You can also set this parameter to "replot" to just replot the subtree. onComplete - _optional_ An action to perform after the animation (if any). Example: (start code js) st.removeSubtree('idOfSubtreeToBeRemoved', false, 'animate', { onComplete: function() { alert('complete!'); } }); (end code) */ removeSubtree: function(id, removeRoot, method, onComplete) { var node = this.graph.getNode(id), subids = []; Graph.Util.eachLevel(node, +!removeRoot, false, function(n) { subids.push(n.id); }); if(method == 'replot') { this.op.removeNode(subids, $extend({ type: 'replot' }, onComplete || {})); } else if (method == 'animate') { this.op.removeNode(subids, $extend({ type: 'fade:seq'}, onComplete || {})); } }, /* Method: select Selects a sepecific node in the Spacetree without performing an animation. Useful when selecting nodes which are currently hidden or deep inside the tree. Parameters: id - The id of the node to select. onComplete - _optional_ onComplete callback. Example: (start code js) st.select('mynodeid', { onComplete: function() { alert('complete!'); } }); (end code) */ select: function(id, onComplete) { var group = this.group, geom = this.geom; var node= this.graph.getNode(id), canvas = this.canvas; var root = this.graph.getNode(this.root); var complete = $merge(this.controller, onComplete); var that = this; complete.onBeforeCompute(node); this.selectPath(node); this.clickedNode= node; this.requestNodes(node, { onComplete: function(){ group.hide(group.prepare(getNodesToHide.call(that)), complete); geom.setRightLevelToShow(node, canvas); that.compute("pos"); Graph.Util.eachNode(that.graph, function(n) { var pos = n.pos.getc(true); n.startPos.setc(pos.x, pos.y); n.endPos.setc(pos.x, pos.y); n.visited = false; }); that.geom.translate(node.endPos.scale(-1), ["pos", "startPos", "endPos"]); group.show(getNodesToShow.call(that)); that.plot(); complete.onAfterCompute(that.clickedNode); complete.onComplete(); } }); }, /* Method: onClick This method is called when clicking on a tree node. It mainly performs all calculations and the animation of contracting, translating and expanding pertinent nodes. Parameters: id - A node id. options - A group of options and callbacks such as - _onComplete_ an object callback called when the animation finishes. - _Move_ an object that has as properties _offsetX_ or _offsetY_ for adding some offset position to the centered node. Example: (start code js) st.onClick('mynodeid', { Move: { enable: true, offsetX: 30, offsetY: 5 }, onComplete: function() { alert('yay!'); } }); (end code) */ onClick: function (id, options) { var canvas = this.canvas, that = this, Fx = this.fx, Util = Graph.Util, Geom = this.geom; var innerController = { Move: { enable: true, offsetX: 0, offsetY: 0 }, onBeforeRequest: $empty, onBeforeContract: $empty, onBeforeMove: $empty, onBeforeExpand: $empty }; var complete = $merge(this.controller, innerController, options); if(!this.busy) { this.busy= true; var node= this.graph.getNode(id); this.selectPath(node, this.clickedNode); this.clickedNode= node; complete.onBeforeCompute(node); complete.onBeforeRequest(node); this.requestNodes(node, { onComplete: function() { complete.onBeforeContract(node); that.contract({ onComplete: function() { Geom.setRightLevelToShow(node, canvas); complete.onBeforeMove(node); that.move(node, { Move: complete.Move, onComplete: function() { complete.onBeforeExpand(node); that.expand(node, { onComplete: function() { that.busy = false; complete.onAfterCompute(id); complete.onComplete(); } }); //expand } }); //move } });//contract } });//request } } }); })(); /* Class: ST.Op Performs advanced operations on trees and graphs. Extends: All methods Access: This instance can be accessed with the _op_ parameter of the st instance created. Example: (start code js) var st = new ST(canvas, config); st.op.morph //or can also call any other method (end code) */ ST.Op = new Class({ Implements: Graph.Op, initialize: function(viz) { this.viz = viz; } }); /* Performs operations on group of nodes. */ ST.Group = new Class({ initialize: function(viz) { this.viz = viz; this.canvas = viz.canvas; this.config = viz.config; this.animation = new Animation; this.nodes = null; }, /* Calls the request method on the controller to request a subtree for each node. */ requestNodes: function(nodes, controller) { var counter = 0, len = nodes.length, nodeSelected = {}; var complete = function() { controller.onComplete(); }; var viz = this.viz; if(len == 0) complete(); for(var i=0; i= b._depth); }); for(var i=0; i 0 && n.drawn) { n.drawn = false; nds[node.id].push(n); } else if((!root || !orns) && n.drawn) { n.drawn = false; nds[node.id].push(n); } }); node.drawn = true; } //plot the whole (non-scaled) tree if(nodes.length > 0) viz.fx.plot(); //show nodes that were previously hidden for(i in nds) { $each(nds[i], function(n) { n.drawn = true; }); } //plot each scaled subtree for(i=0; i method (end code) */ ST.Geom = new Class({ initialize: function(viz) { this.viz = viz; this.config = viz.config; this.node = viz.config.Node; this.edge = viz.config.Edge; }, /* Method: translate Applies a translation to the tree. Parameters: pos - A number specifying translation vector. prop - A position property ('pos', 'startPos' or 'endPos'). Example: (start code js) st.geom.translate(new Complex(300, 100), 'endPos'); (end code) */ translate: function(pos, prop) { prop = $splat(prop); Graph.Util.eachNode(this.viz.graph, function(elem) { $each(prop, function(p) { elem[p].$add(pos); }); }); }, /* Changes the tree current orientation to the one specified. You should usually use instead. */ switchOrientation: function(orn) { this.config.orientation = orn; }, /* Makes a value dispatch according to the current layout Works like a CSS property, either _top-right-bottom-left_ or _top|bottom - left|right_. */ dispatch: function() { //TODO(nico) should store Array.prototype.slice.call somewhere. var args = Array.prototype.slice.call(arguments); var s = args.shift(), len = args.length; var val = function(a) { return typeof a == 'function'? a() : a; }; if(len == 2) { return (s == "top" || s == "bottom")? val(args[0]) : val(args[1]); } else if(len == 4) { switch(s) { case "top": return val(args[0]); case "right": return val(args[1]); case "bottom": return val(args[2]); case "left": return val(args[3]); } } return undefined; }, /* Returns label height or with, depending on the tree current orientation. */ getSize: function(n, invert) { var node = this.node, data = n.data, config = this.config; var cond = node.overridable, siblingOffset = config.siblingOffset; var s = (this.config.multitree && ('$orn' in n.data) && n.data.$orn) || this.config.orientation; var w = (cond && data.$width || node.width) + siblingOffset; var h = (cond && data.$height || node.height) + siblingOffset; if(!invert) return this.dispatch(s, h, w); else return this.dispatch(s, w, h); }, /* Calculates a subtree base size. This is an utility function used by _getBaseSize_ */ getTreeBaseSize: function(node, level, leaf) { var size = this.getSize(node, true), baseHeight = 0, that = this; if(leaf(level, node)) return size; if(level === 0) return 0; Graph.Util.eachSubnode(node, function(elem) { baseHeight += that.getTreeBaseSize(elem, level -1, leaf); }); return (size > baseHeight? size : baseHeight) + this.config.subtreeOffset; }, /* Method: getEdge Returns a Complex instance with the begin or end position of the edge to be plotted. Parameters: node - A that is connected to this edge. type - Returns the begin or end edge position. Possible values are 'begin' or 'end'. Returns: A number specifying the begin or end position. */ getEdge: function(node, type, s) { var $C = function(a, b) { return function(){ return node.pos.add(new Complex(a, b)); }; }; var dim = this.node; var cond = this.node.overridable, data = node.data; var w = cond && data.$width || dim.width; var h = cond && data.$height || dim.height; if(type == 'begin') { if(dim.align == "center") { return this.dispatch(s, $C(0, h/2), $C(-w/2, 0), $C(0, -h/2),$C(w/2, 0)); } else if(dim.align == "left") { return this.dispatch(s, $C(0, h), $C(0, 0), $C(0, 0), $C(w, 0)); } else if(dim.align == "right") { return this.dispatch(s, $C(0, 0), $C(-w, 0), $C(0, -h),$C(0, 0)); } else throw "align: not implemented"; } else if(type == 'end') { if(dim.align == "center") { return this.dispatch(s, $C(0, -h/2), $C(w/2, 0), $C(0, h/2), $C(-w/2, 0)); } else if(dim.align == "left") { return this.dispatch(s, $C(0, 0), $C(w, 0), $C(0, h), $C(0, 0)); } else if(dim.align == "right") { return this.dispatch(s, $C(0, -h),$C(0, 0), $C(0, 0), $C(-w, 0)); } else throw "align: not implemented"; } }, /* Adjusts the tree position due to canvas scaling or translation. */ getScaledTreePosition: function(node, scale) { var dim = this.node; var cond = this.node.overridable, data = node.data; var w = (cond && data.$width || dim.width); var h = (cond && data.$height || dim.height); var s = (this.config.multitree && ('$orn' in node.data) && node.data.$orn) || this.config.orientation; var $C = function(a, b) { return function(){ return node.pos.add(new Complex(a, b)).$scale(1 - scale); }; }; if(dim.align == "left") { return this.dispatch(s, $C(0, h), $C(0, 0), $C(0, 0), $C(w, 0)); } else if(dim.align == "center") { return this.dispatch(s, $C(0, h / 2), $C(-w / 2, 0), $C(0, -h / 2),$C(w / 2, 0)); } else if(dim.align == "right") { return this.dispatch(s, $C(0, 0), $C(-w, 0), $C(0, -h),$C(0, 0)); } else throw "align: not implemented"; }, /* Method: treeFitsInCanvas Returns a Boolean if the current subtree fits in canvas. Parameters: node - A which is the current root of the subtree. canvas - The object. level - The depth of the subtree to be considered. */ treeFitsInCanvas: function(node, canvas, level) { var csize = canvas.getSize(node); var s = (this.config.multitree && ('$orn' in node.data) && node.data.$orn) || this.config.orientation; var size = this.dispatch(s, csize.width, csize.height); var baseSize = this.getTreeBaseSize(node, level, function(level, node) { return level === 0 || !Graph.Util.anySubnode(node); }); return (baseSize < size); }, /* Hides levels of the tree until it properly fits in canvas. */ setRightLevelToShow: function(node, canvas) { var level = this.getRightLevelToShow(node, canvas), fx = this.viz.fx; Graph.Util.eachLevel(node, 0, this.config.levelsToShow, function(n) { var d = n._depth - node._depth; if(d > level) { n.drawn = false; n.exist = false; fx.hideLabel(n, false); } else { n.exist = true; } }); node.drawn= true; }, /* Returns the right level to show for the current tree in order to fit in canvas. */ getRightLevelToShow: function(node, canvas) { var config = this.config; var level = config.levelsToShow; var constrained = config.constrained; if(!constrained) return level; while(!this.treeFitsInCanvas(node, canvas, level) && level > 1) { level-- ; } return level; } }); /* Object: ST.Plot Performs plotting operations. Extends: All methods Access: This instance can be accessed with the _fx_ parameter of the st instance created. Example: (start code js) var st = new ST(canvas, config); st.fx.placeLabel //or can also call any other method (end code) */ ST.Plot = new Class({ Implements: Graph.Plot, initialize: function(viz) { this.viz = viz; this.config = viz.config; this.node = this.config.Node; this.edge = this.config.Edge; this.animation = new Animation; this.nodeTypes = new ST.Plot.NodeTypes; this.edgeTypes = new ST.Plot.EdgeTypes; }, /* Plots a subtree from the spacetree. */ plotSubtree: function(node, opt, scale, animating) { var viz = this.viz, canvas = viz.canvas; scale = Math.min(Math.max(0.001, scale), 1); if(scale >= 0) { node.drawn = false; var ctx = canvas.getCtx(); var diff = viz.geom.getScaledTreePosition(node, scale); ctx.translate(diff.x, diff.y); ctx.scale(scale, scale); } this.plotTree(node, !scale, opt, animating); if(scale >= 0) node.drawn = true; }, /* Plots a Subtree. */ plotTree: function(node, plotLabel, opt, animating) { var that = this, viz = this.viz, canvas = viz.canvas, config = this.config, ctx = canvas.getCtx(); var root = config.multitree && !('$orn' in node.data); var orns = root && node.data.$orns; Graph.Util.eachSubnode(node, function(elem) { //multitree root node check if((!root || orns.indexOf(elem.data.$orn) > 0) && elem.exist && elem.drawn) { var adj = node.getAdjacency(elem.id); !animating && opt.onBeforePlotLine(adj); ctx.globalAlpha = Math.min(node.alpha, elem.alpha); that.plotLine(adj, canvas, animating); !animating && opt.onAfterPlotLine(adj); that.plotTree(elem, plotLabel, opt, animating); } }); if(node.drawn) { ctx.globalAlpha = node.alpha; !animating && opt.onBeforePlotNode(node); this.plotNode(node, canvas, animating); !animating && opt.onAfterPlotNode(node); if(plotLabel && ctx.globalAlpha >= 0.95) this.plotLabel(canvas, node, opt); else this.hideLabel(node, false); } else { this.hideLabel(node, true); } }, /* Method: placeLabel Overrides abstract method placeLabel in . Parameters: tag - A DOM label element. node - A . controller - A configuration/controller object passed to the visualization. */ placeLabel: function(tag, node, controller) { var pos = node.pos.getc(true), dim = this.node, canvas = this.viz.canvas; var w = dim.overridable && node.data.$width || dim.width; var h = dim.overridable && node.data.$height || dim.height; var radius = canvas.getSize(); var labelPos, orn; if(dim.align == "center") { labelPos= { x: Math.round(pos.x - w / 2 + radius.width/2), y: Math.round(pos.y - h / 2 + radius.height/2) }; } else if (dim.align == "left") { orn = this.config.orientation; if(orn == "bottom" || orn == "top") { labelPos= { x: Math.round(pos.x - w / 2 + radius.width/2), y: Math.round(pos.y + radius.height/2) }; } else { labelPos= { x: Math.round(pos.x + radius.width/2), y: Math.round(pos.y - h / 2 + radius.height/2) }; } } else if(dim.align == "right") { orn = this.config.orientation; if(orn == "bottom" || orn == "top") { labelPos= { x: Math.round(pos.x - w / 2 + radius.width/2), y: Math.round(pos.y - h + radius.height/2) }; } else { labelPos= { x: Math.round(pos.x - w + radius.width/2), y: Math.round(pos.y - h / 2 + radius.height/2) }; } } else throw "align: not implemented"; var style = tag.style; style.left = labelPos.x + 'px'; style.top = labelPos.y + 'px'; style.display = this.fitsInCanvas(labelPos, canvas)? '' : 'none'; controller.onPlaceLabel(tag, node); }, getAlignedPos: function(pos, width, height) { var nconfig = this.node; var square, orn; if(nconfig.align == "center") { square = { x: pos.x - width / 2, y: pos.y - height / 2 }; } else if (nconfig.align == "left") { orn = this.config.orientation; if(orn == "bottom" || orn == "top") { square = { x: pos.x - width / 2, y: pos.y }; } else { square = { x: pos.x, y: pos.y - height / 2 }; } } else if(nconfig.align == "right") { orn = this.config.orientation; if(orn == "bottom" || orn == "top") { square = { x: pos.x - width / 2, y: pos.y - height }; } else { square = { x: pos.x - width, y: pos.y - height / 2 }; } } else throw "align: not implemented"; return square; }, getOrientation: function(adj) { var config = this.config; var orn = config.orientation; if(config.multitree) { var nodeFrom = adj.nodeFrom; var nodeTo = adj.nodeTo; orn = (('$orn' in nodeFrom.data) && nodeFrom.data.$orn) || (('$orn' in nodeTo.data) && nodeTo.data.$orn); } return orn; } }); /* Class: ST.Plot.NodeTypes Here are implemented all kinds of node rendering functions. Rendering functions implemented are 'none', 'circle', 'ellipse', 'rectangle' and 'square'. You can add new Node types by implementing a new method in this class Example: (start code js) ST.Plot.NodeTypes.implement({ 'newnodetypename': function(node, canvas) { //Render my node here. } }); (end code) */ ST.Plot.NodeTypes = new Class({ 'none': function() {}, 'circle': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var cond = nconfig.overridable && data; var dim = cond && data.$dim || nconfig.dim; var algnPos = this.getAlignedPos(pos, dim * 2, dim * 2); canvas.path('fill', function(context) { context.arc(algnPos.x + dim, algnPos.y + dim, dim, 0, Math.PI * 2, true); }); }, 'square': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var cond = nconfig.overridable && data; var dim = cond && data.$dim || nconfig.dim; var algnPos = this.getAlignedPos(pos, dim, dim); canvas.getCtx().fillRect(algnPos.x, algnPos.y, dim, dim); }, 'ellipse': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var cond = nconfig.overridable && data; var width = (cond && data.$width || nconfig.width) / 2; var height = (cond && data.$height || nconfig.height) / 2; var algnPos = this.getAlignedPos(pos, width * 2, height * 2); var ctx = canvas.getCtx(); ctx.save(); ctx.scale(width / height, height / width); canvas.path('fill', function(context) { context.arc((algnPos.x + width) * (height / width), (algnPos.y + height) * (width / height), height, 0, Math.PI * 2, true); }); ctx.restore(); }, 'rectangle': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var cond = nconfig.overridable && data; var width = cond && data.$width || nconfig.width; var height = cond && data.$height || nconfig.height; var algnPos = this.getAlignedPos(pos, width, height); canvas.getCtx().fillRect(algnPos.x, algnPos.y, width, height); } }); /* Class: ST.Plot.EdgeTypes Here are implemented all kinds of edge rendering functions. Rendering functions implemented are 'none', 'line', 'quadratic:begin', 'quadratic:end', 'bezier' and 'arrow'. You can add new Edge types by implementing a new method in this class Example: (start code js) ST.Plot.EdgeTypes.implement({ 'newedgetypename': function(adj, canvas) { //Render my edge here. } }); (end code) */ ST.Plot.EdgeTypes = new Class({ 'none': function() {}, 'line': function(adj, canvas) { var orn = this.getOrientation(adj); var nodeFrom = adj.nodeFrom, nodeTo = adj.nodeTo; var begin = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeFrom:nodeTo, 'begin', orn); var end = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeTo:nodeFrom, 'end', orn); canvas.path('stroke', function(ctx) { ctx.moveTo(begin.x, begin.y); ctx.lineTo(end.x, end.y); }); }, 'quadratic:begin': function(adj, canvas) { var orn = this.getOrientation(adj); var data = adj.data, econfig = this.edge; var nodeFrom = adj.nodeFrom, nodeTo = adj.nodeTo; var begin = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeFrom:nodeTo, 'begin', orn); var end = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeTo:nodeFrom, 'end', orn); var cond = econfig.overridable && data; var dim = cond && data.$dim || econfig.dim; switch(orn) { case "left": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(begin.x + dim, begin.y, end.x, end.y); }); break; case "right": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(begin.x - dim, begin.y, end.x, end.y); }); break; case "top": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(begin.x, begin.y + dim, end.x, end.y); }); break; case "bottom": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(begin.x, begin.y - dim, end.x, end.y); }); break; } }, 'quadratic:end': function(adj, canvas) { var orn = this.getOrientation(adj); var data = adj.data, econfig = this.edge; var nodeFrom = adj.nodeFrom, nodeTo = adj.nodeTo; var begin = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeFrom:nodeTo, 'begin', orn); var end = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeTo:nodeFrom, 'end', orn); var cond = econfig.overridable && data; var dim = cond && data.$dim || econfig.dim; switch(orn) { case "left": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(end.x - dim, end.y, end.x, end.y); }); break; case "right": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(end.x + dim, end.y, end.x, end.y); }); break; case "top": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(end.x, end.y - dim, end.x, end.y); }); break; case "bottom": canvas.path('stroke', function(ctx){ ctx.moveTo(begin.x, begin.y); ctx.quadraticCurveTo(end.x, end.y + dim, end.x, end.y); }); break; } }, 'bezier': function(adj, canvas) { var data = adj.data, econfig = this.edge; var orn = this.getOrientation(adj); var nodeFrom = adj.nodeFrom, nodeTo = adj.nodeTo; var begin = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeFrom:nodeTo, 'begin', orn); var end = this.viz.geom.getEdge(nodeFrom._depth < nodeTo._depth? nodeTo:nodeFrom, 'end', orn); var cond = econfig.overridable && data; var dim = cond && data.$dim || econfig.dim; switch(orn) { case "left": canvas.path('stroke', function(ctx) { ctx.moveTo(begin.x, begin.y); ctx.bezierCurveTo(begin.x + dim, begin.y, end.x - dim, end.y, end.x, end.y); }); break; case "right": canvas.path('stroke', function(ctx) { ctx.moveTo(begin.x, begin.y); ctx.bezierCurveTo(begin.x - dim, begin.y, end.x + dim, end.y, end.x, end.y); }); break; case "top": canvas.path('stroke', function(ctx) { ctx.moveTo(begin.x, begin.y); ctx.bezierCurveTo(begin.x, begin.y + dim, end.x, end.y - dim, end.x, end.y); }); break; case "bottom": canvas.path('stroke', function(ctx) { ctx.moveTo(begin.x, begin.y); ctx.bezierCurveTo(begin.x, begin.y - dim, end.x, end.y + dim, end.x, end.y); }); break; } }, 'arrow': function(adj, canvas) { var orn = this.getOrientation(adj); var node = adj.nodeFrom, child = adj.nodeTo; var data = adj.data, econfig = this.edge; //get edge dim var cond = econfig.overridable && data; var edgeDim = cond && data.$dim || econfig.dim; //get edge direction if(cond && data.$direction && data.$direction.length > 1) { var nodeHash = {}; nodeHash[node.id] = node; nodeHash[child.id] = child; var sense = data.$direction; node = nodeHash[sense[0]]; child = nodeHash[sense[1]]; } var posFrom = this.viz.geom.getEdge(node, 'begin', orn); var posTo = this.viz.geom.getEdge(child, 'end', orn); var vect = new Complex(posTo.x - posFrom.x, posTo.y - posFrom.y); vect.$scale(edgeDim / vect.norm()); var intermediatePoint = new Complex(posTo.x - vect.x, posTo.y - vect.y); var normal = new Complex(-vect.y / 2, vect.x / 2); var v1 = intermediatePoint.add(normal), v2 = intermediatePoint.$add(normal.$scale(-1)); canvas.path('stroke', function(context) { context.moveTo(posFrom.x, posFrom.y); context.lineTo(posTo.x, posTo.y); }); canvas.path('fill', function(context) { context.moveTo(v1.x, v1.y); context.lineTo(v2.x, v2.y); context.lineTo(posTo.x, posTo.y); }); } }); })(); /* * File: AngularWidth.js * * Provides utility methods for calculating angular widths. * * Implemented by: * * , * */ /* Object: AngularWidth Provides utility methods for calculating angular widths. */ var AngularWidth = { /* Method: setAngularWidthForNodes Sets nodes angular widths. */ setAngularWidthForNodes: function() { var config = this.config.Node; var overridable = config.overridable; var dim = config.dim; Graph.Util.eachBFS(this.graph, this.root, function(elem, i) { var diamValue = (overridable && elem.data && elem.data.$aw) || dim; elem._angularWidth = diamValue / i; }, "ignore"); }, /* Method: setSubtreesAngularWidth Sets subtrees angular widths. */ setSubtreesAngularWidth: function() { var that = this; Graph.Util.eachNode(this.graph, function(elem) { that.setSubtreeAngularWidth(elem); }, "ignore"); }, /* Method: setSubtreeAngularWidth Sets the angular width for a subtree. */ setSubtreeAngularWidth: function(elem) { var that = this, nodeAW = elem._angularWidth, sumAW = 0; Graph.Util.eachSubnode(elem, function(child) { that.setSubtreeAngularWidth(child); sumAW += child._treeAngularWidth; }, "ignore"); elem._treeAngularWidth = Math.max(nodeAW, sumAW); }, /* Method: computeAngularWidths Computes nodes and subtrees angular widths. */ computeAngularWidths: function () { this.setAngularWidthForNodes(); this.setSubtreesAngularWidth(); } }; /* * File: RGraph.js * * Implements the class and other derived classes. * * Description: * * A radial layout of a tree puts the root node on the center of the canvas, places its children on the first concentric ring away from the root node, its grandchildren on a second concentric ring, and so on... * * Ka-Ping Yee, Danyel Fisher, Rachna Dhamija and Marti Hearst introduced a very interesting paper called "Animated Exploration of Dynamic Graphs with Radial Layout". In this paper they describe a way to animate a radial layout of a tree with ease-in and ease-out transitions, which make transitions from a graph's state to another easier to understand for the viewer. * * Inspired by: * * Animated Exploration of Dynamic Graphs with Radial Layout (Ka-Ping Yee, Danyel Fisher, Rachna Dhamija, Marti Hearst) * * * * Disclaimer: * * This visualization was built from scratch, taking only the paper as inspiration, and only shares some features with this paper. * * */ /* Class: RGraph The main RGraph class Extends: , Parameters: canvas - A Class config - A configuration/controller object. Configuration: The configuration object can have the following properties (all properties are optional and have a default value) *General* - _interpolation_ Interpolation type used for animations. Possible options are 'polar' and 'linear'. Default's 'linear'. - _levelDistance_ Distance between a parent node and its children. Default's 100. - _withLabels_ Whether the visualization should use/create labels or not. Default's *true*. *Node* Customize the visualization nodes' shape, color, and other style properties. - _Node_ This object has as properties - _overridable_ Determine whether or not nodes properties can be overriden by a particular node. Default's false. If given a JSON tree or graph, a node _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the node properties will override the global node properties. - _type_ Node type (shape). Possible options are "none", "square", "rectangle", "circle", "triangle", "star". Default's "circle". - _color_ Node color. Default's '#ccb'. - _lineWidth_ Line width. If nodes aren't drawn with strokes then this property won't be of any use. Default's 1. - _height_ Node height. Used for plotting rectangular nodes. Default's 5. - _width_ Node width. Used for plotting rectangular nodes. Default's 5. - _dim_ An extra parameter used by other complex shapes such as square and circle to determine the shape's diameter. Default's 3. *Edge* Customize the visualization edges' shape, color, and other style properties. - _Edge_ This object has as properties - _overridable_ Determine whether or not edges properties can be overriden by a particular edge object. Default's false. If given a JSON _complex_ graph (defined in ), an adjacency _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the adjacency properties will override the global edge properties. - _type_ Edge type (shape). Possible options are "none", "line" and "arrow". Default's "line". - _color_ Edge color. Default's '#ccb'. - _lineWidth_ Line width. If edges aren't drawn with strokes then this property won't be of any use. Default's 1. *Animations* - _duration_ Duration of the animation in milliseconds. Default's 2500. - _fps_ Frames per second. Default's 40. - _transition_ One of the transitions defined in the class. Default's Quart.easeInOut. - _clearCanvas_ Whether to clear canvas on each animation frame or not. Default's true. *Controller options* You can also implement controller functions inside the configuration object. This functions are - _onBeforeCompute(node)_ This method is called right before performing all computation and animations to the JIT visualization. - _onAfterCompute()_ This method is triggered right after all animations or computations for the JIT visualizations ended. - _onCreateLabel(domElement, node)_ This method receives the label dom element as first parameter, and the corresponding as second parameter. This method will only be called on label creation. Note that a is a node from the input tree/graph you provided to the visualization. If you want to know more about what kind of JSON tree/graph format is used to feed the visualizations, you can take a look at . This method proves useful when adding events to the labels used by the JIT. - _onPlaceLabel(domElement, node)_ This method receives the label dom element as first parameter and the corresponding as second parameter. This method is called each time a label has been placed on the visualization, and thus it allows you to update the labels properties, such as size or position. Note that onPlaceLabel will be triggered after updating the labels positions. That means that, for example, the left and top css properties are already updated to match the nodes positions. - _onBeforePlotNode(node)_ This method is triggered right before plotting a given node. The _node_ parameter is the to be plotted. This method is useful for changing a node style right before plotting it. - _onAfterPlotNode(node)_ This method is triggered right after plotting a given node. The _node_ parameter is the plotted. - _onBeforePlotLine(adj)_ This method is triggered right before plotting an edge. The _adj_ parameter is a object. This method is useful for adding some styles to a particular edge before being plotted. - _onAfterPlotLine(adj)_ This method is triggered right after plotting an edge. The _adj_ parameter is the plotted. Example: Here goes a complete example. In most cases you won't be forced to implement all properties and methods. In fact, all configuration properties have the default value assigned. I won't be instanciating a class here. If you want to know more about instanciating a class please take a look at the class documentation. (start code js) var rgraph = new RGraph(canvas, { interpolation: 'linear', levelDistance: 100, withLabels: true, Node: { overridable: false, type: 'circle', color: '#ccb', lineWidth: 1, height: 5, width: 5, dim: 3 }, Edge: { overridable: false, type: 'line', color: '#ccb', lineWidth: 1 }, duration: 2500, fps: 40, transition: Trans.Quart.easeInOut, clearCanvas: true, onBeforeCompute: function(node) { //do something onBeforeCompute }, onAfterCompute: function () { //do something onAfterCompute }, onCreateLabel: function(domElement, node) { //do something onCreateLabel }, onPlaceLabel: function(domElement, node) { //do something onPlaceLabel }, onBeforePlotNode:function(node) { //do something onBeforePlotNode }, onAfterPlotNode: function(node) { //do something onAfterPlotNode }, onBeforePlotLine:function(adj) { //do something onBeforePlotLine }, onAfterPlotLine: function(adj) { //do something onAfterPlotLine } }); (end code) Instance Properties: - _graph_ Access a instance. - _op_ Access a instance. - _fx_ Access a instance. */ this.RGraph = new Class({ Implements: [Loader, AngularWidth], initialize: function(canvas, controller) { var config= { labelContainer: canvas.id + '-label', interpolation: 'linear', levelDistance: 100, withLabels: true, Node: { overridable: false, type: 'circle', dim: 3, color: '#ccb', width: 5, height: 5, lineWidth: 1 }, Edge: { overridable: false, type: 'line', color: '#ccb', lineWidth: 1 }, fps:40, duration: 2500, transition: Trans.Quart.easeInOut, clearCanvas: true }; var innerController = { onBeforeCompute: $empty, onAfterCompute: $empty, onCreateLabel: $empty, onPlaceLabel: $empty, onComplete: $empty, onBeforePlotLine:$empty, onAfterPlotLine: $empty, onBeforePlotNode:$empty, onAfterPlotNode: $empty }; this.controller = this.config = $merge(config, innerController, controller); this.graphOptions = { 'complex': false, 'Node': { 'selected': false, 'exist': true, 'drawn': true } }; this.graph = new Graph(this.graphOptions); this.fx = new RGraph.Plot(this); this.op = new RGraph.Op(this); this.json = null; this.canvas = canvas; this.root = null; this.busy = false; this.parent = false; }, /* Method: refresh Computes nodes' positions and replots the tree. */ refresh: function() { this.compute(); this.plot(); }, /* Method: reposition An alias for computing new positions to _endPos_ See also: */ reposition: function() { this.compute('endPos'); }, /* Method: plot Plots the RGraph */ plot: function() { this.fx.plot(); }, /* Method: compute Computes nodes' positions. Parameters: property - _optional_ A position property to store the new positions. Possible values are 'pos', 'endPos' or 'startPos'. */ compute: function(property) { var prop = property || ['pos', 'startPos', 'endPos']; var node = this.graph.getNode(this.root); node._depth = 0; Graph.Util.computeLevels(this.graph, this.root, 0, "ignore"); this.computeAngularWidths(); this.computePositions(prop); }, /* computePositions Performs the main algorithm for computing node positions. */ computePositions: function(property) { var propArray = $splat(property); var aGraph = this.graph; var GUtil = Graph.Util; var root = this.graph.getNode(this.root); var parent = this.parent; var config = this.config; for(var i=0; i 0 && subnodes[0].dist) { subnodes.sort(function(a, b) { return (a.dist >= b.dist) - (a.dist <= b.dist); }); } for(var k=0; k < subnodes.length; k++) { var child = subnodes[k]; if(!child._flag) { child._rel = child._treeAngularWidth / totalAngularWidths; var angleProportion = child._rel * angleSpan; var theta = angleInit + angleProportion / 2; for(var i=0; i 0)? ps[0] : false; if(p) { var posParent = p.pos.getc(), posChild = n.pos.getc(); var newPos = posParent.add(posChild.scale(-1)); theta = Math.atan2(newPos.y, newPos.x); if(theta < 0) theta += 2 * Math.PI; } return {parent: p, theta: theta}; }, /* tagChildren Enumerates the children in order to mantain child ordering (second constraint of the paper). */ tagChildren: function(par, id) { if(par.angleSpan) { var adjs = []; Graph.Util.eachAdjacency(par, function(elem) { adjs.push(elem.nodeTo); }, "ignore"); var len = adjs.length; for(var i=0; i < len && id != adjs[i].id; i++); for(var j= (i+1) % len, k = 0; id != adjs[j].id; j = (j+1) % len) { adjs[j].dist = k++; } } }, /* Method: onClick Performs all calculations and animations to center the node specified by _id_. Parameters: id - A id. opt - _optional_ An object containing some extra properties like - _hideLabels_ Hide labels when performing the animation. Default's *true*. Example: (start code js) rgraph.onClick('someid'); //or also... rgraph.onClick('someid', { hideLabels: false }); (end code) */ onClick: function(id, opt) { if(this.root != id && !this.busy) { this.busy = true; this.root = id; that = this; this.controller.onBeforeCompute(this.graph.getNode(id)); var obj = this.getNodeAndParentAngle(id); //second constraint this.tagChildren(obj.parent, id); this.parent = obj.parent; this.compute('endPos'); //first constraint var thetaDiff = obj.theta - obj.parent.endPos.theta; Graph.Util.eachNode(this.graph, function(elem) { elem.endPos.set(elem.endPos.getp().add($P(thetaDiff, 0))); }); var mode = this.config.interpolation; opt = $merge({ onComplete: $empty }, opt || {}); this.fx.animate($merge({ hideLabels: true, modes: [mode] }, opt, { onComplete: function() { that.busy = false; opt.onComplete(); } })); } } }); /* Class: RGraph.Op Performs advanced operations on trees and graphs. Extends: All methods Access: This instance can be accessed with the _op_ parameter of the instance created. Example: (start code js) var rgraph = new RGraph(canvas, config); rgraph.op.morph //or can also call any other method (end code) */ RGraph.Op = new Class({ Implements: Graph.Op, initialize: function(viz) { this.viz = viz; } }); /* Class: RGraph.Plot Performs plotting operations. Extends: All methods Access: This instance can be accessed with the _fx_ parameter of the instance created. Example: (start code js) var rgraph = new RGraph(canvas, config); rgraph.fx.placeLabel //or can also call any other method (end code) */ RGraph.Plot = new Class({ Implements: Graph.Plot, initialize: function(viz) { this.viz = viz; this.config = viz.config; this.node = viz.config.Node; this.edge = viz.config.Edge; this.animation = new Animation; this.nodeTypes = new RGraph.Plot.NodeTypes; this.edgeTypes = new RGraph.Plot.EdgeTypes; }, /* Method: placeLabel Overrides abstract method placeLabel in . Parameters: tag - A DOM label element. node - A . controller - A configuration/controller object passed to the visualization. */ placeLabel: function(tag, node, controller) { var pos = node.pos.getc(true), canvas = this.viz.canvas; var radius= canvas.getSize(); var labelPos= { x: Math.round(pos.x + radius.width/2), y: Math.round(pos.y + radius.height/2) }; var style = tag.style; style.left = labelPos.x + 'px'; style.top = labelPos.y + 'px'; style.display = this.fitsInCanvas(labelPos, canvas)? '' : 'none'; controller.onPlaceLabel(tag, node); } }); /* Class: RGraph.Plot.NodeTypes Here are implemented all kinds of node rendering functions. Rendering functions implemented are 'none', 'circle', 'triangle', 'rectangle', 'star' and 'square'. You can add new Node types by implementing a new method in this class Example: (start code js) RGraph.Plot.NodeTypes.implement({ 'newnodetypename': function(node, canvas) { //Render my node here. } }); (end code) */ RGraph.Plot.NodeTypes = new Class({ 'none': function() {}, 'circle': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; canvas.path('fill', function(context) { context.arc(pos.x, pos.y, nodeDim, 0, Math.PI*2, true); }); }, 'square': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var nodeDim2 = 2 * nodeDim; canvas.getCtx().fillRect(pos.x - nodeDim, pos.y - nodeDim, nodeDim2, nodeDim2); }, 'rectangle': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var width = nconfig.overridable && data && data.$width || nconfig.width; var height = nconfig.overridable && data && data.$height || nconfig.height; canvas.getCtx().fillRect(pos.x - width / 2, pos.y - height / 2, width, height); }, 'triangle': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var c1x = pos.x, c1y = pos.y - nodeDim, c2x = c1x - nodeDim, c2y = pos.y + nodeDim, c3x = c1x + nodeDim, c3y = c2y; canvas.path('fill', function(ctx) { ctx.moveTo(c1x, c1y); ctx.lineTo(c2x, c2y); ctx.lineTo(c3x, c3y); }); }, 'star': function(node, canvas) { var pos = node.pos.getc(true), nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var ctx = canvas.getCtx(), pi5 = Math.PI / 5; ctx.save(); ctx.translate(pos.x, pos.y); ctx.beginPath(); ctx.moveTo(nodeDim, 0); for (var i=0; i<9; i++){ ctx.rotate(pi5); if(i % 2 == 0) { ctx.lineTo((nodeDim / 0.525731) * 0.200811, 0); } else { ctx.lineTo(nodeDim, 0); } } ctx.closePath(); ctx.fill(); ctx.restore(); } }); /* Class: RGraph.Plot.EdgeTypes Here are implemented all kinds of edge rendering functions. Rendering functions implemented are 'none', 'line' and 'arrow'. You can add new Edge types by implementing a new method in this class Example: (start code js) RGraph.Plot.EdgeTypes.implement({ 'newedgetypename': function(adj, canvas) { //Render my edge here. } }); (end code) */ RGraph.Plot.EdgeTypes = new Class({ 'none': function() {}, 'line': function(adj, canvas) { var pos = adj.nodeFrom.pos.getc(true); var posChild = adj.nodeTo.pos.getc(true); canvas.path('stroke', function(context) { context.moveTo(pos.x, pos.y); context.lineTo(posChild.x, posChild.y); }); }, 'arrow': function(adj, canvas) { var node = adj.nodeFrom, child = adj.nodeTo; var data = adj.data, econfig = this.edge; //get edge dim var cond = econfig.overridable && data; var edgeDim = cond && data.$dim || 14; //get edge direction if(cond && data.$direction && data.$direction.length > 1) { var nodeHash = {}; nodeHash[node.id] = node; nodeHash[child.id] = child; var sense = data.$direction; node = nodeHash[sense[0]]; child = nodeHash[sense[1]]; } var posFrom = node.pos.getc(true), posTo = child.pos.getc(true); var vect = new Complex(posTo.x - posFrom.x, posTo.y - posFrom.y); vect.$scale(edgeDim / vect.norm()); var intermediatePoint = new Complex(posTo.x - vect.x, posTo.y - vect.y); var normal = new Complex(-vect.y / 2, vect.x / 2); var v1 = intermediatePoint.add(normal), v2 = intermediatePoint.$add(normal.$scale(-1)); canvas.path('stroke', function(context) { context.moveTo(posFrom.x, posFrom.y); context.lineTo(posTo.x, posTo.y); }); canvas.path('fill', function(context) { context.moveTo(v1.x, v1.y); context.lineTo(v2.x, v2.y); context.lineTo(posTo.x, posTo.y); }); } }); /* * File: Hypertree.js * * Implements the class and other derived classes. * * Description: * * A Hyperbolic Tree (HT) is a focus+context information visualization technique used to display large amount of inter-related data. This technique was originally developed at Xerox PARC. * * The HT algorithm plots a tree in what's called the Poincare Disk model of Hyperbolic Geometry, a kind of non-Euclidean geometry. By doing this, the HT algorithm applies a moebius transformation to the tree in order to display it with a magnifying glass effect. * * Inspired by: * * A Focus+Context Technique Based on Hyperbolic Geometry for Visualizing Large Hierarchies (John Lamping, Ramana Rao, and Peter Pirolli). * * * * Disclaimer: * * This visualization was built from scratch, taking only the paper as inspiration, and only shares some features with the Hypertree. * */ /* Complex A multi-purpose Complex Class with common methods. Exetended for the Hypertree. */ /* moebiusTransformation Calculates a moebius transformation for this point / complex. For more information go to: http://en.wikipedia.org/wiki/Moebius_transformation. Parameters: c - An initialized Complex instance representing a translation Vector. */ Complex.prototype.moebiusTransformation = function(c) { var num = this.add(c); var den = c.$conjugate().$prod(this); den.x++; return num.$div(den); }; /* Method: getClosestNodeToOrigin Extends . Returns the closest node to the center of canvas. Parameters: graph - A instance. prop - _optional_ a position property. Possible properties are 'startPos', 'pos' or 'endPos'. Default's 'pos'. Returns: Closest node to origin. Returns *null* otherwise. */ Graph.Util.getClosestNodeToOrigin = function(graph, prop, flags) { return this.getClosestNodeToPos(graph, Polar.KER, prop, flags); }; /* Method: getClosestNodeToPos Extends . Returns the closest node to the given position. Parameters: graph - A instance. p[os - A or instance. prop - _optional_ a position property. Possible properties are 'startPos', 'pos' or 'endPos'. Default's 'pos'. Returns: Closest node to the given position. Returns *null* otherwise. */ Graph.Util.getClosestNodeToPos = function(graph, pos, prop, flags) { var node = null; prop = prop || 'pos'; pos = pos && pos.getc(true) || Complex.KER; var distance = function(a, b) { var d1 = a.x - b.x, d2 = a.y - b.y; return d1 * d1 + d2 * d2; }; this.eachNode(graph, function(elem) { node = (node == null || distance(elem[prop].getc(true), pos) < distance(node[prop].getc(true), pos))? elem : node; }, flags); return node; }; /* moebiusTransformation Calculates a moebius transformation for the hyperbolic tree. Parameters: graph - A instance. pos - A . prop - A property array. theta - Rotation angle. startPos - _optional_ start position. */ Graph.Util.moebiusTransformation = function(graph, pos, prop, startPos, flags) { this.eachNode(graph, function(elem) { for(var i=0; i, Parameters: canvas - A Class config - A configuration/controller object. Configuration: The configuration object can have the following properties (all properties are optional and have a default value) *General* - _withLabels_ Whether the visualization should use/create labels or not. Default's *true*. *Node* Customize the visualization nodes' shape, color, and other style properties. - _Node_ This object has as properties - _overridable_ Determine whether or not nodes properties can be overriden by a particular node. Default's false. If given a JSON tree or graph, a node _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the node properties will override the global node properties. - _type_ Node type (shape). Possible options are "none", "square", "rectangle", "circle", "triangle", "star". Default's "circle". - _color_ Node color. Default's '#ccb'. - _lineWidth_ Line width. If nodes aren't drawn with strokes then this property won't be of any use. Default's 1. - _height_ Node height. Used for plotting rectangular nodes. Default's 5. - _width_ Node width. Used for plotting rectangular nodes. Default's 5. - _dim_ An extra parameter used by other complex shapes such as square and circle to determine the shape's diameter. Default's 7. - _transform_ Whether to apply the moebius transformation to the nodes or not. Default's true. *Edge* Customize the visualization edges' shape, color, and other style properties. - _Edge_ This object has as properties - _overridable_ Determine whether or not edges properties can be overriden by a particular edge object. Default's false. If given a JSON _complex_ graph (defined in ), an adjacency _data_ property contains properties which are the same as defined here but prefixed with a dollar sign (i.e $), the adjacency properties will override the global edge properties. - _type_ Edge type (shape). Possible options are "none", "line" and "hyperline". Default's "hyperline". - _color_ Edge color. Default's '#ccb'. - _lineWidth_ Line width. If edges aren't drawn with strokes then this property won't be of any use. Default's 1. *Animations* - _duration_ Duration of the animation in milliseconds. Default's 1500. - _fps_ Frames per second. Default's 40. - _transition_ One of the transitions defined in the class. Default's Quart.easeInOut. - _clearCanvas_ Whether to clear canvas on each animation frame or not. Default's true. *Controller options* You can also implement controller functions inside the configuration object. This functions are - _onBeforeCompute(node)_ This method is called right before performing all computation and animations to the JIT visualization. - _onAfterCompute()_ This method is triggered right after all animations or computations for the JIT visualizations ended. - _onCreateLabel(domElement, node)_ This method receives the label dom element as first parameter, and the corresponding as second parameter. This method will only be called on label creation. Note that a is a node from the input tree/graph you provided to the visualization. If you want to know more about what kind of JSON tree/graph format is used to feed the visualizations, you can take a look at . This method proves useful when adding events to the labels used by the JIT. - _onPlaceLabel(domElement, node)_ This method receives the label dom element as first parameter and the corresponding as second parameter. This method is called each time a label has been placed on the visualization, and thus it allows you to update the labels properties, such as size or position. Note that onPlaceLabel will be triggered after updating the labels positions. That means that, for example, the left and top css properties are already updated to match the nodes positions. - _onBeforePlotNode(node)_ This method is triggered right before plotting a given node. The _node_ parameter is the to be plotted. This method is useful for changing a node style right before plotting it. - _onAfterPlotNode(node)_ This method is triggered right after plotting a given node. The _node_ parameter is the plotted. - _onBeforePlotLine(adj)_ This method is triggered right before plotting an edge. The _adj_ parameter is a object. This method is useful for adding some styles to a particular edge before being plotted. - _onAfterPlotLine(adj)_ This method is triggered right after plotting an edge. The _adj_ parameter is the plotted. Example: Here goes a complete example. In most cases you won't be forced to implement all properties and methods. In fact, all configuration properties have the default value assigned. I won't be instanciating a class here. If you want to know more about instanciating a class please take a look at the class documentation. (start code js) var ht = new Hypertree(canvas, { Node: { overridable: false, type: 'circle', color: '#ccb', lineWidth: 1, height: 5, width: 5, dim: 7, transform: true }, Edge: { overridable: false, type: 'hyperline', color: '#ccb', lineWidth: 1 }, duration: 1500, fps: 40, transition: Trans.Quart.easeInOut, clearCanvas: true, withLabels: true, onBeforeCompute: function(node) { //do something onBeforeCompute }, onAfterCompute: function () { //do something onAfterCompute }, onCreateLabel: function(domElement, node) { //do something onCreateLabel }, onPlaceLabel: function(domElement, node) { //do something onPlaceLabel }, onBeforePlotNode:function(node) { //do something onBeforePlotNode }, onAfterPlotNode: function(node) { //do something onAfterPlotNode }, onBeforePlotLine:function(adj) { //do something onBeforePlotLine }, onAfterPlotLine: function(adj) { //do something onAfterPlotLine } }); (end code) Instance Properties: - _graph_ Access a instance. - _op_ Access a instance. - _fx_ Access a instance. */ this.Hypertree = new Class({ Implements: [Loader, AngularWidth], initialize: function(canvas, controller) { var config = { labelContainer: canvas.id + '-label', withLabels: true, Node: { overridable: false, type: 'circle', dim: 7, color: '#ccb', width: 5, height: 5, lineWidth: 1, transform: true }, Edge: { overridable: false, type: 'hyperline', color: '#ccb', lineWidth: 1 }, clearCanvas: true, fps:40, duration: 1500, transition: Trans.Quart.easeInOut }; var innerController = { onBeforeCompute: $empty, onAfterCompute: $empty, onCreateLabel: $empty, onPlaceLabel: $empty, onComplete: $empty, onBeforePlotLine:$empty, onAfterPlotLine: $empty, onBeforePlotNode:$empty, onAfterPlotNode: $empty }; this.controller = this.config = $merge(config, innerController, controller); this.graphOptions = { 'complex': false, 'Node': { 'selected': false, 'exist': true, 'drawn': true } }; this.graph = new Graph(this.graphOptions); this.fx = new Hypertree.Plot(this); this.op = new Hypertree.Op(this); this.json = null; this.canvas = canvas; this.root = null; this.busy = false; }, /* Method: refresh Computes nodes' positions and replots the tree. Parameters: reposition - _optional_ Set this to *true* to force repositioning. See also: */ refresh: function(reposition) { if(reposition) { this.reposition(); Graph.Util.eachNode(this.graph, function(node) { node.startPos.rho = node.pos.rho = node.endPos.rho; node.startPos.theta = node.pos.theta = node.endPos.theta; }); } else { this.compute(); } this.plot(); }, /* Method: reposition Computes nodes' positions and restores the tree to its previous position. For calculating nodes' positions the root must be placed on its origin. This method does this and then attemps to restore the hypertree to its previous position. */ reposition: function() { this.compute('endPos'); var vector = this.graph.getNode(this.root).pos.getc().scale(-1); Graph.Util.moebiusTransformation(this.graph, [vector], ['endPos'], 'endPos', "ignore"); Graph.Util.eachNode(this.graph, function(node) { if (node.ignore) { node.endPos.rho = node.pos.rho; node.endPos.theta = node.pos.theta; } }); }, /* Method: plot Plots the Hypertree */ plot: function() { this.fx.plot(); }, /* Method: compute Computes nodes' positions. Parameters: property - _optional_ A position property to store the new positions. Possible values are 'pos', 'endPos' or 'startPos'. */ compute: function(property) { var prop = property || ['pos', 'startPos']; var node = this.graph.getNode(this.root); node._depth = 0; Graph.Util.computeLevels(this.graph, this.root, 0, "ignore"); this.computeAngularWidths(); this.computePositions(prop); }, /* computePositions Performs the main algorithm for computing node positions. Parameters: property - A position property to store the new positions. Possible values are 'pos', 'endPos' or 'startPos'. */ computePositions: function(property) { var propArray = $splat(property); var aGraph = this.graph, GUtil = Graph.Util; var root = this.graph.getNode(this.root), that = this, config = this.config; var size = this.canvas.getSize(); var scale = Math.min(size.width, size.height)/ 2; //Set default values for the root node for(var i=0; i depth)? node._depth : depth; node._scale = scale; }, "ignore"); for(var i=0.51; i<=1; i+=0.01) { var valSeries = (function(a, n) { return (1 - Math.pow(a, n)) / (1 - a); })(i, depth + 1); if(valSeries >= 2) return i - 0.01; } return 0.5; })(); GUtil.eachBFS(this.graph, this.root, function (elem) { var angleSpan = elem.angleSpan.end - elem.angleSpan.begin; var angleInit = elem.angleSpan.begin; var totalAngularWidths = (function (element){ var total = 0; GUtil.eachSubnode(element, function(sib) { total += sib._treeAngularWidth; }, "ignore"); return total; })(elem); for(var i=1, rho = 0, lenAcum = edgeLength, depth = elem._depth; i<=depth+1; i++) { rho += lenAcum; lenAcum *= edgeLength; } GUtil.eachSubnode(elem, function(child) { if(!child._flag) { child._rel = child._treeAngularWidth / totalAngularWidths; var angleProportion = child._rel * angleSpan; var theta = angleInit + angleProportion / 2; for(var i=0; i id. opt - _optional_ An object containing some extra properties like - _hideLabels_ Hide labels when performing the animation. Default's *true*. Example: (start code js) ht.onClick('someid'); //or also... ht.onClick('someid', { hideLabels: false }); (end code) */ onClick: function(id, opt) { var pos = this.graph.getNode(id).pos.getc(true); this.move(pos, opt); }, /* Method: move Translates the tree to the given position. Parameters: pos - A number determining the position to move the tree to. opt - _optional_ An object containing some extra properties defined in */ move: function(pos, opt) { var versor = $C(pos.x, pos.y); if(this.busy === false && versor.norm() < 1) { var GUtil = Graph.Util; this.busy = true; var root = GUtil.getClosestNodeToPos(this.graph, versor), that = this; GUtil.computeLevels(this.graph, root.id, 0); this.controller.onBeforeCompute(root); if (versor.norm() < 1) { opt = $merge({ onComplete: $empty }, opt || {}); this.fx.animate($merge({ modes: ['moebius'], hideLabels: true }, opt, { onComplete: function(){ that.busy = false; opt.onComplete(); } }), versor); } } } }); /* Class: Hypertree.Op Performs advanced operations on trees and graphs. Extends: All methods Access: This instance can be accessed with the _op_ parameter of the hypertree instance created. Example: (start code js) var ht = new Hypertree(canvas, config); ht.op.morph //or can also call any other method (end code) */ Hypertree.Op = new Class({ Implements: Graph.Op, initialize: function(viz) { this.viz = viz; } }); /* Class: Hypertree.Plot Performs plotting operations. Extends: All methods Access: This instance can be accessed with the _fx_ parameter of the hypertree instance created. Example: (start code js) var ht = new Hypertree(canvas, config); ht.fx.placeLabel //or can also call any other method (end code) */ Hypertree.Plot = new Class({ Implements: Graph.Plot, initialize: function(viz) { this.viz = viz; this.config = viz.config; this.node = this.config.Node; this.edge = this.config.Edge; this.animation = new Animation; this.nodeTypes = new Hypertree.Plot.NodeTypes; this.edgeTypes = new Hypertree.Plot.EdgeTypes; }, /* Method: hyperline Plots a hyperline between two nodes. A hyperline is an arc of a circle which is orthogonal to the main circle. Parameters: adj - A object. canvas - A instance. */ hyperline: function(adj, canvas) { var node = adj.nodeFrom, child = adj.nodeTo, data = adj.data; var pos = node.pos.getc(), posChild = child.pos.getc(); var centerOfCircle = this.computeArcThroughTwoPoints(pos, posChild); var size = canvas.getSize(); var scale = Math.min(size.width, size.height)/2; if (centerOfCircle.a > 1000 || centerOfCircle.b > 1000 || centerOfCircle.ratio > 1000) { canvas.path('stroke', function(ctx) { ctx.moveTo(pos.x * scale, pos.y * scale); ctx.lineTo(posChild.x * scale, posChild.y * scale); }); } else { var angleBegin = Math.atan2(posChild.y - centerOfCircle.y, posChild.x - centerOfCircle.x); var angleEnd = Math.atan2(pos.y - centerOfCircle.y, pos.x - centerOfCircle.x); var sense = this.sense(angleBegin, angleEnd); var context = canvas.getCtx(); canvas.path('stroke', function(ctx) { ctx.arc(centerOfCircle.x*scale, centerOfCircle.y*scale, centerOfCircle.ratio*scale, angleBegin, angleEnd, sense); }); } }, /* computeArcThroughTwoPoints Calculates the arc parameters through two points. More information in Parameters: p1 - A instance. p2 - A instance. Returns: An object containing some arc properties. */ computeArcThroughTwoPoints: function(p1, p2) { var aDen = (p1.x * p2.y - p1.y * p2.x), bDen = aDen; var sq1 = p1.squaredNorm(), sq2 = p2.squaredNorm(); //Fall back to a straight line if (aDen == 0) return { x:0, y:0, ratio: 1001 }; var a = (p1.y * sq2 - p2.y * sq1 + p1.y - p2.y) / aDen; var b = (p2.x * sq1 - p1.x * sq2 + p2.x - p1.x) / bDen; var x = -a / 2; var y = -b / 2; var squaredRatio = (a * a + b * b) / 4 -1; //Fall back to a straight line if(squaredRatio < 0) return { x:0, y:0, ratio: 1001 }; var ratio = Math.sqrt(squaredRatio); var out= { x: x, y: y, ratio: ratio, a: a, b: b }; return out; }, /* sense Sets angle direction to clockwise (true) or counterclockwise (false). Parameters: angleBegin - Starting angle for drawing the arc. angleEnd - The HyperLine will be drawn from angleBegin to angleEnd. Returns: A Boolean instance describing the sense for drawing the HyperLine. */ sense: function(angleBegin, angleEnd) { return (angleBegin < angleEnd)? ((angleBegin + Math.PI > angleEnd)? false : true) : ((angleEnd + Math.PI > angleBegin)? true : false); }, /* Method: placeLabel Overrides abstract method placeLabel in . Parameters: tag - A DOM label element. node - A . controller - A configuration/controller object passed to the visualization. */ placeLabel: function(tag, node, controller) { var pos = node.pos.getc(true), canvas = this.viz.canvas; var radius= canvas.getSize(); var scale = node._scale; var labelPos= { x: Math.round(pos.x * scale + radius.width/2), y: Math.round(pos.y * scale + radius.height/2) }; var style = tag.style; style.left = labelPos.x + 'px'; style.top = labelPos.y + 'px'; style.display = ''; controller.onPlaceLabel(tag, node); } }); /* Class: Hypertree.Plot.NodeTypes Here are implemented all kinds of node rendering functions. Rendering functions implemented are 'none', 'circle', 'triangle', 'rectangle', 'star' and 'square'. You can add new Node types by implementing a new method in this class Example: (start code js) Hypertree.Plot.NodeTypes.implement({ 'newnodetypename': function(node, canvas) { //Render my node here. } }); (end code) */ Hypertree.Plot.NodeTypes = new Class({ 'none': function() {}, 'circle': function(node, canvas) { var nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var p = node.pos.getc(), pos = p.scale(node._scale); var prod = nconfig.transform? nodeDim * (1 - p.squaredNorm()) : nodeDim; if(prod >= nodeDim / 4) { canvas.path('fill', function(context) { context.arc(pos.x, pos.y, prod, 0, Math.PI * 2, true); }); } }, 'square': function(node, canvas) { var nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var p = node.pos.getc(), pos = p.scale(node._scale); var prod = nconfig.transform? nodeDim * (1 - p.squaredNorm()) : nodeDim; var nodeDim2 = 2 * prod; if (prod >= nodeDim / 4) { canvas.getCtx().fillRect(pos.x - prod, pos.y - prod, nodeDim2, nodeDim2); } }, 'rectangle': function(node, canvas) { var nconfig = this.node, data = node.data; var width = nconfig.overridable && data && data.$width || nconfig.width; var height = nconfig.overridable && data && data.$height || nconfig.height; var p = node.pos.getc(), pos = p.scale(node._scale); var prod = 1 - p.squaredNorm(); width = nconfig.transform? width * prod : width; height = nconfig.transform? height * prod : height; if(prod >= 0.25) { canvas.getCtx().fillRect(pos.x - width / 2, pos.y - height / 2, width, height); } }, 'triangle': function(node, canvas) { var nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var p = node.pos.getc(), pos = p.scale(node._scale); var prod = nconfig.transform? nodeDim * (1 - p.squaredNorm()) : nodeDim; if (prod >= nodeDim / 4) { var c1x = pos.x, c1y = pos.y - prod, c2x = c1x - prod, c2y = pos.y + prod, c3x = c1x + prod, c3y = c2y; canvas.path('fill', function(ctx){ ctx.moveTo(c1x, c1y); ctx.lineTo(c2x, c2y); ctx.lineTo(c3x, c3y); }); } }, 'star': function(node, canvas) { var nconfig = this.node, data = node.data; var nodeDim = nconfig.overridable && data && data.$dim || nconfig.dim; var p = node.pos.getc(), pos = p.scale(node._scale); var prod = nconfig.transform? nodeDim * (1 - p.squaredNorm()) : nodeDim; if (prod >= nodeDim / 4) { var ctx = canvas.getCtx(), pi5 = Math.PI / 5; ctx.save(); ctx.translate(pos.x, pos.y); ctx.beginPath(); ctx.moveTo(nodeDim, 0); for (var i = 0; i < 9; i++) { ctx.rotate(pi5); if (i % 2 == 0) { ctx.lineTo((prod / 0.525731) * 0.200811, 0); } else { ctx.lineTo(prod, 0); } } ctx.closePath(); ctx.fill(); ctx.restore(); } } }); /* Class: Hypertree.Plot.EdgeTypes Here are implemented all kinds of edge rendering functions. Rendering functions implemented are 'none', 'line' and 'hyperline'. You can add new Edge types by implementing a new method in this class Example: (start code js) Hypertree.Plot.EdgeTypes.implement({ 'newedgetypename': function(adj, canvas) { //Render my edge here. } }); (end code) */ Hypertree.Plot.EdgeTypes = new Class({ 'none': function() {}, 'line': function(adj, canvas) { var s = adj.nodeFrom._scale; var pos = adj.nodeFrom.pos.getc(true); var posChild = adj.nodeTo.pos.getc(true); canvas.path('stroke', function(context) { context.moveTo(pos.x * s, pos.y * s); context.lineTo(posChild.x * s, posChild.y * s); }); }, 'hyperline': function(adj, canvas) { this.hyperline(adj, canvas); } }); /* * File: Treemap.js * * Implements the class and other derived classes. * * Description: * * A Treemap is an information visualization technique, proven very useful when displaying large hierarchical structures on a constrained space. The idea behind a Treemap is to describe hierarchical relations as 'containment'. That means that if node B is child of node A, then B 'is contained' in A. * * Inspired by: * * Squarified Treemaps (Mark Bruls, Kees Huizing, and Jarke J. van Wijk) * * * * Tree visualization with tree-maps: 2-d space-filling approach (Ben Shneiderman) * * * * Disclaimer: * * This visualization was built from scratch, taking only these papers as inspiration, and only shares some features with the Treemap papers mentioned above. * */ /* Object: TM Abstract Treemap object. Implemented By: , and . Description: Implements layout and configuration options inherited by , and . All Treemap constructors take the same configuration object as parameter. Two special _data_ keys are read from the JSON tree structure loaded by to calculate node's color and dimensions. These properties are $area (for nodes dimensions) and $color. Both of these properties are floats. This means that the tree structure defined in should now look more like this (start code js) var json = { "id": "aUniqueIdentifier", "name": "usually a nodes name", "data": { "$area": 33, //some float value "$color": 36, //-optional- some float value "some key": "some value", "some other key": "some other value" }, "children": [ 'other nodes or empty' ] }; (end code) If you want to know more about JSON tree structures and the _data_ property please read . Configuration: *General* - _rootId_ The id of the div container where the Treemap will be injected. Default's 'infovis'. - _orientation_ For and only. The layout algorithm orientation. Possible values are 'h' or 'v'. - _levelsToShow_ Max depth of the plotted tree. Useful when using the request method. - _addLeftClickHandler_ Add a left click event handler to zoom in the Treemap view when clicking a node. Default's *false*. - _addRightClickHandler_ Add a right click event handler to zoom out the Treemap view. Default's *false*. - _selectPathOnHover_ If setted to *true* all nodes contained in the path between the hovered node and the root node will have an *in-path* CSS class. Default's *false*. *Nodes* There are two kinds of Treemap nodes. (see treemapnode.png) Inner nodes are nodes having children, like _Pearl Jam_. These nodes are represented by three div elements. A _content_ element, a _head_ element (where the title goes) and a _body_ element, where the children are laid out. (start code xml)
Pearl Jam
...other nodes here...
(end code) Leaves are optionally colored nodes laying at the "bottom" of the tree. For example, _Yield_, _Vs._ and _Riot Act_ are leaves. These nodes are represented by two div elements. A _content_ element and a wrapped _leaf_ element (start code xml)
Yield
(end code) There are some configuration properties regarding Treemap nodes - _titleHeight_ The height of the title (_head_) div container. Default's 13. - _offset_ The separation offset between the _content_ div element and its contained div(s). Default's 4. *Color* _Color_ is an object containing as properties - _allow_ If *true*, the algorithm will check for the JSON node data _$color_ property to add some color to the Treemap leaves. This color is calculated by interpolating a node's $color value range with a real RGB color range. By specifying min|maxValues for the $color property and min|maxColorValues for the RGB counterparts, the visualization is able to interpolate color values and assign a proper color to the leaf node. Default's *false*. - _minValue_ The minimum value expected for the $color value property. Used for interpolating. Default's -100. - _maxValue_ The maximum value expected for the $color value property. Used for interpolating. Default's 100. - _minColorValue_ A three-element RGB array defining the color to be assigned to the _$color_ having _minValue_ as value. Default's [255, 0, 50]. - _maxColorValue_ A three-element RGB array defining the color to be assigned to the _$color_ having _maxValue_ as value. Default's [0, 255, 50]. *Tips* _Tips_ is an object containing as properties - _allow_ If *true*, a tooltip will be shown when a node is hovered. The tooltip is a div DOM element having "tip" as CSS class. Default's *false*. - _offsetX_ An offset added to the current tooltip x-position (which is the same as the current mouse position). Default's 20. - _offsetY_ An offset added to the current tooltip y-position (which is the same as the current mouse position). Default's 20. - _onShow(tooltip, node, isLeaf, domElement)_ Implement this method to change the HTML content of the tooltip when hovering a node. Parameters: tooltip - The tooltip div element. node - The corresponding JSON tree node (See also ). isLeaf - Whether is a leaf or inner node. domElement - The current hovered DOM element. *Controller options* You can also implement controller functions inside the configuration object. These functions are - _onBeforeCompute(node)_ This method is called right before performing all computation and animations to the JIT visualization. - _onAfterCompute()_ This method is triggered right after all animations or computations for the JIT visualizations ended. - _onCreateElement(content, node, isLeaf, elem1, elem2)_ This method is called on each newly created node. Parameters: content - The div wrapper element with _content_ className. node - The corresponding JSON tree node (See also ). isLeaf - Whether is a leaf or inner node. If the node's an inner tree node, elem1 and elem2 will become the _head_ and _body_ div elements respectively. If the node's a _leaf_, then elem1 will become the div leaf element. - _onDestroyElement(content, node, isLeaf, elem1, elem2)_ This method is called before collecting each node. Takes the same parameters as onCreateElement. - _request(nodeId, level, onComplete)_ This method is used for buffering information into the visualization. When clicking on an empty node, the visualization will make a request for this node's subtrees, specifying a given level for this subtree (defined by _levelsToShow_). Once the request is completed, the _onComplete_ object should be called with the given result. See also , and . */ this.TM = { layout: { orientation: "h", vertical: function() { return this.orientation == "v"; }, horizontal: function() { return this.orientation == "h"; }, change: function() { this.orientation = this.vertical()? "h" : "v"; } }, innerController: { onBeforeCompute: $empty, onAfterCompute: $empty, onComplete: $empty, onCreateElement: $empty, onDestroyElement: $empty, request: false }, config: { orientation: "h", titleHeight: 13, rootId: 'infovis', offset:4, levelsToShow: 3, addLeftClickHandler: false, addRightClickHandler: false, selectPathOnHover: false, Color: { allow: false, minValue: -100, maxValue: 100, minColorValue: [255, 0, 50], maxColorValue: [0, 255, 50] }, Tips: { allow: false, offsetX: 20, offsetY: 20, onShow: $empty } }, initialize: function(controller) { this.tree = null; this.shownTree = null; this.controller = this.config = $merge(this.config, this.innerController, controller); this.rootId = this.config.rootId; this.layout.orientation = this.config.orientation; //add tooltip if(this.config.Tips.allow && document.body) { var tip = document.getElementById('_tooltip') || document.createElement('div'); tip.id = '_tooltip'; tip.className = 'tip'; var style = tip.style; style.position = 'absolute'; style.display = 'none'; style.zIndex = 13000; document.body.appendChild(tip); this.tip = tip; } //purge var that = this; var fn = function() { that.empty(); if(window.CollectGarbage) window.CollectGarbage(); delete fn; }; if(window.addEventListener) { window.addEventListener('unload', fn, false); } else { window.attachEvent('onunload', fn); } }, /* Method: each Traverses head and leaf nodes applying a given function Parameters: f - A function that takes as parameters the same as the onCreateElement and onDestroyElement methods described in . */ each: function(f) { (function rec(elem) { if(!elem) return; var ch = elem.childNodes, len = ch.length; if(len > 0) { f.apply(this, [elem, len === 1, ch[0], ch[1]]); } if (len > 1) { for(var chi = ch[1].childNodes, i=0; i Returns: A boolean value specifying if the node is a tree leaf or not. */ leaf: function(tree) { return tree.children == 0; }, /* Method: createBox Constructs the proper DOM layout from a json node. If the node's an _inner node_, this method calls , and to create the following HTML structure (start code xml)
[Node name]
[Node's children]
(end code) If the node's a leaf node, it creates the following structure by calling , (start code xml)
[Node name]
(end code) Parameters: json - A JSON subtree. See also . coord - A coordinates object specifying width, height, left and top style properties. html - html to inject into the _body_ element if the node is an inner Tree node. Returns: The HTML structure described above. See also: , , , , . */ createBox: function(json, coord, html) { var box; if(!this.leaf(json)) { box = this.headBox(json, coord) + this.bodyBox(html, coord); } else { box = this.leafBox(json, coord); } return this.contentBox(json, coord, box); }, /* Method: plot Renders the Treemap. Parameters: json - A JSON tree structure preprocessed by some Treemap layout algorithm. Returns: The HTML to inject to the main visualization container. See also: . */ plot: function(json) { var coord = json.coord, html = ""; if(this.leaf(json)) return this.createBox(json, coord, null); for(var i=0, ch=json.children; i 1) { html+= this.plot(chi); } } return this.createBox(json, coord, html); }, /* Method: headBox Creates the _head_ div dom element that usually contains the name of a parent JSON tree node. Parameters: json - A JSON subtree. See also . coord - width and height base coordinate object. Returns: A new _head_ div dom element that has _head_ as class name. See also: . */ headBox: function(json, coord) { var config = this.config, offst = config.offset; var c = { 'height': config.titleHeight + "px", 'width': (coord.width - offst) + "px", 'left': offst / 2 + "px" }; return "
" + json.name + "
"; }, /* Method: bodyBox Creates the _body_ div dom element that usually contains a subtree dom element layout. Parameters: html - html that should be contained in the body html. coord - width and height base coordinate object. Returns: A new _body_ div dom element that has _body_ as class name. See also: . */ bodyBox: function(html, coord) { var config = this.config, th = config.titleHeight, offst = config.offset; var c = { 'width': (coord.width - offst) + "px", 'height':(coord.height - offst - th) + "px", 'top': (th + offst / 2) + "px", 'left': (offst / 2) + "px" }; return "
" + html + "
"; }, /* Method: contentBox Creates the _content_ div dom element that usually contains a _leaf_ div dom element or _head_ and _body_ div dom elements. Parameters: json - A JSON node. See also . coord - An object containing width, height, left and top coordinates. html - input html wrapped by this tag. Returns: A new _content_ div dom element that has _content_ as class name. See also: . */ contentBox: function(json, coord, html) { var c = {}; for(var i in coord) c[i] = coord[i] + "px"; return "
" + html + "
"; }, /* Method: leafBox Creates the _leaf_ div dom element that usually contains nothing else. Parameters: json - A JSON subtree. See also . coord - base with and height coordinate object. Returns: A new _leaf_ div dom element having _leaf_ as class name. See also: . */ leafBox: function(json, coord) { var config = this.config; var backgroundColor = config.Color.allow && this.setColor(json), offst = config.offset, width = coord.width - offst, height = coord.height - offst; var c = { 'top': (offst / 2) + "px", 'height':height + "px", 'width': width + "px", 'left': (offst / 2) + "px" }; if(backgroundColor) c['background-color'] = backgroundColor; return "
" + json.name + "
"; }, /* Method: setColor Calculates an hexa color string based on the _$color_ data node property. This method is called by to assign an hexadecimal color to each leaf node. This color is calculated by making a linear interpolation between _$color_ max and min values and RGB max and min values so that > hex = (maxColorValue - minColorValue) / (maxValue - minValue) * (x - minValue) + minColorValue where _x_ range is [minValue, maxValue] and - _minValue_ - _maxValue_ - _minColorValue_ - _maxColorValue_ are defined in the configuration object. This method is called by iif _Color.allow_ is setted to _true_. Sometimes linear interpolation for coloring is just not enough. In that case you can re-implement this method so that it fits your coloring needs. Some people might find useful to implement their own coloring interpolation method and to assign the resulting hex string to the _$color_ property. In that case we could re-implement the method like this (start code js) //TM.Strip, TM.SliceAndDice also work TM.Squarified.implement({ 'setColor': function(json) { return json.data.$color; } }); (end code) So that it returns the previously assigned hex string. Parameters: json - A JSON tree node. Returns: A String that represents a color in hex value. */ setColor: function(json) { var c = this.config.Color, maxcv = c.maxColorValue, mincv = c.minColorValue, maxv = c.maxValue, minv = c.minValue, diff = maxv - minv, x = (json.data.$color - 0); //linear interpolation var comp = function(i, x) { return Math.round((((maxcv[i] - mincv[i]) / diff) * (x - minv) + mincv[i])); }; return $rgbToHex([ comp(0, x), comp(1, x), comp(2, x) ]); }, /* Method: enter Sets the _elem_ parameter as root and performs the layout. Parameters: elem - A JSON Tree node. See also . */ enter: function(elem) { this.view(elem.parentNode.id); }, /* Method: onLeftClick Sets the _elem_ parameter as root and performs the layout. This method is called when _addLeftClickHandler_ is *true* and a node is left-clicked. You can override this method to add some custom behavior when the node is left clicked though. An Example for overriding this method could be (start code js) //TM.Strip or TM.SliceAndDice also work TM.Squarified.implement({ 'onLeftClick': function(elem) { //some custom code... } }); (end code) Parameters: elem - A JSON Tree node. See also . See also: */ onLeftClick: function(elem) { this.enter(elem); }, /* Method: out Sets the _parent_ node of the currently shown subtree as root and performs the layout. */ out: function() { var parent = TreeUtil.getParent(this.tree, this.shownTree.id); if(parent) { if(this.controller.request) TreeUtil.prune(parent, this.config.levelsToShow); this.view(parent.id); } }, /* Method: onRightClick Sets the _parent_ node of the currently shown subtree as root and performs the layout. This method is called when _addRightClickHandler_ is *true* and a node is right-clicked. You can override this method to add some custom behavior when the node is right-clicked though. An Example for overriding this method could be (start code js) //TM.Strip or TM.SliceAndDice also work TM.Squarified.implement({ 'onRightClick': function() { //some custom code... } }); (end code) See also: */ onRightClick: function() { this.out(); }, /* Method: view Sets the root of the treemap to the specified node id and performs the layout. Parameters: id - A node identifier */ view: function(id) { var config = this.config, that = this; var post = { onComplete: function() { that.loadTree(id); $get(config.rootId).focus(); } }; if (this.controller.request) { var TUtil = TreeUtil; TUtil.loadSubtrees(TUtil.getSubtree(this.tree, id), $merge(this.controller, post)); } else { post.onComplete(); } }, /* Method: resetPath Sets an 'in-path' className for _leaf_ and _head_ elements which belong to the path between the given tree node and the visualization's root node. Parameters: tree - A JSON tree node. See also . */ resetPath: function(tree) { var root = this.rootId, previous = this.resetPath.previous; this.resetPath.previous = tree || false; function getParent(c) { var p = c.parentNode; return p && (p.id != root) && p; }; function toggleInPath(elem, remove) { if(elem) { var container = $get(elem.id); if(container) { var parent = getParent(container); while(parent) { elem = parent.childNodes[0]; if($hasClass(elem, 'in-path')) { if(remove == undefined || !!remove) $removeClass(elem, 'in-path'); } else { if(!remove) $addClass(elem, 'in-path'); } parent = getParent(parent); } } } }; toggleInPath(previous, true); toggleInPath(tree, false); }, /* Method: initializeElements Traverses the DOM tree applying the onCreateElement method. The onCreateElement controller method should attach events and add some behavior to the DOM element node created. *By default, the Treemap wont add any event to its elements.* */ initializeElements: function() { var cont = this.controller, that = this; var ff = $lambda(false), tipsAllow = cont.Tips.allow; this.each(function(content, isLeaf, elem1, elem2) { var tree = TreeUtil.getSubtree(that.tree, content.id); cont.onCreateElement(content, tree, isLeaf, elem1, elem2); //eliminate context menu when right clicking if(cont.addRightClickHandler) elem1.oncontextmenu = ff; //add click handlers if(cont.addLeftClickHandler || cont.addRightClickHandler) { $addEvent(elem1, 'mouseup', function(e) { var rightClick = (e.which == 3 || e.button == 2); if (rightClick) { if(cont.addRightClickHandler) that.onRightClick(); } else { if(cont.addLeftClickHandler) that.onLeftClick(elem1); } //prevent default if (e.preventDefault) e.preventDefault(); else e.returnValue = false; }); } //add path selection on hovering nodes if(cont.selectPathOnHover || tipsAllow) { $addEvent(elem1, 'mouseover', function(e){ if(cont.selectPathOnHover) { if (isLeaf) { $addClass(elem1, 'over-leaf'); } else { $addClass(elem1, 'over-head'); $addClass(content, 'over-content'); } if (content.id) that.resetPath(tree); } if(tipsAllow) cont.Tips.onShow(that.tip, tree, isLeaf, elem1); }); $addEvent(elem1, 'mouseout', function(e){ if(cont.selectPathOnHover) { if (isLeaf) { $removeClass(elem1, 'over-leaf'); } else { $removeClass(elem1, 'over-head'); $removeClass(content, 'over-content'); } that.resetPath(); } if(tipsAllow) that.tip.style.display = 'none'; }); if(tipsAllow) { //Add mousemove event handler $addEvent(elem1, 'mousemove', function(e, win){ var tip = that.tip; //get mouse position win = win || window; e = e || win.event; var doc = win.document; doc = doc.html || doc.body; var page = { x: e.pageX || e.clientX + doc.scrollLeft, y: e.pageY || e.clientY + doc.scrollTop }; tip.style.display = ''; //get window dimensions win = { 'height': document.body.clientHeight, 'width': document.body.clientWidth }; //get tooltip dimensions var obj = { 'width': tip.offsetWidth, 'height': tip.offsetHeight }; //set tooltip position var style = tip.style, x = cont.Tips.offsetX, y = cont.Tips.offsetY; style.top = ((page.y + y + obj.height > win.height)? (page.y - obj.height - y) : page.y + y) + 'px'; style.left = ((page.x + obj.width + x > win.width)? (page.x - obj.width - x) : page.x + x) + 'px'; }); } } }); }, /* Method: destroyElements Traverses the tree applying the onDestroyElement method. The onDestroyElement controller method should detach events and garbage collect the element. *By default, the Treemap adds some garbage collect facilities for IE.* */ destroyElements: function() { if(this.controller.onDestroyElement != $empty) { var cont = this.controller, that = this; this.each(function(content, isLeaf, elem1, elem2) { cont.onDestroyElement(content, TreeUtil.getSubtree(that.tree, content.id), isLeaf, elem1, elem2); }); } }, /* Method: empty Empties the Treemap container (trying also to garbage collect things). */ empty: function() { this.destroyElements(); $clean($get(this.rootId)); }, /* Method: loadTree Loads the subtree specified by _id_ and plots it on the layout container. Parameters: id - A subtree id. */ loadTree: function(id) { this.empty(); this.loadJSON(TreeUtil.getSubtree(this.tree, id)); } }; /* Class: TM.SliceAndDice A JavaScript implementation of the Slice and Dice Treemap algorithm. The constructor takes an _optional_ configuration object described in . This visualization (as all other Treemap visualizations) is fed with JSON Tree structures. The _$area_ node data key is required for calculating rectangles dimensions. The _$color_ node data key is required if _Color_ _allow_ is *true* and is used for calculating leaves colors. Extends: Parameters: config - Configuration defined in . Example: Here's a way of instanciating the will all its _optional_ configuration features (start code js) var tm = new TM.SliceAndDice({ orientation: "h", titleHeight: 13, rootId: 'infovis', offset:4, levelsToShow: 3, addLeftClickHandler: false, addRightClickHandler: false, selectPathOnHover: false, Color: { allow: false, minValue: -100, maxValue: 100, minColorValue: [255, 0, 50], maxColorValue: [0, 255, 50] }, Tips: { allow: false, offsetX; 20, offsetY: 20, onShow: function(tooltip, node, isLeaf, domElement) {} }, onBeforeCompute: function(node) { //Some stuff on before compute... }, onAfterCompute: function() { //Some stuff on after compute... }, onCreateElement: function(content, node, isLeaf, head, body) { //Some stuff onCreateElement }, onDestroyElement: function(content, node, isLeaf, head, body) { //Some stuff onDestroyElement }, request: false }); tm.loadJSON(json); (end code) */ TM.SliceAndDice = new Class({ Implements: TM, /* Method: loadJSON Loads the specified JSON tree and lays it on the main container. Parameters: json - A JSON Tree. See also . */ loadJSON: function (json) { this.controller.onBeforeCompute(json); var container = $get(this.rootId), config = this.config, width = container.offsetWidth, height = container.offsetHeight; var p = { 'coord': { 'top': 0, 'left': 0, 'width': width, 'height': height + config.titleHeight + config.offset } }; if(this.tree == null) this.tree = json; this.shownTree = json; this.compute(p, json, this.layout.orientation); container.innerHTML = this.plot(json); this.initializeElements(); this.controller.onAfterCompute(json); }, /* Method: compute Called by loadJSON to calculate recursively all node positions and lay out the tree. Parameters: par - The parent node of the json subtree. json - A JSON subtree. See also . orientation - The current orientation. This value is switched recursively. */ compute: function(par, json, orientation) { var config = this.config, coord = par.coord, offst = config.offset, width = coord.width - offst, height = coord.height - offst - config.titleHeight, pdata = par.data, fact = (pdata && ("$area" in pdata))? json.data.$area / pdata.$area : 1; var otherSize, size, dim, pos, pos2; var horizontal = (orientation == "h"); if(horizontal) { orientation = 'v'; otherSize = height; size = Math.round(width * fact); dim = 'height'; pos = 'top'; pos2 = 'left'; } else { orientation = 'h'; otherSize = Math.round(height * fact); size = width; dim = 'width'; pos = 'left'; pos2 = 'top'; } json.coord = { 'width':size, 'height':otherSize, 'top':0, 'left':0 }; var offsetSize = 0, tm = this; $each(json.children, function(elem){ tm.compute(json, elem, orientation); elem.coord[pos] = offsetSize; elem.coord[pos2] = 0; offsetSize += Math.floor(elem.coord[dim]); }); } }); /* Class: TM.Area Abstract Treemap class containing methods that are common to aspect ratio related algorithms such as and . Implemented by: , */ TM.Area = new Class({ /* Method: loadJSON Loads the specified JSON tree and lays it on the main container. Parameters: json - A JSON tree. See also . */ loadJSON: function (json) { this.controller.onBeforeCompute(json); var container = $get(this.rootId), width = container.offsetWidth, height = container.offsetHeight, offst = this.config.offset, offwdth = width - offst, offhght = height - offst - this.config.titleHeight; json.coord = { 'height': height, 'width': width, 'top': 0, 'left': 0 }; var coord = $merge(json.coord, { 'width': offwdth, 'height': offhght }); this.compute(json, coord); container.innerHTML = this.plot(json); if(this.tree == null) this.tree = json; this.shownTree = json; this.initializeElements(); this.controller.onAfterCompute(json); }, /* Method: computeDim Computes dimensions and positions of a group of nodes according to a custom layout row condition. Parameters: tail - An array of nodes. initElem - An array of nodes (containing the initial node to be laid). w - A fixed dimension where nodes will be layed out. coord - A coordinates object specifying width, height, left and top style properties. comp - A custom comparison function */ computeDim: function(tail, initElem, w, coord, comp) { if(tail.length + initElem.length == 1) { var l = (tail.length == 1)? tail : initElem; this.layoutLast(l, w, coord); return; } if(tail.length >= 2 && initElem.length == 0) { initElem = [tail[0]]; tail = tail.slice(1); } if(tail.length == 0) { if(initElem.length > 0) this.layoutRow(initElem, w, coord); return; } var c = tail[0]; if(comp(initElem, w) >= comp([c].concat(initElem), w)) { this.computeDim(tail.slice(1), initElem.concat([c]), w, coord, comp); } else { var newCoords = this.layoutRow(initElem, w, coord); this.computeDim(tail, [], newCoords.dim, newCoords, comp); } }, /* Method: worstAspectRatio Calculates the worst aspect ratio of a group of rectangles. See also: Parameters: ch - An array of nodes. w - The fixed dimension where rectangles are being laid out. Returns: The worst aspect ratio. */ worstAspectRatio: function(ch, w) { if(!ch || ch.length == 0) return Number.MAX_VALUE; var areaSum = 0, maxArea = 0, minArea = Number.MAX_VALUE; for(var i=0; i area)? maxArea : area; } var sqw = w * w, sqAreaSum = areaSum * areaSum; return Math.max(sqw * maxArea / sqAreaSum, sqAreaSum / (sqw * minArea)); }, /* Method: avgAspectRatio Calculates the average aspect ratio of a group of rectangles. See also: Parameters: ch - An array of nodes. w - The fixed dimension where rectangles are being laid out. Returns: The average aspect ratio. */ avgAspectRatio: function(ch, w) { if(!ch || ch.length == 0) return Number.MAX_VALUE; var arSum = 0; for(var i=0; i h)? w / h : h / w; } return arSum / ch.length; }, /* layoutLast Performs the layout of the last computed sibling. Parameters: ch - An array of nodes. w - A fixed dimension where nodes will be layed out. coord - A coordinates object specifying width, height, left and top style properties. */ layoutLast: function(ch, w, coord) { ch[0].coord = coord; } }); /* Class: TM.Squarified A JavaScript implementation of the Squarified Treemap algorithm. The constructor takes an _optional_ configuration object described in . This visualization (as all other Treemap visualizations) is fed with JSON Tree structures. The _$area_ node data key is required for calculating rectangles dimensions. The _$color_ node data key is required if _Color_ _allow_ is *true* and is used for calculating leaves colors. Extends: and Parameters: config - Configuration defined in . Example: Here's a way of instanciating the will all its _optional_ configuration features (start code js) var tm = new TM.Squarified({ titleHeight: 13, rootId: 'infovis', offset:4, levelsToShow: 3, addLeftClickHandler: false, addRightClickHandler: false, selectPathOnHover: false, Color: { allow: false, minValue: -100, maxValue: 100, minColorValue: [255, 0, 50], maxColorValue: [0, 255, 50] }, Tips: { allow: false, offsetX: 20, offsetY: 20, onShow: function(tooltip, node, isLeaf, domElement) {} }, onBeforeCompute: function(node) { //Some stuff on before compute... }, onAfterCompute: function() { //Some stuff on after compute... }, onCreateElement: function(content, node, isLeaf, head, body) { //Some stuff onCreateElement }, onDestroyElement: function(content, node, isLeaf, head, body) { //Some stuff onDestroyElement }, request: false }); tm.loadJSON(json); (end code) */ TM.Squarified = new Class({ Implements: [TM, TM.Area], /* Method: compute Called by loadJSON to calculate recursively all node positions and lay out the tree. Parameters: json - A JSON tree. See also . coord - A coordinates object specifying width, height, left and top style properties. */ compute: function(json, coord) { if (!(coord.width >= coord.height && this.layout.horizontal())) this.layout.change(); var ch = json.children, config = this.config; if(ch.length > 0) { this.processChildrenLayout(json, ch, coord); for(var i=0; i= b._area); }); var initElem = [ch[0]]; var tail = ch.slice(1); this.squarify(tail, initElem, minimumSideValue, coord); }, /* Method: squarify Performs an heuristic method to calculate div elements sizes in order to have a good aspect ratio. Parameters: tail - An array of nodes. initElem - An array of nodes, containing the initial node to be laid out. w - A fixed dimension where nodes will be laid out. coord - A coordinates object specifying width, height, left and top style properties. */ squarify: function(tail, initElem, w, coord) { this.computeDim(tail, initElem, w, coord, this.worstAspectRatio); }, /* Method: layoutRow Performs the layout of an array of nodes. Parameters: ch - An array of nodes. w - A fixed dimension where nodes will be laid out. coord - A coordinates object specifying width, height, left and top style properties. */ layoutRow: function(ch, w, coord) { if(this.layout.horizontal()) { return this.layoutV(ch, w, coord); } else { return this.layoutH(ch, w, coord); } }, layoutV: function(ch, w, coord) { var totalArea = 0, rnd = Math.round; $each(ch, function(elem) { totalArea += elem._area; }); var width = rnd(totalArea / w), top = 0; for(var i=0; i constructor takes an _optional_ configuration object described in . This visualization (as all other Treemap visualizations) is fed with JSON Tree structures. The _$area_ node data key is required for calculating rectangles dimensions. The _$color_ node data key is required if _Color_ _allow_ is *true* and is used for calculating leaves colors. Extends: and Parameters: config - Configuration defined in . Example: Here's a way of instanciating the will all its _optional_ configuration features (start code js) var tm = new TM.Strip({ titleHeight: 13, orientation: "h", rootId: 'infovis', offset:4, levelsToShow: 3, addLeftClickHandler: false, addRightClickHandler: false, selectPathOnHover: false, Color: { allow: false, minValue: -100, maxValue: 100, minColorValue: [255, 0, 50], maxColorValue: [0, 255, 50] }, Tips: { allow: false, offsetX: 20, offsetY: 20, onShow: function(tooltip, node, isLeaf, domElement) {} }, onBeforeCompute: function(node) { //Some stuff on before compute... }, onAfterCompute: function() { //Some stuff on after compute... }, onCreateElement: function(content, node, isLeaf, head, body) { //Some stuff onCreateElement }, onDestroyElement: function(content, node, isLeaf, head, body) { //Some stuff onDestroyElement }, request: false }); tm.loadJSON(json); (end code) */ TM.Strip = new Class({ Implements: [ TM, TM.Area ], /* Method: compute Called by loadJSON to calculate recursively all node positions and lay out the tree. Parameters: json - A JSON subtree. See also . coord - A coordinates object specifying width, height, left and top style properties. */ compute: function(json, coord) { var ch = json.children, config = this.config; if(ch.length > 0) { this.processChildrenLayout(json, ch, coord); for(var i=0; i |wUf+g|Nx @_k^i;y\xoݽrW.N+@w4ώ;['~E]fͥo+ Sީ&=z= wQi: >yy9w!?oO\~VފQi: >yyU2W<]Vxcvjҳ+]ć^srƫXU{0OS}_CN{ftzk*& H?̬4´'ώךn;?$xάL|rVX%wm OW{.N`hi4z+ěK߄WZbWXj׵ˌyJa=xK$_y: >yyU2S{u4J9d&vg|1S?qaWpywp~蝆g\z'Ү0QSWKX>oOt|˕ט;j@y$wW]Mz^yCA|Q պɬ4´<'ώךޝ+}*˰;8oWݾG/aj?Ww3NN;⴪>p'1NMx%Vy~^rn/䔓~^wHS\'ZeTˣxOzf?gW7 I*Ϝy+NW߃X]{dTaZ9wWCuw +NJ+t}Omރ)3A Q:\\+ i'\V^wh7)s+?5ɛ;+-*SXjS {"rN_\w`jTsN&vHsW?epI[XKϞurw2ʳ=3yLBr"#uS?qRUWyU;nO.83;5ɟVXI,5S?q^}/cm;%jggFrW4Z9{m~g2×YU:ɝ_y+Mz~5SZ]ͬڿbO;8an8 KKː9ܫ8'US cFYLro.9wUc=ؤ_qpk7vO|%^;^iꧬx_ȱ&k>KWW~Egwf2O0i\}G\ 2tJ>3wt_KAz6\WK{9W{;ZҦf~Pg3ۚjnŝ`̔~rFS pd0k'$Z${eҦ_ʳOΚNg+;gNJa' תfN磎5SMS yg҉|RWLZ<ONrgvW\_aʤ_iymԲF5:>{(Ыͯ]tjwʳڥM9Ԝ`eXSw1S>~&͘tgYa@W/~r]-.ګ=)CÄW=/󮜩8LݝE5ϦNׯX;f <¥=kH,{v.xUnjvzJzΨtUr.{譕+Gk곦R$uzz<2ƽګMfOK5@WjgT{IGnK [8+9NOUS;V: ϕX4~&gvrɚWAw3YÄk}??S#wqyM亚jh;jg{ߙ!m;R[ųe{e_͘\;Xj.3xȽ~7/EXRW<}Wn)zfV:NiujZDzw9N#'ߕ$lv^y&}EuNݷk:ԝEM7%]+%\K_ ' ϳw琎>3SĽ)ޜT zOoKO<۪~:c< F_QlpɱW^UoMk9ULUOg>9 59T cvgnőO8\T/jƵTz3Pl<K_ W{ɹ_i:p-YUf7Hu XWorPCjrʓZ7Ye3ξvnvjj u%;C>5 8WLsMݪ风5u;5'hg2N:r8};5;N&5d:ޚ%o zY~ueӻS3xUSy2VSQ4˒nWea9;S\ԝ99 VZ>$DO?8`Mi͜LıW>yZy&?J]SϚڮ2de]XK!Բ,e]7@f[qO8W<ԙ#aֈbϚN9+~@>FRw 2YK"]N<5}Wu+_}s|5$eI-R܀Rg|%7:Zw^x/xSuuN}=ygLhÝhyQW}'ڼ>1ynnjei'='53zwo5c*㊧D{9vj\֫v*cLOK.y&UՌ3|h bDլ;|8I]Vy@ˇ,f]ͺ+ 1߅4.13j5:YU>YI̔/,-\j_uO Iԓ;1,R|2VJWY+)tswiYwzԲ6}SOyy@7jõ7oVװ?5^Wzf^e++gYfş]Y'ԾRw'}SO^[V!g`]L XScz3_jƷdarb8.-D+t~s} a|Nn[:GNy;+gXi[{@NWQ˚u1ثfo>1^x7{'=kj^zI-_3#{@8d(}U}53NŭzkRU/OKl3WjfjYi_1IևVȉɃ$Z]qj+{I\;}j˾v{55szyo5c "O_sQyzcve)Il9ȝ99]Ռ;9(@mWrOU}b 8ղ/uwIGI̮^[Ɛ_$c.R3Su\c0/;/GLuΚEq 1j3嬥Uݽ˩Ǟf3V.x} tN-kHʒZ֥xdi_GĈKxsO9fx.QMάݾU:M#X`tuQ'jɫתtϻ5Q|MF8W*zv5uI$G-r^_2 FjYCrT2㴞uYc21'u'}j˚Ӛ9'u7gAJK9 9> DÌ|r:\\j3y 򲟻s'%yUt*<3W5'Qڮ:| P>5 8WLsMݪ风5u;5'hg mhAзS_j2kvJg jg,Y۩9wrr*>֕؇VȉKojX3ɿ)Z YҬ^dmo<{a:gt==]yO;1;A(`}AݜNg&=+.w0ZyOaaz:;Ӛ3XPϜUM/|@~ afGOW+kzcڹIys=uSsUJc.:֓ lY~@.Mo»3Iȧ}jWx.i5UMO Zi*NoyU]ͥ0.ΜgN{쓯zc̎WY3-gW=1ʞXS7<[WR`78Ӈ3IwGέpM+/ݴruO1\Ҥμʾ6yJWiC4Yӟ5u?U癞z}K7Bw}9굘^ϥZK:䄓N{%q=i+nK {:{:_߰ pߩɛ͞t&9kb>~v뺽wWW.WwEGw֟bXG:rً#}k@wuw.J,Uόo>9u5?Ubzr'1'K}ך+nKI?i u?U>HwW ռΓg.}Wc,g 7Y%P{Lf \ ~IDATNo+LHϤ#'ߕ$lv^y&}EuNݷk:ث.ƿtuΘt2z>5;4Zcީ3ʬX=kw ϋɕӝpSL2ֽfL|u,5S_ZD]͋U}E13'ZŌx7Ou1?y}TU,}Y|XSԱN-Avut]Ϥ# [>~[wo~cS-k.+ó?p/O7'zSV 8{&^]9Sqϙ;)kM5:c.+2v9eRW m pf.Úq6nƤ5=˺;aTwI13;}0qZ'!I:֔}U^W^#jYSiYAr`Q$#: U`iS5Wvp]r8OU͜Gk꧚:ADO:z:vvp_S1VS3z1ۘwy|L^gTWV%vO].u'vjz?Oh?ԮqK{>SSibyAxruܵVY_q; =u!ǚ̠uzSQW/oqeM]سVfW狯4;s ss'Gl]W ƙ/5:ߤYX r-djkO]NYƳWM}՟bky%ovjW;)+9cr]M}[DݠNG|G-W3v0ג67;Ts+c|\wK]w6? CT_MyG_ek&@A|r;R{gqFbƩ7qUp.g^͘~&I55YSQD?䮮*tS.9t>W1Viѯ^gJN8IgYN+]b}oYajՓN3gn/yRc NOiO>j?t}Ȏpgƪ!}nO1Чڋg0g5cu.^fvǥ}YQpYsJG2TklZT>a^Ӟ]]y:"ǚ @#?T֒g}¥j/N8-]gvz*.lgN9+W{+2kTpԲr K^q´t\<[rw.v u^W^އv黣2:I NO'ˍ&zjW9OY;;XjN{^JS-?DwqKsU K^qƬgwr'Mǝ^W+=x?}|@v G-k[y*Mb5Oy; Ӳyתn^w ^i^M_iy?RqO:> >?T ]pht\WśW՟wSfO|.uWˬI?/Iw?|]pV|OWXJuO@d!og֤&4kDM=k}8kϪZ+LJ;Tkq?ȣ<.UO{W,5w,7j?k?  :9\+l3skW0-\ӓ;yNfNvN..w]aZՍyWg&W,5wS*{ֺY'wWlƴӻW:^γZyNy2&Nfs&vg?e-9H}hɱg e^9Jzb_qU{enNڎ;+mb{_yySAK:Ou}5`9cɩJ};ؤj]͜v;Mzس}2N.w9&Nx M܇g3L;+mb^wl!z坴/  r{+Mg ':}´wՙy+mǟvKMس~U+zY^|һW:^=w^ zZy'Nf'_$7}7Cx#1{Opz*_FxW+MǟvK;6> :w|ϸu~♭^7ywjwzjst3V ˬ;1KPٳ Gn8;agm8_8:<ۤ[w39wWIJΞW ctJI ':}´UWOJ]Ѥg'N?l ܳ^iwgLϫZ7åI>Zv4wWIJ5&JCU{+m wމ%'L7;={Нs4W&=YA N녯<++]bxS^@~=?+w\WΕxwiz'(C̯N#sTkٌi>yiTg0.j^ySYwx;+o+^hμL♽k9=s9֕ꓹ Wy2m=}PL3 -1}function p(v,u){if(!s(v,u)){v.className=(v.className+" "+u)}}function a(v,u){v.className=v.className.replace(new RegExp("(^|\\s)"+u+"(?:\\s|$)"),"$1")}function e(u){return document.getElementById(u)}var o=function(v){v=v||{};var u=function(){this.constructor=u;if(o.prototyping){return this}var x=(this.initialize)?this.initialize.apply(this,arguments):this;return x};for(var w in o.Mutators){if(!v[w]){continue}v=o.Mutators[w](v,v[w]);delete v[w]}c(u,this);u.constructor=o;u.prototype=v;return u};o.Mutators={Extends:function(w,u){o.prototyping=u.prototype;var v=new u;delete v.parent;v=o.inherit(v,w);delete o.prototyping;return v},Implements:function(u,v){g(j(v),function(w){o.prototying=w;c(u,(h(w)=="function")?new w:w);delete o.prototyping});return u}};c(o,{inherit:function(v,y){var u=arguments.callee.caller;for(var x in y){var w=y[x];var A=v[x];var z=h(w);if(A&&z=="function"){if(w!=A){if(u){w.__parent=A;v[x]=w}else{o.override(v,x,w)}}}else{if(z=="object"){v[x]=r(A,w)}else{v[x]=w}}}if(u){v.parent=function(){return arguments.callee.caller.__parent.apply(this,arguments)}}return v},override:function(v,u,y){var x=o.prototyping;if(x&&v[u]!=x[u]){x=null}var w=function(){var z=this.parent;this.parent=x?x[u]:v[u];var A=y.apply(this,arguments);this.parent=z;return A};v[u]=w}});o.prototype.implement=function(){var u=this.prototype;g(Array.prototype.slice.call(arguments||[]),function(v){o.inherit(u,v)});return this};this.TreeUtil={prune:function(v,u){this.each(v,function(x,w){if(w==u&&x.children){delete x.children;x.children=[]}})},getParent:function(u,y){if(u.id==y){return false}var x=u.children;if(x&&x.length>0){for(var w=0;wx){if(z>B){y=v((B+((z-A)-B)*C))}else{y=v((B-A+(z-(B-A))*C))}}else{y=v((B+(z-B)*C))}var u=(this.rho-w.rho)*C+w.rho;return{theta:y,rho:u}}};var l=function(v,u){return new Polar(v,u)};Polar.KER=l(0,0);this.Complex=function(u,v){this.x=u;this.y=v};Complex.prototype={getc:function(){return this},getp:function(u){return this.toPolar(u)},set:function(u){u=u.getc(true);this.x=u.x;this.y=u.y},setc:function(u,v){this.x=u;this.y=v},setp:function(v,u){this.x=Math.cos(v)*u;this.y=Math.sin(v)*u},clone:function(){return new Complex(this.x,this.y)},toPolar:function(w){var u=this.norm();var v=Math.atan2(this.y,this.x);if(v<0){v+=Math.PI*2}if(w){return{theta:v,rho:u}}return new Polar(v,u)},norm:function(){return Math.sqrt(this.squaredNorm())},squaredNorm:function(){return this.x*this.x+this.y*this.y},add:function(u){return new Complex(this.x+u.x,this.y+u.y)},prod:function(u){return new Complex(this.x*u.x-this.y*u.y,this.y*u.x+this.x*u.y)},conjugate:function(){return new Complex(this.x,-this.y)},scale:function(u){return new Complex(this.x*u,this.y*u)},equals:function(u){return this.x==u.x&&this.y==u.y},$add:function(u){this.x+=u.x;this.y+=u.y;return this},$prod:function(w){var u=this.x,v=this.y;this.x=u*w.x-v*w.y;this.y=v*w.x+u*w.y;return this},$conjugate:function(){this.y=-this.y;return this},$scale:function(u){this.x*=u;this.y*=u;return this},$div:function(z){var u=this.x,w=this.y;var v=z.squaredNorm();this.x=u*z.x+w*z.y;this.y=w*z.x-u*z.y;return this.$scale(1/v)}};var q=function(v,u){return new Complex(v,u)};Complex.KER=q(0,0);this.Graph=new o({initialize:function(u){var v={complex:false,Node:{}};this.opt=r(v,u||{});this.nodes={}},getNode:function(u){if(this.hasNode(u)){return this.nodes[u]}return false},getAdjacence:function(w,u){var v=[];if(this.hasNode(w)&&this.hasNode(u)&&this.nodes[w].adjacentTo({id:u})&&this.nodes[u].adjacentTo({id:w})){v.push(this.nodes[w].getAdjacency(u));v.push(this.nodes[u].getAdjacency(w));return v}return false},addNode:function(u){if(!this.nodes[u.id]){this.nodes[u.id]=new Graph.Node(c({id:u.id,name:u.name,data:u.data},this.opt.Node),this.opt.complex)}return this.nodes[u.id]},addAdjacence:function(x,w,v){var y=[];if(!this.hasNode(x.id)){this.addNode(x)}if(!this.hasNode(w.id)){this.addNode(w)}x=this.nodes[x.id];w=this.nodes[w.id];for(var u in this.nodes){if(this.nodes[u].id==x.id){if(!this.nodes[u].adjacentTo(w)){y.push(this.nodes[u].addAdjacency(w,v))}}if(this.nodes[u].id==w.id){if(!this.nodes[u].adjacentTo(x)){y.push(this.nodes[u].addAdjacency(x,v))}}}return y},removeNode:function(w){if(this.hasNode(w)){var v=this.nodes[w];for(var u=0 in v.adjacencies){var adj=v.adjacencies[u];this.removeAdjacence(w,adj.nodeTo.id)}delete this.nodes[w]}},removeAdjacence:function(y,x){if(this.hasNode(y)){this.nodes[y].removeAdjacency(x)}if(this.hasNode(x)){this.nodes[x].removeAdjacency(y)}},hasNode:function(x){return x in this.nodes}});Graph.Node=new o({initialize:function(x,z){var y={id:"",name:"",data:{},adjacencies:{},selected:false,drawn:false,exist:false,angleSpan:{begin:0,end:0},alpha:1,startAlpha:1,endAlpha:1,pos:(z&&q(0,0))||l(0,0),startPos:(z&&q(0,0))||l(0,0),endPos:(z&&q(0,0))||l(0,0)};c(this,c(y,x))},adjacentTo:function(x){return x.id in this.adjacencies},getAdjacency:function(x){return this.adjacencies[x]},addAdjacency:function(y,z){var x=new Graph.Adjacence(this,y,z);return this.adjacencies[y.id]=x},removeAdjacency:function(x){delete this.adjacencies[x]}});Graph.Adjacence=function(x,z,y){this.nodeFrom=x;this.nodeTo=z;this.data=y||{};this.alpha=1;this.startAlpha=1;this.endAlpha=1};Graph.Util={filter:function(y){if(!y||!(h(y)=="string")){return function(){return true}}var x=y.split(" ");return function(A){for(var z=0;z=G&&J<=H&&x(I)){C(I,J)}if(JJ){z(L,G,H)}})}})(B,F+E,y+E)},eachSubgraph:function(y,z,x){this.eachLevel(y,0,false,z,x)},eachSubnode:function(y,z,x){this.eachLevel(y,1,1,z,x)},anySubnode:function(A,z,y){var x=false;z=z||m(true);var B=h(z)=="string"?function(C){return C[z]}:z;this.eachSubnode(A,function(C){if(B(C)){x=true}},y);return x},getSubnodes:function(C,D,x){var z=[],B=this;D=D||0;var A,y;if(h(D)=="array"){A=D[0];y=D[1]}else{A=D;y=Number.MAX_VALUE-C._depth}this.eachLevel(C,A,y,function(E){z.push(E)},x);return z},getParents:function(y){var x=[];this.eachAdjacency(y,function(z){var A=z.nodeTo;if(A._depth=0.95){C.plotLabel(z,H,y)}else{C.hideLabel(H,false)}}F.restore();H.visited=!A})},plotLabel:function(A,B,z){var C=B.id,x=this.getLabel(C);if(!x&&!(x=document.getElementById(C))){x=document.createElement("div");var y=this.getLabelContainer();y.appendChild(x);x.id=C;x.className="node";x.style.position="absolute";z.onCreateLabel(x,B);this.labels[B.id]=x}this.placeLabel(x,B,z)},plotNode:function(z,y,G){var E=this.node,B=z.data;var D=E.overridable&&B;var x=D&&B.$lineWidth||E.lineWidth;var A=D&&B.$color||E.color;var F=y.getCtx();F.lineWidth=x;F.fillStyle=A;F.strokeStyle=A;var C=z.data&&z.data.$type||E.type;this.nodeTypes[C].call(this,z,y,G)},plotLine:function(E,z,G){var x=this.edge,B=E.data;var D=x.overridable&&B;var y=D&&B.$lineWidth||x.lineWidth;var A=D&&B.$color||x.color;var F=z.getCtx();F.lineWidth=y;F.fillStyle=A;F.strokeStyle=A;var C=E.data&&E.data.$type||x.type;this.edgeTypes[C].call(this,E,z,G)},fitsInCanvas:function(z,x){var y=x.getSize();if(z.x>=y.width||z.x<0||z.y>=y.height||z.y<0){return false}return true}};var Loader={construct:function(y){var z=(h(y)=="array");var x=new Graph(this.graphOptions);if(!z){(function(A,C){A.addNode(C);for(var B=0,D=C.children;B=(7-4*A)/11){B=z*z-Math.pow((11-6*A-11*C)/4,2);break}}return B},Elastic:function(A,z){return Math.pow(2,10*--A)*Math.cos(20*A*Math.PI*(z[0]||1)/3)}};g(y,function(A,z){Trans[z]=x(A)});g(["Quad","Cubic","Quart","Quint"],function(A,z){Trans[A]=x(function(B){return Math.pow(B,[z+2])})})})();var Animation=new o({initalize:function(x){this.setOptions(x)},setOptions:function(x){var y={duration:2500,fps:40,transition:Trans.Quart.easeInOut,compute:b,complete:b};this.opt=r(y,x||{});return this},getTime:function(){return k()},step:function(){var y=this.getTime(),x=this.opt;if(y0)?R[0]:null;Q(R)}for(var L=0,M=[P.id].concat(J);L=Q._depth)});for(var N=0;N0&&W.drawn){W.drawn=false;J[M.id].push(W)}else{if((!R||!P)&&W.drawn){W.drawn=false;J[M.id].push(W)}}});M.drawn=true}if(I.length>0){S.fx.plot()}for(N in J){g(J[N],function(W){W.drawn=true})}for(N=0;NI?K:I)+this.config.subtreeOffset},getEdge:function(I,N,Q){var M=function(S,R){return function(){return I.pos.add(new Complex(S,R))}};var L=this.node;var O=this.node.overridable,J=I.data;var P=O&&J.$width||L.width;var K=O&&J.$height||L.height;if(N=="begin"){if(L.align=="center"){return this.dispatch(Q,M(0,K/2),M(-P/2,0),M(0,-K/2),M(P/2,0))}else{if(L.align=="left"){return this.dispatch(Q,M(0,K),M(0,0),M(0,0),M(P,0))}else{if(L.align=="right"){return this.dispatch(Q,M(0,0),M(-P,0),M(0,-K),M(0,0))}else{throw"align: not implemented"}}}}else{if(N=="end"){if(L.align=="center"){return this.dispatch(Q,M(0,-K/2),M(P/2,0),M(0,K/2),M(-P/2,0))}else{if(L.align=="left"){return this.dispatch(Q,M(0,0),M(P,0),M(0,K),M(0,0))}else{if(L.align=="right"){return this.dispatch(Q,M(0,-K),M(0,0),M(0,0),M(-P,0))}else{throw"align: not implemented"}}}}}},getScaledTreePosition:function(I,J){var L=this.node;var O=this.node.overridable,K=I.data;var P=(O&&K.$width||L.width);var M=(O&&K.$height||L.height);var Q=(this.config.multitree&&("$orn" in I.data)&&I.data.$orn)||this.config.orientation;var N=function(S,R){return function(){return I.pos.add(new Complex(S,R)).$scale(1-J)}};if(L.align=="left"){return this.dispatch(Q,N(0,M),N(0,0),N(0,0),N(P,0))}else{if(L.align=="center"){return this.dispatch(Q,N(0,M/2),N(-P/2,0),N(0,-M/2),N(P/2,0))}else{if(L.align=="right"){return this.dispatch(Q,N(0,0),N(-P,0),N(0,-M),N(0,0))}else{throw"align: not implemented"}}}},treeFitsInCanvas:function(N,I,O){var K=I.getSize(N);var L=(this.config.multitree&&("$orn" in N.data)&&N.data.$orn)||this.config.orientation;var J=this.dispatch(L,K.width,K.height);var M=this.getTreeBaseSize(N,O,function(Q,P){return Q===0||!Graph.Util.anySubnode(P)});return(ML){N.drawn=false;N.exist=false;J.hideLabel(N,false)}else{N.exist=true}});K.drawn=true},getRightLevelToShow:function(L,J){var I=this.config;var M=I.levelsToShow;var K=I.constrained;if(!K){return M}while(!this.treeFitsInCanvas(L,J,M)&&M>1){M--}return M}});ST.Plot=new o({Implements:Graph.Plot,initialize:function(I){this.viz=I;this.config=I.config;this.node=this.config.Node;this.edge=this.config.Edge;this.animation=new Animation;this.nodeTypes=new ST.Plot.NodeTypes;this.edgeTypes=new ST.Plot.EdgeTypes},plotSubtree:function(N,M,P,K){var I=this.viz,L=I.canvas;P=Math.min(Math.max(0.001,P),1);if(P>=0){N.drawn=false;var J=L.getCtx();var O=I.geom.getScaledTreePosition(N,P);J.translate(O.x,O.y);J.scale(P,P)}this.plotTree(N,!P,M,K);if(P>=0){N.drawn=true}},plotTree:function(L,M,I,S){var O=this,Q=this.viz,J=Q.canvas,K=this.config,R=J.getCtx();var P=K.multitree&&!("$orn" in L.data);var N=P&&L.data.$orns;Graph.Util.eachSubnode(L,function(U){if((!P||N.indexOf(U.data.$orn)>0)&&U.exist&&U.drawn){var T=L.getAdjacency(U.id);!S&&I.onBeforePlotLine(T);R.globalAlpha=Math.min(L.alpha,U.alpha);O.plotLine(T,J,S);!S&&I.onAfterPlotLine(T);O.plotTree(U,M,I,S)}});if(L.drawn){R.globalAlpha=L.alpha;!S&&I.onBeforePlotNode(L);this.plotNode(L,J,S);!S&&I.onAfterPlotNode(L);if(M&&R.globalAlpha>=0.95){this.plotLabel(J,L,I)}else{this.hideLabel(L,false)}}else{this.hideLabel(L,true)}},placeLabel:function(T,L,O){var R=L.pos.getc(true),M=this.node,J=this.viz.canvas;var S=M.overridable&&L.data.$width||M.width;var N=M.overridable&&L.data.$height||M.height;var P=J.getSize();var K,Q;if(M.align=="center"){K={x:Math.round(R.x-S/2+P.width/2),y:Math.round(R.y-N/2+P.height/2)}}else{if(M.align=="left"){Q=this.config.orientation;if(Q=="bottom"||Q=="top"){K={x:Math.round(R.x-S/2+P.width/2),y:Math.round(R.y+P.height/2)}}else{K={x:Math.round(R.x+P.width/2),y:Math.round(R.y-N/2+P.height/2)}}}else{if(M.align=="right"){Q=this.config.orientation;if(Q=="bottom"||Q=="top"){K={x:Math.round(R.x-S/2+P.width/2),y:Math.round(R.y-N+P.height/2)}}else{K={x:Math.round(R.x-S+P.width/2),y:Math.round(R.y-N/2+P.height/2)}}}else{throw"align: not implemented"}}}var I=T.style;I.left=K.x+"px";I.top=K.y+"px";I.display=this.fitsInCanvas(K,J)?"":"none";O.onPlaceLabel(T,L)},getAlignedPos:function(N,L,I){var K=this.node;var M,J;if(K.align=="center"){M={x:N.x-L/2,y:N.y-I/2}}else{if(K.align=="left"){J=this.config.orientation;if(J=="bottom"||J=="top"){M={x:N.x-L/2,y:N.y}}else{M={x:N.x,y:N.y-I/2}}}else{if(K.align=="right"){J=this.config.orientation;if(J=="bottom"||J=="top"){M={x:N.x-L/2,y:N.y-I}}else{M={x:N.x-L,y:N.y-I/2}}}else{throw"align: not implemented"}}}return M},getOrientation:function(I){var K=this.config;var J=K.orientation;if(K.multitree){var L=I.nodeFrom;var M=I.nodeTo;J=(("$orn" in L.data)&&L.data.$orn)||(("$orn" in M.data)&&M.data.$orn)}return J}});ST.Plot.NodeTypes=new o({none:function(){},circle:function(M,J){var P=M.pos.getc(true),L=this.node,N=M.data;var K=L.overridable&&N;var O=K&&N.$dim||L.dim;var I=this.getAlignedPos(P,O*2,O*2);J.path("fill",function(Q){Q.arc(I.x+O,I.y+O,O,0,Math.PI*2,true)})},square:function(M,J){var P=M.pos.getc(true),L=this.node,N=M.data;var K=L.overridable&&N;var O=K&&N.$dim||L.dim;var I=this.getAlignedPos(P,O,O);J.getCtx().fillRect(I.x,I.y,O,O)},ellipse:function(K,J){var N=K.pos.getc(true),O=this.node,L=K.data;var M=O.overridable&&L;var I=(M&&L.$width||O.width)/2;var Q=(M&&L.$height||O.height)/2;var P=this.getAlignedPos(N,I*2,Q*2);var R=J.getCtx();R.save();R.scale(I/Q,Q/I);J.path("fill",function(S){S.arc((P.x+I)*(Q/I),(P.y+Q)*(I/Q),Q,0,Math.PI*2,true)});R.restore()},rectangle:function(K,J){var N=K.pos.getc(true),O=this.node,L=K.data;var M=O.overridable&&L;var I=M&&L.$width||O.width;var Q=M&&L.$height||O.height;var P=this.getAlignedPos(N,I,Q);J.getCtx().fillRect(P.x,P.y,I,Q)}});ST.Plot.EdgeTypes=new o({none:function(){},line:function(J,L){var K=this.getOrientation(J);var N=J.nodeFrom,O=J.nodeTo;var M=this.viz.geom.getEdge(N._depth1){var K={};K[U.id]=U;K[M.id]=M;var V=Z.$direction;U=K[V[0]];M=K[V[1]]}var N=this.viz.geom.getEdge(U,"begin",W);var S=this.viz.geom.getEdge(M,"end",W);var T=new Complex(S.x-N.x,S.y-N.y);T.$scale(O/T.norm());var X=new Complex(S.x-T.x,S.y-T.y);var Y=new Complex(-T.y/2,T.x/2);var J=X.add(Y),I=X.$add(Y.$scale(-1));L.path("stroke",function(aa){aa.moveTo(N.x,N.y);aa.lineTo(S.x,S.y)});L.path("fill",function(aa){aa.moveTo(J.x,J.y);aa.lineTo(I.x,I.y);aa.lineTo(S.x,S.y)})}})})();var AngularWidth={setAngularWidthForNodes:function(){var x=this.config.Node;var z=x.overridable;var y=x.dim;Graph.Util.eachBFS(this.graph,this.root,function(C,A){var B=(z&&C.data&&C.data.$aw)||y;C._angularWidth=B/A},"ignore")},setSubtreesAngularWidth:function(){var x=this;Graph.Util.eachNode(this.graph,function(y){x.setSubtreeAngularWidth(y)},"ignore")},setSubtreeAngularWidth:function(A){var z=this,y=A._angularWidth,x=0;Graph.Util.eachSubnode(A,function(B){z.setSubtreeAngularWidth(B);x+=B._treeAngularWidth},"ignore");A._treeAngularWidth=Math.max(y,x)},computeAngularWidths:function(){this.setAngularWidthForNodes();this.setSubtreesAngularWidth()}};this.RGraph=new o({Implements:[Loader,AngularWidth],initialize:function(A,x){var z={labelContainer:A.id+"-label",interpolation:"linear",levelDistance:100,withLabels:true,Node:{overridable:false,type:"circle",dim:3,color:"#ccb",width:5,height:5,lineWidth:1},Edge:{overridable:false,type:"line",color:"#ccb",lineWidth:1},fps:40,duration:2500,transition:Trans.Quart.easeInOut,clearCanvas:true};var y={onBeforeCompute:b,onAfterCompute:b,onCreateLabel:b,onPlaceLabel:b,onComplete:b,onBeforePlotLine:b,onAfterPlotLine:b,onBeforePlotNode:b,onAfterPlotNode:b};this.controller=this.config=r(z,y,x);this.graphOptions={complex:false,Node:{selected:false,exist:true,drawn:true}};this.graph=new Graph(this.graphOptions);this.fx=new RGraph.Plot(this);this.op=new RGraph.Op(this);this.json=null;this.canvas=A;this.root=null;this.busy=false;this.parent=false},refresh:function(){this.compute();this.plot()},reposition:function(){this.compute("endPos")},plot:function(){this.fx.plot()},compute:function(y){var z=y||["pos","startPos","endPos"];var x=this.graph.getNode(this.root);x._depth=0;Graph.Util.computeLevels(this.graph,this.root,0,"ignore");this.computeAngularWidths();this.computePositions(z)},computePositions:function(E){var y=j(E);var D=this.graph;var C=Graph.Util;var x=this.graph.getNode(this.root);var B=this.parent;var z=this.config;for(var A=0;A0&&F[0].dist){F.sort(function(R,Q){return(R.dist>=Q.dist)-(R.dist<=Q.dist)})}for(var J=0;J0)?B[0]:false;if(A){var x=A.pos.getc(),C=D.pos.getc();var y=x.add(C.scale(-1));z=Math.atan2(y.y,y.x);if(z<0){z+=2*Math.PI}}return{parent:A,theta:z}},tagChildren:function(B,D){if(B.angleSpan){var C=[];Graph.Util.eachAdjacency(B,function(E){C.push(E.nodeTo)},"ignore");var x=C.length;for(var A=0;A1){var y={};y[D.id]=D;y[A.id]=A;var z=E.$direction;D=y[z[0]];A=y[z[1]]}var N=D.pos.getc(true),C=A.pos.getc(true);var H=new Complex(C.x-N.x,C.y-N.y);H.$scale(L/H.norm());var F=new Complex(C.x-H.x,C.y-H.y);var G=new Complex(-H.y/2,H.x/2);var M=F.add(G),K=F.$add(G.$scale(-1));B.path("stroke",function(O){O.moveTo(N.x,N.y);O.lineTo(C.x,C.y)});B.path("fill",function(O){O.moveTo(M.x,M.y);O.lineTo(K.x,K.y);O.lineTo(C.x,C.y)})}});Complex.prototype.moebiusTransformation=function(z){var x=this.add(z);var y=z.$conjugate().$prod(this);y.x++;return x.$div(y)};Graph.Util.getClosestNodeToOrigin=function(y,z,x){return this.getClosestNodeToPos(y,Polar.KER,z,x)};Graph.Util.getClosestNodeToPos=function(z,C,B,x){var y=null;B=B||"pos";C=C&&C.getc(true)||Complex.KER;var A=function(E,D){var G=E.x-D.x,F=E.y-D.y;return G*G+F*F};this.eachNode(z,function(D){y=(y==null||A(D[B].getc(true),C)K)?L._depth:K;L._scale=z},"ignore");for(var J=0.51;J<=1;J+=0.01){var I=(function(L,M){return(1-Math.pow(L,M))/(1-L)})(J,K+1);if(I>=2){return J-0.01}}return 0.5})();D.eachBFS(this.graph,this.root,function(N){var J=N.angleSpan.end-N.angleSpan.begin;var O=N.angleSpan.begin;var M=(function(Q){var R=0;D.eachSubnode(Q,function(S){R+=S._treeAngularWidth},"ignore");return R})(N);for(var L=1,I=0,K=y,P=N._depth;L<=P+1;L++){I+=K;K*=y}D.eachSubnode(N,function(T){if(!T._flag){T._rel=T._treeAngularWidth/M;var S=T._rel*J;var R=O+S/2;for(var Q=0;Q1000||D.b>1000||D.ratio>1000){A.path("stroke",function(L){L.moveTo(J.x*C,J.y*C);L.lineTo(E.x*C,E.y*C)})}else{var H=Math.atan2(E.y-D.y,E.x-D.x);var G=Math.atan2(J.y-D.y,J.x-D.x);var y=this.sense(H,G);var x=A.getCtx();A.path("stroke",function(L){L.arc(D.x*C,D.y*C,D.ratio*C,H,G,y)})}},computeArcThroughTwoPoints:function(L,K){var D=(L.x*K.y-L.y*K.x),z=D;var C=L.squaredNorm(),B=K.squaredNorm();if(D==0){return{x:0,y:0,ratio:1001}}var J=(L.y*B-K.y*C+L.y-K.y)/D;var H=(K.x*C-L.x*B+K.x-L.x)/z;var I=-J/2;var G=-H/2;var F=(J*J+H*H)/4-1;if(F<0){return{x:0,y:0,ratio:1001}}var E=Math.sqrt(F);var A={x:I,y:G,ratio:E,a:J,b:H};return A},sense:function(x,y){return(xy)?false:true):((y+Math.PI>x)?true:false)},placeLabel:function(F,A,C){var E=A.pos.getc(true),y=this.viz.canvas;var D=y.getSize();var B=A._scale;var z={x:Math.round(E.x*B+D.width/2),y:Math.round(E.y*B+D.height/2)};var x=F.style;x.left=z.x+"px";x.top=z.y+"px";x.display="";C.onPlaceLabel(F,A)}});Hypertree.Plot.NodeTypes=new o({none:function(){},circle:function(A,y){var z=this.node,C=A.data;var B=z.overridable&&C&&C.$dim||z.dim;var D=A.pos.getc(),E=D.scale(A._scale);var x=z.transform?B*(1-D.squaredNorm()):B;if(x>=B/4){y.path("fill",function(F){F.arc(E.x,E.y,x,0,Math.PI*2,true)})}},square:function(A,z){var F=this.node,C=A.data;var x=F.overridable&&C&&C.$dim||F.dim;var y=A.pos.getc(),E=y.scale(A._scale);var D=F.transform?x*(1-y.squaredNorm()):x;var B=2*D;if(D>=x/4){z.getCtx().fillRect(E.x-D,E.y-D,B,B)}},rectangle:function(A,z){var E=this.node,B=A.data;var y=E.overridable&&B&&B.$width||E.width;var F=E.overridable&&B&&B.$height||E.height;var x=A.pos.getc(),D=x.scale(A._scale);var C=1-x.squaredNorm();y=E.transform?y*C:y;F=E.transform?F*C:F;if(C>=0.25){z.getCtx().fillRect(D.x-y/2,D.y-F/2,y,F)}},triangle:function(C,z){var I=this.node,D=C.data;var x=I.overridable&&D&&D.$dim||I.dim;var y=C.pos.getc(),H=y.scale(C._scale);var G=I.transform?x*(1-y.squaredNorm()):x;if(G>=x/4){var B=H.x,A=H.y-G,K=B-G,J=H.y+G,F=B+G,E=J;z.path("fill",function(L){L.moveTo(B,A);L.lineTo(K,J);L.lineTo(F,E)})}},star:function(A,z){var G=this.node,C=A.data;var x=G.overridable&&C&&C.$dim||G.dim;var y=A.pos.getc(),F=y.scale(A._scale);var E=G.transform?x*(1-y.squaredNorm()):x;if(E>=x/4){var H=z.getCtx(),D=Math.PI/5;H.save();H.translate(F.x,F.y);H.beginPath();H.moveTo(x,0);for(var B=0;B<9;B++){H.rotate(D);if(B%2==0){H.lineTo((E/0.525731)*0.200811,0)}else{H.lineTo(E,0)}}H.closePath();H.fill();H.restore()}}});Hypertree.Plot.EdgeTypes=new o({none:function(){},line:function(x,y){var z=x.nodeFrom._scale;var B=x.nodeFrom.pos.getc(true);var A=x.nodeTo.pos.getc(true);y.path("stroke",function(C){C.moveTo(B.x*z,B.y*z);C.lineTo(A.x*z,A.y*z)})},hyperline:function(x,y){this.hyperline(x,y)}});this.TM={layout:{orientation:"h",vertical:function(){return this.orientation=="v"},horizontal:function(){return this.orientation=="h"},change:function(){this.orientation=this.vertical()?"h":"v"}},innerController:{onBeforeCompute:b,onAfterCompute:b,onComplete:b,onCreateElement:b,onDestroyElement:b,request:false},config:{orientation:"h",titleHeight:13,rootId:"infovis",offset:4,levelsToShow:3,addLeftClickHandler:false,addRightClickHandler:false,selectPathOnHover:false,Color:{allow:false,minValue:-100,maxValue:100,minColorValue:[255,0,50],maxColorValue:[0,255,50]},Tips:{allow:false,offsetX:20,offsetY:20,onShow:b}},initialize:function(x){this.tree=null;this.shownTree=null;this.controller=this.config=r(this.config,this.innerController,x);this.rootId=this.config.rootId;this.layout.orientation=this.config.orientation;if(this.config.Tips.allow&&document.body){var B=document.getElementById("_tooltip")||document.createElement("div");B.id="_tooltip";B.className="tip";var z=B.style;z.position="absolute";z.display="none";z.zIndex=13000;document.body.appendChild(B);this.tip=B}var A=this;var y=function(){A.empty();if(window.CollectGarbage){window.CollectGarbage()}delete y};if(window.addEventListener){window.addEventListener("unload",y,false)}else{window.attachEvent("onunload",y)}},each:function(x){(function y(D){if(!D){return}var C=D.childNodes,z=C.length;if(z>0){x.apply(this,[D,z===1,C[0],C[1]])}if(z>1){for(var A=C[1].childNodes,B=0;B1){A+=this.plot(y)}}return this.createBox(B,D,A)},headBox:function(y,B){var x=this.config,A=x.offset;var z={height:x.titleHeight+"px",width:(B.width-A)+"px",left:A/2+"px"};return'
'+y.name+"
"},bodyBox:function(y,C){var x=this.config,z=x.titleHeight,B=x.offset;var A={width:(C.width-B)+"px",height:(C.height-B-z)+"px",top:(z+B/2)+"px",left:(B/2)+"px"};return'
'+y+"
"},contentBox:function(z,B,y){var A={};for(var x in B){A[x]=B[x]+"px"}return'
'+y+"
"},leafBox:function(A,E){var z=this.config;var y=z.Color.allow&&this.setColor(A),D=z.offset,B=E.width-D,x=E.height-D;var C={top:(D/2)+"px",height:x+"px",width:B+"px",left:(D/2)+"px"};if(y){C["background-color"]=y}return'
'+A.name+"
"},setColor:function(F){var A=this.config.Color,B=A.maxColorValue,y=A.minColorValue,C=A.maxValue,G=A.minValue,E=C-G,D=(F.data.$color-0);var z=function(I,H){return Math.round((((B[I]-y[I])/E)*(H-G)+y[I]))};return d([z(0,D),z(1,D),z(2,D)])},enter:function(x){this.view(x.parentNode.id)},onLeftClick:function(x){this.enter(x)},out:function(){var x=TreeUtil.getParent(this.tree,this.shownTree.id);if(x){if(this.controller.request){TreeUtil.prune(x,this.config.levelsToShow)}this.view(x.id)}},onRightClick:function(){this.out()},view:function(B){var x=this.config,z=this;var y={onComplete:function(){z.loadTree(B);e(x.rootId).focus()}};if(this.controller.request){var A=TreeUtil;A.loadSubtrees(A.getSubtree(this.tree,B),r(this.controller,y))}else{y.onComplete()}},resetPath:function(x){var y=this.rootId,B=this.resetPath.previous;this.resetPath.previous=x||false;function z(D){var C=D.parentNode;return C&&(C.id!=y)&&C}function A(F,C){if(F){var D=e(F.id);if(D){var E=z(D);while(E){F=E.childNodes[0];if(s(F,"in-path")){if(C==undefined||!!C){a(F,"in-path")}}else{if(!C){p(F,"in-path")}}E=z(E)}}}}A(B,true);A(x,false)},initializeElements:function(){var x=this.controller,z=this;var y=m(false),A=x.Tips.allow;this.each(function(F,E,D,C){var B=TreeUtil.getSubtree(z.tree,F.id);x.onCreateElement(F,B,E,D,C);if(x.addRightClickHandler){D.oncontextmenu=y}if(x.addLeftClickHandler||x.addRightClickHandler){t(D,"mouseup",function(G){var H=(G.which==3||G.button==2);if(H){if(x.addRightClickHandler){z.onRightClick()}}else{if(x.addLeftClickHandler){z.onLeftClick(D)}}if(G.preventDefault){G.preventDefault()}else{G.returnValue=false}})}if(x.selectPathOnHover||A){t(D,"mouseover",function(G){if(x.selectPathOnHover){if(E){p(D,"over-leaf")}else{p(D,"over-head");p(F,"over-content")}if(F.id){z.resetPath(B)}}if(A){x.Tips.onShow(z.tip,B,E,D)}});t(D,"mouseout",function(G){if(x.selectPathOnHover){if(E){a(D,"over-leaf")}else{a(D,"over-head");a(F,"over-content")}z.resetPath()}if(A){z.tip.style.display="none"}});if(A){t(D,"mousemove",function(J,I){var O=z.tip;I=I||window;J=J||I.event;var N=I.document;N=N.html||N.body;var K={x:J.pageX||J.clientX+N.scrollLeft,y:J.pageY||J.clientY+N.scrollTop};O.style.display="";I={height:document.body.clientHeight,width:document.body.clientWidth};var H={width:O.offsetWidth,height:O.offsetHeight};var G=O.style,M=x.Tips.offsetX,L=x.Tips.offsetY;G.top=((K.y+L+H.height>I.height)?(K.y-H.height-L):K.y+L)+"px";G.left=((K.x+H.width+M>I.width)?(K.x-H.width-M):K.x+M)+"px"})}}})},destroyElements:function(){if(this.controller.onDestroyElement!=b){var x=this.controller,y=this;this.each(function(C,B,A,z){x.onDestroyElement(C,TreeUtil.getSubtree(y.tree,C.id),B,A,z)})}},empty:function(){this.destroyElements();f(e(this.rootId))},loadTree:function(x){this.empty();this.loadJSON(TreeUtil.getSubtree(this.tree,x))}};TM.SliceAndDice=new o({Implements:TM,loadJSON:function(A){this.controller.onBeforeCompute(A);var y=e(this.rootId),z=this.config,B=y.offsetWidth,x=y.offsetHeight;var C={coord:{top:0,left:0,width:B,height:x+z.titleHeight+z.offset}};if(this.tree==null){this.tree=A}this.shownTree=A;this.compute(C,A,this.layout.orientation);y.innerHTML=this.plot(A);this.initializeElements();this.controller.onAfterCompute(A)},compute:function(D,M,B){var O=this.config,I=D.coord,L=O.offset,H=I.width-L,F=I.height-L-O.titleHeight,y=D.data,x=(y&&("$area" in y))?M.data.$area/y.$area:1;var G,E,K,C,A;var N=(B=="h");if(N){B="v";G=F;E=Math.round(H*x);K="height";C="top";A="left"}else{B="h";G=Math.round(F*x);E=H;K="width";C="left";A="top"}M.coord={width:E,height:G,top:0,left:0};var J=0,z=this;g(M.children,function(P){z.compute(M,P,B);P.coord[C]=J;P.coord[A]=0;J+=Math.floor(P.coord[K])})}});TM.Area=new o({loadJSON:function(z){this.controller.onBeforeCompute(z);var y=e(this.rootId),A=y.offsetWidth,x=y.offsetHeight,E=this.config.offset,C=A-E,B=x-E-this.config.titleHeight;z.coord={height:x,width:A,top:0,left:0};var D=r(z.coord,{width:C,height:B});this.compute(z,D);y.innerHTML=this.plot(z);if(this.tree==null){this.tree=z}this.shownTree=z;this.initializeElements();this.controller.onAfterCompute(z)},computeDim:function(A,E,y,D,z){if(A.length+E.length==1){var x=(A.length==1)?A:E;this.layoutLast(x,y,D);return}if(A.length>=2&&E.length==0){E=[A[0]];A=A.slice(1)}if(A.length==0){if(E.length>0){this.layoutRow(E,y,D)}return}var C=A[0];if(z(E,y)>=z([C].concat(E),y)){this.computeDim(A.slice(1),E.concat([C]),y,D,z)}else{var B=this.layoutRow(E,y,D);this.computeDim(A,[],B.dim,B,z)}},worstAspectRatio:function(x,E){if(!x||x.length==0){return Number.MAX_VALUE}var y=0,F=0,B=Number.MAX_VALUE;for(var C=0;Cz)?F:z}var D=E*E,A=y*y;return Math.max(D*F/A,A/(D*B))},avgAspectRatio:function(A,x){if(!A||A.length==0){return Number.MAX_VALUE}var C=0;for(var y=0;yz)?x/z:z/x}return C/A.length},layoutLast:function(y,x,z){y[0].coord=z}});TM.Squarified=new o({Implements:[TM,TM.Area],compute:function(F,C){if(!(C.width>=C.height&&this.layout.horizontal())){this.layout.change()}var x=F.children,z=this.config;if(x.length>0){this.processChildrenLayout(F,x,C);for(var B=0;B=H._area)});var E=[x[0]];var D=x.slice(1);this.squarify(D,E,z,B)},squarify:function(y,A,x,z){this.computeDim(y,A,x,z,this.worstAspectRatio)},layoutRow:function(y,x,z){if(this.layout.horizontal()){return this.layoutV(y,x,z)}else{return this.layoutH(y,x,z)}},layoutV:function(x,F,C){var G=0,z=Math.round;g(x,function(H){G+=H._area});var y=z(G/F),D=0;for(var A=0;A0){this.processChildrenLayout(F,x,C);for(var B=0;B); run_test_group( { extra_options => { # set options for this test: usecputime => 1, # restrict irrelevant options: compress => 1, slowops => 0, savesrc => 0, leave => 0, stmts => 0, }, extra_test_count => 6, extra_test_code => sub { my ($profile, $env) = @_; my $trace = ($^O eq 'freebsd'); # XXX temp $profile = profile_this( src_code => $src_code, out_file => $env->{file}, #htmlopen => 1, verbose => $trace, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; warn "ticks_per_sec ".$profile->attributes->{ticks_per_sec}."\n" if $trace; my $subs = $profile->subname_subinfo_map; my $sub = $subs->{'main::foo'}; ok $sub; is $sub->calls, 1, 'main::foo should be called 1 time'; cmp_ok $sub->incl_time, '>=', 0.4 * 0.99, 'cputime of foo() should be at least 0.4'; cmp_ok $sub->incl_time, '<', 1.1, 'cputime of foo() should be not much more than 0.4'; is $sub->incl_time, $sub->excl_time, 'incl_time and excl_time should be the same'; }, }); __DATA__ #!perl BEGIN { eval { require Time::HiRes } and Time::HiRes->import('time') } alarm(20); # watchdog timer my $trace = 0; my $cpu1; my $cpu2; sub foo { my $cpuspend = shift; # sleep to separate cputime from realtime # (not very effective in cpu-starved VMs) sleep 1; my $loops = 0; my $prev; while (++$loops) { my @times = times; my $crnt = $times[0] + $times[1] - $cpu1; warn sprintf "tick %.4f\t%f\n", $crnt, time() if $trace >= 2 && $prev && $crnt != $prev; $prev = $crnt; last if $crnt >= $cpuspend; } warn "cputime loop count $loops\n" if $trace >= 2; } # record start time my $start = time() + 1; # sync up... # spin till wall clock ticks 1 while time() <= $start; # spin till cpu clock ticks (typically 0.1 sec max) my @times = times; $cpu1 = $times[0] + $times[1]; while (1) { @times = times; $cpu2 = $times[0] + $times[1]; last if $cpu2 != $cpu1; } warn sprintf "step %f\t%f\n", $cpu2-$cpu1, time() if $trace; $cpu1 = $cpu2; # set cpu1 to new current cpu time # consume this much cpu time inside foo() foo(0.4); # report realtime to help identify is cputime is really measuring realtime print "realtime used ".(time()-$start)."\n" if $trace; Devel-NYTProf-6.06/xt/test23-strevalxs.t000644 000766 000024 00000000121 12067023751 020253 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/xt/test71-while.p000644 000766 000024 00000000212 12067023751 017330 0ustar00timbostaff000000 000000 $a = 2; sub A { } sub B { } sub C { --$a } $a = 2; while ( C() ) { A(); } $a = 2; while ( C() ) { A(); } continue { B(); } Devel-NYTProf-6.06/xt/test23-strevalxs.rdt000644 000766 000024 00000003236 12067023751 020613 0ustar00timbostaff000000 000000 attribute application test23-strevalxs.p attribute basetime 0 attribute clock_id 0 attribute nv_size 0 attribute perl_version 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 0 0 fid_block_time 1 4 1 1 fid_block_time 1 4 2 1 [ 0 1 ] fid_fileinfo 1 [ test23-strevalxs.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 2-2 fid_fileinfo 1 call 4 Devel::NYTProf::Test::example_xsub_eval [ 1 0 0 0 0 0 0 ] fid_fileinfo 1 eval 4 [ 1 0 ] fid_fileinfo 2 [ (eval 0)[test23-strevalxs.p:4] 1 4 2 2 0 0 ] fid_fileinfo 2 call 1 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 ] fid_fileinfo 3 [ Devel/NYTProf/Test.pm 3 4 0 0 ] fid_fileinfo 3 sub Devel::NYTProf::Test::example_sub 13-13 fid_fileinfo 3 sub Devel::NYTProf::Test::example_xsub 0-0 fid_fileinfo 3 sub Devel::NYTProf::Test::example_xsub_eval 0-0 fid_line_time 1 4 0 0 fid_line_time 1 4 1 1 fid_line_time 1 4 2 1 [ 0 1 ] fid_sub_time 1 4 0 0 fid_sub_time 1 4 1 1 fid_sub_time 1 4 2 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo Devel::NYTProf::Test::example_sub [ 3 13 13 0 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub [ 3 0 0 1 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 2 1 [ 1 0 0 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub_eval [ 3 0 0 1 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub_eval called_by 1 4 [ 1 0 0 0 0 0 0 ] sub_subinfo main::BEGIN [ 1 2 2 0 0 0 0 0 ] Devel-NYTProf-6.06/xt/test23-strevalxs.p000644 000766 000024 00000000222 12067023751 020251 0ustar00timbostaff000000 000000 # test string eval made from embedded environment use Devel::NYTProf::Test qw(example_xsub_eval); example_xsub_eval(); # calls eval_pv() perlapi Devel-NYTProf-6.06/xt/test82-stress.t000644 000766 000024 00000002614 12067023751 017561 0ustar00timbostaff000000 000000 # Stress tests use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { compress => 1, savesrc => 1, }, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, ); isa_ok $profile, 'Devel::NYTProf::Data'; # check if data truncated e.g. due to assertion failure ok $profile->{attribute}{complete}; ok my $subs = $profile->subs_defined_in_file(1); ok $subs->{'main::pass'}->calls; }, extra_test_count => 4, }); __DATA__ # test for old perl bug 20010515.004 that NYTProf tickled into life # http://markmail.org/message/3q6q2on3gl6fzdhv # http://markmail.org/message/b7qnerilkusauydf # based on test in perl's t/run/fresh_perl.t my @h = 1 .. 10; sub bad { undef @h; open BUF, '>', \my $stdout_buf or die "Can't open STDOUT: $!"; # is the bug is tickled this will print something like # HASH(0x82acc0)ARRAY(0x821b60)ARRAY(0x812f10)HASH(0x8133f0)HASH(0x8133f0)ARRAY(0x821b60)00 print BUF for @_; # this line is very sensitive to changes die "\@_ affected by NYTProf" if $stdout_buf; close BUF; } bad(@h); sub pass { }; pass(); # flag successful completion Devel-NYTProf-6.06/xt/test90-stress.p000644 000766 000024 00000002051 12067023751 017547 0ustar00timbostaff000000 000000 # Assorted stress tests # We're happy if we run this without dieing... my $is_developer = (-d '.svn'); check_readonly() if $is_developer; sub check_readonly { unless (eval { require Readonly }) { warn "readonly test skipped - Readonly module not installed\n"; return; } # Check for # "Invalid tie at .../Readonly.pm line 278" # which was noticed first around r266 (when Readonly::XS is not installed). # Looks like it only affects perl <5.8.8. It's not related to # the DB::DB workaround because it happens with use_db_sub=0 as well. # Readonly uses caller() to explicitly check where it's being called from: # my $whence = (caller 2)[3]; # Check if naughty user is trying to tie directly. # Readonly::croak "Invalid tie" unless $whence && $whence =~ /^Readonly::(?:Scalar1?|Readonly)$/; eval q{ Readonly::Scalar my $sca => 42; Readonly::Array my @arr => qw(A B C); Readonly::Hash my %has => (A => 1, B => 2); 1; } or die; #warn "ok - readonly\n"; } Devel-NYTProf-6.06/xt/test45-overload.p000644 000766 000024 00000001124 12067023751 020037 0ustar00timbostaff000000 000000 # test to see that # example from the overload docs (with slight changes) { package two_face; # Scalars with separate string and numeric values. use overload '""' => \&str, # ref to named sub '0+' => sub {shift->[0]}, # ref to anon sub '&{}' => "code", # name of method fallback => 1; sub new { my $p = shift; bless [@_], $p } sub str { shift->[0] } sub code { sub { 1 } } } my $seven = new two_face ("vii", 7); printf "seven=$seven, seven=%d, eight=%d\n", $seven, $seven+1; print "seven contains ‘i’\n" if $seven =~ /i/; $seven->(); Devel-NYTProf-6.06/t/80-version.t000644 000766 000024 00000000543 12067023751 016630 0ustar00timbostaff000000 000000 use Test::More tests => 4; use_ok('Devel::NYTProf::Core'); my $version = $Devel::NYTProf::Core::VERSION; ok $version, 'lib/Devel/NYTProf/Core.pm $VERSION should be set'; use_ok('Devel::NYTProf'); is $Devel::NYTProf::VERSION, $version, 'lib/Devel/NYTProf.pm $VERSION should match'; # clean up after ourselves DB::finish_profile(); unlink 'nytprof.out'; Devel-NYTProf-6.06/t/test03.p000644 000766 000024 00000000252 12067023751 016031 0ustar00timbostaff000000 000000 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(); Devel-NYTProf-6.06/t/test01.t000644 000766 000024 00000000352 12067023751 016034 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group({ extra_test_count => 1, extra_test_code => sub { my ($profile, $env) = @_; isa_ok($profile, 'Devel::NYTProf::Data'); }, }); Devel-NYTProf-6.06/t/test09.p000644 000766 000024 00000000223 12067023751 016035 0ustar00timbostaff000000 000000 sub foo { eval "shift; shift; bar();"; } sub bar { eval '$a = 10_001; while (--$a) { ++$b }'; } foo(); foo(); bar(); Devel-NYTProf-6.06/t/test02.pf.csv000644 000766 000024 00000000634 12345547500 016776 0ustar00timbostaff000000 000000 Name, File location, Time, Avg. Time, Own Time, Invocation Count, Level main::bar, /Users/timbo/repos/nytprof/master/t/test02.p, 0.117, 0.000, 0.067, 7, 0 main::CORE:print, /Users/timbo/repos/nytprof/master/t/test02.p, 0.052, 0.000, 0.052, 10, 0 main::baz, /Users/timbo/repos/nytprof/master/t/test02.p, 0.057, 0.000, 0.026, 1, 0 main::foo, /Users/timbo/repos/nytprof/master/t/test02.p, 0.031, 0.000, 0.019, 2, 0 Devel-NYTProf-6.06/t/test17-goto.p000644 000766 000024 00000000565 12067023751 017013 0ustar00timbostaff000000 000000 # test various forms of goto # simple in-line goto goto main_label; die "should not get here"; main_label:; sub other { } # stub for checking sub caller info # goto &sub sub origin { other(); goto &destination; } sub destination { other(); } origin(); # goto out of a sub sub bar { goto foo_label; } sub foo { bar(); foo_label:; } foo(); Devel-NYTProf-6.06/t/test40pmc.pm000644 000766 000024 00000000373 12067023751 016713 0ustar00timbostaff000000 000000 # this test14.pm file should not be loaded because the test14.pmc # file should be newer and so that's the one that perl will use die sprintf q{%s used in error. The %sc file needs to be newer so perl will use the .pmc instead. }, __FILE__, __FILE__; Devel-NYTProf-6.06/t/test07.x000644 000766 000024 00000000267 12533402722 016050 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,1,0,print "only one line\n"; Devel-NYTProf-6.06/t/test18-goto2.calls000644 000766 000024 00000000102 12130047577 017723 0ustar00timbostaff000000 000000 Test18::longmess 1 Test18::longmess_jmp 1 Test18::longmess_real 1 Devel-NYTProf-6.06/t/42-global.t000644 000766 000024 00000005360 12405530157 016402 0ustar00timbostaff000000 000000 # Tests CORE::GLOBAL::foo plus assorted data model methods use strict; use Test::More; use lib '/home/travis/perl5'; # travis workaround https://travis-ci.org/timbunce/devel-nytprof/jobs/35285944 use Test::Differences; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); my $pre589 = ($] < 5.008009 or $] eq "5.010000"); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin' }, extra_test_count => 17, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs1 = $profile->subname_subinfo_map; my $begin = ($pre589) ? 'main::BEGIN' : 'main::BEGIN@4'; ok $subs1->{$begin}; ok $subs1->{'main::RUNTIME'}; ok $subs1->{'main::foo'}; my @fi = $profile->all_fileinfos; is @fi, 1, 'should be 1 fileinfo'; my $fid = $fi[0]->fid; my @a; # ($file, $fid, $first, $last); @a = $profile->file_line_range_of_sub($begin); is "$a[1] $a[2] $a[3]", "$fid 4 7", "details for $begin should match"; @a = $profile->file_line_range_of_sub('main::RUNTIME'); is "$a[1] $a[2] $a[3]", "$fid 1 1", 'details for main::RUNTIME should match'; @a = $profile->file_line_range_of_sub('main::foo'); is "$a[1] $a[2] $a[3]", "$fid 2 2", 'details for main::foo should match'; my $subs2 = $profile->subs_defined_in_file($fid); eq_or_diff [ sort keys %$subs2 ], [ sort keys %$subs1 ], 'keys from subname_subinfo_map and subs_defined_in_file should match'; my @begins = grep { $_->subname =~ /\bBEGIN\b/ } values %$subs2; if ($pre589) { # we only see one sub and we don't see it called is @begins, 1, 'number of BEGIN subs'; is grep({ $_->calls == 1 } @begins), 0, 'BEGIN has no calls'; } else { is @begins, 3, 'number of BEGIN subs'; is grep({ $_->calls == 1 } @begins), scalar @begins, 'all BEGINs should be called just once'; } my $sub; ok $sub = $subs2->{'main::RUNTIME'}; is $sub->calls, 0, 'main::RUNTIME should be called 0 times'; ok $sub = $subs2->{'main::foo'}; is $sub->calls, 2, 'main::foo should be called 2 times'; ok my $called_by_subnames = $sub->called_by_subnames; is keys %$called_by_subnames, 2, 'should be called from 2 subs'; }, }); __DATA__ #!perl sub foo { 42 } BEGIN { 'b' } BEGIN { 'c' } # two on same line BEGIN { # BEGIN@3 foo(2); *CORE::GLOBAL::sleep = \&foo; } sleep 1; Devel-NYTProf-6.06/t/70-subname.t000644 000766 000024 00000002722 12471565360 016603 0ustar00timbostaff000000 000000 # Tests CORE::GLOBAL::foo plus assorted data model methods use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; eval "use Sub::Name 0.11; 1" or plan skip_all => "Sub::Name 0.11 or later required"; print "Sub::Name $Sub::Name::VERSION $INC{'Sub/Name.pm'}\n"; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'init', compress => 1, leave => 0, stmts => 0, slowops => 0, }, extra_test_count => 6, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, #htmlopen => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs = $profile->subname_subinfo_map; my $sub = $subs->{'main::named'}; ok $sub; is $sub->calls, 1; is $sub->subname, 'main::named'; SKIP: { skip "Sub::Name 0.06 required for subname line numbers", 2 if $Sub::Name::VERSION <= 0.06; is $sub->first_line, 3; is $sub->last_line, 3; } }, }); __DATA__ #!perl use Sub::Name; (subname 'named' => sub { print "sub called\n" })->(); my $longname = "sub34567890" x 10 x 4; (subname $longname => sub { print "sub called\n" })->(); my $deepname = "sub345678::" x 10 x 4; (subname $deepname => sub { print "sub called\n" })->(); Devel-NYTProf-6.06/t/test03.x000644 000766 000024 00000000646 12533402722 016045 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub foo { 0,1,0,print "in sub foo\n"; 0,1,0,exit(0); 0,0,0,bar(); 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,2,0,print "in sub bar\n"; 0,0,0,} 0,0,0, 0,0,0,sub baz { 0,1,0,print "in sub baz\n"; 0,1,0,bar(); 0,1,0,foo(); 0,0,0,} 0,0,0, 0,1,0,bar(); 0,1,0,baz(); 0,0,0,foo(); Devel-NYTProf-6.06/t/50-errno.t000644 000766 000024 00000003653 12503512040 016257 0ustar00timbostaff000000 000000 use Test::More; my $nytprof_out; BEGIN { $nytprof_out = "t/nytprof-50-errno.out"; $ENV{NYTPROF} = "start=init:file=$nytprof_out"; unlink $nytprof_out; } use Devel::NYTProf::Test qw(example_xsub example_sub set_errno); BEGIN { # https://rt.cpan.org/Ticket/Display.html?id=55049 $! = 1; # set errno via perl set_errno(2); # set errno via C-code in NYTProf.xs return if $! == 2; # all is well plan skip_all => "Can't control errno in this perl build (linked with different CRT than perl?)"; } plan tests => 8; use Devel::NYTProf; # We set errno to some particular non-zero value to see if NYTProf changes it # (on many unix-like systems 3 is ESRCH 'No such process') my $dflterrno = 3; # simple assignment and immediate check of $! $! = $dflterrno; is 0+$!, $dflterrno, '$! should not be altered by NYTProf'; my $size1 = -s $nytprof_out; ok defined $size1, "$nytprof_out should at least exist" or die "Can't continue: $!"; SKIP: { skip 'On VMS buffer is not flushed', 1 if ($^O eq 'VMS'); cmp_ok $size1, '>', 0, "$nytprof_out should not be empty"; } $! = $dflterrno; example_sub(); is 0+$!, $dflterrno, "\$! should not be altered by assigning fids to previously unprofiled modules ($!)"; $! = $dflterrno; example_xsub(); is 0+$!, $dflterrno, "\$! should not be altered by assigning fids to previously unprofiled modules ($!)"; SKIP: { skip 'On VMS buffer does not flush', 1 if($^O eq 'VMS'); $! = $dflterrno; while (-s $nytprof_out == $size1) { # execute lots of statements to force some i/o even if zipping busy(); } is 0+$!, $dflterrno, '$! should not be altered by NYTProf i/o'; } ok not eval { example_xsub(0, "die"); 1; }; like $@, qr/^example_xsub\(die\)/; exit 0; sub busy { # none of this should alter $! for (my $i = 1_000; $i > 0; --$i) { example_xsub(); next if $i % 100; example_sub(); } } Devel-NYTProf-6.06/t/test21-streval3.rdt000644 000766 000024 00000005761 12114475212 020132 0ustar00timbostaff000000 000000 attribute application test21-streval3.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 3 ] fid_block_time 1 5 [ 0 1 ] fid_block_time 1 17 [ 0 1 ] fid_block_time 2 2 [ 0 1 ] fid_block_time 2 3 [ 0 1 ] fid_block_time 2 4 [ 0 1 ] fid_block_time 3 2 [ 0 1 ] fid_block_time 3 3 [ 0 1 ] fid_block_time 3 4 [ 0 1 ] fid_block_time 4 2 [ 0 1 ] fid_block_time 4 3 [ 0 1 ] fid_fileinfo 1 [ test21-streval3.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:sselect 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::foo 4-4 fid_fileinfo 1 eval 17 [ count 1 nested 2 merged 0 ] fid_fileinfo 2 [ (eval 0)[test21-streval3.p:17] 1 17 2 2 0 0 ] fid_fileinfo 2 call 2 main::CORE:sselect [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 call 3 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 eval 4 [ count 1 nested 1 merged 0 ] fid_fileinfo 3 [ (eval 0)[(eval 0)[test21-streval3.p:17]:4] 2 4 3 2 0 0 ] fid_fileinfo 3 call 2 main::CORE:sselect [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 3 call 3 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 3 eval 4 [ count 1 nested 0 merged 0 ] fid_fileinfo 4 [ (eval 0)[(eval 0)[(eval 0)[test21-streval3.p:17]:4]:4] 3 4 4 2 0 0 ] fid_fileinfo 4 call 2 main::CORE:sselect [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 4 call 3 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 4 [ 0 3 ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 17 [ 0 1 ] fid_line_time 2 2 [ 0 1 ] fid_line_time 2 3 [ 0 1 ] fid_line_time 2 4 [ 0 1 ] fid_line_time 3 2 [ 0 1 ] fid_line_time 3 3 [ 0 1 ] fid_line_time 3 4 [ 0 1 ] fid_line_time 4 2 [ 0 1 ] fid_line_time 4 3 [ 0 1 ] fid_sub_time 1 4 [ 0 3 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 17 [ 0 1 ] fid_sub_time 2 2 [ 0 1 ] fid_sub_time 2 3 [ 0 1 ] fid_sub_time 2 4 [ 0 1 ] fid_sub_time 3 2 [ 0 1 ] fid_sub_time 3 3 [ 0 1 ] fid_sub_time 3 4 [ 0 1 ] fid_sub_time 4 2 [ 0 1 ] fid_sub_time 4 3 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:sselect [ 1:0-0 calls 3 times 0 0 0 0 ] sub_subinfo main::CORE:sselect called_by 2:2 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:sselect called_by 3:2 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:sselect called_by 4:2 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::foo [ 1:4-4 calls 3 times 0 0 0 0 ] sub_subinfo main::foo called_by 2:3 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 3:3 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 4:3 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test60-subname.calls000644 000766 000024 00000000214 12130047577 020324 0ustar00timbostaff000000 000000 Devel::NYTProf::Test::example_xsub 7 Devel::NYTProf::Test::example_xsub;main::will_die 1 main::launch 1 main::CORE:wait 1 main::CORE:open 1 Devel-NYTProf-6.06/t/test22-strevala.p000644 000766 000024 00000000501 12130047577 017651 0ustar00timbostaff000000 000000 # test merging of anon subs from evals my $code = qq{ sub { print "sub called\n" } $Devel::NYTProf::StrEvalTestPad}; # call once from particular line eval($code)->(); # call twice from the same line eval($code)->(); eval($code)->(); # called from inside a string eval eval q{ eval($code)->(); eval($code)->(); }; Devel-NYTProf-6.06/t/test09.x000644 000766 000024 00000000535 12533402722 016050 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub foo { 0,2,0,eval "shift; 0,0,0,shift; 0,0,0,bar();"; 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,3,0,eval '$a = 10_001; while (--$a) { ++$b }'; 0,0,0,} 0,0,0, 0,1,0,foo(); 0,1,0,foo(); 0,1,0,bar(); Devel-NYTProf-6.06/t/test90-strsubref.t000644 000766 000024 00000002102 12211321460 020041 0ustar00timbostaff000000 000000 # Tests dieing on Can't use string ... as a subroutine ref while "strict refs" in use # that used to core dump (RT#86638) # https://rt.cpan.org/Ticket/Display.html?id=86638 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, calls => 0, savesrc => 0, stmts => 0, slowops => 0, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; # check if data was truncated ok $profile->{attribute}{complete}; }, }); __DATA__ #!perl use strict; # Can't use string ("") as a subroutine ref while "strict refs" in use at - line 4. eval { $x::z->() }; die $@ if $@ !~ /^Can't use .* as a subroutine ref/; Devel-NYTProf-6.06/t/test05.t000644 000766 000024 00000000121 12067023751 016032 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test06.calls000644 000766 000024 00000000306 12130047577 016676 0ustar00timbostaff000000 000000 main::foo 1 main::foo;main::CORE:print 1 main::foo;main::noop 110 main::bar 1 main::bar;main::CORE:print 1 main::bar;main::noop 100 main::baz 1 main::baz;main::CORE:print 1 main::baz;main::noop 200 Devel-NYTProf-6.06/t/test50-disable.calls000644 000766 000024 00000000026 12130047577 020275 0ustar00timbostaff000000 000000 DB::disable_profile 2 Devel-NYTProf-6.06/t/test07.p000644 000766 000024 00000000031 12067023751 016030 0ustar00timbostaff000000 000000 print "only one line\n"; Devel-NYTProf-6.06/t/test17-goto.calls000644 000766 000024 00000000200 12130047577 017637 0ustar00timbostaff000000 000000 main::origin 1 main::origin;main::other 1 main::destination 1 main::destination;main::other 1 main::foo 1 main::foo;main::bar 1 Devel-NYTProf-6.06/t/test02.calls000644 000766 000024 00000000603 12130047577 016672 0ustar00timbostaff000000 000000 main::bar 2 main::bar;main::CORE:print 2 main::foo 1 main::foo;main::CORE:print 1 main::foo;main::bar 1 main::foo;main::bar;main::CORE:print 1 main::baz 1 main::baz;main::CORE:print 1 main::baz;main::bar 3 main::baz;main::bar;main::CORE:print 3 main::baz;main::foo 1 main::baz;main::foo;main::CORE:print 1 main::baz;main::foo;main::bar 1 main::baz;main::foo;main::bar;main::CORE:print 1 Devel-NYTProf-6.06/t/test30-fork-0.t000644 000766 000024 00000000263 12067023751 017133 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; plan skip_all => "doesn't work with fork() emulation" if (($^O eq "MSWin32") || ($^O eq 'VMS')); run_test_group; Devel-NYTProf-6.06/t/test13.x000644 000766 000024 00000001514 12533402722 016041 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# Testing various types of eval calls. Some are processed differently internally 0,0,0, 0,0,0,sub foo { 0,3,0,print "in sub foo\n"; 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,1,0,print "in sub bar\n"; 0,0,0,} 0,0,0, 0,0,0,sub baz { 0,1,0,print "in sub baz\n"; 0,2,0,eval { foo(); # two stmts executed on this line (eval + foo() call) 0,1,0,foo(); }; # one stmt executed on this line 0,2,0,eval { x(); # two stmts executed on this line (eval + x() call), fails out of eval 0,0,0,x(); }; # zero stmts because previous statement threw an exception 0,0,0,} 0,0,0, 0,1,0,eval "foo();"; # one stmt in this fid, one statement in eval fid 0,2,0,eval { bar(); }; # two stmts 0,1,0,baz(); Devel-NYTProf-6.06/t/test30-fork-0.calls000644 000766 000024 00000000467 12130047577 017777 0ustar00timbostaff000000 000000 main::other 1 main::other;main::CORE:print 1 main::prefork 1 main::prefork;main::CORE:print 1 main::prefork;main::other 1 main::prefork;main::other;main::CORE:print 1 main::postfork 1 main::postfork;main::CORE:print 1 main::postfork;main::other 1 main::postfork;main::other;main::CORE:print 1 main::CORE:wait 1 Devel-NYTProf-6.06/t/test51-enable.calls000644 000766 000024 00000000067 12130047577 020126 0ustar00timbostaff000000 000000 main::CORE:unlink 1 main::sub1 1 DB::disable_profile 1 Devel-NYTProf-6.06/t/test62-tie-a.t000644 000766 000024 00000000414 12471711743 017043 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; plan skip_all => "needs perl >= 5.8.9 or >= 5.10.1" if $] < 5.008009 or $] eq "5.010000"; plan skip_all => "needs perl < 5.21.1 (see t/test62-tie-b.t)" # XXX if $] >= 5.021001; run_test_group; Devel-NYTProf-6.06/t/71-moose.t000644 000766 000024 00000002167 12130047577 016274 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; eval "use Moose 2.0; 1" or plan skip_all => "Moose 2.0 required"; print "Moose $Moose::VERSION $INC{'Moose.pm'}\n"; plan skip_all => "Test is incomplete (has no results defined yet)";# unless -d '.svn'; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, stmts => 0, slowops => 0, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, htmlopen => $ENV{NYTPROF_TEST_HTMLOPEN}, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs = $profile->subname_subinfo_map; ok 1; }, }); __DATA__ #!perl package P; use Moose; has attrib_std => ( is => 'rw', default => 42 ); has attrib_lazy => ( is => 'rw', lazy => 1, default => sub { 43 } ); END { my $p = P->new; print $p->attrib_std."\n"; print $p->attrib_lazy."\n"; } Devel-NYTProf-6.06/t/30-util.t000644 000766 000024 00000002611 12130047577 016114 0ustar00timbostaff000000 000000 use Test::More tests => 28; use Devel::NYTProf::Util qw( fmt_time fmt_incl_excl_time html_safe_filename trace_level ); my $us = "µs"; is(fmt_time(0), "0s"); is(fmt_time(1.1253e-10), "0ns"); is(fmt_time(1.1253e-9), "1ns"); is(fmt_time(1.1253e-8), "11ns"); is(fmt_time(1.1253e-7), "113ns"); is(fmt_time(1.1253e-6), "1$us"); is(fmt_time(1.1253e-5), "11$us"); is(fmt_time(1.1253e-4), "113$us"); is(fmt_time(1.1253e-3), "1.13ms"); is(fmt_time(1.1253e-2), "11.3ms"); is(fmt_time(1.1253e-1), "113ms"); is(fmt_time(1.1253e-0), "1.13s"); is(fmt_time(1.1253e+1), "11.3s"); is(fmt_time(1.1253e+2), "113s"); is(fmt_time(1.1253e+3), "1125s"); is(fmt_incl_excl_time(3, 3), "3.00s"); is(fmt_incl_excl_time(3, 2), "3.00s (2.00+1.00)"); is(fmt_incl_excl_time(3, 2.997), "3.00s (3.00+3.00ms)"); is(fmt_incl_excl_time(0.1, 0.0997), "100ms (99.7+300$us)"); is(fmt_incl_excl_time(4e-5, 1e-5), "40$us (10+30)"); is html_safe_filename('/foo/bar'), 'foo-bar'; is html_safe_filename('\foo\bar'), 'foo-bar'; is html_safe_filename('\foo/bar'), 'foo-bar'; is html_safe_filename('C:foo'), 'C-foo'; is html_safe_filename('C:\foo'), 'C-foo'; is html_safe_filename('of|\'really\'special*"chars"?'), 'lots-of-really-special-chars'; is html_safe_filename('no.dots.please'), 'no-dots-please'; my $trace_level = (($ENV{NYTPROF}||'') =~ m/\b trace=(\d+) /x) ? $1 : 0; is trace_level(), $trace_level, "trace_level $trace_level"; Devel-NYTProf-6.06/t/test50-disable.t000644 000766 000024 00000000121 12067023751 017433 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test13.p000644 000766 000024 00000001122 12067023751 016027 0ustar00timbostaff000000 000000 # Testing various types of eval calls. Some are processed differently internally sub foo { print "in sub foo\n"; } sub bar { print "in sub bar\n"; } sub baz { print "in sub baz\n"; eval { foo(); # two stmts executed on this line (eval + foo() call) foo(); }; # one stmt executed on this line eval { x(); # two stmts executed on this line (eval + x() call), fails out of eval x(); }; # zero stmts because previous statement threw an exception } eval "foo();"; # one stmt in this fid, one statement in eval fid eval { bar(); }; # two stmts baz(); Devel-NYTProf-6.06/t/test23-strevall.rdt000644 000766 000024 00000001733 12114475177 020232 0ustar00timbostaff000000 000000 attribute application test23-strevall.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 1 ] fid_block_time 2 45 [ 0 1 ] fid_fileinfo 1 [ test23-strevall.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 2 [ (eval 0) 3 1 2 2 0 0 ] fid_fileinfo 3 [ /unknown-eval-invoker 3 386 0 0 ] fid_fileinfo 3 eval 1 [ count 1 nested 0 merged 0 ] fid_line_time 1 4 [ 0 1 ] fid_line_time 2 45 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 2 45 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test11.t000644 000766 000024 00000000121 12067023751 016027 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test21-streval3.calls000644 000766 000024 00000000041 12130047577 020430 0ustar00timbostaff000000 000000 main::CORE:sselect 3 main::foo 3 Devel-NYTProf-6.06/t/test62-tie-b.calls000644 000766 000024 00000000061 12471711312 017665 0ustar00timbostaff000000 000000 MyTie::TIESCALAR 1 MyTie::STORE 1 MyTie::FETCH 1 Devel-NYTProf-6.06/t/10-run.t000644 000766 000024 00000002640 12067023751 015740 0ustar00timbostaff000000 000000 use Test::More; use strict; use lib qw(t/lib); use NYTProfTest; # test run_test_group() with extra_test_code and profile_this() use Devel::NYTProf::Run qw(profile_this); # tiny amount of source code to exercise RT#50851 my @src = ( "\$a = 1;\n", "\$b = 2;\n", ); run_test_group( { extra_options => { }, extra_test_count => 17, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => join('', @src), out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my ($fi, @others) = $profile->all_fileinfos; is @others, 0, 'should be one fileinfo'; is $fi->fid, 1; is $fi->filename, '-'; # profile_this() does "| perl -" is $fi->abs_filename, '-'; is $fi->filename_without_inc, '-'; is $fi->eval_fi, undef; is $fi->eval_fid, ''; # PL_sv_no is $fi->eval_line, ''; # PL_sv_no is_deeply $fi->evals_by_line, {}; is $fi->profile, $profile; ok not $fi->is_eval; ok not $fi->is_fake; ok not $fi->is_pmc; my $line_time_data = $fi->line_time_data; is ref $line_time_data, 'ARRAY'; is $fi->sum_of_stmts_count, 2; # should be tiny (will be 0 on systems without a highres clock) cmp_ok $fi->sum_of_stmts_time, '<', 10; }, }); Devel-NYTProf-6.06/t/test24-strevalc.p000644 000766 000024 00000000263 12067023751 017657 0ustar00timbostaff000000 000000 # test 'collapsing' of string evals my @src = ( (("1+1") x 2), (("eval '1+1'") x 2), (("sub { 1 }->()") x 2), ); for my $src (@src) { eval $src; } Devel-NYTProf-6.06/t/test51-enable.x000644 000766 000024 00000003002 12533402722 017261 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# test using enable_profile() to write multiple profile files 0,0,0, 0,1,0,my $file_b = "nytprof-test51-b.out"; 0,1,0,my $file_c = "nytprof-test51-c.out"; 0,1,0,unlink $file_b, $file_c; 0,0,0, 0,1,0,sub sub1 { 1 } 0,0,0,sub sub2 { 1 } 0,0,0,sub sub3 { 1 } 0,0,0,sub sub4 { 1 } 0,0,0,sub sub5 { 1 } 0,0,0,sub sub6 { 1 } 0,0,0,sub sub7 { 1 } 0,0,0,sub sub8 { 1 } 0,0,0, 0,1,0,sub1(); # profiled 0,0,0, 0,0,0,DB::disable_profile(); # also tests that sub1() call timing has completed 0,0,0, 0,0,0,sub2(); # not profiled 0,0,0, 0,0,0,# switch to new file and (re)enable profiling 0,0,0,# the new file includes accumulated fid and subs-called data 0,0,0,DB::enable_profile($file_b); 0,0,0, 0,0,0,sub3(); # profiled 0,0,0, 0,0,0,DB::finish_profile(); 0,0,0,die "$file_b should exist" unless -s $file_b; 0,0,0, 0,0,0,sub4(); # not profiled 0,0,0, 0,0,0,# enable to new file 0,0,0,DB::enable_profile($file_c); 0,0,0, 0,0,0,sub5(); # profiled but file will be overwritten by enable_profile() below 0,0,0, 0,0,0,DB::finish_profile(); 0,0,0, 0,0,0,sub6(); # not profiled 0,0,0, 0,0,0,DB::enable_profile(); # enable to current file 0,0,0, 0,0,0,sub7(); # profiled 0,0,0, 0,0,0,DB::finish_profile(); 0,0,0, 0,0,0,# This can be removed once we have a better test harness 0,0,0,-f $_ or die "$_ should exist" for ($file_b, $file_c); 0,0,0, 0,0,0,# TODO should test for enable/disable within subs Devel-NYTProf-6.06/t/test08.t000644 000766 000024 00000000121 12067023751 016035 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test23-strevall.calls000644 000766 000024 00000000000 12130047577 020516 0ustar00timbostaff000000 000000 Devel-NYTProf-6.06/t/test40pmc.x000644 000766 000024 00000000521 12533402722 016536 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# test test40pmc.pmc is loaded instead of test40pmc.pm 0,0,0,# (which requires test40pmc.pmc to be newer, which Makefile.PL arranges) 0,0,0,use test40pmc; 0,1,0,test40pmc::foo(); Devel-NYTProf-6.06/t/test07.calls000644 000766 000024 00000000023 12130047577 016673 0ustar00timbostaff000000 000000 main::CORE:print 1 Devel-NYTProf-6.06/t/test60-subname.p000644 000766 000024 00000001722 12471565404 017474 0ustar00timbostaff000000 000000 # test sub name resolution use Devel::NYTProf::Test qw(example_xsub); # call XS sub directly Devel::NYTProf::Test::example_xsub("foo"); # call XS sub imported into main # (should still be reported as a call to Devel::NYTProf::Test::example_xsub) example_xsub("foo"); # call XS sub as a method (ignore the extra arg) Devel::NYTProf::Test->example_xsub(); # call XS sub as a method via subclass (ignore the extra arg) @Subclass::ISA = qw(Devel::NYTProf::Test); Subclass->example_xsub(); my $subname = "Devel::NYTProf::Test::example_xsub"; &$subname("foo"); # return from xsub call via an exception # should correctly record the name of the xsub sub will_die { die "foo\n" } eval { example_xsub(0, \&will_die); 1; }; warn "\$@ was not the expected 'foo': $@" if $@ ne "foo\n"; # goto &$sub sub launch { goto &$subname } launch("foo"); # call builtin wait(); # call builtin that exits via an exception eval { open my $f, '<&', 'nonesuch' }; # $@ "Bad filehandle: nonesuch" Devel-NYTProf-6.06/t/test02.t000644 000766 000024 00000000121 12067023751 016027 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test21-streval3.p000644 000766 000024 00000000426 12067023751 017575 0ustar00timbostaff000000 000000 # test nested string evals sub foo { 1 } my $code = q{ select(undef,undef,undef,0.2); foo(); eval q{ select(undef,undef,undef,0.2); foo(); eval q{ select(undef,undef,undef,0.2); foo(); } } }; eval $code; Devel-NYTProf-6.06/t/test05.calls000644 000766 000024 00000000612 12130047577 016675 0ustar00timbostaff000000 000000 main::foo1 1 main::foo1;main::CORE:print 1 main::foo1;main::bar 1 main::foo1;main::bar;main::CORE:print 1 main::foo1;main::bar;main::yeppers 1 main::foo1;main::bar;main::yeppers;main::CORE:print 1 main::foo2 1 main::foo2;main::CORE:print 1 main::foo2;main::bar 1 main::foo2;main::bar;main::CORE:print 1 main::foo2;main::bar;main::yeppers 1 main::foo2;main::bar;main::yeppers;main::CORE:print 1 Devel-NYTProf-6.06/t/test30-fork-0.rdt000644 000766 000024 00000006250 12114475205 017461 0ustar00timbostaff000000 000000 attribute application test30-fork-0.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 2 ] fid_block_time 1 7 [ 0 3 ] fid_block_time 1 11 [ 0 2 ] fid_block_time 1 15 [ 0 1 ] fid_block_time 1 17 [ 0 1 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 20 [ 0 1 ] fid_block_time 1 22 [ 0 1 ] fid_fileinfo 1 [ test30-fork-0.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::CORE:wait 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::other 6-8 fid_fileinfo 1 sub main::postfork 10-13 fid_fileinfo 1 sub main::prefork 1-4 fid_fileinfo 1 call 2 main::CORE:print [ 1 0 0 0 0 0 0 main::prefork ] fid_fileinfo 1 call 3 main::other [ 1 0 0 0 0 0 0 main::prefork ] fid_fileinfo 1 call 7 main::CORE:print [ 3 0 0 0 0 0 0 main::other ] fid_fileinfo 1 call 11 main::CORE:print [ 1 0 0 0 0 0 0 main::postfork ] fid_fileinfo 1 call 12 main::other [ 1 0 0 0 0 0 0 main::postfork ] fid_fileinfo 1 call 15 main::prefork [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 19 main::postfork [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 20 main::other [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 22 main::CORE:wait [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 1 ] fid_line_time 1 3 [ 0 1 ] fid_line_time 1 7 [ 0 3 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 15 [ 0 1 ] fid_line_time 1 17 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 20 [ 0 1 ] fid_line_time 1 22 [ 0 1 ] fid_sub_time 1 2 [ 0 2 ] fid_sub_time 1 7 [ 0 3 ] fid_sub_time 1 11 [ 0 2 ] fid_sub_time 1 15 [ 0 1 ] fid_sub_time 1 17 [ 0 1 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 20 [ 0 1 ] fid_sub_time 1 22 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 5 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:2 [ 1 0 0 0 0 0 0 main::prefork ] sub_subinfo main::CORE:print called_by 1:7 [ 3 0 0 0 0 0 0 main::other ] sub_subinfo main::CORE:print called_by 1:11 [ 1 0 0 0 0 0 0 main::postfork ] sub_subinfo main::CORE:wait [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:wait called_by 1:22 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::other [ 1:6-8 calls 3 times 0 0 0 0 ] sub_subinfo main::other called_by 1:3 [ 1 0 0 0 0 0 0 main::prefork ] sub_subinfo main::other called_by 1:12 [ 1 0 0 0 0 0 0 main::postfork ] sub_subinfo main::other called_by 1:20 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::postfork [ 1:10-13 calls 1 times 0 0 0 0 ] sub_subinfo main::postfork called_by 1:19 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::prefork [ 1:1-4 calls 1 times 0 0 0 0 ] sub_subinfo main::prefork called_by 1:15 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test06.t000644 000766 000024 00000000121 12067023751 016033 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test62-subcaller1.rdt000644 000766 000024 00000011113 12471702057 020423 0ustar00timbostaff000000 000000 attribute application test62-subcaller1.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 1 ] fid_block_time 1 5 [ 0 2 ] fid_block_time 1 9 [ 0 1 ] fid_block_time 1 10 [ 0 2 ] fid_block_time 1 13 [ 0 6 ] fid_block_time 1 15 [ 0 7 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 22 [ 0 2 ] fid_block_time 1 23 [ 0 1 ] fid_block_time 1 24 [ 0 1 ] fid_block_time 1 26 [ 0 1 ] fid_block_time 2 7 [ 0 1 ] fid_block_time 2 8 [ 0 1 ] fid_block_time 2 9 [ 0 1 ] fid_block_time 2 11 [ 0 1 ] fid_block_time 2 15 [ 0 1 ] fid_fileinfo 1 [ test62-subcaller1.p 1 2 0 0 ] fid_fileinfo 1 sub Devel::NYTProf::Test::example_xsub undef-undef fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:sort 0-0 fid_fileinfo 1 sub main::CORE:subst 0-0 fid_fileinfo 1 sub main::CORE:substcont 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::sub1 9-9 fid_fileinfo 1 sub main::sub2 13-13 fid_fileinfo 1 sub main::sub3 18-18 fid_fileinfo 1 sub main::sub4 22-22 fid_fileinfo 1 call 5 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 10 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 10 main::sub1 [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 15 Devel::NYTProf::Test::example_xsub [ 3 0 0 0 0 0 0 main::CORE:sort ] fid_fileinfo 1 call 15 main::CORE:sort [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 15 main::sub2 [ 6 0 0 0 0 0 0 main::CORE:sort ] fid_fileinfo 1 call 19 main::CORE:sort [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 24 main::CORE:subst [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 24 main::CORE:substcont [ 3 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 24 main::sub4 [ 2 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 [ Devel/NYTProf/Test.pm 2 2 0 0 ] fid_fileinfo 2 sub Devel::NYTProf::Test::example_sub 13-13 fid_fileinfo 3 [ Exporter.pm 3 2 0 0 ] fid_line_time 1 4 [ 0 1 ] fid_line_time 1 5 [ 0 2 ] fid_line_time 1 9 [ 0 1 ] fid_line_time 1 10 [ 0 2 ] fid_line_time 1 13 [ 0 6 ] fid_line_time 1 15 [ 0 7 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 22 [ 0 2 ] fid_line_time 1 23 [ 0 1 ] fid_line_time 1 24 [ 0 1 ] fid_line_time 1 26 [ 0 1 ] fid_line_time 2 7 [ 0 1 ] fid_line_time 2 8 [ 0 1 ] fid_line_time 2 9 [ 0 1 ] fid_line_time 2 11 [ 0 1 ] fid_line_time 2 15 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 1 5 [ 0 2 ] fid_sub_time 1 9 [ 0 1 ] fid_sub_time 1 10 [ 0 2 ] fid_sub_time 1 13 [ 0 6 ] fid_sub_time 1 15 [ 0 7 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 22 [ 0 2 ] fid_sub_time 1 23 [ 0 1 ] fid_sub_time 1 24 [ 0 1 ] fid_sub_time 1 26 [ 0 1 ] fid_sub_time 2 7 [ 0 1 ] fid_sub_time 2 8 [ 0 1 ] fid_sub_time 2 9 [ 0 1 ] fid_sub_time 2 11 [ 0 1 ] fid_sub_time 2 15 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo Devel::NYTProf::Test::example_sub [ 2:13-13 calls 0 times 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub [ 1:undef-undef calls 5 times 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:5 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:10 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:15 [ 3 0 0 0 0 0 0 main::CORE:sort ] sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:sort [ 1:0-0 calls 2 times 0 0 0 0 ] sub_subinfo main::CORE:sort called_by 1:15 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:sort called_by 1:19 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:subst [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:subst called_by 1:24 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:substcont [ 1:0-0 calls 3 times 0 0 0 0 ] sub_subinfo main::CORE:substcont called_by 1:24 [ 3 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::sub1 [ 1:9-9 calls 1 times 0 0 0 0 ] sub_subinfo main::sub1 called_by 1:10 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::sub2 [ 1:13-13 calls 6 times 0 0 0 0 ] sub_subinfo main::sub2 called_by 1:15 [ 6 0 0 0 0 0 0 main::CORE:sort ] sub_subinfo main::sub3 [ 1:18-18 calls 0 times 0 0 0 0 ] sub_subinfo main::sub4 [ 1:22-22 calls 2 times 0 0 0 0 ] sub_subinfo main::sub4 called_by 1:24 [ 2 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test09.rdt000644 000766 000024 00000004527 12114475203 016376 0ustar00timbostaff000000 000000 attribute application test09.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 2 ] fid_block_time 1 8 [ 0 3 ] fid_block_time 1 11 [ 0 1 ] fid_block_time 1 12 [ 0 1 ] fid_block_time 1 13 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_block_time 2 2 [ 0 1 ] fid_block_time 2 3 [ 0 1 ] fid_block_time 3 1 [ 0 10002 ] fid_fileinfo 1 [ test09.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 7-9 fid_fileinfo 1 sub main::foo 1-5 fid_fileinfo 1 call 11 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 12 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 13 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 2 [ count 1 nested 0 merged 1 ] fid_fileinfo 1 eval 8 [ count 1 nested 0 merged 2 ] fid_fileinfo 2 [ (eval 0)[test09.p:2] 1 2 2 2 0 0 ] fid_fileinfo 2 call 3 main::bar [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 3 [ (eval 0)[test09.p:8] 1 8 3 2 0 0 ] fid_line_time 1 2 [ 0 2 ] fid_line_time 1 8 [ 0 3 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 13 [ 0 1 ] fid_line_time 2 1 [ 0 2 ] fid_line_time 2 2 [ 0 2 ] fid_line_time 2 3 [ 0 2 ] fid_line_time 3 1 [ 0 30006 ] fid_sub_time 1 2 [ 0 2 ] fid_sub_time 1 8 [ 0 3 ] fid_sub_time 1 11 [ 0 1 ] fid_sub_time 1 12 [ 0 1 ] fid_sub_time 1 13 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] fid_sub_time 2 2 [ 0 1 ] fid_sub_time 2 3 [ 0 1 ] fid_sub_time 3 1 [ 0 10002 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:7-9 calls 3 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:13 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::bar called_by 2:3 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::foo [ 1:1-5 calls 2 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:11 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 1:12 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test40pmc.pmc000644 000766 000024 00000000220 13305245116 017042 0ustar00timbostaff000000 000000 # this is test14.pmc which perl will load in preference to test14.pmc # (if it's newer than test14.pm) package test40pmc; sub foo { 1; } 1; Devel-NYTProf-6.06/t/test51-enable.p000644 000766 000024 00000002070 12130047577 017263 0ustar00timbostaff000000 000000 # test using enable_profile() to write multiple profile files my $file_b = "nytprof-test51-b.out"; my $file_c = "nytprof-test51-c.out"; unlink $file_b, $file_c; sub sub1 { 1 } sub sub2 { 1 } sub sub3 { 1 } sub sub4 { 1 } sub sub5 { 1 } sub sub6 { 1 } sub sub7 { 1 } sub sub8 { 1 } sub1(); # profiled DB::disable_profile(); # also tests that sub1() call timing has completed sub2(); # not profiled # switch to new file and (re)enable profiling # the new file includes accumulated fid and subs-called data DB::enable_profile($file_b); sub3(); # profiled DB::finish_profile(); die "$file_b should exist" unless -s $file_b; sub4(); # not profiled # enable to new file DB::enable_profile($file_c); sub5(); # profiled but file will be overwritten by enable_profile() below DB::finish_profile(); sub6(); # not profiled DB::enable_profile(); # enable to current file sub7(); # profiled DB::finish_profile(); # This can be removed once we have a better test harness -f $_ or die "$_ should exist" for ($file_b, $file_c); # TODO should test for enable/disable within subs Devel-NYTProf-6.06/t/test40pmc.rdt000644 000766 000024 00000002263 12114475214 017066 0ustar00timbostaff000000 000000 attribute application test40pmc.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 1 ] fid_block_time 2 6 [ 0 1 ] fid_fileinfo 1 [ test40pmc.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 3-3 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 4 test40pmc::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 [ test40pmc.pm 2 3 0 0 ] fid_fileinfo 2 sub test40pmc::foo 5-7 fid_line_time 1 4 [ 0 1 ] fid_line_time 2 6 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 2 6 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:3-3 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo test40pmc::foo [ 2:5-7 calls 1 times 0 0 0 0 ] sub_subinfo test40pmc::foo called_by 1:4 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test80-recurs.p000644 000766 000024 00000000234 12067023751 017337 0ustar00timbostaff000000 000000 sub recurs { my $depth = shift; select(undef, undef, undef, 0.3); recurs($depth-1) if $depth > 1; } recurs(3); # recurs gets called twice Devel-NYTProf-6.06/t/test40pmc.p000644 000766 000024 00000000241 12067023751 016530 0ustar00timbostaff000000 000000 # test test40pmc.pmc is loaded instead of test40pmc.pm # (which requires test40pmc.pmc to be newer, which Makefile.PL arranges) use test40pmc; test40pmc::foo(); Devel-NYTProf-6.06/t/test08.rdt000644 000766 000024 00000001753 12114475205 016375 0ustar00timbostaff000000 000000 attribute application test08.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 1 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_block_time 2 2 [ 0 1 ] fid_fileinfo 1 [ test08.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 eval 1 [ count 1 nested 0 merged 0 ] fid_fileinfo 2 [ (eval 0)[test08.p:1] 1 1 2 2 0 0 ] fid_line_time 1 1 [ 0 1 ] fid_line_time 2 1 [ 0 1 ] fid_line_time 2 2 [ 0 1 ] fid_sub_time 1 1 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] fid_sub_time 2 2 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test30-fork-1.rdt000644 000766 000024 00000003023 12067023751 017457 0ustar00timbostaff000000 000000 attribute application test30-fork.0.p attribute basetime 0 attribute clock_id 0 attribute nv_size 0 attribute perl_version 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 7 [ 0 2 ] fid_block_time 1 11 [ 0 2 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 20 [ 0 1 ] fid_block_time 1 22 [ 0 1 ] fid_fileinfo 1 [ test30-fork.0.p 1 2 0 0 ] fid_fileinfo 1 sub main::other 6-8 fid_fileinfo 1 sub main::postfork 10-13 fid_fileinfo 1 sub main::prefork 1-4 fid_fileinfo 1 call 12 main::other [ 1 0 0 0 0 0 0 ] fid_fileinfo 1 call 19 main::postfork [ 1 0 0 0 0 0 0 ] fid_fileinfo 1 call 20 main::other [ 1 0 0 0 0 0 0 ] fid_line_time 1 7 [ 0 2 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 20 [ 0 1 ] fid_line_time 1 22 [ 0 1 ] fid_sub_time 1 7 [ 0 2 ] fid_sub_time 1 11 [ 0 2 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 20 [ 0 1 ] fid_sub_time 1 22 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::other [ 1 6 8 2 0 0 0 0 ] sub_subinfo main::other called_by 1 12 [ 1 0 0 0 0 0 0 ] sub_subinfo main::other called_by 1 20 [ 1 0 0 0 0 0 0 ] sub_subinfo main::postfork [ 1 10 13 1 0 0 0 0 ] sub_subinfo main::postfork called_by 1 19 [ 1 0 0 0 0 0 0 ] sub_subinfo main::prefork [ 1 1 4 0 0 0 0 0 ] Devel-NYTProf-6.06/t/test21-streval3.x000644 000766 000024 00000000714 12533402722 017602 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# test nested string evals 0,0,0, 0,0,0, 0,3,0,sub foo { 1 } 0,1,0,my $code = q{ 0,0,0,select(undef,undef,undef,0.2); 0,0,0,foo(); 0,0,0,eval q{ 0,0,0,select(undef,undef,undef,0.2); 0,0,0,foo(); 0,0,0,eval q{ 0,0,0,select(undef,undef,undef,0.2); 0,0,0,foo(); 0,0,0,} 0,0,0,} 0,0,0,}; 0,1,0,eval $code; Devel-NYTProf-6.06/t/test62-tie-b.t000644 000766 000024 00000000245 12471711752 017046 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; plan skip_all => "needs perl >= 5.21.1 (see t/test62-tie-a)" if $] < 5.021001; run_test_group; Devel-NYTProf-6.06/t/test16.t000644 000766 000024 00000000214 12067023751 016037 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; plan skip_all => "needs perl >= 5.10" unless $] >= 5.010; run_test_group; Devel-NYTProf-6.06/t/test70-subexcl.p000644 000766 000024 00000001454 12130047577 017510 0ustar00timbostaff000000 000000 # This test isn't very useful until we can test subroutine timings # perhaps by adding an option to nytprofcsv to include them # and adjusting test.pl to test for them (including the ~N fudge factor). # Meanwhile the test is useful for sanity checking the subroutine timing # code using a command like # make && NYTPROF_TEST=trace=3 perl -Mblib test.pl -leave=1 -use_db_sub=0 t/test70-subexcl.* my $T = $ENV{NYTPROF_TEST_PAUSE_TIME} || 0.2; sub A { # inclusive ~= $T, exclusive ~= $T select undef, undef, undef, $T; } sub B { # inclusive ~= $T*2, exclusive ~= $T A(); select undef, undef, undef, $T; } sub C { # inclusive ~= $T*2, exclusive ~= 0.0 B(); } sub D { # inclusive ~= $T*4, exclusive ~= 0.0 C(); C(); # cumulative_subr_secs non-zero on sub entry } D(); Devel-NYTProf-6.06/t/40-savesrc.t000644 000766 000024 00000004276 13305236420 016607 0ustar00timbostaff000000 000000 use Test::More; use strict; use lib qw(t/lib); use NYTProfTest; plan skip_all => "needs perl >= 5.8.9 or >= 5.10.1" if $] < 5.008009 or $] eq "5.010000"; use Devel::NYTProf::Run qw(profile_this); run_test_group( { extra_test_count => 8, extra_test_code => sub { my ($profile, $env) = @_; my $src_eval = "foo()"; my $src_code = "sub foo { } foo(); eval '$src_eval'; "; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my @fi = $profile->all_fileinfos; is scalar @fi, 2, 'should have one fileinfo'; #printf "# %s\n", $_->filename for @fi; my $fi_s = $profile->fileinfo_of('-'); isa_ok $fi_s, 'Devel::NYTProf::FileInfo', 'should have fileinfo for "-"'; if ($env->{savesrc}) { my $lines_s = $fi_s->srclines_array; isa_ok $lines_s, 'ARRAY', 'srclines_array should return an array ref'; is $lines_s->[0], $src_code, 'source code line should match'; } else { pass() for 1..2 } # Strawberry perl portable has eval ID '(eval 5)[-:1]', # others have '(eval 0)[-:1]'. # Assume that, if we get two fileinfos then second is what we wanted. # Possibly should check if we match /\(eval [15]\)\[-:1\]/. my @file_infos = $profile->all_fileinfos; is (scalar @file_infos, 2, 'Got two file infos'); my $target_eval_name = $file_infos[-1]->filename; my $fi_e = $profile->fileinfo_of($target_eval_name); isa_ok $fi_e, 'Devel::NYTProf::FileInfo', 'should have fileinfo for "$target_eval_name"' or do { diag "Have fileinfo for: '$_'" for sort map { $_->filename } $profile->all_fileinfos; }; if ($env->{savesrc} && $fi_e) { my $lines_e = $fi_e->srclines_array; # perl adds a newline to eval strings is $lines_e->[0], "$src_eval\n", 'source code line should match'; #warn "@$lines_e"; } else { pass() for 1; } }, }); Devel-NYTProf-6.06/t/test81-swash.t000644 000766 000024 00000001732 12067023751 017172 0ustar00timbostaff000000 000000 # Tests implicit calling of utf8::SWASHNEW from unicode regex. # # Actually a stress test of all sorts of nasty cases including opcodes calling # back to perl and stack switching (PUSHSTACKi(PERLSI_MAGIC)). use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; # check if data truncated due to assertion failure ok $profile->{attribute}{complete}; }, }); # crashes with perl 5.11.1+ __DATA__ $_ = "N\x{100}"; chop $_; s/ (?: [A-Z] | [\d] )+ (?= [\s] ) //x; Devel-NYTProf-6.06/t/test61-submerge.t000644 000766 000024 00000000171 12067023751 017650 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; $ENV{NYTPROF_TEST_SKIP_EVAL_NORM} = 1; run_test_group; Devel-NYTProf-6.06/t/test14.p000644 000766 000024 00000001207 12067023751 016034 0ustar00timbostaff000000 000000 # If the AutoSplit module has been loaded before we got initialized # (specifically before we redirected the opcodes used when compiling) # then the profiler won't profile AutoSplit code so the test will fail # because the results won't match. # The tricky part is that we need to take care to avoid being tripped up # by the fact that XSLoader will fallback to using DynaLoader in some cases # and DynaLoader uses AutoSplit. # See Makefile.PL for how we avoid XSLoader fallback to using DynaLoader. BEGIN { use AutoSplit; mkdir('./auto'); autosplit('test14', './auto', 1, 0, 0); } use test14; test14::pre(); test14::foo(); test14::bar(); Devel-NYTProf-6.06/t/test12.pl000644 000766 000024 00000000003 12067023751 016177 0ustar00timbostaff000000 000000 1; Devel-NYTProf-6.06/t/test14.pm_x000644 000766 000024 00000000473 12533402722 016541 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,package test14; 0,0,0,use AutoLoader 'AUTOLOAD'; 0,0,0, 0,0,0,1; 0,0,0,__END__ 0,0,0,sub foo { 0,1,0,1; 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,2,0,eval 2; 0,0,0,} Devel-NYTProf-6.06/t/test10.x000644 000766 000024 00000000360 12533402722 016034 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code ~1,1,0,$code = eval "sub { sleep 1; }$Devel::NYTProf::StrEvalTestPad"; 0,1,0,$code->(); Devel-NYTProf-6.06/t/test01.calls000644 000766 000024 00000000603 12352027271 016664 0ustar00timbostaff000000 000000 main::bar 1 main::bar;main::CORE:print 1 main::foo 1 main::foo;main::CORE:print 1 main::foo;main::bar 1 main::foo;main::bar;main::CORE:print 1 main::baz 1 main::baz;main::CORE:print 1 main::baz;main::bar 1 main::baz;main::bar;main::CORE:print 1 main::baz;main::foo 1 main::baz;main::foo;main::CORE:print 1 main::baz;main::foo;main::bar 1 main::baz;main::foo;main::bar;main::CORE:print 1 Devel-NYTProf-6.06/t/test23-strevall.t000644 000766 000024 00000000121 12067023751 017664 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test62-subcaller1.t000644 000766 000024 00000000260 12067023751 020074 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; plan skip_all => "needs perl >= 5.8.9 or >= 5.10.1" if $] < 5.008009 or $] eq "5.010000"; run_test_group; Devel-NYTProf-6.06/t/test20-streval.x000644 000766 000024 00000000774 12533402722 017524 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# test merging of sub calls from eval fids 0,0,0, 0,4,0,sub foo { print "foo\n" } 0,0,0, 0,1,0,my $code = 'foo()'; 0,0,0, 0,0,0,# call once from particular line 0,1,0,eval $code; 0,0,0, 0,0,0,# call twice from the same line 0,2,0,eval $code or die $@; eval $code or die $@; 0,0,0, 0,0,0,# once from an eval inside an eval 0,1,0,eval "eval q{$code}"; Devel-NYTProf-6.06/t/test70-subexcl.calls000644 000766 000024 00000000272 12130047577 020344 0ustar00timbostaff000000 000000 main::D 1 main::D;main::C 2 main::D;main::C;main::B 2 main::D;main::C;main::B;main::CORE:sselect 2 main::D;main::C;main::B;main::A 2 main::D;main::C;main::B;main::A;main::CORE:sselect 2 Devel-NYTProf-6.06/t/test03.calls000644 000766 000024 00000000314 12130047577 016672 0ustar00timbostaff000000 000000 main::bar 1 main::bar;main::CORE:print 1 main::baz 1 main::baz;main::CORE:print 1 main::baz;main::bar 1 main::baz;main::bar;main::CORE:print 1 main::baz;main::foo 1 main::baz;main::foo;main::CORE:print 1 Devel-NYTProf-6.06/t/test14.x000644 000766 000024 00000001613 12533402722 016042 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# If the AutoSplit module has been loaded before we got initialized 0,0,0,# (specifically before we redirected the opcodes used when compiling) 0,0,0,# then the profiler won't profile AutoSplit code so the test will fail 0,0,0,# because the results won't match. 0,0,0,# The tricky part is that we need to take care to avoid being tripped up 0,0,0,# by the fact that XSLoader will fallback to using DynaLoader in some cases 0,0,0,# and DynaLoader uses AutoSplit. 0,0,0,# See Makefile.PL for how we avoid XSLoader fallback to using DynaLoader. 0,0,0, 0,0,0,BEGIN { 0,0,0,use AutoSplit; 0,0,0,mkdir('./auto'); 0,0,0,autosplit('test14', './auto', 1, 0, 0); 0,0,0,} 0,0,0, 0,0,0,use test14; 0,1,0,test14::pre(); 0,1,0,test14::foo(); 0,1,0,test14::bar(); Devel-NYTProf-6.06/t/test62-tie-a.calls000644 000766 000024 00000000061 12471702635 017674 0ustar00timbostaff000000 000000 MyTie::TIESCALAR 1 MyTie::STORE 1 MyTie::FETCH 1 Devel-NYTProf-6.06/t/test60-subname.rdt000644 000766 000024 00000010661 12114475212 020017 0ustar00timbostaff000000 000000 attribute application test60-subname.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 1 ] fid_block_time 1 9 [ 0 1 ] fid_block_time 1 12 [ 0 1 ] fid_block_time 1 15 [ 0 1 ] fid_block_time 1 16 [ 0 1 ] fid_block_time 1 18 [ 0 1 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 23 [ 0 1 ] fid_block_time 1 24 [ 0 2 ] fid_block_time 1 25 [ 0 1 ] fid_block_time 1 28 [ 0 1 ] fid_block_time 1 29 [ 0 1 ] fid_block_time 1 32 [ 0 1 ] fid_block_time 1 35 [ 0 2 ] fid_fileinfo 1 [ test60-subname.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 2-2 fid_fileinfo 1 sub main::CORE:open 0-0 fid_fileinfo 1 sub main::CORE:wait 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::launch 28-28 fid_fileinfo 1 sub main::will_die 23-23 fid_fileinfo 1 call 5 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 9 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 12 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 16 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 19 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 24 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 24 main::will_die [ 1 0 0 0 0 0 0 Devel::NYTProf::Test::example_xsub ] fid_fileinfo 1 call 28 Devel::NYTProf::Test::example_xsub [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 29 main::launch [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 32 main::CORE:wait [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 35 main::CORE:open [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 [ Devel/NYTProf/Test.pm 2 4 0 0 ] fid_fileinfo 2 sub Devel::NYTProf::Test::example_sub 13-13 fid_fileinfo 2 sub Devel::NYTProf::Test::example_xsub 0-0 fid_line_time 1 5 [ 0 1 ] fid_line_time 1 9 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 15 [ 0 1 ] fid_line_time 1 16 [ 0 1 ] fid_line_time 1 18 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 23 [ 0 1 ] fid_line_time 1 24 [ 0 2 ] fid_line_time 1 25 [ 0 1 ] fid_line_time 1 28 [ 0 1 ] fid_line_time 1 29 [ 0 1 ] fid_line_time 1 32 [ 0 1 ] fid_line_time 1 35 [ 0 2 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 9 [ 0 1 ] fid_sub_time 1 12 [ 0 1 ] fid_sub_time 1 15 [ 0 1 ] fid_sub_time 1 16 [ 0 1 ] fid_sub_time 1 18 [ 0 1 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 23 [ 0 1 ] fid_sub_time 1 24 [ 0 2 ] fid_sub_time 1 25 [ 0 1 ] fid_sub_time 1 28 [ 0 1 ] fid_sub_time 1 29 [ 0 1 ] fid_sub_time 1 32 [ 0 1 ] fid_sub_time 1 35 [ 0 2 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo Devel::NYTProf::Test::example_sub [ 2:13-13 calls 0 times 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub [ 2:0-0 calls 7 times 0 0 0 0 ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:5 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:9 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:12 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:16 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:19 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:24 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo Devel::NYTProf::Test::example_xsub called_by 1:28 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::BEGIN [ 1:2-2 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:open [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:open called_by 1:35 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::CORE:wait [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:wait called_by 1:32 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::launch [ 1:28-28 calls 1 times 0 0 0 0 ] sub_subinfo main::launch called_by 1:29 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::will_die [ 1:23-23 calls 1 times 0 0 0 0 ] sub_subinfo main::will_die called_by 1:24 [ 1 0 0 0 0 0 0 Devel::NYTProf::Test::example_xsub ] Devel-NYTProf-6.06/t/test10.p000644 000766 000024 00000000113 12130047577 016026 0ustar00timbostaff000000 000000 $code = eval "sub { sleep 1; }$Devel::NYTProf::StrEvalTestPad"; $code->(); Devel-NYTProf-6.06/t/test20-streval.p000644 000766 000024 00000000420 12067023751 017503 0ustar00timbostaff000000 000000 # test merging of sub calls from eval fids sub foo { print "foo\n" } my $code = 'foo()'; # call once from particular line eval $code; # call twice from the same line eval $code or die $@; eval $code or die $@; # once from an eval inside an eval eval "eval q{$code}"; Devel-NYTProf-6.06/t/test18-goto2.t000644 000766 000024 00000000121 12067023751 017066 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test30-fork-1.x000644 000766 000024 00000000734 12533402722 017140 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub prefork { 0,0,0,print "in sub prefork\n"; 0,0,0,other(); 0,0,0,} 0,0,0, 0,0,0,sub other { 0,2,0,print "in sub other\n"; 0,0,0,} 0,0,0, 0,0,0,sub postfork { 0,1,0,print "in sub postfork\n"; 0,1,0,other(); 0,0,0,} 0,0,0, 0,0,0,prefork(); 0,0,0, 0,0,0,fork; 0,0,0, 0,1,0,postfork(); 0,1,0,other(); 0,0,0, 0,1,0,wait; Devel-NYTProf-6.06/t/test12.t000644 000766 000024 00000000121 12067023751 016030 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/91-pod_coverage.t000644 000766 000024 00000000535 12130047577 017606 0ustar00timbostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; plan skip_all => "Currently a developer-only test" unless -d '.git'; plan skip_all => "needs work"; all_pod_coverage_ok({ also_private => [ qr/removeChildAt/ ] }); Devel-NYTProf-6.06/t/test16.calls000644 000766 000024 00000000212 12130047577 016673 0ustar00timbostaff000000 000000 main::foo 2 main::foo;main::CORE:match 3 main::foo;main::CORE:say 2 main::bar 2 main::bar;main::CORE:match 3 main::bar;main::CORE:print 2 Devel-NYTProf-6.06/t/test05.x000644 000766 000024 00000001065 12533402722 016043 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# Test that fastprof doesn't break 0,0,0,# &bar; used as &bar(@_); 0,0,0, 0,0,0,sub foo1 { 0,1,0,print "in foo1(@_)\n"; 0,1,0,bar(@_); 0,0,0,} 0,0,0,sub foo2 { 0,1,0,print "in foo2(@_)\n"; 0,1,0,&bar; 0,0,0,} 0,0,0,sub bar { 0,2,0,print "in bar(@_)\n"; 0,2,0,if( @_ > 0 ){ 0,0,0,&yeppers; 0,0,0,} 0,0,0,} 0,0,0,sub yeppers { 0,2,0,print "rest easy\n"; 0,0,0,} 0,0,0, 0,1,0,&foo1( A ); 0,1,0,&foo2( B ); Devel-NYTProf-6.06/t/test17-goto.t000644 000766 000024 00000000121 12067023751 017003 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test03.rdt000644 000766 000024 00000004755 12114475201 016371 0ustar00timbostaff000000 000000 attribute application test03.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 2 ] fid_block_time 1 8 [ 0 2 ] fid_block_time 1 12 [ 0 3 ] fid_block_time 1 17 [ 0 1 ] fid_block_time 1 18 [ 0 1 ] fid_fileinfo 1 [ test03.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 7-9 fid_fileinfo 1 sub main::baz 11-15 fid_fileinfo 1 sub main::foo 1-5 fid_fileinfo 1 call 2 main::CORE:print [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 8 main::CORE:print [ 2 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 12 main::CORE:print [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 13 main::bar [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 14 main::foo [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 17 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 18 main::baz [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 1 ] fid_line_time 1 3 [ 0 1 ] fid_line_time 1 8 [ 0 2 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 13 [ 0 1 ] fid_line_time 1 14 [ 0 1 ] fid_line_time 1 17 [ 0 1 ] fid_line_time 1 18 [ 0 1 ] fid_sub_time 1 2 [ 0 2 ] fid_sub_time 1 8 [ 0 2 ] fid_sub_time 1 12 [ 0 3 ] fid_sub_time 1 17 [ 0 1 ] fid_sub_time 1 18 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 4 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:2 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:print called_by 1:8 [ 2 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:12 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:7-9 calls 2 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:13 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::bar called_by 1:17 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::baz [ 1:11-15 calls 1 times 0 0 0 0 ] sub_subinfo main::baz called_by 1:18 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:1-5 calls 1 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:14 [ 1 0 0 0 0 0 0 main::baz ] Devel-NYTProf-6.06/t/test03.t000644 000766 000024 00000000121 12067023751 016030 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test01.p000644 000766 000024 00000000237 12067023751 016032 0ustar00timbostaff000000 000000 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(); Devel-NYTProf-6.06/t/test02.rdt000644 000766 000024 00000006512 12114475201 016361 0ustar00timbostaff000000 000000 attribute application test02.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 4 ] fid_block_time 1 7 [ 0 7 ] fid_block_time 1 11 [ 0 5 ] fid_block_time 1 18 [ 0 1 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 20 [ 0 1 ] fid_block_time 1 21 [ 0 1 ] fid_fileinfo 1 [ test02.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 6-8 fid_fileinfo 1 sub main::baz 10-16 fid_fileinfo 1 sub main::foo 1-4 fid_fileinfo 1 call 2 main::CORE:print [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 3 main::bar [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 7 main::CORE:print [ 7 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 11 main::CORE:print [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 12 main::bar [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 13 main::bar [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 14 main::bar [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 15 main::foo [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 18 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 19 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 20 main::baz [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 21 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 2 ] fid_line_time 1 3 [ 0 2 ] fid_line_time 1 7 [ 0 7 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 13 [ 0 1 ] fid_line_time 1 14 [ 0 1 ] fid_line_time 1 15 [ 0 1 ] fid_line_time 1 18 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 20 [ 0 1 ] fid_line_time 1 21 [ 0 1 ] fid_sub_time 1 2 [ 0 4 ] fid_sub_time 1 7 [ 0 7 ] fid_sub_time 1 11 [ 0 5 ] fid_sub_time 1 18 [ 0 1 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 20 [ 0 1 ] fid_sub_time 1 21 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 10 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:2 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:print called_by 1:7 [ 7 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:11 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:6-8 calls 7 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:3 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::bar called_by 1:12 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::bar called_by 1:13 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::bar called_by 1:14 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::bar called_by 1:18 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::bar called_by 1:19 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::baz [ 1:10-16 calls 1 times 0 0 0 0 ] sub_subinfo main::baz called_by 1:20 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:1-4 calls 2 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:15 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::foo called_by 1:21 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test16.rdt000644 000766 000024 00000006235 13222220743 016370 0ustar00timbostaff000000 000000 attribute application test16.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 10 [ 0 4 ] fid_block_time 1 11 [ 0 3 ] fid_block_time 1 22 [ 0 4 ] fid_block_time 1 31 [ 0 1 ] fid_block_time 1 32 [ 0 1 ] fid_block_time 1 33 [ 0 1 ] fid_block_time 1 34 [ 0 1 ] fid_fileinfo 1 [ test16.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 7-7 fid_fileinfo 1 sub main::CORE:match 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::CORE:say 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 21-28 fid_fileinfo 1 sub main::foo 9-19 fid_fileinfo 1 call 12 main::CORE:match [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 12 main::CORE:say [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 15 main::CORE:match [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 15 main::CORE:say [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 23 main::CORE:match [ 3 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 23 main::CORE:print [ 2 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 31 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 32 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 33 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 34 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 10 [ 0 2 ] fid_line_time 1 11 [ 0 2 ] fid_line_time 1 12 [ 0 2 ] fid_line_time 1 15 [ 0 1 ] fid_line_time 1 22 [ 0 2 ] fid_line_time 1 23 [ 0 2 ] fid_line_time 1 31 [ 0 1 ] fid_line_time 1 32 [ 0 1 ] fid_line_time 1 33 [ 0 1 ] fid_line_time 1 34 [ 0 1 ] fid_sub_time 1 10 [ 0 7 ] fid_sub_time 1 22 [ 0 4 ] fid_sub_time 1 31 [ 0 1 ] fid_sub_time 1 32 [ 0 1 ] fid_sub_time 1 33 [ 0 1 ] fid_sub_time 1 34 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:7-7 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:match [ 1:0-0 calls 6 times 0 0 0 0 ] sub_subinfo main::CORE:match called_by 1:12 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:match called_by 1:15 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:match called_by 1:23 [ 3 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print [ 1:0-0 calls 2 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:23 [ 2 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:say [ 1:0-0 calls 2 times 0 0 0 0 ] sub_subinfo main::CORE:say called_by 1:12 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:say called_by 1:15 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:21-28 calls 2 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:33 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::bar called_by 1:34 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:9-19 calls 2 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:31 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 1:32 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test09.t000644 000766 000024 00000000121 12067023751 016036 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test62-tie-b.rdt000644 000766 000024 00000003775 12471712122 017377 0ustar00timbostaff000000 000000 attribute application test62-tie-b.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 1 ] fid_block_time 1 6 [ 0 1 ] fid_block_time 1 7 [ 0 1 ] fid_block_time 1 10 [ 0 2 ] fid_block_time 1 11 [ 0 1 ] fid_block_time 1 12 [ 0 1 ] fid_block_time 1 14 [ 0 1 ] fid_fileinfo 1 [ test62-tie-b.p 1 2 0 0 ] fid_fileinfo 1 sub MyTie::FETCH 6-6 fid_fileinfo 1 sub MyTie::STORE 7-7 fid_fileinfo 1 sub MyTie::TIESCALAR 5-5 fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 10 MyTie::TIESCALAR [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 11 MyTie::STORE [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 12 MyTie::FETCH [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 1 7 [ 0 1 ] fid_line_time 1 10 [ 0 2 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 14 [ 0 1 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 6 [ 0 1 ] fid_sub_time 1 7 [ 0 1 ] fid_sub_time 1 10 [ 0 2 ] fid_sub_time 1 11 [ 0 1 ] fid_sub_time 1 12 [ 0 1 ] fid_sub_time 1 14 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo MyTie::FETCH [ 1:6-6 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::FETCH called_by 1:12 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo MyTie::STORE [ 1:7-7 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::STORE called_by 1:11 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo MyTie::TIESCALAR [ 1:5-5 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::TIESCALAR called_by 1:10 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test18-goto2.pm000644 000766 000024 00000000246 12067023751 017247 0ustar00timbostaff000000 000000 package Test18; sub longmess_real { return "Heavy" } delete $Test18::{longmess_jmp}; *longmess_jmp = *longmess_real; my $dummy = $&; # also test sawampersand 1; Devel-NYTProf-6.06/t/test62-subcaller1.calls000644 000766 000024 00000000315 12471702101 020720 0ustar00timbostaff000000 000000 Devel::NYTProf::Test::example_xsub 2 main::sub1 1 main::CORE:sort 2 main::CORE:sort;Devel::NYTProf::Test::example_xsub 3 main::CORE:sort;main::sub2 6 main::CORE:subst 1 main::CORE:substcont 3 main::sub4 2 Devel-NYTProf-6.06/t/test05.p000644 000766 000024 00000000447 12067023751 016041 0ustar00timbostaff000000 000000 # Test that fastprof 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 ); Devel-NYTProf-6.06/t/test14.rdt000644 000766 000024 00000004606 12130047577 016377 0ustar00timbostaff000000 000000 attribute application test14.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 17 [ 0 1 ] fid_block_time 1 18 [ 0 1 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 2 8 [ 0 1 ] fid_block_time 2 13 [ 0 1 ] fid_block_time 2 17 [ 0 2 ] fid_block_time 2 20 [ 0 1 ] fid_block_time 4 1 [ 0 1 ] fid_fileinfo 1 [ test14.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 16-16 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 17 test14::pre [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 18 AutoLoader::AUTOLOAD [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 19 AutoLoader::AUTOLOAD [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 2 [ test14.pm 2 2 0 0 ] fid_fileinfo 2 sub test14::BEGIN 2-2 fid_fileinfo 2 sub test14::bar 16-18 fid_fileinfo 2 sub test14::foo 12-14 fid_fileinfo 2 sub test14::pre 8-8 fid_fileinfo 2 eval 17 [ count 1 nested 0 merged 0 ] fid_fileinfo 3 [ AutoLoader.pm 3 2 0 0 ] fid_fileinfo 4 [ (eval 0)[test14.pm (autosplit into auto/test14/bar.al):17] 2 17 4 2 0 0 ] fid_line_time 1 17 [ 0 1 ] fid_line_time 1 18 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 2 8 [ 0 1 ] fid_line_time 2 13 [ 0 1 ] fid_line_time 2 17 [ 0 2 ] fid_line_time 2 20 [ 0 1 ] fid_line_time 4 1 [ 0 1 ] fid_sub_time 1 17 [ 0 1 ] fid_sub_time 1 18 [ 0 1 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 2 8 [ 0 1 ] fid_sub_time 2 13 [ 0 1 ] fid_sub_time 2 17 [ 0 2 ] fid_sub_time 2 20 [ 0 1 ] fid_sub_time 4 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:16-16 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo test14::BEGIN [ 2:2-2 calls 0 times 0 0 0 0 ] sub_subinfo test14::bar [ 2:16-18 calls 1 times 0 0 0 0 ] sub_subinfo test14::bar called_by 3:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo test14::foo [ 2:12-14 calls 1 times 0 0 0 0 ] sub_subinfo test14::foo called_by 3:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo test14::pre [ 2:8-8 calls 1 times 0 0 0 0 ] sub_subinfo test14::pre called_by 1:17 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/92-file_port.t000644 000766 000024 00000001147 12130047577 017135 0ustar00timbostaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More; eval "require Test::Portability::Files;"; plan skip_all => "Test::Portability::Files required for testing filename portability. ${ $@=~s/\.pm .*/.pm/, \$@ }" if $@; plan skip_all => "Set NYTPROF_TEST_PORTABILITY_FILES env var to enable test" unless $ENV{'NYTPROF_TEST_PORTABILITY_FILES'}; Test::Portability::Files->import(); # calls plan() #options(use_file_find => 1); # test all files not just those in MANIFEST (lots of .svn/* errors) #options(all_tests => 1); # to be hyper-strict (e.g., lots of DOS 8.3 length errors) run_tests(); 1; Devel-NYTProf-6.06/t/00-load.t000644 000766 000024 00000003237 12067023751 016055 0ustar00timbostaff000000 000000 use Test::More tests => 2; use Config; use_ok( 'Devel::NYTProf::Core' ); # we note the time in the test log here (the first test) and in t/zzz.t # so we can judge how fast the set of tests ran and this the rough speed of the system diag( "Testing Devel::NYTProf $Devel::NYTProf::Core::VERSION started at ".localtime(time) ); use_ok( 'Devel::NYTProf::Constants', qw( NYTP_DEFAULT_COMPRESSION NYTP_ZLIB_VERSION ) ); diag( sprintf "Compression: default level is %d, zlib version %s", NYTP_DEFAULT_COMPRESSION(), NYTP_ZLIB_VERSION() ); diag "--- Perl $] Config on $Config{archname}:"; diag "\t$_: ".(defined $Config{$_} ? $Config{$_} : '(undef)') for qw( d_gettimeod d_sysconf ); if ("$Config{archname} $Config{osvers}" =~ /\b xen \b/x or -d "/proc/xen" # maybe ) { diag("------------------------"); diag("--- Xen platform issues:"); diag("It looks like this is running inside a Xen virtual machine."); diag("Operating system clocks may appear to be unstable in this situation,"); diag("so tests may fail or produce odd warnings."); diag("See results from http://www.google.com/search?q=xen+clock+backwards"); diag("Including https://bugs.launchpad.net/xen/+bug/146924"); diag("And https://bugzilla.redhat.com/show_bug.cgi?id=449346"); diag("And http://rhn.redhat.com/errata/RHSA-2009-1243.html"); diag("In short, you may need to upgrade Xen and/or your OS."); diag("Note that use of NYTProf inside a virtual machine is likely to affect accuracy anyway."); diag("------------------------"); } my @env = grep { /^NYTPROF/ } sort keys %ENV; diag("--- Environment variables:") if @env; diag("\t$_=$ENV{$_}") for @env; Devel-NYTProf-6.06/t/test07.t000644 000766 000024 00000000121 12067023751 016034 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test51-enable.rdt000644 000766 000024 00000004763 12114475201 017617 0ustar00timbostaff000000 000000 attribute application test51-enable.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 3 [ 0 1 ] fid_block_time 1 4 [ 0 1 ] fid_block_time 1 5 [ 0 1 ] fid_block_time 1 7 [ 0 1 ] fid_block_time 1 16 [ 0 1 ] fid_fileinfo 1 [ test51-enable.p 1 2 0 0 ] fid_fileinfo 1 sub DB::disable_profile 0-0 fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:unlink 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::sub1 7-7 fid_fileinfo 1 sub main::sub2 8-8 fid_fileinfo 1 sub main::sub3 9-9 fid_fileinfo 1 sub main::sub4 10-10 fid_fileinfo 1 sub main::sub5 11-11 fid_fileinfo 1 sub main::sub6 12-12 fid_fileinfo 1 sub main::sub7 13-13 fid_fileinfo 1 sub main::sub8 14-14 fid_fileinfo 1 call 5 main::CORE:unlink [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 16 main::sub1 [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 18 DB::disable_profile [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 3 [ 0 1 ] fid_line_time 1 4 [ 0 1 ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 7 [ 0 1 ] fid_line_time 1 16 [ 0 1 ] fid_sub_time 1 3 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 7 [ 0 1 ] fid_sub_time 1 16 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo DB::disable_profile [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo DB::disable_profile called_by 1:18 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:unlink [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:unlink called_by 1:5 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::sub1 [ 1:7-7 calls 1 times 0 0 0 0 ] sub_subinfo main::sub1 called_by 1:16 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::sub2 [ 1:8-8 calls 0 times 0 0 0 0 ] sub_subinfo main::sub3 [ 1:9-9 calls 0 times 0 0 0 0 ] sub_subinfo main::sub4 [ 1:10-10 calls 0 times 0 0 0 0 ] sub_subinfo main::sub5 [ 1:11-11 calls 0 times 0 0 0 0 ] sub_subinfo main::sub6 [ 1:12-12 calls 0 times 0 0 0 0 ] sub_subinfo main::sub7 [ 1:13-13 calls 0 times 0 0 0 0 ] sub_subinfo main::sub8 [ 1:14-14 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test01.x000644 000766 000024 00000000627 12533402722 016042 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub foo { 0,2,0,print "in sub foo\n"; 0,2,0,bar(); 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,4,0,print "in sub bar\n"; 0,0,0,} 0,0,0, 0,0,0,sub baz { 0,1,0,print "in sub baz\n"; 0,1,0,bar(); 0,1,0,foo(); 0,0,0,} 0,0,0, 0,1,0,bar(); 0,1,0,baz(); 0,1,0,foo(); Devel-NYTProf-6.06/t/test01.rdt000644 000766 000024 00000005500 12114475203 016356 0ustar00timbostaff000000 000000 attribute application test01.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 4 ] fid_block_time 1 7 [ 0 4 ] fid_block_time 1 11 [ 0 3 ] fid_block_time 1 16 [ 0 1 ] fid_block_time 1 17 [ 0 1 ] fid_block_time 1 18 [ 0 1 ] fid_fileinfo 1 [ test01.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 6-8 fid_fileinfo 1 sub main::baz 10-14 fid_fileinfo 1 sub main::foo 1-4 fid_fileinfo 1 call 2 main::CORE:print [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 3 main::bar [ 2 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 7 main::CORE:print [ 4 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 11 main::CORE:print [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 12 main::bar [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 13 main::foo [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 16 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 17 main::baz [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 18 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 2 ] fid_line_time 1 3 [ 0 2 ] fid_line_time 1 7 [ 0 4 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 13 [ 0 1 ] fid_line_time 1 16 [ 0 1 ] fid_line_time 1 17 [ 0 1 ] fid_line_time 1 18 [ 0 1 ] fid_sub_time 1 2 [ 0 4 ] fid_sub_time 1 7 [ 0 4 ] fid_sub_time 1 11 [ 0 3 ] fid_sub_time 1 16 [ 0 1 ] fid_sub_time 1 17 [ 0 1 ] fid_sub_time 1 18 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 7 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:2 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:print called_by 1:7 [ 4 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:11 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:6-8 calls 4 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:3 [ 2 0 0 0 0 0 0 main::foo ] sub_subinfo main::bar called_by 1:12 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::bar called_by 1:16 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::baz [ 1:10-14 calls 1 times 0 0 0 0 ] sub_subinfo main::baz called_by 1:17 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:1-4 calls 2 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:13 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::foo called_by 1:18 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test22-strevala.t000644 000766 000024 00000003635 12130047577 017670 0ustar00timbostaff000000 000000 use strict; use Test::More; use List::Util qw(sum); use lib qw(t/lib); use NYTProfTest; # don't normalize eval seqn because doing so would create duplicates $ENV{NYTPROF_TEST_SKIP_EVAL_NORM} = 1; use Devel::NYTProf::Constants qw(NYTP_SCi_elements); run_test_group( { extra_test_count => 2 + (3 * 3), extra_test_code => sub { my ($profile, $env) = @_; # check sub callers from sub perspective my $subs = $profile->subname_subinfo_map; my @anon = grep { $_->is_anon } values %$subs; is @anon, 3, 'should be 3 anon subs (after merging)'; is sum(map { $_->calls } @anon), 5, 'call count'; my %fids; for my $si (@anon) { printf "------ sub %s\n", $si->subname; my $called_by_subnames = $si->called_by_subnames; ok $called_by_subnames; is_deeply [ keys %$called_by_subnames ], [ 'main::RUNTIME' ], 'should be called from only from main::RUNTIME'; my $callers = $si->caller_fid_line_places; ok $callers; print "caller_fid_line_places: ".Data::Dumper::Dumper($callers); ++$fids{$_} for keys %$callers; } return; # check sub callers from file perspective for my $fid (keys %fids) { print "------ fid $fid\n"; ok my $fi = $profile->fileinfo_of($fid); ok my $sub_call_lines = $fi->sub_call_lines; warn "sub_call_lines: ".Data::Dumper::Dumper($sub_call_lines); is keys %$sub_call_lines, 1; is keys %{$sub_call_lines->{1}}, 1; ok my $sc = $sub_call_lines->{1}{'main::foo'}; is @$sc, NYTP_SCi_elements(), 'si should have all elements'; } }, } ); exit 0; __END__ my $code = 'sub { print "sub called\n" }'; eval($code)->(); eval($code)->(); eval($code)->(); eval q{ eval($code)->(); eval($code)->(); }; Devel-NYTProf-6.06/t/test62-tie-a.rdt000644 000766 000024 00000003775 12471711173 017403 0ustar00timbostaff000000 000000 attribute application test62-tie-a.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 2 ] fid_block_time 1 6 [ 0 1 ] fid_block_time 1 7 [ 0 1 ] fid_block_time 1 10 [ 0 1 ] fid_block_time 1 11 [ 0 1 ] fid_block_time 1 12 [ 0 1 ] fid_block_time 1 14 [ 0 1 ] fid_fileinfo 1 [ test62-tie-a.p 1 2 0 0 ] fid_fileinfo 1 sub MyTie::FETCH 6-6 fid_fileinfo 1 sub MyTie::STORE 7-7 fid_fileinfo 1 sub MyTie::TIESCALAR 5-5 fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 10 MyTie::TIESCALAR [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 11 MyTie::STORE [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 12 MyTie::FETCH [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 5 [ 0 2 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 1 7 [ 0 1 ] fid_line_time 1 10 [ 0 1 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 14 [ 0 1 ] fid_sub_time 1 5 [ 0 2 ] fid_sub_time 1 6 [ 0 1 ] fid_sub_time 1 7 [ 0 1 ] fid_sub_time 1 10 [ 0 1 ] fid_sub_time 1 11 [ 0 1 ] fid_sub_time 1 12 [ 0 1 ] fid_sub_time 1 14 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo MyTie::FETCH [ 1:6-6 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::FETCH called_by 1:12 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo MyTie::STORE [ 1:7-7 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::STORE called_by 1:11 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo MyTie::TIESCALAR [ 1:5-5 calls 1 times 0 0 0 0 ] sub_subinfo MyTie::TIESCALAR called_by 1:10 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test20-streval.rdt000644 000766 000024 00000005161 12114475205 020042 0ustar00timbostaff000000 000000 attribute application test20-streval.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 3 [ 0 4 ] fid_block_time 1 5 [ 0 1 ] fid_block_time 1 8 [ 0 1 ] fid_block_time 1 11 [ 0 2 ] fid_block_time 1 14 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_block_time 3 1 [ 0 1 ] fid_block_time 5 1 [ 0 1 ] fid_block_time 6 1 [ 0 1 ] fid_fileinfo 1 [ test20-streval.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::foo 3-3 fid_fileinfo 1 call 3 main::CORE:print [ 4 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 eval 8 [ count 1 nested 0 merged 0 ] fid_fileinfo 1 eval 11 [ count 1 nested 0 merged 1 ] fid_fileinfo 1 eval 14 [ count 1 nested 1 merged 0 ] fid_fileinfo 2 [ (eval 0)[test20-streval.p:8] 1 8 2 2 0 0 ] fid_fileinfo 2 call 1 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 3 [ (eval 0)[test20-streval.p:11] 1 11 3 2 0 0 ] fid_fileinfo 3 call 1 main::foo [ 2 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 5 [ (eval 0)[test20-streval.p:14] 1 14 5 2 0 0 ] fid_fileinfo 5 eval 1 [ count 1 nested 0 merged 0 ] fid_fileinfo 6 [ (eval 0)[(eval 0)[test20-streval.p:14]:1] 5 1 6 2 0 0 ] fid_fileinfo 6 call 1 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 3 [ 0 4 ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 8 [ 0 1 ] fid_line_time 1 11 [ 0 2 ] fid_line_time 1 14 [ 0 1 ] fid_line_time 2 1 [ 0 1 ] fid_line_time 3 1 [ 0 2 ] fid_line_time 5 1 [ 0 1 ] fid_line_time 6 1 [ 0 1 ] fid_sub_time 1 3 [ 0 4 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 8 [ 0 1 ] fid_sub_time 1 11 [ 0 2 ] fid_sub_time 1 14 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] fid_sub_time 3 1 [ 0 1 ] fid_sub_time 5 1 [ 0 1 ] fid_sub_time 6 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 4 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:3 [ 4 0 0 0 0 0 0 main::foo ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::foo [ 1:3-3 calls 4 times 0 0 0 0 ] sub_subinfo main::foo called_by 2:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 3:1 [ 2 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo called_by 6:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test62-tie-a.p000644 000766 000024 00000000526 12471703552 017042 0ustar00timbostaff000000 000000 # test determination of subroutine caller in tie calls { # calls to TIESCALAR aren't seen by perl < 5.8.9 and 5.10.1 sub MyTie::TIESCALAR { bless {}, shift; } sub MyTie::FETCH { } sub MyTie::STORE { } } tie my $tied, 'MyTie', 42; # TIESCALAR $tied = 1; # STORE if ($tied) { 1 } # FETCH exit 0; Devel-NYTProf-6.06/t/test05.rdt000644 000766 000024 00000005713 12114475213 016371 0ustar00timbostaff000000 000000 attribute application test05.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 2 ] fid_block_time 1 9 [ 0 2 ] fid_block_time 1 13 [ 0 4 ] fid_block_time 1 19 [ 0 2 ] fid_block_time 1 22 [ 0 1 ] fid_block_time 1 23 [ 0 1 ] fid_fileinfo 1 [ test05.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 12-17 fid_fileinfo 1 sub main::foo1 4-7 fid_fileinfo 1 sub main::foo2 8-11 fid_fileinfo 1 sub main::yeppers 18-20 fid_fileinfo 1 call 5 main::CORE:print [ 1 0 0 0 0 0 0 main::foo1 ] fid_fileinfo 1 call 6 main::bar [ 1 0 0 0 0 0 0 main::foo1 ] fid_fileinfo 1 call 9 main::CORE:print [ 1 0 0 0 0 0 0 main::foo2 ] fid_fileinfo 1 call 10 main::bar [ 1 0 0 0 0 0 0 main::foo2 ] fid_fileinfo 1 call 13 main::CORE:print [ 2 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 14 main::yeppers [ 2 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 19 main::CORE:print [ 2 0 0 0 0 0 0 main::yeppers ] fid_fileinfo 1 call 22 main::foo1 [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 23 main::foo2 [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 1 9 [ 0 1 ] fid_line_time 1 10 [ 0 1 ] fid_line_time 1 13 [ 0 2 ] fid_line_time 1 14 [ 0 2 ] fid_line_time 1 19 [ 0 2 ] fid_line_time 1 22 [ 0 1 ] fid_line_time 1 23 [ 0 1 ] fid_sub_time 1 5 [ 0 2 ] fid_sub_time 1 9 [ 0 2 ] fid_sub_time 1 13 [ 0 4 ] fid_sub_time 1 19 [ 0 2 ] fid_sub_time 1 22 [ 0 1 ] fid_sub_time 1 23 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 6 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:5 [ 1 0 0 0 0 0 0 main::foo1 ] sub_subinfo main::CORE:print called_by 1:9 [ 1 0 0 0 0 0 0 main::foo2 ] sub_subinfo main::CORE:print called_by 1:13 [ 2 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:19 [ 2 0 0 0 0 0 0 main::yeppers ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:12-17 calls 2 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:6 [ 1 0 0 0 0 0 0 main::foo1 ] sub_subinfo main::bar called_by 1:10 [ 1 0 0 0 0 0 0 main::foo2 ] sub_subinfo main::foo1 [ 1:4-7 calls 1 times 0 0 0 0 ] sub_subinfo main::foo1 called_by 1:22 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo2 [ 1:8-11 calls 1 times 0 0 0 0 ] sub_subinfo main::foo2 called_by 1:23 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::yeppers [ 1:18-20 calls 2 times 0 0 0 0 ] sub_subinfo main::yeppers called_by 1:14 [ 2 0 0 0 0 0 0 main::bar ] Devel-NYTProf-6.06/t/test11.rdt000644 000766 000024 00000003127 12114475205 016364 0ustar00timbostaff000000 000000 attribute application test11.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 1 ] fid_block_time 1 6 [ 0 1 ] fid_block_time 2 1 [ 0 2 ] fid_fileinfo 1 [ test11.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 2-4 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 5 main::__ANON__[(eval 0)[test11.p:3]:1] [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 6 main::__ANON__[(eval 0)[test11.p:3]:1] [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 3 [ count 1 nested 0 merged 0 ] fid_fileinfo 2 [ (eval 0)[test11.p:3] 1 3 2 2 0 0 ] fid_fileinfo 2 sub main::__ANON__[(eval 0)[test11.p:3]:1] 1-1 fid_line_time 1 5 [ 0 1 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 2 1 [ 0 2 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 6 [ 0 1 ] fid_sub_time 2 1 [ 0 2 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:2-4 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 0)[test11.p:3]:1] [ 2:1-1 calls 2 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 0)[test11.p:3]:1] called_by 1:5 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 0)[test11.p:3]:1] called_by 1:6 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test61-submerge.calls000644 000766 000024 00000000273 12130047577 020511 0ustar00timbostaff000000 000000 main::__ANON__[(eval 0)[test61-submerge.p:8]:1] 3 main::__ANON__[(eval 0)[test61-submerge.p:8]:1];main::foo 3 main::__ANON__[(eval 0)[test61-submerge.p:8]:1];main::foo;main::CORE:print 3 Devel-NYTProf-6.06/t/test10.calls000644 000766 000024 00000000143 12130047577 016670 0ustar00timbostaff000000 000000 main::__ANON__[(eval 0)[test10.p:1]:1] 1 main::__ANON__[(eval 0)[test10.p:1]:1];main::CORE:sleep 1 Devel-NYTProf-6.06/t/test50-disable.x000644 000766 000024 00000000501 12533402722 017436 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,1,0,shift; 0,1,0,DB::disable_profile(); 0,0,0,shift; 0,1,0,DB::enable_profile(); 0,1,0,shift; 0,0,0,DB::disable_profile(); 0,0,0,shift; # finish with profile disabled Devel-NYTProf-6.06/t/test25-strevalb.t000644 000766 000024 00000004227 12414316330 017661 0ustar00timbostaff000000 000000 # Tests CORE::GLOBAL::foo plus assorted data model methods use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Config qw(%Config); use Devel::NYTProf::Run qw(profile_this); use Devel::NYTProf::Constants qw(NYTP_SCi_elements); my $pre589 = ($] < 5.008009 or $] eq "5.010000"); my $src_code = join("", ); # perl assert failure https://rt.perl.org/Ticket/Display.html?id=122771 my $perl_rt70211 = ($] >= 5.020 && $Config{ccflags} =~ /-DDEBUGGING/); run_test_group( { extra_options => { start => 'begin', optimize => ($perl_rt70211) ? 0 : 1, }, extra_test_count => 8, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $fi = $profile->fileinfo_of(1); my $subdefs_at_line = $profile->subs_defined_in_file_by_line($fi->filename); # 0: version::(bool, 1: main::BEGIN@1, 2: main::BEGIN@2, 3: main::add, 4: main::inc #warn join ", ", map { "$_: ".$subdefs_at_line->{$_}[0]->subname } sort keys %$subdefs_at_line; isa_ok my $add_si = $subdefs_at_line->{4}[0], 'Devel::NYTProf::SubInfo'; is $add_si->subname, 'main::add'; my $callers = $add_si->caller_fid_line_places; print Dumper($callers); is keys %$callers, 1, 'called from 1 fid'; my $caller_fid = (keys %$callers)[0]; my $sc_lineinfo = $callers->{$caller_fid}; is keys %$sc_lineinfo, 1, 'called from 1 line in that fid'; my $caller_line = (keys %$sc_lineinfo)[0]; my $sc = (values %$sc_lineinfo)[0]; is ref $sc, 'ARRAY'; is @$sc, NYTP_SCi_elements(), "call from $caller_fid:$caller_line to main::add should have all elements in $sc"; my $called_by_subnames = $add_si->called_by_subnames; is keys %$called_by_subnames, 1, 'called_by_subnames should report one caller for main::add'; }, }); __DATA__ use strict; use Benchmark; my $i; sub add { ++$i } timethis( 10, \&add ); die "panic $i" unless $i == 10; Devel-NYTProf-6.06/t/test40pmc.pm_x000644 000766 000024 00000000534 12533402722 017236 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# this is test14.pmc which perl will load in preference to test14.pmc 0,0,0,# (if it's newer than test14.pm) 0,0,0,package test40pmc; 0,0,0, 0,0,0,sub foo { 0,1,0,1; 0,0,0,} 0,0,0, 0,0,0,1; Devel-NYTProf-6.06/t/test30-fork-0.p000644 000766 000024 00000000312 12067023751 017122 0ustar00timbostaff000000 000000 sub prefork { print "in sub prefork\n"; other(); } sub other { print "in sub other\n"; } sub postfork { print "in sub postfork\n"; other(); } prefork(); fork; postfork(); other(); wait; Devel-NYTProf-6.06/t/test09.calls000644 000766 000024 00000000056 12130047577 016703 0ustar00timbostaff000000 000000 main::bar 1 main::foo 2 main::foo;main::bar 2 Devel-NYTProf-6.06/t/68-hashline.t000644 000766 000024 00000002212 12067023751 016737 0ustar00timbostaff000000 000000 # Tests CORE::GLOBAL::foo plus assorted data model methods use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Devel::NYTProf::Run qw(profile_this); plan skip_all => "Currently a developer-only test" unless -d '.svn'; warn "This test script needs more work\n"; my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, stmts => 1, slowops => 0, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, htmlopen => $ENV{NYTPROF_TEST_HTMLOPEN}, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs = $profile->subname_subinfo_map; ok 1; }, }); __DATA__ sub a { 0 } #line 101 "hash-line-first" sub b { 1 } #line 202 "hash-line-second" sub c { 2 } eval qq{#line 303 "hash-line-eval" sub d { 3 } 1} or die; a(); b(); c(); d(); print "# File: $_\n" for sort grep { m/_ $DB::sub{$_}\n" for sort keys %DB::sub; Devel-NYTProf-6.06/t/test50-disable.rdt000644 000766 000024 00000002733 12114475204 017771 0ustar00timbostaff000000 000000 attribute application test50-disable.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 1 [ 0 1 ] fid_block_time 1 2 [ 0 1 ] fid_block_time 1 4 [ 0 1 ] fid_block_time 1 5 [ 0 1 ] fid_fileinfo 1 [ test50-disable.p 1 2 0 0 ] fid_fileinfo 1 sub DB::disable_profile 0-0 fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 2 DB::disable_profile [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 6 DB::disable_profile [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 1 [ 0 1 ] fid_line_time 1 2 [ 0 1 ] fid_line_time 1 4 [ 0 1 ] fid_line_time 1 5 [ 0 1 ] fid_sub_time 1 1 [ 0 1 ] fid_sub_time 1 2 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 1 5 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo DB::disable_profile [ 1:0-0 calls 2 times 0 0 0 0 ] sub_subinfo DB::disable_profile called_by 1:2 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo DB::disable_profile called_by 1:6 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test10.rdt000644 000766 000024 00000003302 12130047577 016363 0ustar00timbostaff000000 000000 attribute application test10.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 1 [ 0 1 ] fid_block_time 1 2 [ 0 1 ] fid_block_time 2 1 [ 0 2 ] fid_fileinfo 1 [ test10.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:sleep 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 2 main::__ANON__[(eval 0)[test10.p:1]:1] [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 1 [ count 1 nested 0 merged 0 ] fid_fileinfo 2 [ (eval 0)[test10.p:1] 1 1 2 2 0 0 ] fid_fileinfo 2 sub main::__ANON__[(eval 0)[test10.p:1]:1] 1-1 fid_fileinfo 2 call 1 main::CORE:sleep [ 1 0 0 0 0 0 0 main::__ANON__[(eval 0)[test10.p:1]:1] ] fid_line_time 1 1 [ 0 1 ] fid_line_time 1 2 [ 0 1 ] fid_line_time 2 1 [ 0 2 ] fid_sub_time 1 1 [ 0 1 ] fid_sub_time 1 2 [ 0 1 ] fid_sub_time 2 1 [ 0 2 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:sleep [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:sleep called_by 2:1 [ 1 0 0 0 0 0 0 main::__ANON__[(eval 0)[test10.p:1]:1] ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 0)[test10.p:1]:1] [ 2:1-1 calls 1 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 0)[test10.p:1]:1] called_by 1:2 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test40pmc.calls000644 000766 000024 00000000021 12130047577 017366 0ustar00timbostaff000000 000000 test40pmc::foo 1 Devel-NYTProf-6.06/t/test11.x000644 000766 000024 00000000366 12533402722 016043 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,use vars qw/$b/; 0,0,0,BEGIN { 0,0,0,$b = eval "sub {1}"; 0,0,0,} 0,1,0,&$b; 0,1,0,&$b; Devel-NYTProf-6.06/t/44-model.t000644 000766 000024 00000001463 12067023751 016245 0ustar00timbostaff000000 000000 # Tests assorted data model methods use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); run_test_group( { extra_options => { start => 'begin' }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; my $src_code = q{ use strict 0.01; }; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs = $profile->subname_subinfo_map; my ($filename, $fid, $first, $last) = $profile->file_line_range_of_sub("UNIVERSAL::VERSION"); is "$first-$last", "0-0", 'UNIVERSAL::VERSION line range'; }, }); Devel-NYTProf-6.06/t/test12.rdt000644 000766 000024 00000001534 12114475201 016361 0ustar00timbostaff000000 000000 attribute application test12.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 1 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_fileinfo 1 [ test12.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 2 [ test12.pl 2 2 0 0 ] fid_line_time 1 1 [ 0 1 ] fid_line_time 2 1 [ 0 1 ] fid_sub_time 1 1 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test06.rdt000644 000766 000024 00000007561 12114475201 016372 0ustar00timbostaff000000 000000 attribute application test06.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 1 ] fid_block_time 1 6 [ 0 410 ] fid_block_time 1 10 [ 0 2 ] fid_block_time 1 12 [ 0 20 ] fid_block_time 1 14 [ 0 100 ] fid_block_time 1 20 [ 0 3 ] fid_block_time 1 23 [ 0 20 ] fid_block_time 1 25 [ 0 100 ] fid_block_time 1 31 [ 0 3 ] fid_block_time 1 33 [ 0 20 ] fid_block_time 1 35 [ 0 200 ] fid_block_time 1 42 [ 0 1 ] fid_block_time 1 43 [ 0 1 ] fid_block_time 1 44 [ 0 1 ] fid_fileinfo 1 [ test06.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 19-28 fid_fileinfo 1 sub main::baz 30-40 fid_fileinfo 1 sub main::foo 9-17 fid_fileinfo 1 sub main::noop 5-7 fid_fileinfo 1 call 10 main::CORE:print [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 12 main::noop [ 10 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 14 main::noop [ 100 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 20 main::CORE:print [ 1 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 25 main::noop [ 100 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 31 main::CORE:print [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 36 main::noop [ 100 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 37 main::noop [ 100 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 42 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 43 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 44 main::baz [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 4 [ 0 1 ] fid_line_time 1 6 [ 0 410 ] fid_line_time 1 10 [ 0 1 ] fid_line_time 1 11 [ 0 1 ] fid_line_time 1 12 [ 0 10 ] fid_line_time 1 13 [ 0 10 ] fid_line_time 1 14 [ 0 100 ] fid_line_time 1 20 [ 0 1 ] fid_line_time 1 21 [ 0 1 ] fid_line_time 1 22 [ 0 1 ] fid_line_time 1 23 [ 0 10 ] fid_line_time 1 24 [ 0 10 ] fid_line_time 1 25 [ 0 100 ] fid_line_time 1 31 [ 0 1 ] fid_line_time 1 32 [ 0 1 ] fid_line_time 1 33 [ 0 1 ] fid_line_time 1 34 [ 0 10 ] fid_line_time 1 35 [ 0 10 ] fid_line_time 1 36 [ 0 100 ] fid_line_time 1 37 [ 0 100 ] fid_line_time 1 42 [ 0 1 ] fid_line_time 1 43 [ 0 1 ] fid_line_time 1 44 [ 0 1 ] fid_sub_time 1 4 [ 0 1 ] fid_sub_time 1 6 [ 0 410 ] fid_sub_time 1 10 [ 0 122 ] fid_sub_time 1 20 [ 0 123 ] fid_sub_time 1 31 [ 0 223 ] fid_sub_time 1 42 [ 0 1 ] fid_sub_time 1 43 [ 0 1 ] fid_sub_time 1 44 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 3 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:10 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:print called_by 1:20 [ 1 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:31 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:19-28 calls 1 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:43 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::baz [ 1:30-40 calls 1 times 0 0 0 0 ] sub_subinfo main::baz called_by 1:44 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:9-17 calls 1 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:42 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::noop [ 1:5-7 calls 410 times 0 0 0 0 ] sub_subinfo main::noop called_by 1:12 [ 10 0 0 0 0 0 0 main::foo ] sub_subinfo main::noop called_by 1:14 [ 100 0 0 0 0 0 0 main::foo ] sub_subinfo main::noop called_by 1:25 [ 100 0 0 0 0 0 0 main::bar ] sub_subinfo main::noop called_by 1:36 [ 100 0 0 0 0 0 0 main::baz ] sub_subinfo main::noop called_by 1:37 [ 100 0 0 0 0 0 0 main::baz ] Devel-NYTProf-6.06/t/72-autodie.t000644 000766 000024 00000001746 12130047577 016607 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; eval "use autodie; 1" or plan skip_all => "autodie required"; print "autodie $autodie::VERSION $INC{'autodie.pm'}\n"; plan skip_all => "Currently a developer-only test" unless -d '.svn'; warn "This test script needs more work\n"; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, stmts => 0, slowops => 0, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, htmlopen => $ENV{NYTPROF_TEST_HTMLOPEN}, ); isa_ok $profile, 'Devel::NYTProf::Data'; my $subs = $profile->subname_subinfo_map; ok 1; }, }); __DATA__ #!perl package P; use autodie; eval { rmdir "nonsuch file name" }; Devel-NYTProf-6.06/t/lib/000750 000766 000024 00000000000 13305245314 015265 5ustar00timbostaff000000 000000 Devel-NYTProf-6.06/t/test50-disable.p000644 000766 000024 00000000177 12067023751 017442 0ustar00timbostaff000000 000000 shift; DB::disable_profile(); shift; DB::enable_profile(); shift; DB::disable_profile(); shift; # finish with profile disabled Devel-NYTProf-6.06/t/test30-fork-0.x000644 000766 000024 00000000734 12533402722 017137 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub prefork { 0,1,0,print "in sub prefork\n"; 0,1,0,other(); 0,0,0,} 0,0,0, 0,0,0,sub other { 0,3,0,print "in sub other\n"; 0,0,0,} 0,0,0, 0,0,0,sub postfork { 0,1,0,print "in sub postfork\n"; 0,1,0,other(); 0,0,0,} 0,0,0, 0,1,0,prefork(); 0,0,0, 0,1,0,fork; 0,0,0, 0,1,0,postfork(); 0,1,0,other(); 0,0,0, 0,1,0,wait; Devel-NYTProf-6.06/t/test13.t000644 000766 000024 00000000121 12067023751 016031 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test12.calls000644 000766 000024 00000000000 12130047577 016662 0ustar00timbostaff000000 000000 Devel-NYTProf-6.06/t/test11.p000644 000766 000024 00000000074 12067023751 016032 0ustar00timbostaff000000 000000 use vars qw/$b/; BEGIN { $b = eval "sub {1}"; } &$b; &$b; Devel-NYTProf-6.06/t/test07.rdt000644 000766 000024 00000002075 12114475213 016371 0ustar00timbostaff000000 000000 attribute application test07.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 1 [ 0 1 ] fid_fileinfo 1 [ test07.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 1 main::CORE:print [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 1 [ 0 1 ] fid_sub_time 1 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 1 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] Devel-NYTProf-6.06/t/test14.pm000644 000766 000024 00000000607 12067023751 016214 0ustar00timbostaff000000 000000 package test14; use AutoLoader 'AUTOLOAD'; # The tests run with start=init so we need to arrange to execute some # profiled code before the first autosplit sub gets loaded in order to # test the handling of autosplit subs. We could use an INIT block for # that but calling a sub suits the tests better for obscure reasons. sub pre { 1 } 1; __END__ sub foo { $&; } sub bar { eval 2; } Devel-NYTProf-6.06/t/test13.rdt000644 000766 000024 00000006221 12114475202 016361 0ustar00timbostaff000000 000000 attribute application test13.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 3 ] fid_block_time 1 8 [ 0 1 ] fid_block_time 1 12 [ 0 3 ] fid_block_time 1 13 [ 0 2 ] fid_block_time 1 15 [ 0 1 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 20 [ 0 2 ] fid_block_time 1 21 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_fileinfo 1 [ test13.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 7-9 fid_fileinfo 1 sub main::baz 11-17 fid_fileinfo 1 sub main::foo 3-5 fid_fileinfo 1 sub main::x undef-undef fid_fileinfo 1 call 4 main::CORE:print [ 3 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 8 main::CORE:print [ 1 0 0 0 0 0 0 main::bar ] fid_fileinfo 1 call 12 main::CORE:print [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 13 main::foo [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 14 main::foo [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 15 main::x [ 1 0 0 0 0 0 0 main::baz ] fid_fileinfo 1 call 20 main::bar [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 21 main::baz [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 19 [ count 1 nested 0 merged 0 ] fid_fileinfo 2 [ (eval 0)[test13.p:19] 1 19 2 2 0 0 ] fid_fileinfo 2 call 1 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 4 [ 0 3 ] fid_line_time 1 8 [ 0 1 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 1 13 [ 0 2 ] fid_line_time 1 14 [ 0 1 ] fid_line_time 1 15 [ 0 2 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 20 [ 0 2 ] fid_line_time 1 21 [ 0 1 ] fid_line_time 2 1 [ 0 1 ] fid_sub_time 1 4 [ 0 3 ] fid_sub_time 1 8 [ 0 1 ] fid_sub_time 1 12 [ 0 6 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 20 [ 0 2 ] fid_sub_time 1 21 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 5 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:4 [ 3 0 0 0 0 0 0 main::foo ] sub_subinfo main::CORE:print called_by 1:8 [ 1 0 0 0 0 0 0 main::bar ] sub_subinfo main::CORE:print called_by 1:12 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:7-9 calls 1 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:20 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::baz [ 1:11-17 calls 1 times 0 0 0 0 ] sub_subinfo main::baz called_by 1:21 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:3-5 calls 3 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:13 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::foo called_by 1:14 [ 1 0 0 0 0 0 0 main::baz ] sub_subinfo main::foo called_by 2:1 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::x [ 1:undef-undef calls 1 times 0 0 0 0 ] sub_subinfo main::x called_by 1:15 [ 1 0 0 0 0 0 0 main::baz ] Devel-NYTProf-6.06/t/test08.p000644 000766 000024 00000000027 12067023751 016036 0ustar00timbostaff000000 000000 eval "shift; shift;"; Devel-NYTProf-6.06/t/test17-goto.rdt000644 000766 000024 00000005445 12114475212 017343 0ustar00timbostaff000000 000000 attribute application test17-goto.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 5 [ 0 1 ] fid_block_time 1 7 [ 0 1 ] fid_block_time 1 9 [ 0 2 ] fid_block_time 1 14 [ 0 2 ] fid_block_time 1 19 [ 0 1 ] fid_block_time 1 22 [ 0 1 ] fid_block_time 1 27 [ 0 1 ] fid_block_time 1 31 [ 0 2 ] fid_block_time 1 35 [ 0 1 ] fid_fileinfo 1 [ test17-goto.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::bar 26-28 fid_fileinfo 1 sub main::destination 18-20 fid_fileinfo 1 sub main::foo 30-33 fid_fileinfo 1 sub main::origin 13-16 fid_fileinfo 1 sub main::other 9-9 fid_fileinfo 1 call 14 main::other [ 1 0 0 0 0 0 0 main::origin ] fid_fileinfo 1 call 15 main::destination [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 19 main::other [ 1 0 0 0 0 0 0 main::destination ] fid_fileinfo 1 call 22 main::origin [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 31 main::bar [ 1 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 35 main::foo [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 5 [ 0 1 ] fid_line_time 1 7 [ 0 1 ] fid_line_time 1 9 [ 0 2 ] fid_line_time 1 14 [ 0 1 ] fid_line_time 1 15 [ 0 1 ] fid_line_time 1 19 [ 0 1 ] fid_line_time 1 22 [ 0 1 ] fid_line_time 1 27 [ 0 1 ] fid_line_time 1 31 [ 0 1 ] fid_line_time 1 32 [ 0 1 ] fid_line_time 1 35 [ 0 1 ] fid_sub_time 1 5 [ 0 1 ] fid_sub_time 1 7 [ 0 1 ] fid_sub_time 1 9 [ 0 2 ] fid_sub_time 1 14 [ 0 2 ] fid_sub_time 1 19 [ 0 1 ] fid_sub_time 1 22 [ 0 1 ] fid_sub_time 1 27 [ 0 1 ] fid_sub_time 1 31 [ 0 2 ] fid_sub_time 1 35 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::bar [ 1:26-28 calls 1 times 0 0 0 0 ] sub_subinfo main::bar called_by 1:31 [ 1 0 0 0 0 0 0 main::foo ] sub_subinfo main::destination [ 1:18-20 calls 1 times 0 0 0 0 ] sub_subinfo main::destination called_by 1:15 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::foo [ 1:30-33 calls 1 times 0 0 0 0 ] sub_subinfo main::foo called_by 1:35 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::origin [ 1:13-16 calls 1 times 0 0 0 0 ] sub_subinfo main::origin called_by 1:22 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::other [ 1:9-9 calls 2 times 0 0 0 0 ] sub_subinfo main::other called_by 1:14 [ 1 0 0 0 0 0 0 main::origin ] sub_subinfo main::other called_by 1:19 [ 1 0 0 0 0 0 0 main::destination ] Devel-NYTProf-6.06/t/test60-subname.t000644 000766 000024 00000000446 12067023751 017475 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; # XXX needed because the call from example_xsub to will_die, # made via call_sv() doesn't get profiled on older perls plan skip_all => "needs perl >= 5.8.9 or >= 5.10.1" if $] < 5.008009 or $] eq "5.010000"; run_test_group; Devel-NYTProf-6.06/t/test02.p000644 000766 000024 00000000270 12067023751 016030 0ustar00timbostaff000000 000000 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(); Devel-NYTProf-6.06/t/60-forkdepth.t000644 000766 000024 00000001555 12067023751 017133 0ustar00timbostaff000000 000000 use Test::More; use strict; use lib qw(t/lib); use NYTProfTest; plan skip_all => "doesn't work with fork() emulation" if (($^O eq "MSWin32") || ($^O eq 'VMS')); plan tests => 5; my $out = 'nytprof-forkdepth.out'; is run_forkdepth( 0 ), 1; is run_forkdepth( 1 ), 2; is run_forkdepth( 2 ), 3; is run_forkdepth( -1 ), 3; is run_forkdepth( undef), 3; exit 0; sub run_forkdepth { my ($forkdepth) = @_; printf "run_forkdepth %s\n", defined($forkdepth) ? $forkdepth : "undef"; unlink $_ for glob("$out.*"); $ENV{NYTPROF} = "file=$out:addpid=1:trace=0"; $ENV{NYTPROF} .= ":forkdepth=$forkdepth" if defined $forkdepth; my $forkdepth_cmd = q{-d:NYTProf -e "sub f { fork or return; wait; exit \$? } f; f; exit 0"}; run_perl_command($forkdepth_cmd); my @files = glob("$out.*"); unlink $_ for @files; return scalar @files; } Devel-NYTProf-6.06/t/test21-streval3.t000644 000766 000024 00000000121 12067023751 017571 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test24-strevalc.t000644 000766 000024 00000000171 12067023751 017661 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; $ENV{NYTPROF_TEST_SKIP_EVAL_NORM} = 1; run_test_group; Devel-NYTProf-6.06/t/test06.x000644 000766 000024 00000001650 12533402722 016044 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# tests loops. noop is a hack for perl>5.6 where 0,0,0,# the closing "}" of a loop counts as being executed if loop is empty. 0,0,0, 0,1,0,my $_z; 0,0,0,sub noop { 0,410,0,$_z++; 0,0,0,} 0,0,0, 0,0,0,sub foo { 0,1,0,print "in sub foo\n"; 0,1,0,foreach (1 .. 10) { 0,10,0,noop(); 0,10,0,foreach (1 .. 10) { 0,100,0,noop(); 0,0,0,} 0,0,0,} 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,1,0,print "in sub bar\n"; 0,1,0,my ($x, $y); 0,1,0,while (10 > $x++) { 0,10,0,$y = 0; 0,10,0,while (10 > $y++) { 0,100,0,noop(); 0,0,0,} 0,0,0,} 0,0,0,} 0,0,0, 0,0,0,sub baz { 0,1,0,print "in sub baz\n"; 0,1,0,my ($x, $y) = (1); 0,1,0,do { 0,10,0,$y = 1; 0,10,0,do { 0,100,0,noop(); 0,100,0,noop(); 0,0,0,} while(10 > $y++); 0,0,0,} while(10 > $x++); 0,0,0,} 0,0,0, 0,1,0,foo(); 0,1,0,bar(); 0,1,0,baz(); Devel-NYTProf-6.06/t/test08.x000644 000766 000024 00000000273 12533402722 016046 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,1,0,eval "shift; 0,0,0,shift;"; Devel-NYTProf-6.06/t/test24-strevalc.rdt000644 000766 000024 00000004725 12405402474 020217 0ustar00timbostaff000000 000000 attribute application test24-strevalc.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 1 ] fid_block_time 1 7 [ 0 1 ] fid_block_time 1 8 [ 0 6 ] fid_block_time 2 1 [ 0 1 ] fid_block_time 4 1 [ 0 1 ] fid_block_time 5 1 [ 0 1 ] fid_block_time 6 1 [ 0 1 ] fid_block_time 7 1 [ 0 1 ] fid_block_time 8 1 [ 0 2 ] fid_fileinfo 1 [ test24-strevalc.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 eval 8 [ count 4 nested 2 merged 2 ] fid_fileinfo 2 [ (eval 1)[test24-strevalc.p:8] 1 8 2 2 0 0 ] fid_fileinfo 4 [ (eval 3)[test24-strevalc.p:8] 1 8 4 2 0 0 ] fid_fileinfo 4 eval 1 [ count 1 nested 0 merged 0 ] fid_fileinfo 5 [ (eval 4)[(eval 3)[test24-strevalc.p:8]:1] 4 1 5 2 0 0 ] fid_fileinfo 6 [ (eval 5)[test24-strevalc.p:8] 1 8 6 2 0 0 ] fid_fileinfo 6 eval 1 [ count 1 nested 0 merged 0 ] fid_fileinfo 7 [ (eval 6)[(eval 5)[test24-strevalc.p:8]:1] 6 1 7 2 0 0 ] fid_fileinfo 8 [ (eval 7)[test24-strevalc.p:8] 1 8 8 2 0 0 ] fid_fileinfo 8 sub main::__ANON__[(eval 7)[test24-strevalc.p:8]:1] 1-1 fid_fileinfo 8 call 1 main::__ANON__[(eval 7)[test24-strevalc.p:8]:1] [ 2 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 1 ] fid_line_time 1 7 [ 0 1 ] fid_line_time 1 8 [ 0 6 ] fid_line_time 2 1 [ 0 2 ] fid_line_time 4 1 [ 0 1 ] fid_line_time 5 1 [ 0 1 ] fid_line_time 6 1 [ 0 1 ] fid_line_time 7 1 [ 0 1 ] fid_line_time 8 1 [ 0 4 ] fid_sub_time 1 2 [ 0 1 ] fid_sub_time 1 7 [ 0 1 ] fid_sub_time 1 8 [ 0 6 ] fid_sub_time 2 1 [ 0 1 ] fid_sub_time 4 1 [ 0 1 ] fid_sub_time 5 1 [ 0 1 ] fid_sub_time 6 1 [ 0 1 ] fid_sub_time 7 1 [ 0 1 ] fid_sub_time 8 1 [ 0 2 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 7)[test24-strevalc.p:8]:1] [ 8:1-1 calls 2 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 7)[test24-strevalc.p:8]:1] called_by 8:1 [ 2 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 7)[test24-strevalc.p:8]:1] merge_donor main::__ANON__[(eval 8)[test24-strevalc.p:8]:1] Devel-NYTProf-6.06/t/test40pmc.t000644 000766 000024 00000000547 12506067531 016547 0ustar00timbostaff000000 000000 use strict; use Test::More; use Config; my $no_pmc; if (Config->can('non_bincompat_options')) { foreach(Config::non_bincompat_options()) { if($_ eq "PERL_DISABLE_PMC"){ $no_pmc = 1; last; } } }; plan skip_all => ".pmc are disabled in this perl" if $no_pmc; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test80-recurs.t000644 000766 000024 00000000121 12067023751 017336 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test02.x000644 000766 000024 00000000676 12533402722 016047 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,sub foo { 0,2,0,print "in sub foo\n"; 0,2,0,bar(); 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,7,0,print "in sub bar\n"; 0,0,0,} 0,0,0, 0,0,0,sub baz { 0,1,0,print "in sub baz\n"; 0,1,0,bar(); 0,1,0,bar(); 0,1,0,bar(); 0,1,0,foo(); 0,0,0,} 0,0,0, 0,1,0,bar(); 0,1,0,bar(); 0,1,0,baz(); 0,1,0,foo(); Devel-NYTProf-6.06/t/zzz.t000644 000766 000024 00000000357 12067023751 015556 0ustar00timbostaff000000 000000 use Test::More qw(no_plan); pass(); # we note the time in the test log here (the first test) and in t/zzz.t # so we can judge how fast the set of tests ran and this the rough speed of the system diag("Tests ended at ". localtime(time)); Devel-NYTProf-6.06/t/test06.p000644 000766 000024 00000001114 12067023751 016032 0ustar00timbostaff000000 000000 # tests loops. noop is a hack for perl>5.6 where # the closing "}" of a loop counts as being executed if loop is empty. my $_z; sub noop { $_z++; } sub foo { print "in sub foo\n"; foreach (1 .. 10) { noop(); foreach (1 .. 10) { noop(); } } } sub bar { print "in sub bar\n"; my ($x, $y); while (10 > $x++) { $y = 0; while (10 > $y++) { noop(); } } } sub baz { print "in sub baz\n"; my ($x, $y) = (1); do { $y = 1; do { noop(); noop(); } while(10 > $y++); } while(10 > $x++); } foo(); bar(); baz(); Devel-NYTProf-6.06/t/test22-strevala.calls000644 000766 000024 00000000571 12130047577 020517 0ustar00timbostaff000000 000000 main::__ANON__[(eval 0)[test22-strevala.p:6]:2] 1 main::__ANON__[(eval 0)[test22-strevala.p:6]:2];main::CORE:print 1 main::__ANON__[(eval 0)[test22-strevala.p:9]:2] 2 main::__ANON__[(eval 0)[test22-strevala.p:9]:2];main::CORE:print 2 main::__ANON__[(eval 0)[(eval 0)[test22-strevala.p:12]:2]:2] 2 main::__ANON__[(eval 0)[(eval 0)[test22-strevala.p:12]:2]:2];main::CORE:print 2 Devel-NYTProf-6.06/t/test51-enable.t000644 000766 000024 00000002344 12067023751 017270 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group({ extra_test_count => 3, extra_test_code => sub { my ($profile, $env) = @_; is_deeply(sub_calls($profile), { 'main::sub1' => 1, 'DB::disable_profile' => 1, 'main::CORE:unlink' => 1, }); my $file_b = "nytprof-test51-b.out"; my $file_c = "nytprof-test51-c.out"; my $pb = Devel::NYTProf::Data->new( { filename => $file_b, quiet => 0 } ); is_deeply(sub_calls($pb), { 'main::sub1' => 1, 'main::sub3' => 1, 'DB::disable_profile' => 1, 'main::CORE:unlink' => 1, }, "$file_b sub calls"); my $pc = Devel::NYTProf::Data->new( { filename => $file_c, quiet => 0 } ); is_deeply(sub_calls($pc), { 'main::sub7' => 1, 'DB::finish_profile' => 1, }, "$file_c sub calls"); }, }); sub sub_calls { my ($profile) = @_; my %sub_calls; for my $si (values %{ $profile->subname_subinfo_map }) { my $calls = $si->calls or next; $sub_calls{ $si->subname } = $calls; } print "sub_calls: { @{[ %sub_calls ]} }\n"; return \%sub_calls; } Devel-NYTProf-6.06/t/test80-recurs.calls000644 000766 000024 00000000341 12130047577 020200 0ustar00timbostaff000000 000000 main::recurs 1 main::recurs;main::CORE:sselect 1 main::recurs;main::recurs 1 main::recurs;main::recurs;main::CORE:sselect 1 main::recurs;main::recurs;main::recurs 1 main::recurs;main::recurs;main::recurs;main::CORE:sselect 1 Devel-NYTProf-6.06/t/31-env.t000644 000766 000024 00000002154 12067023751 015727 0ustar00timbostaff000000 000000 use Test::More; require XSLoader; # Disable "once" warnings BEGIN { my $ok = eval { require warnings; 1 }; if ( $ok ) { warnings->unimport( qw( once redefine ) ); } else { $^W = 0; } } my @tests = ( [ 'start=no:file=nytprof.out' => { start => 'no', file => 'nytprof.out' } ], [ 'start=no:file=nytprof\:out' => { start => 'no', file => 'nytprof:out' } ], [ 'start=no:file=nytprof\=out' => { start => 'no', file => 'nytprof=out' } ], ); plan( tests => 1 * @tests ); for my $test ( @tests ) { my ( $nytprof, $expected ) = @$test; # Abrogate the XSLoader used to load the XS function DB::set_option. local *XSLoader::load = sub {}; # Hook the function used to set options to capture it's parsing. my %got; local *DB::set_option = sub { my ( $k, $v ) = @_; $got{$k} = $v; }; # (pretend to) Unload the class. delete $INC{'Devel/NYTProf/Core.pm'}; # Test the class's parsing. local $ENV{NYTPROF} = $nytprof; require Devel::NYTProf::Core; is_deeply( \%got, $expected, "Parsed \$ENV{NYTPROF}='$nytprof' ok" ); } Devel-NYTProf-6.06/t/test23-strevall.p000644 000766 000024 00000000724 12067023751 017671 0ustar00timbostaff000000 000000 # test handling of string eval 'file names' that don't include the # invoking filename (normally added when $^P & 0x100 is true). shift; # fake an eval (using a #line directive) that doesn't match the # usual "(eval N)[file:line]" syntax: #line 42 "(eval 142)" # [stats for the line below won't appear in reports because as far as perl is # concerned the rest of this file isn't actually part of this file, but is # actually part of a file called "(eval 142)"] 242; Devel-NYTProf-6.06/t/test20-streval.calls000644 000766 000024 00000000051 12130047577 020345 0ustar00timbostaff000000 000000 main::foo 4 main::foo;main::CORE:print 4 Devel-NYTProf-6.06/t/test62-subcaller1.p000644 000766 000024 00000001465 12471702034 020075 0ustar00timbostaff000000 000000 # test determination of subroutine caller in unusual cases # test dying from an xsub require Devel::NYTProf::Test; eval { Devel::NYTProf::Test::example_xsub(0, "die") }; # test dying from an xsub where the surrounding eval is an # argument to a sub call. This used to coredump. sub sub1 { $_[0] } sub1 eval { Devel::NYTProf::Test::example_xsub(0, "die") }; # test sub calls (xs and perl) from within a sort block sub sub2 { $_[0] } # sort block on one line due to change to line numbering in perl 5.21 my @a = sort { Devel::NYTProf::Test::example_xsub(); sub2($a) <=> sub2($b); } (1,3,2); # test sub call as a sort block sub sub3 { $_[0] } # XXX not recorded due to limitation of perl my @b = sort \&sub3, 3, 1, 2; # test sub call from a subst sub sub4 { $_[0] } my $a = "abcbd"; $a =~ s/b/sub4(uc($1))/ge; exit 0; Devel-NYTProf-6.06/t/test12.x000644 000766 000024 00000000256 12533402722 016042 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,1,0,do 'test12.pl'; Devel-NYTProf-6.06/t/test22-strevala.rdt000644 000766 000024 00000010655 12405402474 020212 0ustar00timbostaff000000 000000 attribute application test22-strevala.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 3 [ 0 1 ] fid_block_time 1 6 [ 0 1 ] fid_block_time 1 9 [ 0 2 ] fid_block_time 1 12 [ 0 1 ] fid_block_time 2 1 [ 0 1 ] fid_block_time 2 2 [ 0 1 ] fid_block_time 3 1 [ 0 1 ] fid_block_time 3 2 [ 0 1 ] fid_block_time 5 2 [ 0 2 ] fid_block_time 6 1 [ 0 1 ] fid_block_time 6 2 [ 0 1 ] fid_fileinfo 1 [ test22-strevala.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 call 6 main::__ANON__[(eval 1)[test22-strevala.p:6]:2] [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 call 9 main::__ANON__[(eval 2)[test22-strevala.p:9]:2] [ 2 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 6 [ count 1 nested 0 merged 0 ] fid_fileinfo 1 eval 9 [ count 1 nested 0 merged 1 ] fid_fileinfo 1 eval 12 [ count 1 nested 1 merged 0 ] fid_fileinfo 2 [ (eval 1)[test22-strevala.p:6] 1 6 2 2 0 0 ] fid_fileinfo 2 sub main::__ANON__[(eval 1)[test22-strevala.p:6]:2] 1-2 fid_fileinfo 2 call 1 main::CORE:print [ 1 0 0 0 0 0 0 main::__ANON__[(eval 1)[test22-strevala.p:6]:2] ] fid_fileinfo 3 [ (eval 2)[test22-strevala.p:9] 1 9 3 2 0 0 ] fid_fileinfo 3 sub main::__ANON__[(eval 2)[test22-strevala.p:9]:2] 1-2 fid_fileinfo 3 call 1 main::CORE:print [ 2 0 0 0 0 0 0 main::__ANON__[(eval 2)[test22-strevala.p:9]:2]|main::__ANON__[(eval 3)[test22-strevala.p:9]:2] ] fid_fileinfo 5 [ (eval 4)[test22-strevala.p:12] 1 12 5 2 0 0 ] fid_fileinfo 5 call 2 main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2] [ 2 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 5 eval 2 [ count 1 nested 0 merged 1 ] fid_fileinfo 6 [ (eval 5)[(eval 4)[test22-strevala.p:12]:2] 5 2 6 2 0 0 ] fid_fileinfo 6 sub main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2] 1-2 fid_fileinfo 6 call 1 main::CORE:print [ 2 0 0 0 0 0 0 main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2]|main::__ANON__[(eval 6)[(eval 4)[test22-strevala.p:12]:2]:2] ] fid_line_time 1 3 [ 0 1 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 1 9 [ 0 2 ] fid_line_time 1 12 [ 0 1 ] fid_line_time 2 1 [ 0 1 ] fid_line_time 2 2 [ 0 1 ] fid_line_time 3 1 [ 0 2 ] fid_line_time 3 2 [ 0 2 ] fid_line_time 5 2 [ 0 2 ] fid_line_time 6 1 [ 0 2 ] fid_line_time 6 2 [ 0 2 ] fid_sub_time 1 3 [ 0 1 ] fid_sub_time 1 6 [ 0 1 ] fid_sub_time 1 9 [ 0 2 ] fid_sub_time 1 12 [ 0 1 ] fid_sub_time 2 1 [ 0 1 ] fid_sub_time 2 2 [ 0 1 ] fid_sub_time 3 1 [ 0 1 ] fid_sub_time 3 2 [ 0 1 ] fid_sub_time 5 2 [ 0 2 ] fid_sub_time 6 1 [ 0 1 ] fid_sub_time 6 2 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 5 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 2:1 [ 1 0 0 0 0 0 0 main::__ANON__[(eval 1)[test22-strevala.p:6]:2] ] sub_subinfo main::CORE:print called_by 3:1 [ 2 0 0 0 0 0 0 main::__ANON__[(eval 2)[test22-strevala.p:9]:2]|main::__ANON__[(eval 3)[test22-strevala.p:9]:2] ] sub_subinfo main::CORE:print called_by 6:1 [ 2 0 0 0 0 0 0 main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2]|main::__ANON__[(eval 6)[(eval 4)[test22-strevala.p:12]:2]:2] ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 1)[test22-strevala.p:6]:2] [ 2:1-2 calls 1 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 1)[test22-strevala.p:6]:2] called_by 1:6 [ 1 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 2)[test22-strevala.p:9]:2] [ 3:1-2 calls 2 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 2)[test22-strevala.p:9]:2] called_by 1:9 [ 2 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 2)[test22-strevala.p:9]:2] merge_donor main::__ANON__[(eval 3)[test22-strevala.p:9]:2] sub_subinfo main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2] [ 6:1-2 calls 2 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2] called_by 5:2 [ 2 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 5)[(eval 4)[test22-strevala.p:12]:2]:2] merge_donor main::__ANON__[(eval 6)[(eval 4)[test22-strevala.p:12]:2]:2] Devel-NYTProf-6.06/t/test16.p000644 000766 000024 00000001050 13222220743 016024 0ustar00timbostaff000000 000000 # tests given/when. Can only be tested by Perl 5.10 or later. use warnings; use strict; use feature ":5.10"; no if "$]" >= 5.018, warnings => "experimental"; sub foo { my $whameth = shift; given ($whameth) { when(/\d/) { say "number-like"; } when(/\w/) { say "word-like"; } } } sub bar { my $zlott = shift; if($zlott =~ /\d/) { print "number-like\n"; } elsif($zlott =~ /\w/) { print "word-like\n"; } } foo("baz"); foo(17); bar("baz"); bar(17); Devel-NYTProf-6.06/t/22-readstream.t000644 000766 000024 00000005075 12405402474 017272 0ustar00timbostaff000000 000000 use Test::More; use strict; use Config; use Data::Dumper; use lib qw(t/lib); use NYTProfTest; use Devel::NYTProf::ReadStream qw(for_chunks); my $pre589 = ($] < 5.008009 or $] eq "5.010000"); (my $base = __FILE__) =~ s/\.t$//; # generate an nytprof out file my $out = 'nytprof_readstream.out'; $ENV{NYTPROF} = "calls=2:blocks=1:file=$out"; unlink $out; run_perl_command(qq{-d:NYTProf -e "sub A { };" -e "1;" -e "A() $Devel::NYTProf::StrEvalTestPad"}); my %prof; my @seqn; for_chunks { push @seqn, "$."; my $tag = shift; push @{ $prof{$tag} }, [ @_ ]; if (1) { my @params = @_; not defined $_ and $_ = '(undef)' for @params; chomp @params; print "# $. $tag @params\n"; } } filename => $out; my %option = map { @$_ } @{$prof{OPTION}}; cmp_ok scalar keys %option, '>=', 17, 'enough options'; #diag Dumper(\%option); my %attribute = map { @$_ } @{$prof{ATTRIBUTE}}; cmp_ok scalar keys %attribute, '>=', 9, 'enough attribute'; #diag Dumper(\%attribute); ok scalar @seqn, 'should have read chunks'; is_deeply(\@seqn, [0..@seqn-1], "chunk seq"); #use Data::Dumper; warn Dumper \%prof; is_deeply $prof{VERSION}, [ [ 5, 0 ] ]; # check for expected tags # but not START_DEFLATE as that'll be missing if there's no zlib # and not SRC_LINE as old perl's my @expected_tags = qw( COMMENT ATTRIBUTE OPTION DISCOUNT SUB_INFO SUB_CALLERS PID_START PID_END NEW_FID SUB_ENTRY SUB_RETURN ); push @expected_tags, 'TIME_BLOCK' if $option{calls}; for my $tag (@expected_tags) { is ref $prof{$tag}[0], 'ARRAY', "raw $tag array seen" or diag Dumper $prof{$tag}; } SKIP: { skip 'needs perl >= 5.8.9 or >= 5.10.1', 1 if $pre589; is ref $prof{SRC_LINE}[0], 'ARRAY', 'SRC_LINE'; } # check some attributes my %attr = map { $_->[0] => $_->[1] } @{ $prof{ATTRIBUTE} }; cmp_ok $attr{ticks_per_sec}, '>=', 1_000_000, 'ticks_per_sec'; is $attr{application}, '-e', 'application'; is $attr{nv_size}, $Config{nvsize}, 'nv_size'; cmp_ok $attr{xs_version}, '>=', 2.1, 'xs_version'; cmp_ok $attr{basetime}, '>=', $^T, 'basetime'; my @sub_info_sorted = sort { $a->[3] cmp $b->[3] } @{$prof{SUB_INFO}}; is_deeply \@sub_info_sorted, [ [1, 1, 1, "main::A"], [1, 0, 0, "main::BEGIN"], [1, 1, 1, "main::RUNTIME"], ]; $prof{SUB_CALLERS}[0][$_] = 0 for (3,4); is_deeply $prof{SUB_CALLERS}, [ [ 1, 3, 1, 0, 0, '0', 0, 'main::A', 'main::RUNTIME' ] ]; is_deeply $prof{SUB_ENTRY}, [ [ 1, 3 ] ], 'SUB_ENTRY args'; $prof{SUB_RETURN}[0][$_] = 0 for (1,2); is_deeply $prof{SUB_RETURN}, [ [ 1, 0, 0, 'main::A' ] ], 'SUB_RETURN args'; done_testing(); Devel-NYTProf-6.06/t/test62-tie-b.p000644 000766 000024 00000000526 12471711316 017040 0ustar00timbostaff000000 000000 # test determination of subroutine caller in tie calls { # calls to TIESCALAR aren't seen by perl < 5.8.9 and 5.10.1 sub MyTie::TIESCALAR { bless {}, shift; } sub MyTie::FETCH { } sub MyTie::STORE { } } tie my $tied, 'MyTie', 42; # TIESCALAR $tied = 1; # STORE if ($tied) { 1 } # FETCH exit 0; Devel-NYTProf-6.06/t/test02.pf000644 000766 000024 00000000424 12471557774 016217 0ustar00timbostaff000000 000000 Name, File location, Time, Avg. Time, Own Time, Invocation Count, Level main::CORE:print, [^,]+?, \d+.\d+, 0.000, \d+.\d+, 10, 0 main::bar, [^,]+?, \d+.\d+, 0.000, \d+.\d+, 7, 0 main::baz, [^,]+?, \d+.\d+, 0.000, \d+.\d+, 1, 0 main::foo, [^,]+?, \d+.\d+, 0.000, \d+.\d+, 2, 0 Devel-NYTProf-6.06/t/test70-subexcl.t000644 000766 000024 00000000121 12067023751 017477 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test24-strevalc.calls000644 000766 000024 00000000062 12130047577 020516 0ustar00timbostaff000000 000000 main::__ANON__[(eval 0)[test24-strevalc.p:8]:1] 2 Devel-NYTProf-6.06/t/test13.calls000644 000766 000024 00000000314 12130047577 016673 0ustar00timbostaff000000 000000 main::foo 1 main::foo;main::CORE:print 1 main::bar 1 main::bar;main::CORE:print 1 main::baz 1 main::baz;main::CORE:print 1 main::baz;main::foo 2 main::baz;main::foo;main::CORE:print 2 main::baz;main::x 1 Devel-NYTProf-6.06/t/90-pod.t000644 000766 000024 00000000221 12067023751 015717 0ustar00timbostaff000000 000000 #!perl -w use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); 1; Devel-NYTProf-6.06/t/test61-submerge.p000644 000766 000024 00000000361 12130047577 017650 0ustar00timbostaff000000 000000 # test merging of sub info and sub callers # which is applied to, e.g., anon subs inside evals sub foo { print "foo @_\n" } my $code = qq{ sub { foo() } $Devel::NYTProf::StrEvalTestPad}; eval($code)->(); eval($code)->(); eval($code)->(); Devel-NYTProf-6.06/t/test14.t000644 000766 000024 00000000314 12130047577 016041 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; # hack to disable sawampersand test, just to simplify the testing across versions $ENV{DISABLE_NYTPROF_SAWAMPERSAND} = 1; run_test_group; Devel-NYTProf-6.06/t/test11.calls000644 000766 000024 00000000051 12130047577 016667 0ustar00timbostaff000000 000000 main::__ANON__[(eval 0)[test11.p:3]:1] 2 Devel-NYTProf-6.06/t/test61-submerge.rdt000644 000766 000024 00000004744 12405402474 020207 0ustar00timbostaff000000 000000 attribute application test61-submerge.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 4 [ 0 3 ] fid_block_time 1 6 [ 0 1 ] fid_block_time 1 8 [ 0 3 ] fid_block_time 2 1 [ 0 2 ] fid_fileinfo 1 [ test61-submerge.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:print 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::foo 4-4 fid_fileinfo 1 call 4 main::CORE:print [ 3 0 0 0 0 0 0 main::foo ] fid_fileinfo 1 call 8 main::__ANON__[(eval 1)[test61-submerge.p:8]:1] [ 3 0 0 0 0 0 0 main::RUNTIME ] fid_fileinfo 1 eval 8 [ count 1 nested 0 merged 2 ] fid_fileinfo 2 [ (eval 1)[test61-submerge.p:8] 1 8 2 2 0 0 ] fid_fileinfo 2 sub main::__ANON__[(eval 1)[test61-submerge.p:8]:1] 1-1 fid_fileinfo 2 call 1 main::foo [ 3 0 0 0 0 0 0 main::__ANON__[(eval 1)[test61-submerge.p:8]:1]|main::__ANON__[(eval 2)[test61-submerge.p:8]:1]|main::__ANON__[(eval 3)[test61-submerge.p:8]:1] ] fid_line_time 1 4 [ 0 3 ] fid_line_time 1 6 [ 0 1 ] fid_line_time 1 8 [ 0 3 ] fid_line_time 2 1 [ 0 6 ] fid_sub_time 1 4 [ 0 3 ] fid_sub_time 1 6 [ 0 1 ] fid_sub_time 1 8 [ 0 3 ] fid_sub_time 2 1 [ 0 2 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:print [ 1:0-0 calls 3 times 0 0 0 0 ] sub_subinfo main::CORE:print called_by 1:4 [ 3 0 0 0 0 0 0 main::foo ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 1)[test61-submerge.p:8]:1] [ 2:1-1 calls 3 times 0 0 0 0 ] sub_subinfo main::__ANON__[(eval 1)[test61-submerge.p:8]:1] called_by 1:8 [ 3 0 0 0 0 0 0 main::RUNTIME ] sub_subinfo main::__ANON__[(eval 1)[test61-submerge.p:8]:1] merge_donor main::__ANON__[(eval 2)[test61-submerge.p:8]:1] sub_subinfo main::__ANON__[(eval 1)[test61-submerge.p:8]:1] merge_donor main::__ANON__[(eval 3)[test61-submerge.p:8]:1] sub_subinfo main::foo [ 1:4-4 calls 3 times 0 0 0 0 ] sub_subinfo main::foo called_by 2:1 [ 3 0 0 0 0 0 0 main::__ANON__[(eval 1)[test61-submerge.p:8]:1]|main::__ANON__[(eval 2)[test61-submerge.p:8]:1]|main::__ANON__[(eval 3)[test61-submerge.p:8]:1] ] Devel-NYTProf-6.06/t/test10.t000644 000766 000024 00000000121 12067023751 016026 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; run_test_group; Devel-NYTProf-6.06/t/test18-goto2.p000644 000766 000024 00000000636 12067023751 017075 0ustar00timbostaff000000 000000 # Test Carp::Heavy's "swap subs out from under you with goto &sub" use lib 't'; package Test18; sub longmess { goto &longmess_jmp } sub longmess_jmp { # the required file deletes this longmess_jmp sub, while it's executing, # and replaces it with longmess_real, which we then goto into! require 'test18-goto2.pm'; # has to be require, not eval '...' goto &longmess_real; } longmess("Oops"); Devel-NYTProf-6.06/t/test20-streval.t000644 000766 000024 00000003272 12067023751 017517 0ustar00timbostaff000000 000000 use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Devel::NYTProf::Constants qw(NYTP_SCi_elements); run_test_group( { extra_test_count => 8 + (3 * 6), extra_test_code => sub { my ($profile, $env) = @_; # check sub callers from sub perspective my $subs = $profile->subname_subinfo_map; my $si = $subs->{'main::foo'}; ok $si; is $si->calls, 4; my $called_by_subnames = $si->called_by_subnames; ok $called_by_subnames; is_deeply [ keys %$called_by_subnames ], [ 'main::RUNTIME' ], 'should be called from only from main::RUNTIME'; my $callers = $si->caller_fid_line_places; ok $callers; #warn Data::Dumper::Dumper($callers); # two calls from evals on same line get collapsed my @fids = keys %$callers; is @fids, 3, 'should be called from 3 files'; is_deeply [ map { keys %$_ } values %$callers ], [ 1, 1, 1 ], 'should all be called from line 1'; my @sc = map { values %$_ } values %$callers; is_deeply [ map { scalar @$_ } @sc ], [ (NYTP_SCi_elements()) x 3], 'all sub calls infos should have all elements'; # check sub callers from file perspective for my $fid (@fids) { ok my $fi = $profile->fileinfo_of($fid); ok my $sub_call_lines = $fi->sub_call_lines; #warn Data::Dumper::Dumper($sub_call_lines); is keys %$sub_call_lines, 1; is keys %{$sub_call_lines->{1}}, 1; ok my $sc = $sub_call_lines->{1}{'main::foo'}; is @$sc, NYTP_SCi_elements(), 'si should have all elements'; } }, } ); Devel-NYTProf-6.06/t/test12.p000644 000766 000024 00000000020 12067023751 016022 0ustar00timbostaff000000 000000 do 'test12.pl'; Devel-NYTProf-6.06/t/test82-version.t000644 000766 000024 00000001634 12067023751 017534 0ustar00timbostaff000000 000000 # Tests interaction with UNIVERSAL::VERSION (RT#54600) use strict; use Test::More; use lib qw(t/lib); use NYTProfTest; use Data::Dumper; use Devel::NYTProf::Run qw(profile_this); my $src_code = join("", ); run_test_group( { extra_options => { start => 'begin', compress => 1, leave => 0, stmts => 0, slowops => 0, }, extra_test_count => 2, extra_test_code => sub { my ($profile, $env) = @_; $profile = profile_this( src_code => $src_code, out_file => $env->{file}, skip_sitecustomize => 1, ); isa_ok $profile, 'Devel::NYTProf::Data'; # check if data was truncated ok $profile->{attribute}{complete}; }, }); __DATA__ #!perl -w { package X; sub warner { print "# Hello world\n" } sub DESTROY { goto \&warner; } } my $a = bless [], 'X'; undef $a; Devel-NYTProf-6.06/t/test16.x000644 000766 000024 00000001450 13222220743 016040 0ustar00timbostaff000000 000000 # Profile data generated by Devel::NYTProf::Reader # More information at http://metacpan.org/release/Devel-NYTProf/ # Format: time,calls,time/call,code 0,0,0,# tests given/when. Can only be tested by Perl 5.10 or later. 0,0,0, 0,0,0,use warnings; 0,0,0,use strict; 0,0,0, 0,0,0,use feature ":5.10"; 0,0,0,no if "$]" >= 5.018, warnings => "experimental"; 0,0,0, 0,0,0,sub foo { 0,2,0,my $whameth = shift; 0,2,0,given ($whameth) { 0,2,0,when(/\d/) { 0,0,0,say "number-like"; 0,0,0,} 0,1,0,when(/\w/) { 0,0,0,say "word-like"; 0,0,0,} 0,0,0,} 0,0,0,} 0,0,0, 0,0,0,sub bar { 0,2,0,my $zlott = shift; 0,2,0,if($zlott =~ /\d/) { 0,0,0,print "number-like\n"; 0,0,0,} elsif($zlott =~ /\w/) { 0,0,0,print "word-like\n"; 0,0,0,} 0,0,0,} 0,0,0, 0,0,0, 0,1,0,foo("baz"); 0,1,0,foo(17); 0,1,0,bar("baz"); 0,1,0,bar(17); Devel-NYTProf-6.06/t/test80-recurs.rdt000644 000766 000024 00000003102 12114475222 017663 0ustar00timbostaff000000 000000 attribute application test80-recurs.p attribute basetime 0 attribute clock_id 0 attribute complete 1 attribute nv_size 0 attribute perl_version 0 attribute profiler_active 0 attribute profiler_duration 0 attribute profiler_end_time 0 attribute profiler_start_time 0 attribute ticks_per_sec 0 attribute total_stmts_discounted 0 attribute total_stmts_duration 0 attribute total_stmts_measured 0 attribute total_sub_calls 0 attribute xs_version 0 fid_block_time 1 2 [ 0 9 ] fid_block_time 1 7 [ 0 1 ] fid_fileinfo 1 [ test80-recurs.p 1 2 0 0 ] fid_fileinfo 1 sub main::BEGIN 0-0 fid_fileinfo 1 sub main::CORE:sselect 0-0 fid_fileinfo 1 sub main::RUNTIME 1-1 fid_fileinfo 1 sub main::recurs 1-5 fid_fileinfo 1 call 3 main::CORE:sselect [ 3 0 0 0 0 0 0 main::recurs ] fid_fileinfo 1 call 4 main::recurs [ 2 0 0 0 0 0 2 main::recurs ] fid_fileinfo 1 call 7 main::recurs [ 1 0 0 0 0 0 0 main::RUNTIME ] fid_line_time 1 2 [ 0 3 ] fid_line_time 1 3 [ 0 3 ] fid_line_time 1 4 [ 0 3 ] fid_line_time 1 7 [ 0 1 ] fid_sub_time 1 2 [ 0 9 ] fid_sub_time 1 7 [ 0 1 ] profile_modes fid_block_time block profile_modes fid_line_time line profile_modes fid_sub_time sub sub_subinfo main::BEGIN [ 1:0-0 calls 0 times 0 0 0 0 ] sub_subinfo main::CORE:sselect [ 1:0-0 calls 3 times 0 0 0 0 ] sub_subinfo main::CORE:sselect called_by 1:3 [ 3 0 0 0 0 0 0 main::recurs ] sub_subinfo main::RUNTIME [ 1:1-1 calls 0 times 0 0 0 0 ] sub_subinfo main::recurs [ 1:1-5 calls 3 times 0 0 2 0 ] sub_subinfo main::recurs called_by 1:4 [ 2 0 0 0 0 0 2 main::recurs ] sub_subinfo main::recurs called_by 1:7 [ 1 0 0 0 0 0 0 main::RUNTIME ] Devel-NYTProf-6.06/t/test08.calls000644 000766 000024 00000000000 12130047577 016667 0ustar00timbostaff000000 000000 Devel-NYTProf-6.06/t/lib/NYTProfTest.pm000644 000766 000024 00000060007 13305236420 017772 0ustar00timbostaff000000 000000 package NYTProfTest; use strict; use warnings; use Carp; use Config; use ExtUtils::testlib; use Getopt::Long; use Test::More; use Data::Dumper; use File::Spec; use File::Temp qw(tempfile); use List::Util qw(shuffle); use base qw(Exporter); our @EXPORT = qw( run_test_group run_command run_perl_command ); use Devel::NYTProf::Data; use Devel::NYTProf::Reader; use Devel::NYTProf::Util qw(strip_prefix_from_paths html_safe_filename); use Devel::NYTProf::Run qw(perl_command_words); my $diff_opts = ($Config{osname} eq 'MSWin32') ? '-c' : '-u'; eval { require BSD::Resource } if $ENV{NYTPROF_TEST_RUSAGE}; # experimental my %opts = ( one => $ENV{NYTPROF_TEST_ONE}, profperlopts => $ENV{NYTPROF_TEST_PROFPERLOPTS} || '-d:NYTProf', html => $ENV{NYTPROF_TEST_HTML}, mergerdt => $ENV{NYTPROF_TEST_MERGERDT}, # overkill, but handy ); GetOptions(\%opts, qw/p=s I=s v|verbose d|debug html open profperlopts=s blocks=i leave=i use_db_sub=i savesrc=i compress=i one abort/) or exit 1; $opts{v} ||= $opts{d}; $opts{html} ||= $opts{open}; # note some env vars that might impact the tests $ENV{$_} && warn "$_='$ENV{$_}'\n" for qw(PERL5DB PERL5OPT PERL_UNICODE PERLIO); if ($ENV{NYTPROF}) { # avoid external interference warn "Existing NYTPROF env var value ($ENV{NYTPROF}) ignored for tests. Use NYTPROF_TEST env var if need be.\n"; $ENV{NYTPROF} = ''; } # options the user wants to override when running tests my %NYTPROF_TEST = map { split /=/, $_, 2 } split /:/, $ENV{NYTPROF_TEST} || ''; # set some NYTProf options for this process in case 'extra tests' call # Devel::NYTProf::Data methods directly. This is a hack because the options # are global and there's no way to discover defaults or restore previous values. # So we just do trace for now. for my $opt (qw(trace)) { DB::set_option($opt, $NYTPROF_TEST{$opt}) if defined $NYTPROF_TEST{$opt}; } my $text_extn_info = { p => { order => 10, tests => 1, }, rdt => { order => 20, tests => ($opts{mergerdt}) ? 2 : 1, }, x => { order => 30, tests => 3, }, calls => { order => 40, tests => 1, }, pf => { order => 50, tests => 2, }, }; # having t/* in @INC is necessary for prefix-stripping # to reduce test-file names down to the single tokens # that are used in the comparison-output files. unshift @INC, File::Spec->rel2abs('./t') if -d 't'; chdir('t') if -d 't'; if (-d '../blib') { unshift @INC, '../blib/arch', '../blib/lib'; } my $bindir = (grep {-d} qw(./blib/script ../blib/script))[0] || do { my $bin = (grep {-d} qw(./bin ../bin))[0] or die "Can't find scripts"; warn "Couldn't find blib/script directory, so using $bin"; $bin; }; my $nytprofcsv = File::Spec->catfile($bindir, "nytprofcsv"); my $nytprofcalls = File::Spec->catfile($bindir, "nytprofcalls"); my $nytprofhtml = File::Spec->catfile($bindir, "nytprofhtml"); my $nytprofpf = File::Spec->catfile($bindir, "nytprofpf"); my $nytprofmerge = File::Spec->catfile($bindir, "nytprofmerge"); my $path_sep = $Config{path_sep} || ':'; my $perl5lib = $opts{I} || join($path_sep, @INC); my $perl = $opts{p} || $^X; # turn ./perl into ../perl, because of chdir(t) above. $perl = ".$perl" if $perl =~ m|^\./|; $perl = qq{"$perl"}; # in case it has spaces if ($opts{one}) { # for one quick test $opts{leave} = 1; $opts{use_db_sub} = 0; $opts{savesrc} = 1; $opts{compress} = 1; $opts{calls} = 2; $opts{blocks} = 1; } # force savesrc off for perl 5.11.2 due to perl bug RT#70804 $opts{savesrc} = 0 if $] eq "5.011002"; my @test_opt_blocks = (defined $opts{blocks}) ? ($opts{blocks}) : (1); my @test_opt_leave = (defined $opts{leave}) ? ($opts{leave}) : (0, 1); my @test_opt_use_db_sub = (defined $opts{use_db_sub}) ? ($opts{use_db_sub}) : (0, 1); my @test_opt_savesrc = (defined $opts{savesrc}) ? ($opts{savesrc}) : (0, 1); my @test_opt_compress = (defined $opts{compress}) ? ($opts{compress}) : (0, 1); my @test_opt_calls = (defined $opts{calls}) ? ($opts{calls}) : (0, 1, 2); sub mk_opt_combinations { my ($overrides) = @_; my @opt_combinations; my %seen; for my $blocks (@test_opt_blocks) { for my $leave (@test_opt_leave) { for my $use_db_sub (@test_opt_use_db_sub) { for my $savesrc (@test_opt_savesrc) { for my $compress (@test_opt_compress) { my $o = { start => 'init', slowops => 2, blocks => $blocks, leave => $leave, use_db_sub => $use_db_sub, savesrc => $savesrc, compress => $compress, # we don't need to test the 'calls' opt with all other combinations # so we fudge it here to be on most, but not all, of the time calls => (!!$savesrc + !!$compress), # 0|1|2 ($overrides) ? %$overrides : (), }; my $key = join "\t", map { "$_=>$o->{$_}" } sort keys %$o; next if $seen{$key}++; push @opt_combinations, $o; } } } } } @opt_combinations = shuffle @opt_combinations; return \@opt_combinations; } my %env_influence; my %env_failed; sub do_foreach_opt_combination { my ($opt_combinations, $code) = @_; my $rusage_start = get_rusage(); COMBINATION: for my $env (@$opt_combinations) { my $prev_failures = count_of_failed_tests(); my %env = (%$env, %NYTPROF_TEST); my @keys = sort keys %env; # put trace option first: @keys = ('trace', grep { $_ ne 'trace' } @keys) if $env{trace}; local $ENV{NYTPROF} = join ":", map {"$_=$env{$_}"} @keys; my $context_msg = "NYTPROF=$ENV{NYTPROF}\n"; ($opts{v}) ? warn $context_msg : print $context_msg; ok eval { $code->(\%env) }; if ($@) { diag "Test group aborted: $@"; last COMBINATION; } # did any tests fail? my $failed = (count_of_failed_tests() - $prev_failures) ? 1 : 0; # record what env settings may have influenced the failure ++$env_influence{$_}{$env->{$_}}{$failed ? 'FAIL' : 'pass'} for keys %$env; $env_failed{ $ENV{NYTPROF} } = $failed; } report_rusage($rusage_start); } # report which env vars influenced the failures, if any sub report_env_influence { my ($tag) = @_; #warn Dumper(\%env_influence); my @env_influence; for my $envvar (sort keys %env_influence) { my $variants = $env_influence{$envvar}; local $Data::Dumper::Indent = 0; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Quotekeys= 0; local $Data::Dumper::Pair = ' '; $variants->{$_} = Dumper($variants->{$_}) for keys %$variants; # was there at least one failure? next unless grep { /FAIL/ } values %$variants; my $v = (values %$variants)[0]; # use one as a reference # all the same? next if keys %$variants == grep { $_ eq $v } values %$variants; push @env_influence, sprintf "%15s: %s\n", $envvar, join ', ', map { "$_ => $variants->{$_}" } sort keys %$variants; } if (@env_influence and not defined wantarray) { push @env_influence, sprintf "%s with %s\n", $env_failed{$_} ? 'FAILED' : 'Passed', $_ for sort keys %env_failed; diag "SUMMARY: Breakdown of $tag test failures by option settings:"; diag $_ for @env_influence; } %env_influence = (); return @env_influence; } # execute a group of tests (t/testFoo.*) - calls plan() sub run_test_group { my ($rtg_opts) = @_; my $extra_test_code = $rtg_opts->{extra_test_code}; my $extra_test_count = $rtg_opts->{extra_test_count} || 0; my $extra_options = $rtg_opts->{extra_options}; if ($ENV{NYTPROF_TEST_NOEXTRA}) { diag "NYTPROF_TEST_NOEXTRA - skipping $extra_test_count extra tests" if $extra_test_count; $extra_test_code = undef; $extra_test_count = 0; $extra_options = {}; } # obtain group from file name my $group; if ((caller)[1] =~ /([^\/\\]+)\.t$/) { $group = $1; } else { croak "Can't determine test group"; } my @tests = grep { -f $_ } map { "$group.$_" } sort { $text_extn_info->{$a}{order} <=> $text_extn_info->{$b}{order} } keys %$text_extn_info; unlink <$group.*_new*>; # delete _new* files from previous run if ($opts{v}) { print "tests: @tests\n"; print "perl: $perl\n"; print "perl5lib: $perl5lib\n"; print "nytprofbin: $bindir\n"; } plan skip_all => "No '$group.*' test files and no extra_test_code" if !@tests and !$extra_test_code; my $opts = mk_opt_combinations($extra_options); my $tests_per_env = number_of_tests(@tests) + $extra_test_count + 1; plan tests => 1 + $tests_per_env * @$opts; # Windows emulates the executable bit based on file extension only ok($^O eq "MSWin32" ? -f $nytprofcsv : -x $nytprofcsv, "Found nytprofcsv as $nytprofcsv"); # non-default output file to test override works and to allow parallel testing my $profile_datafile = "nytprof_$group.out"; $NYTPROF_TEST{file} = $profile_datafile; do_foreach_opt_combination( $opts, sub { my ($env) = @_; for my $test (@tests) { run_test($test, $env); } if ($extra_test_code) { my $profile; if (@tests) { print("running $extra_test_count extra tests...\n"); $profile = eval { Devel::NYTProf::Data->new({ filename => $profile_datafile }) }; if ($@) { diag($@); fail("extra tests group '$group'") foreach (1 .. $extra_test_count); return; } } $extra_test_code->($profile, $env); } return 1; } ); report_env_influence($group); } sub run_test { my ($test, $env) = @_; my $tag = join " ", map { ($_ ne 'file') ? "$_=$env->{$_}" : () } sort keys %$env; #print $test . '.'x (20 - length $test); $test =~ / (.+?) \. (?:(\d)\.)? (\w+) $/x or do { warn "Can't parse test filename '$test'"; return; }; my ($basename, $fork_seqn, $type) = ($1, $2 || 0, $3); #warn "($basename, $fork_seqn, $type)\n"; my $profile_datafile = $NYTPROF_TEST{file}; my $test_datafile = (profile_datafiles($profile_datafile))[$fork_seqn]; my $outdir = $basename.'_outdir'; if ($type eq 'p') { unlink_old_profile_datafiles($profile_datafile); profile($test, $profile_datafile) or die "Profiling $test failed\n"; if ($opts{html}) { my $htmloutdir = "/tmp/$outdir"; unlink <$htmloutdir/*>; my $cmd = "$perl $nytprofhtml --file=$profile_datafile --out=$htmloutdir"; $cmd .= " --open" if $opts{open}; run_command($cmd); } } elsif ($type eq 'rdt') { verify_data($test, $tag, $test_datafile); if ($opts{mergerdt}) { # run the file through nytprofmerge my $merged = "$profile_datafile.merged"; my $merge_cmd = "$perl $nytprofmerge -v --out=$merged $test_datafile"; warn "$merge_cmd\n"; system($merge_cmd) == 0 or die "Error running $merge_cmd\n"; verify_data($test, "$tag (merged)", $merged); unlink $merged; } } elsif ($type eq 'calls') { if ($env->{calls}) { verify_calls_report($test, $tag, $test_datafile, $outdir); } else { pass("no calls"); } } elsif ($type eq 'x') { mkdir $outdir or die "mkdir($outdir): $!" unless -d $outdir; unlink <$outdir/*>; verify_csv_report($test, $tag, $test_datafile, $outdir); } elsif ($type eq 'pf') { verify_platforms_csv_report($test, $tag, $test_datafile, $outdir); } elsif ($type =~ /^(?:pl|pm|new|outdir)$/) { # skip; handy for "test.pl t/test01.*" } else { warn "Unrecognized extension '$type' on test file '$test'\n"; } if ($opts{abort}) { my $test_builder = Test::More->builder; my @summary = $test_builder->summary; BAIL_OUT("Aborting after test failure") if grep { !$_ } @summary; } } sub run_command { my ($cmd, $show_stdout) = @_; warn "NYTPROF=$ENV{NYTPROF}\n" if $opts{v} && $ENV{NYTPROF}; local $ENV{PERL5LIB} = $perl5lib; warn "$cmd\n" if $opts{v}; local *RV; open(RV, "$cmd |") or die "Can't execute $cmd: $!\n"; my @results = ; my $ok = close RV; if (not $ok) { warn "Error status $? from $cmd!\n"; warn "NYTPROF=$ENV{NYTPROF}\n" if $ENV{NYTPROF} and not $opts{v}; $show_stdout = 1; sleep 2; } if ($show_stdout) { warn $_ for @results } return $ok; } sub _quote_join { join ' ', map qq{"$_"}, @_; } # some tests use profile_this() in Devel::NYTProf::Run sub run_perl_command { my ($cmd, $show_stdout) = @_; local $ENV{PERL5LIB} = $perl5lib; my @perl = perl_command_words(skip_sitecustomize => 1); run_command(_quote_join(@perl) . " $cmd", $show_stdout); } sub profile { # TODO refactor to use run_perl_command()? my ($test, $profile_datafile) = @_; my @perl = perl_command_words(skip_sitecustomize => 1); my $cmd = _quote_join(@perl) . " $opts{profperlopts} $test"; return ok run_command($cmd), "$test runs ok under the profiler"; } sub verify_data { my ($test, $tag, $profile_datafile) = @_; my $profile = eval { Devel::NYTProf::Data->new({filename => $profile_datafile}) }; if ($@) { diag($@); fail($test); return; } SKIP: { skip 'Expected profile data does not have VMS paths', 1 if $^O eq 'VMS' and $test =~ m/test60|test14/i; $profile->normalize_variables(1); # and options dump_profile_to_file($profile, $test.'_new', $test.'_newp'); is_file_content_same($test.'_new', $test, "$test match generated profile data for $tag"); } } sub is_file_content_same { my ($got_file, $exp_file, $testname) = @_; my @got = slurp_file($got_file); chomp @got; my @exp = slurp_file($exp_file); chomp @exp; my $updated = update_file_content_array (\@got); # Sort the got and exp data if we updated. # This avoids mismatches due to file sort orders. if ($updated) { @got = sort @got; @exp = sort @exp; } is_deeply(\@got, \@exp, $testname) ? unlink($got_file) : diff_files($exp_file, $got_file, $got_file."_patch"); } sub update_file_content_array { my $lines = shift; my $file_info_start; foreach my $i (0 .. $#$lines) { next if not $lines->[$i] =~ /^fid_fileinfo/; # Remove path info that creeps in when run under prove # Should perhaps use Regexp::Common, or borrow from it. $lines->[$i] =~ s|(\d\t\[ )(\w:/)?([\-\w\s]+/)+|$1|; $file_info_start ||= $i; last if $i > $file_info_start + 4; } return if !$file_info_start; my $re_eval_id = qr /\(eval ([0-9]+)\)/; my $start_eval_id = 1; # find the first fid_fileinfo line with an eval in it for my $i ($file_info_start .. 10+$file_info_start) { if ($lines->[$i] =~ $re_eval_id) { $start_eval_id = $1; last; }; } return if $start_eval_id <= 1; my $eval_id_offset = $start_eval_id - 1; # now update the eval IDs for the offset foreach my $i ($file_info_start .. $#$lines) { if (my @matches = ($lines->[$i] =~ m/$re_eval_id/g)) { foreach my $got (@matches) { my $replace = $got - $eval_id_offset; if ($lines->[$i] =~ /test22-strevala.p/) { # Correct for the alphabetical ordering # as otherwise the 10 is listed before the 9 # and the line does not match exactly. # Clunky, but works for now. if ($got == 10) { $replace -= 1; } elsif (@matches > 2 && $got == 9) { $replace += 1; } } $lines->[$i] =~ s/\(eval $got\)/\(eval $replace\)/; } } } # indicate changes return 1; } sub dump_data_to_file { my ($profile, $file) = @_; open my $fh, ">", $file or croak "Can't open $file: $!"; local $Data::Dumper::Indent = 1; local $Data::Dumper::Sortkeys = 1; print $fh Data::Dumper->Dump([$profile], ['expected']); return; } sub dump_profile_to_file { my ($profile, $file, $rename_existing) = @_; rename $file, $rename_existing or warn "rename($file, $rename_existing): $!" if $rename_existing && -f $file; open my $fh, ">", $file or croak "Can't open $file: $!"; $profile->dump_profile_data( { filehandle => $fh, separator => "\t", skip_fileinfo_hook => sub { my $fi = shift; return 1 if $fi->filename =~ /(AutoLoader|Exporter)\.pm$/ or $fi->filename =~ m!^/\.\.\./!; return 0; }, } ); return; } sub diff_files { my ($old_file, $new_file, $newp_file) = @_; # we don't care if this fails, it's just an aid to debug test failures # XXX needs to behave better on windows my @opts = split / /, $ENV{NYTPROF_DIFF_OPTS} || $diff_opts; # e.g. '-y' # can sometimes cause issues with cmd shell if ($^O ne 'MSWin32') { system("diff @opts $old_file $new_file 1>&2"); } } sub verify_calls_report { my ($test, $tag, $profile_datafile, $outdir) = @_; my $got_file = "${test}_new"; note "generating $got_file"; run_command("$perl $nytprofcalls $profile_datafile -stable --calls > $got_file"); is_file_content_same($got_file, $test, "$test match generated calls data for $tag"); } sub verify_csv_report { my ($test, $tag, $profile_datafile, $outdir) = @_; # generate and parse/check csv report # determine the name of the generated csv file my $csvfile = $test; # fork tests will still report using the original script name $csvfile =~ s/\.\d\./.0./; # foo.p => foo.p.csv is tested by foo.x # foo.pm => foo.pm.csv is tested by foo.pm.x $csvfile =~ s/\.x//; $csvfile .= ".p" unless $csvfile =~ /\.p/; $csvfile = html_safe_filename($csvfile); $csvfile = "$outdir/${csvfile}-1-line.csv"; unlink $csvfile; my $cmd = "$perl $nytprofcsv --file=$profile_datafile --out=$outdir"; ok run_command($cmd), "nytprofcsv runs ok"; my @got = slurp_file($csvfile); my @expected = slurp_file($test); if ($opts{d}) { print "GOT:\n"; print @got; print "EXPECTED:\n"; print @expected; print "\n"; } my $index = 0; foreach (@expected) { if ($expected[$index++] =~ m/^# Version/) { splice @expected, $index - 1, 1; } } my $automated_testing = $ENV{AUTOMATED_TESTING} # also try to catch some cases where AUTOMATED_TESTING isn't set # like http://www.cpantesters.org/cpan/report/07588221-b19f-3f77-b713-d32bba55d77f || ($ENV{PERL_BATCH}||'') eq 'yes'; # if it was slower than expected then we're very generous, to allow for # slow systems, e.g. cpan-testers running in cpu-starved virtual machines. # e.g., http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4227689.html my $max_time_overrun_percentage = ($automated_testing) ? 400 : 200; my $max_time_underrun_percentage = 80; my @accuracy_errors; $index = 0; my $limit = scalar(@got) - 1; while ($index < $limit) { $_ = shift @got; next if m/^# Version/; # Ignore version numbers # we allow negative numbers here re RT#85556 s/^(-?[0-9.]+),([0-9.]+),([0-9.]+),(.*)$/0,$2,0,$4/o; my $t0 = $1; my $c0 = $2; my $tc0 = $3; if ( defined $expected[$index] and 0 != $expected[$index] =~ s/^~([0-9.]+)/0/ and $c0 # protect against div-by-0 in some error situations ) { my $expected = $1; my $percent = int(($t0 / $expected) * 100); # <100 if faster, >100 if slower # Test aproximate times push @accuracy_errors, "$test line $index: got $t0 expected approx $expected for time ($percent%)" if ($percent < $max_time_underrun_percentage) or ($percent > $max_time_overrun_percentage); my $tc = $t0 / $c0; push @accuracy_errors, "$test line $index: got $tc0 expected ~$tc for time/calls" if abs($tc - $tc0) > 0.00002; # expected to be very close (rounding errors only) } push @got, $_; $index++; } if ($opts{d}) { print "TRANSFORMED TO:\n"; print @got; print "\n"; } chomp @got; chomp @expected; is_deeply(\@got, \@expected, "$test match generated CSV data for $tag") or do { write_out_file($test.'_new', join("\n", @got,''), $test.'_newp'); diff_files($test, $test.'_new', $test.'_newp'); }; is(join("\n", @accuracy_errors), '', "$test times should be reasonable"); } sub verify_platforms_csv_report { my ($test, $tag, $profile_datafile, $outdir) = @_; my $outfile = "$outdir/$test.csv"; my $cmd = "$perl $nytprofpf --file=$profile_datafile --out=$outfile"; ok run_command($cmd), "nytprofpf runs ok"; my $got = slurp_file($outfile); #test if all lines from .pf are contained in result file #(we can not be sure about the order, so we match each line individually) my $match_result = 1; open (EXPECTED, $test); while () { $match_result = $match_result && $got =~ m/$_/; } close (EXPECTED); ok $match_result, "$outfile file matches $test"; } sub pop_times { my $hash = shift || return; foreach my $key (keys %$hash) { shift @{$hash->{$key}}; pop_times($hash->{$key}->[1]); } } sub number_of_tests { my $total_tests = 0; for (@_) { next unless m/\.(\w+)$/; my $tests = $text_extn_info->{$1}{tests}; warn "Unknown test type '$1' for test file '$_'\n" if not defined $tests; $total_tests += $tests if $tests; } return $total_tests; } sub slurp_file { # individual lines in list context, entire file in scalar context my ($file) = @_; open my $fh, "<", $file or croak "Can't open $file: $!"; return <$fh> if wantarray; local $/ = undef; # slurp; return <$fh>; } sub write_out_file { my ($file, $content, $rename_existing) = @_; rename $file, $rename_existing or warn "rename($file, $rename_existing): $!" if $rename_existing && -f $file; open my $fh, ">", $file or croak "Can't open $file: $!"; print $fh $content; close $fh or die "Error closing $file: $!"; } sub profile_datafiles { my ($filename) = @_; croak "No filename specified" unless $filename; my @profile_datafiles = glob("$filename*"); # sort to ensure datafile without pid suffix is first @profile_datafiles = sort @profile_datafiles; return @profile_datafiles; # count in scalar context } sub unlink_old_profile_datafiles { my ($filename) = @_; my @profile_datafiles = profile_datafiles($filename); print "Unlinking old @profile_datafiles\n" if @profile_datafiles and $opts{v}; 1 while unlink @profile_datafiles; } sub count_of_failed_tests { my @details = Test::Builder->new->details; return scalar grep { not $_->{ok} } @details; } sub get_rusage { return scalar eval { BSD::Resource::getrusage(BSD::Resource::RUSAGE_CHILDREN()) }; } sub report_rusage { my $ru1 = shift or return; my $ru2 = get_rusage(); my %diff; $diff{$_} = $ru2->$_ - $ru1->$_ for (qw(maxrss)); warn " maxrss: $diff{maxrss}\n"; } 1; # vim:ts=8:sw=4:et Devel-NYTProf-6.06/bin/nytprofcg000755 000766 000024 00000007753 13015665355 017017 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## ## This script is part of the Devel::NYTProf distribution ## Released under the same terms as Perl 5.8.0 ## See http://metacpan.org/release/Devel-NYTProf/ ## ########################################################## use warnings; use strict; use Getopt::Long; use Devel::NYTProf::Data; my %opt = ( file => 'nytprof.out', out => 'nytprof.callgrind', ); GetOptions( \%opt, qw/file|f=s out|o=s help|h/ ) or usage(); usage() if $opt{help}; print "Reading $opt{file} ...\n"; my $profile = Devel::NYTProf::Data->new( { filename => $opt{file}, quiet => 1 } ); print "Writing $opt{out} ...\n"; # calltree format specification # http://kcachegrind.sourceforge.net/cgi-bin/show.cgi/KcacheGrindCalltreeFormat open my $fh, '>', $opt{out} or die "Can't write to $opt{out}: $!\n"; print $fh "events: Ticks".$/; print $fh $/; my %callmap; my $subname_subinfo_map = $profile->subname_subinfo_map; for my $sub (values %$subname_subinfo_map) { my $callers = $sub->caller_fid_line_places; next unless ($callers && %$callers); my $fi = eval { $sub->fileinfo }; print $fh 'fl='.( $fi ? $fi->filename : "Unknown").$/; print $fh 'fn='.$sub->subname.$/; print $fh join(' ',$sub->first_line, int($sub->excl_time * 1_000_000)).$/; print $fh $/; my @callers; while ( my ( $fid, $fid_line_info ) = each %$callers ) { for my $line ( keys %$fid_line_info ) { my ( $count, $incl_time, $excl_time, undef, undef, undef, undef, $calling_subs) = @{ $fid_line_info->{$line} }; my @subnames = sort keys %$calling_subs; ref $_ and $_ = sprintf "%s (merge of %d subs)", $_->[0], scalar @$_ for @subnames; my $subname = (@subnames) ? join( " or ", @subnames ) : "__main"; my $fi = $profile->fileinfo_of($fid); my $filename = $fi->filename($fid); my $line_desc = "line $line of $filename"; # chase string eval chain back to a real file while ( my ( $outer_fileinfo, $outer_line ) = $fi->outer ) { ( $filename, $line ) = ( $outer_fileinfo->filename, $outer_line ); $line_desc .= sprintf " at line %s of %s", $line, $filename; $fi = $outer_fileinfo; } push @{ $callmap{$subname} }, [ $filename, $line, $sub, $count, $incl_time, $excl_time ]; } } } for (keys %callmap) { for my $entry (@{$callmap{$_}}) { my ($filename, $line, $sub, $count, $incl_time, $excl_time) = @$entry; print $fh "fl=$filename$/"; print $fh 'fn='.$_.$/; print $fh "cfl=".(eval { $sub->fileinfo->filename } || 'Unknown').$/; print $fh "cfn=".$sub->subname.$/; # calls=(Call Count) (Destination position) # (Source position) (Inclusive cost of call) print $fh "calls=$count ".$sub->first_line.$/; print $fh "$line ".int(1_000_000 * $incl_time).$/; print $fh $/; } } sub usage { print <, -f Specify NYTProf data file [default: nytprof.out] --out , -o Specify output file [default: nytprof.callgrind] --help, -h Print this message This script of part of the Devel::NYTProf distribution. Released under the same terms as Perl 5.8.0 See http://metacpan.org/release/Devel-NYTProf/ END exit 1; } __END__ =head1 NAME nytprofcg - Convert an NYTProf profile into Callgrind format =head1 SYNOPSIS $ nytprofcg --file=nytprof.out --out=nytprof.callgrind $ nytprofcg # same as above =head1 DESCRIPTION Reads a profile data file generated by Devel::NYTProf and writes out the subroutine call graph information it contains in Callgrind format. The output Callgrind file can be loaded into the C GUI for interactive exploration. For more information see L =cut Devel-NYTProf-6.06/bin/nytprofpf000755 000766 000024 00000011313 13305236535 017012 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## ## This script is part of the Devel::NYTProf distribution ## ## Copyright, contact and other information can be found ## at the bottom of this file, or by going to: ## https://metacpan.org/pod/Devel::NYTProf ## ########################################################### =head1 NAME nytprofpf - Generate a report for plat_forms (L) from Devel::NYTProf data =head1 SYNOPSIS Typical usage: $ perl -d:NYTProf some_perl_app.pl $ nytprofpf Options synopsis: --file , -f Read profile data from the specified file [default: nytprof.out] --delete, -d Delete any old report files first --lib , -l Add to the beginning of \@INC --no-mergeevals Disable merging of string evals --help, -h Print this message This script of part of the Devel::NYTProf distribution. Generate a report for plat_forms (L) from Devel::NYTProf data. See http://metacpan.org/release/Devel-NYTProf/ for details and copyright. =encoding ISO8859-1 =cut use warnings; use strict; use Carp; use Config qw(%Config); use Getopt::Long; use List::Util qw(sum max); use File::Copy; use File::Path qw(rmtree); use Devel::NYTProf::Reader; use Devel::NYTProf::Core; use Devel::NYTProf::Util qw( fmt_float fmt_time fmt_incl_excl_time calculate_median_absolute_deviation get_abs_paths_alternation_regex html_safe_filename ); use Devel::NYTProf::Constants qw(NYTP_SCi_CALLING_SUB); our $VERSION = '6.06'; if ($VERSION != $Devel::NYTProf::Core::VERSION) { die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n"; } GetOptions( 'file|f=s' => \(my $opt_file = 'nytprof.out'), 'lib|l=s' => \my $opt_lib, 'out|o=s' => \(my $opt_out = 'nytprof'), 'delete|d!' => \my $opt_delete, 'help|h' => sub { exit usage() }, 'mergeevals!'=> \(my $opt_mergeevals = 1), ) or do { exit usage(); }; sub usage { print <, -f Read profile data from the specified file [default: nytprof.out] --delete, -d Delete any old report files first --lib , -l Add to the beginning of \@INC --no-mergeevals Disable merging of string evals --help, -h Print this message This script of part of the Devel::NYTProf distribution. See http://metacpan.org/release/Devel-NYTProf/ for details and copyright. END return 0; } use constant NUMERIC_PRECISION => 7; # handle output location if (!-e $opt_out) { # everything is fine } elsif (!-f $opt_out) { die "$0: Specified output file '$opt_out' already exists as a directory!\n"; } elsif (!-w $opt_out) { die "$0: Unable to write to output directory '$opt_out'\n"; } else { if (defined($opt_delete)) { print "Deleting existing $opt_out file\n"; rm($opt_out); } } # handle custom lib path if (defined($opt_lib)) { warn "$0: Specified lib directory '$opt_lib' does not exist.\n" unless -d $opt_lib; require lib; lib->import($opt_lib); } $SIG{USR2} = \&Carp::cluck if exists $SIG{USR2}; # some platforms don't have SIGUSR2 (Windows) my $reporter = new Devel::NYTProf::Reader($opt_file, { quiet => 0, skip_collapse_evals => !$opt_mergeevals, }); my $profile = $reporter->{profile}; open my $fh, '>', $opt_out or croak "Unable to open file $opt_out: $!"; print $fh subroutine_table($profile, undef, 0, 'excl_time'); close $fh; sub subroutine_table { my ($profile, $fi, $max_subs, $sortby) = @_; $sortby ||= 'excl_time'; my $subs_unsorted = $profile->subname_subinfo_map; my $inc_path_regex = get_abs_paths_alternation_regex([$profile->inc], qr/^|\[/); my @all_subs = sort { $b->$sortby <=> $a->$sortby or $a->subname cmp $b->subname } values %$subs_unsorted; #don't show subs that were never called my @subs = grep { $_->calls > 0 } @all_subs if !$fi; my $max_pkg_name_len = max(map { length($_->package) } @subs); my $output; $output .= "Name, File location, Time, Avg. Time, Own Time, Invocation Count, Level\n"; my $profiler_active = $profile->{attribute}{profiler_active}; for my $sub (@subs) { $output .= sprintf ("%s, %s, %.3f, %.3f, %.3f, %d, %d\n", $sub->subname, $sub->fileinfo->filename, $sub->incl_time * 1000, 0, $sub->excl_time * 1000, $sub->calls, 0); } return $output; } exit 0; Devel-NYTProf-6.06/bin/nytprofcalls000755 000766 000024 00000014743 13305236542 017513 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################## use warnings; use strict; use Devel::NYTProf::Core; require Devel::NYTProf::Data; our $VERSION = '6.06'; use Data::Dumper; use Getopt::Long; use Carp; GetOptions( 'help|h' => \&usage, 'verbose|v' => \my $opt_verbose, 'calls!' => \my $opt_calls, # sum calls instead of time 'debug|d' => \my $opt_debug, 'stable' => \my $opt_stable, # used for testing (stability) ) or usage(); $opt_verbose++ if $opt_debug; $|++ if $opt_verbose; usage() unless @ARGV; sub usage { print < sub { my (undef, $k, $v) = @_; $option{$k} = $v }, ATTRIBUTE => sub { my (undef, $k, $v) = @_; $attribute{$k} = $v }, }; $callbacks->{SUB_ENTRY} = \&on_sub_entry_log if $opt_verbose; $callbacks->{SUB_RETURN} = \&on_sub_return_build_call_stack; $callbacks->{all_loaded} = sub { output_call_path_hash( extract_call_path_hash($root) ); }; foreach my $input (@ARGV) { warn "Reading $input...\n" if $opt_verbose; Devel::NYTProf::Data->new({ filename => $input, quiet => 1, callback => $callbacks }); } $callbacks->{all_loaded}->(); exit 0; sub on_sub_entry_log { my (undef, $fid, $line) = @_; warn "> at $fid:$line\n"; } sub on_sub_return_build_call_stack { # $retn_depth is the call stack depth of the sub call we're returning from my (undef, $retn_depth, undef, $excl_time, $subname) = @_; warn sprintf "< %2d %-10s %s (stack %d)\n", $retn_depth, $subname, $excl_time, scalar @stack if $opt_verbose; my $v = ($opt_calls) ? 1 : $excl_time; $total_in += $v; # normalize and merge sibling string evals by setting eval seqn to 0 $subname =~ s/\( (\w*eval)\s\d+ \) (?= \[ .+? :\d+ \] )/($1 0)/gx; # assign an id to the subname for memory efficiency my $subid = $subname2id{$subname} ||= ++$last_subid; # Either... # a) we're returning from some sub deeper than the current stack # in which case we push unnamed sub calls ("0") onto the stack # till we get to the right depth, then fall through to: # b) we're returning from the sub on top of the stack. while (@stack <= $retn_depth) { # build out the tree if needed my $crnt_node = $stack[-1]; die "panic" if $crnt_node->{0}; push @stack, ($crnt_node->{0} = {}); } # top of stack: sub we're returning from # next on stack: sub that was the caller my $sub_return = pop @stack; my $sub_caller = $stack[-1] || die "panic"; die "panic" unless $sub_return == $sub_caller->{0}; delete $sub_caller->{0} or die "panic"; # == $sub_return # { # 0 - as-yet un-returned subs # 'v' - cumulative excl_time in this sub # $subid1 => {...} # calls to $subid1 made by this sub # $subid2 => {...} # } $sub_return->{v} += $v; _merge_sub_return_into_caller($sub_caller->{$subid} ||= {}, $sub_return); } # build hash of call paths ("subid;subid;subid" => value) from the call tree sub extract_call_path_hash { my ($root) = @_; my %subid_call_path_hash; visit_nodes_depth_first($root, [], sub { my ($node, $path) = @_; $subid_call_path_hash{ join(";", @$path) } += $node->{v} if @$path; %$node = (); # reclaim memory as we go }); return \%subid_call_path_hash; } sub output_call_path_hash { my ($subid_call_path_hash) = @_; # ensure subnames don't contain ";" or " " tr/; /??/ for values %subname2id; my %subid2name = reverse %subname2id; # output the totals without scaling, so they're in ticks_per_sec units my $val_scale_factor = 1; # ($opt_calls) ? 1 : 1_000_000 / $attribute{ticks_per_sec}; my $val_format = ($opt_calls || $val_scale_factor==1) ? "%s %d\n" : "%s %.1f\n"; my $total_out = 0; # output the subid_call_path_hash hash using subroutine names my @keys = keys %$subid_call_path_hash; @keys = sort @keys if $opt_stable; for my $subidpath (@keys) { my @path = map { $subid2name{$_} } split ";", $subidpath; my $path = join(";", @path); my $v = $subid_call_path_hash->{$subidpath}; printf $val_format, join(";", @path), $v * $val_scale_factor; $total_out += $v; } warn "nytprofcalls inconsistency: total in $total_in doesn't match total out $total_out\n" if $total_in != $total_out; warn sprintf "Done. Total $total_in\n" if $opt_verbose; } sub _merge_sub_return_into_caller { my ($dest, $new, $recurse) = @_; $dest->{v} += delete $new->{v}; while ( my ($new_called_subid, $new_called_node) = each %$new ) { if ($dest->{$new_called_subid}) { _merge_sub_return_into_caller($dest->{$new_called_subid}, $new_called_node); } else { $dest->{$new_called_subid} = $new_called_node; } } } sub visit_nodes_depth_first { # depth first my $node = shift; my $path = shift; my $sub = shift; warn "visit_node: @{[ %$node ]}\n" if $opt_debug; push @$path, undef; while ( my ($subid, $childnode) = each %$node) { next if $subid eq 'v'; die "panic" if $subid eq '0'; $path->[-1] = $subid; warn "node @$path: @{[ %$childnode ]}\n" if $opt_debug; visit_nodes_depth_first($childnode, $path, $sub); } pop @$path; $sub->($node, $path); } __END__ =head1 NAME nytprofcalls - experimental =cut # vim:ts=8:sw=4:et Devel-NYTProf-6.06/bin/nytprofmerge000755 000766 000024 00000034255 13305236546 017520 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################## use warnings; use strict; use Devel::NYTProf::Core; require Devel::NYTProf::FileHandle; require Devel::NYTProf::Data; use List::Util qw(min sum); our $VERSION = '6.06'; if ($VERSION != $Devel::NYTProf::Core::VERSION) { die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n"; } use Getopt::Long; use Carp; my $opt_out = 'nytprof-merged.out'; GetOptions( 'out|o=s' => \$opt_out, 'help|h' => \&usage, 'verbose|v' => \my $opt_verbose, ) or usage(); usage() unless @ARGV; print "Opening output $opt_out\n" if $opt_verbose; my $out = Devel::NYTProf::FileHandle::open($opt_out, "wb") or die "Error opening $opt_out: $!\n"; my $sub_is_anon_in_eval = qr/__ANON__\[\(eval/; my $next_fid = 1; my %fid_to_file; my %file_to_fid; my %fids = (0 => 0); # Similar, but with all evals folded too my %fids_folded = (0 => 0); my %eval_to_fid; my $version; my %seen_subs; my %callers; my %map_range; my @pending_fids; my %pending_subs; sub _write_time_block_or_line { my ($tag, $ticks, $fid, $line, $block_line, $sub_line) = @_; confess("No mapping for $fid") unless defined $fids{$fid}; $fid = $fids{$fid}; # Is this a subroutine (re)defined in an eval? my $mapped_fid = $map_range{$fid}[$line]; $fid = $mapped_fid if defined $mapped_fid; # XXX overflow isn't passed in or through if ($tag eq 'TIME_LINE') { $out->write_time_line($ticks, 0, $fid, $line); } else { $out->write_time_block($ticks, 0, $fid, $line, $block_line, $sub_line); } } # Complain loudly if any of these attributes differ between profiles my %attr_should_be_identical = map {$_, 1} qw( PL_perldb clock_id nv_size perl_version ticks_per_sec xs_version ); # Effectively, these are global variables. Sorry. our $input; our %attributes; our %options; our $deflating; my %dispatcher = ( '' => sub { die "Unknown tag '$_[0]' in $input\n"; }, VERSION => sub { my (undef, $major, $minor) = @_; my $this_version = "$major $minor"; if($version) { die "Incompatible version '$this_version' in $input, expected '$version'" unless $this_version eq $version; } else { $version = $this_version; $out->write_header($major, $minor); } }, COMMENT => sub { my (undef, $text) = @_; chomp $text; # Arguably this is a bug in the callback interface. # This isn't true unless we enable compression ourselves, and if we # do that, the low level code will write out a correct comment # automatically. return if $text =~ /\ACompressed at level \d with zlib [0-9.]+\z/; $out->write_comment($text) }, ATTRIBUTE => sub { my (undef, $key, $value) = @_; if ($attr_should_be_identical{$key}) { if (exists $attributes{$key}) { if ($attributes{$key} ne $value) { warn("Attribute '$key' has value '$value' in $input which differs from the previous value '$attributes{$key}'; this implies inconsistent profiles and thus garbage results\n"); } } else { $attributes{$key} = $value; $out->write_attribute($key, $value); } } else { push @{$attributes{$key}}, $value; } }, OPTION => sub { my (undef, $key, $value) = @_; if (exists $options{$key}) { if ($options{$key} ne $value) { warn("Option '$key' has value '$value' in $input which differs from the previous value '$options{$key}'; this implies inconsistent profiles and thus garbage results\n"); } } else { $options{$key} = $value; $out->write_option($key, $value); } }, START_DEFLATE => sub { if (!$deflating && $out->can('start_deflate_write_tag_comment')) { $out->start_deflate_write_tag_comment; ++$deflating; } }, PID_START => sub { my (undef, $pid, $parent, $time) = @_; $out->write_process_start($pid, $parent, $time); }, PID_END => sub { my (undef, $pid, $time) = @_; $out->write_process_end($pid, $time); }, NEW_FID => sub { my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) = @_; return unless $pending_fids[$fid]; my ($new_fid, $new_eval_fid) = @{$pending_fids[$fid]}; $out->write_new_fid($new_fid, $new_eval_fid, $eval_line, $flags, $size, $mtime, $name); }, TIME_BLOCK => \&_write_time_block_or_line, TIME_LINE => \&_write_time_block_or_line, DISCOUNT => sub { $out->write_discount(); }, SUB_INFO => sub { my (undef, $fid, $first_line, $last_line, $name) = @_; my $output_fid = $pending_subs{"$fid,$first_line,$last_line,$name"}; return unless defined $output_fid; $out->write_sub_info($output_fid, $name, $first_line, $last_line); }, SUB_CALLERS => sub { my (undef, $fid, $line, $count, $incl_time, $excl_time, $reci_time, $rec_depth, $called, $caller) = @_; confess("No mapping for $fid") unless defined $fids{$fid}; $fid = $fids{$fid}; my $mapped_fid = $map_range{$fid}[$line]; $fid = $mapped_fid if defined $mapped_fid; if ($callers{"$fid,$line"}{$called}{$caller}) { my $sum = $callers{"$fid,$line"}{$called}{$caller}; $sum->{count} += $count; $sum->{incl} += $incl_time; $sum->{excl} += $excl_time; $sum->{reci} += $reci_time; $sum->{depth} = $rec_depth if $rec_depth > $sum->{depth}; } else { # New; $callers{"$fid,$line"}{$called}{$caller} = { depth => $rec_depth, count => $count, incl => $incl_time, excl => $excl_time, reci => $reci_time, }; } }, SUB_ENTRY => sub { my (undef, $fid, $line) = @_; confess("No mapping for $fid") unless defined $fids{$fid}; $fid = $fids{$fid}; $out->write_call_entry($fid, $line); }, SUB_RETURN => sub { my (undef, $retn_depth, $incl_time, $excl_time, $subname) = @_; $out->write_call_return($retn_depth, $subname, $incl_time, $excl_time); }, SRC_LINE => sub { my (undef, $fid, $line, $text) = @_; confess("No mapping for $fid") unless defined $fids{$fid}; $fid = $fids{$fid}; # Is this a subroutine (re)defined in an eval? my $mapped_fid = $map_range{$fid}[$line]; $fid = $mapped_fid if defined $mapped_fid; $out->write_src_line($fid, $line, $text); }, ); foreach $input (@ARGV) { print "Reading $input...\n" if $opt_verbose; @pending_fids = (); %pending_subs = (); # first pass Devel::NYTProf::Data->new({filename => $input, callback => { NEW_FID => sub { my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) = @_; my ($new_fid, $new_eval_fid); if($eval_fid) { # Generally, treat every eval as distinct, even at the same location $new_eval_fid = $fids{$eval_fid}; # Sanity check. Should never happen except that # if $eval_fid < $fid then this is a known problem # with evals fids getting profiled/output before the parent fid warn("unknown eval_fid $eval_fid in $input fid $fid\n") unless defined $new_eval_fid; $new_fid = $next_fid++; $fids{$fid} = $new_fid; # But also track the first fid to be allocated at that line of the eval my $folded_fid = $fids_folded{$eval_fid}; Carp::cluck("unknown folded eval_fid $eval_fid in $input fid $fid") unless defined $folded_fid; my $corresponding_eval = $eval_to_fid{"$folded_fid,$eval_line"}; if (!defined $corresponding_eval) { # Not seen a fid generated in an eval at this location before $eval_to_fid{"$folded_fid,$eval_line"} = $new_fid; $fids_folded{$fid} = $new_fid; } else { $fids_folded{$fid} = $corresponding_eval; } } else { $new_eval_fid = $eval_fid; $new_fid = $file_to_fid{$name}; if(defined $new_fid) { $fids_folded{$fid} = $fids{$fid} = $new_fid; return; } $new_fid = $next_fid++; $fids_folded{$fid} = $fids{$fid} = $new_fid; $file_to_fid{$name} = $new_fid; } $fid_to_file{$new_fid} = $name; $pending_fids[$fid] = [$new_fid, $new_eval_fid]; }, SUB_INFO => sub { my (undef, $fid, $first_line, $last_line, $name) = @_; my $output_fid; if ($name =~ $sub_is_anon_in_eval) { confess("No mapping for $fid") unless defined $fids{$fid}; $output_fid = $fids{$fid}; $seen_subs{"$output_fid,$name"} ||= "$first_line,$last_line"; } else { confess("No mapping for $fid") unless defined $fids_folded{$fid}; my $folded = $fids_folded{$fid}; my $seen = $seen_subs{"$folded,$name"}; if (defined $seen && $seen ne "$first_line,$last_line") { # Warn that we are not folding # Carry on, and output a SUB_INFO block for this fid $output_fid = $fid; } else { # This subroutine has be (re)defined in two distinct # evals, but appears to be identical. So for this lines # range in the second eval, treat profiling data as if it # came from the fid of the first eval, so that all calls # to the sub are collated. # Have to use the mapped fid as the key to this hash, as # only the mapped fids are unique my $mapped_fid = $fids{$fid}; $map_range{$mapped_fid}[$_] = $folded for $first_line .. $last_line; return if defined $seen; $seen_subs{"$folded,$name"} = "$first_line,$last_line"; $output_fid = $folded; } } $pending_subs{"$fid,$first_line,$last_line,$name"} = $output_fid; } }}); # second pass print "Re-reading $input...\n" if $opt_verbose; Devel::NYTProf::Data->new({filename => $input, callback => \%dispatcher}); } print "Finalizing...\n" if $opt_verbose; # Deterministic order is useful for testing. foreach my $fid_line (sort keys %callers) { my ($fid, $line) = split ',', $fid_line; foreach my $called (sort keys %{$callers{$fid_line}}) { foreach my $caller (sort keys %{$callers{$fid_line}{$called}}) { my $sum = $callers{$fid_line}{$called}{$caller}; $out->write_sub_callers($fid, $line, $caller, $sum->{count}, @{$sum}{qw(incl excl reci)}, $sum->{depth}, $called); } } } foreach my $key (sort grep {!$attr_should_be_identical{$_}} keys %attributes) { my @values = @{$attributes{$key}}; if ($key eq 'basetime') { my $value = min(@values); $out->write_attribute($key, $value); } elsif ($key eq 'application') { # "merge" the application names my %counts; $counts{$_}++ foreach @values; my @grouped; foreach my $prog (sort keys %counts) { my $count = $counts{$prog}; push @grouped, $prog; $grouped[-1] .= " ($count runs)" if $count > 1; } my $last = pop @grouped; my $value = @grouped ? join (', ', @grouped) . " and $last" : $last; $out->write_attribute($key, $value); } elsif ($key eq 'cumulative_overhead_ticks') { # sum cumulative_overhead_ticks $out->write_attribute($key, sum(@values)); } elsif ($key =~ /^sawampersand_\w+$/) { # sawampersand_fid/_line # we just pass through the first value seen $out->write_attribute($key, $values[0]); } else { warn sprintf "Attribute %s has %d distinct values passed through unmerged\n", $key, scalar @values if @values > 1; $out->write_attribute($key, $_) foreach @values; } } print "Done.\n" if $opt_verbose; exit 0; sub usage { print <, -o Name of output file [default: $opt_out] --help, -h Print this message --verbose, -v Be more verbose This script of part of the Devel::NYTProf distribution. See https://metacpan.org/release/Devel-NYTProf for details and copyright. END exit 0; } __END__ =head1 NAME nytprofmerge - Reads multiple NYTProf profiles and outputs a merged one =head1 SYNOPSIS $ nytprofmerge --out=nytprof-merged.out nytprof.out.* $ nytprofmerge nytprof.out.* =head1 DESCRIPTION Reads multiple profile data files generated by Devel::NYTProf and writes out a new profile data file containing data merged from the original files. C is likely to produce garbage if the input profiles aren't all profiles of I the same software. C is new and somewhat experimental. If it produces unexpected results please produce a I test case that demonstrates the problem and let us know at L - thanks! =cut # vim:ts=8:sw=4:et Devel-NYTProf-6.06/bin/flamegraph.pl000755 000766 000024 00000067322 13015665355 017522 0ustar00timbostaff000000 000000 #!/usr/bin/perl -w # # flamegraph.pl flame stack grapher. # # This takes stack samples and renders a call graph, allowing hot functions # and codepaths to be quickly identified. Stack samples can be generated using # tools such as DTrace, perf, SystemTap, and Instruments. # # USAGE: ./flamegraph.pl [options] input.txt > graph.svg # # grep funcA input.txt | ./flamegraph.pl [options] > graph.svg # # Options are listed in the usage message (--help). # # The input is stack frames and sample counts formatted as single lines. Each # frame in the stack is semicolon separated, with a space and count at the end # of the line. These can be generated using DTrace with stackcollapse.pl, # and other tools using the stackcollapse variants. # # An optional extra column of counts can be provided to generate a differential # flame graph of the counts, colored red for more, and blue for less. This # can be useful when using flame graphs for non-regression testing. # See the header comment in the difffolded.pl program for instructions. # # The output graph shows relative presence of functions in stack samples. The # ordering on the x-axis has no meaning; since the data is samples, time order # of events is not known. The order used sorts function names alphabetically. # # While intended to process stack samples, this can also process stack traces. # For example, tracing stacks for memory allocation, or resource usage. You # can use --title to set the title to reflect the content, and --countname # to change "samples" to "bytes" etc. # # There are a few different palettes, selectable using --color. By default, # the colors are selected at random (except for differentials). Functions # called "-" will be printed gray, which can be used for stack separators (eg, # between user and kernel stacks). # # HISTORY # # This was inspired by Neelakanth Nadgir's excellent function_call_graph.rb # program, which visualized function entry and return trace events. As Neel # wrote: "The output displayed is inspired by Roch's CallStackAnalyzer which # was in turn inspired by the work on vftrace by Jan Boerhout". See: # https://blogs.oracle.com/realneel/entry/visualizing_callstacks_via_dtrace_and # # Copyright 2011 Joyent, Inc. All rights reserved. # Copyright 2011 Brendan Gregg. All rights reserved. # # CDDL HEADER START # # The contents of this file are subject to the terms of the # Common Development and Distribution License (the "License"). # You may not use this file except in compliance with the License. # # You can obtain a copy of the license at docs/cddl1.txt or # http://opensource.org/licenses/CDDL-1.0. # See the License for the specific language governing permissions # and limitations under the License. # # When distributing Covered Code, include this CDDL HEADER in each # file and include the License file at docs/cddl1.txt. # If applicable, add the following below this CDDL HEADER, with the # fields enclosed by brackets "[]" replaced with your own identifying # information: Portions Copyright [yyyy] [name of copyright owner] # # CDDL HEADER END # # 11-Oct-2014 Adrien Mahieux Added zoom. # 21-Nov-2013 Shawn Sterling Added consistent palette file option # 17-Mar-2013 Tim Bunce Added options and more tunables. # 15-Dec-2011 Dave Pacheco Support for frames with whitespace. # 10-Sep-2011 Brendan Gregg Created this. use strict; use Getopt::Long; # tunables my $encoding; my $fonttype = "Verdana"; my $imagewidth = 1200; # max width, pixels my $frameheight = 16; # max height is dynamic my $fontsize = 12; # base text size my $fontwidth = 0.59; # avg width relative to fontsize my $minwidth = 0.1; # min function width, pixels my $nametype = "Function:"; # what are the names in the data? my $countname = "samples"; # what are the counts in the data? my $colors = "hot"; # color theme my $bgcolor1 = "#eeeeee"; # background color gradient start my $bgcolor2 = "#eeeeb0"; # background color gradient stop my $nameattrfile; # file holding function attributes my $timemax; # (override the) sum of the counts my $factor = 1; # factor to scale counts by my $hash = 0; # color by function name my $palette = 0; # if we use consistent palettes (default off) my %palette_map; # palette map hash my $pal_file = "palette.map"; # palette map file name my $stackreverse = 0; # reverse stack order, switching merge end my $inverted = 0; # icicle graph my $negate = 0; # switch differential hues my $titletext = ""; # centered heading my $titledefault = "Flame Graph"; # overwritten by --title my $titleinverted = "Icicle Graph"; # " " my $searchcolor = "rgb(230,0,230)"; # color for search highlighting my $help = 0; sub usage { die < outfile.svg\n --title # change title text --width # width of image (default 1200) --height # height of each frame (default 16) --minwidth # omit smaller functions (default 0.1 pixels) --fonttype # font type (default "Verdana") --fontsize # font size (default 12) --countname # count type label (default "samples") --nametype # name type label (default "Function:") --colors # set color palette. choices are: hot (default), mem, io, # java, js, red, green, blue, yellow, purple, orange --hash # colors are keyed by function name hash --cp # use consistent palette (palette.map) --reverse # generate stack-reversed flame graph --inverted # icicle graph --negate # switch differential hues (blue<->red) --help # this message eg, $0 --title="Flame Graph: malloc()" trace.txt > graph.svg USAGE_END } GetOptions( 'fonttype=s' => \$fonttype, 'width=i' => \$imagewidth, 'height=i' => \$frameheight, 'encoding=s' => \$encoding, 'fontsize=f' => \$fontsize, 'fontwidth=f' => \$fontwidth, 'minwidth=f' => \$minwidth, 'title=s' => \$titletext, 'nametype=s' => \$nametype, 'countname=s' => \$countname, 'nameattr=s' => \$nameattrfile, 'total=s' => \$timemax, 'factor=f' => \$factor, 'colors=s' => \$colors, 'hash' => \$hash, 'cp' => \$palette, 'reverse' => \$stackreverse, 'inverted' => \$inverted, 'negate' => \$negate, 'help' => \$help, ) or usage(); $help && usage(); # internals my $ypad1 = $fontsize * 4; # pad top, include title my $ypad2 = $fontsize * 2 + 10; # pad bottom, include labels my $xpad = 10; # pad lefm and right my $framepad = 1; # vertical padding for frames my $depthmax = 0; my %Events; my %nameattr; if ($titletext eq "") { unless ($inverted) { $titletext = $titledefault; } else { $titletext = $titleinverted; } } if ($nameattrfile) { # The name-attribute file format is a function name followed by a tab then # a sequence of tab separated name=value pairs. open my $attrfh, $nameattrfile or die "Can't read $nameattrfile: $!\n"; while (<$attrfh>) { chomp; my ($funcname, $attrstr) = split /\t/, $_, 2; die "Invalid format in $nameattrfile" unless defined $attrstr; $nameattr{$funcname} = { map { split /=/, $_, 2 } split /\t/, $attrstr }; } } if ($colors eq "mem") { $bgcolor1 = "#eeeeee"; $bgcolor2 = "#e0e0ff"; } if ($colors eq "io") { $bgcolor1 = "#f8f8f8"; $bgcolor2 = "#e8e8e8"; } # SVG functions { package SVG; sub new { my $class = shift; my $self = {}; bless ($self, $class); return $self; } sub header { my ($self, $w, $h) = @_; my $enc_attr = ''; if (defined $encoding) { $enc_attr = qq{ encoding="$encoding"}; } $self->{svg} .= < SVG } sub include { my ($self, $content) = @_; $self->{svg} .= $content; } sub colorAllocate { my ($self, $r, $g, $b) = @_; return "rgb($r,$g,$b)"; } sub group_start { my ($self, $attr) = @_; my @g_attr = map { exists $attr->{$_} ? sprintf(qq/$_="%s"/, $attr->{$_}) : () } qw(class style onmouseover onmouseout onclick); push @g_attr, $attr->{g_extra} if $attr->{g_extra}; $self->{svg} .= sprintf qq/\n/, join(' ', @g_attr); $self->{svg} .= sprintf qq/%s<\/title>/, $attr->{title} if $attr->{title}; # should be first element within g container if ($attr->{href}) { my @a_attr; push @a_attr, sprintf qq/xlink:href="%s"/, $attr->{href} if $attr->{href}; # default target=_top else links will open within SVG push @a_attr, sprintf qq/target="%s"/, $attr->{target} || "_top"; push @a_attr, $attr->{a_extra} if $attr->{a_extra}; $self->{svg} .= sprintf qq//, join(' ', @a_attr); } } sub group_end { my ($self, $attr) = @_; $self->{svg} .= qq/<\/a>\n/ if $attr->{href}; $self->{svg} .= qq/<\/g>\n/; } sub filledRectangle { my ($self, $x1, $y1, $x2, $y2, $fill, $extra) = @_; $x1 = sprintf "%0.1f", $x1; $x2 = sprintf "%0.1f", $x2; my $w = sprintf "%0.1f", $x2 - $x1; my $h = sprintf "%0.1f", $y2 - $y1; $extra = defined $extra ? $extra : ""; $self->{svg} .= qq/\n/; } sub stringTTF { my ($self, $color, $font, $size, $angle, $x, $y, $str, $loc, $extra) = @_; $x = sprintf "%0.2f", $x; $loc = defined $loc ? $loc : "left"; $extra = defined $extra ? $extra : ""; $self->{svg} .= qq/$str<\/text>\n/; } sub svg { my $self = shift; return "$self->{svg}\n"; } 1; } sub namehash { # Generate a vector hash for the name string, weighting early over # later characters. We want to pick the same colors for function # names across different flame graphs. my $name = shift; my $vector = 0; my $weight = 1; my $max = 1; my $mod = 10; # if module name present, trunc to 1st char $name =~ s/.(.*?)`//; foreach my $c (split //, $name) { my $i = (ord $c) % $mod; $vector += ($i / ($mod++ - 1)) * $weight; $max += 1 * $weight; $weight *= 0.70; last if $mod > 12; } return (1 - $vector / $max) } sub color { my ($type, $hash, $name) = @_; my ($v1, $v2, $v3); if ($hash) { $v1 = namehash($name); $v2 = $v3 = namehash(scalar reverse $name); } else { $v1 = rand(1); $v2 = rand(1); $v3 = rand(1); } # theme palettes if (defined $type and $type eq "hot") { my $r = 205 + int(50 * $v3); my $g = 0 + int(230 * $v1); my $b = 0 + int(55 * $v2); return "rgb($r,$g,$b)"; } if (defined $type and $type eq "mem") { my $r = 0; my $g = 190 + int(50 * $v2); my $b = 0 + int(210 * $v1); return "rgb($r,$g,$b)"; } if (defined $type and $type eq "io") { my $r = 80 + int(60 * $v1); my $g = $r; my $b = 190 + int(55 * $v2); return "rgb($r,$g,$b)"; } # multi palettes if (defined $type and $type eq "java") { if ($name =~ /::/) { # C++ $type = "yellow"; } elsif ($name =~ m:/:) { # Java (match "/" in path) $type = "green" } else { # system $type = "red"; } # fall-through to color palettes } if (defined $type and $type eq "js") { if ($name =~ /::/) { # C++ $type = "yellow"; } elsif ($name =~ m:/:) { # JavaScript (match "/" in path) $type = "green" } elsif ($name =~ m/:/) { # JavaScript (match ":" in builtin) $type = "aqua" } elsif ($name =~ m/^ $/) { # Missing symbol $type = "green" } else { # system $type = "red"; } # fall-through to color palettes } # color palettes if (defined $type and $type eq "red") { my $r = 200 + int(55 * $v1); my $x = 50 + int(80 * $v1); return "rgb($r,$x,$x)"; } if (defined $type and $type eq "green") { my $g = 200 + int(55 * $v1); my $x = 50 + int(60 * $v1); return "rgb($x,$g,$x)"; } if (defined $type and $type eq "blue") { my $b = 205 + int(50 * $v1); my $x = 80 + int(60 * $v1); return "rgb($x,$x,$b)"; } if (defined $type and $type eq "yellow") { my $x = 175 + int(55 * $v1); my $b = 50 + int(20 * $v1); return "rgb($x,$x,$b)"; } if (defined $type and $type eq "purple") { my $x = 190 + int(65 * $v1); my $g = 80 + int(60 * $v1); return "rgb($x,$g,$x)"; } if (defined $type and $type eq "aqua") { my $r = 50 + int(60 * $v1); my $g = 165 + int(55 * $v1); my $b = 165 + int(55 * $v1); return "rgb($r,$g,$b)"; } if (defined $type and $type eq "orange") { my $r = 190 + int(65 * $v1); my $g = 90 + int(65 * $v1); return "rgb($r,$g,0)"; } return "rgb(0,0,0)"; } sub color_scale { my ($value, $max) = @_; my ($r, $g, $b) = (255, 255, 255); $value = -$value if $negate; if ($value > 0) { $g = $b = int(210 * ($max - $value) / $max); } elsif ($value < 0) { $r = $g = int(210 * ($max + $value) / $max); } return "rgb($r,$g,$b)"; } sub color_map { my ($colors, $func) = @_; if (exists $palette_map{$func}) { return $palette_map{$func}; } else { $palette_map{$func} = color($colors); return $palette_map{$func}; } } sub write_palette { open(FILE, ">$pal_file"); foreach my $key (sort keys %palette_map) { print FILE $key."->".$palette_map{$key}."\n"; } close(FILE); } sub read_palette { if (-e $pal_file) { open(FILE, $pal_file) or die "can't open file $pal_file: $!"; while ( my $line = ) { chomp($line); (my $key, my $value) = split("->",$line); $palette_map{$key}=$value; } close(FILE) } } my %Node; # Hash of merged frame data my %Tmp; # flow() merges two stacks, storing the merged frames and value data in %Node. sub flow { my ($last, $this, $v, $d) = @_; my $len_a = @$last - 1; my $len_b = @$this - 1; my $i = 0; my $len_same; for (; $i <= $len_a; $i++) { last if $i > $len_b; last if $last->[$i] ne $this->[$i]; } $len_same = $i; for ($i = $len_a; $i >= $len_same; $i--) { my $k = "$last->[$i];$i"; # a unique ID is constructed from "func;depth;etime"; # func-depth isn't unique, it may be repeated later. $Node{"$k;$v"}->{stime} = delete $Tmp{$k}->{stime}; if (defined $Tmp{$k}->{delta}) { $Node{"$k;$v"}->{delta} = delete $Tmp{$k}->{delta}; } delete $Tmp{$k}; } for ($i = $len_same; $i <= $len_b; $i++) { my $k = "$this->[$i];$i"; $Tmp{$k}->{stime} = $v; if (defined $d) { $Tmp{$k}->{delta} += $i == $len_b ? $d : 0; } } return $this; } # parse input my @Data; my $last = []; my $time = 0; my $delta = undef; my $ignored = 0; my $line; my $maxdelta = 1; # reverse if needed foreach (<>) { chomp; $line = $_; if ($stackreverse) { # there may be an extra samples column for differentials # XXX todo: redo these REs as one. It's repeated below. my ($stack, $samples) = (/^(.*)\s+?(\d+(?:\.\d*)?)$/); my $samples2 = undef; if ($stack =~ /^(.*)\s+?(\d+(?:\.\d*)?)$/) { $samples2 = $samples; ($stack, $samples) = $stack =~ (/^(.*)\s+?(\d+(?:\.\d*)?)$/); unshift @Data, join(";", reverse split(";", $stack)) . " $samples $samples2"; } else { unshift @Data, join(";", reverse split(";", $stack)) . " $samples"; } } else { unshift @Data, $line; } } # process and merge frames foreach (sort @Data) { chomp; # process: folded_stack count # eg: func_a;func_b;func_c 31 my ($stack, $samples) = (/^(.*)\s+?(\d+(?:\.\d*)?)$/); unless (defined $samples and defined $stack) { ++$ignored; next; } # there may be an extra samples column for differentials: my $samples2 = undef; if ($stack =~ /^(.*)\s+?(\d+(?:\.\d*)?)$/) { $samples2 = $samples; ($stack, $samples) = $stack =~ (/^(.*)\s+?(\d+(?:\.\d*)?)$/); } $delta = undef; if (defined $samples2) { $delta = $samples2 - $samples; $maxdelta = abs($delta) if abs($delta) > $maxdelta; } $stack =~ tr/<>/()/; # merge frames and populate %Node: $last = flow($last, [ '', split ";", $stack ], $time, $delta); if (defined $samples2) { $time += $samples2; } else { $time += $samples; } } flow($last, [], $time, $delta); warn "Ignored $ignored lines with invalid format\n" if $ignored; unless ($time) { warn "ERROR: No stack counts found\n"; my $im = SVG->new(); # emit an error message SVG, for tools automating flamegraph use my $imageheight = $fontsize * 5; $im->header($imagewidth, $imageheight); $im->stringTTF($im->colorAllocate(0, 0, 0), $fonttype, $fontsize + 2, 0.0, int($imagewidth / 2), $fontsize * 2, "ERROR: No valid input provided to flamegraph.pl.", "middle"); print $im->svg; exit 2; } if ($timemax and $timemax < $time) { warn "Specified --total $timemax is less than actual total $time, so ignored\n" if $timemax/$time > 0.02; # only warn is significant (e.g., not rounding etc) undef $timemax; } $timemax ||= $time; my $widthpertime = ($imagewidth - 2 * $xpad) / $timemax; my $minwidth_time = $minwidth / $widthpertime; # prune blocks that are too narrow and determine max depth while (my ($id, $node) = each %Node) { my ($func, $depth, $etime) = split ";", $id; my $stime = $node->{stime}; die "missing start for $id" if not defined $stime; if (($etime-$stime) < $minwidth_time) { delete $Node{$id}; next; } $depthmax = $depth if $depth > $depthmax; } # draw canvas, and embed interactive JavaScript program my $imageheight = ($depthmax * $frameheight) + $ypad1 + $ypad2; my $im = SVG->new(); $im->header($imagewidth, $imageheight); my $inc = < INC $im->include($inc); $im->filledRectangle(0, 0, $imagewidth, $imageheight, 'url(#background)'); my ($white, $black, $vvdgrey, $vdgrey) = ( $im->colorAllocate(255, 255, 255), $im->colorAllocate(0, 0, 0), $im->colorAllocate(40, 40, 40), $im->colorAllocate(160, 160, 160), ); $im->stringTTF($black, $fonttype, $fontsize + 5, 0.0, int($imagewidth / 2), $fontsize * 2, $titletext, "middle"); $im->stringTTF($black, $fonttype, $fontsize, 0.0, $xpad, $imageheight - ($ypad2 / 2), " ", "", 'id="details"'); $im->stringTTF($black, $fonttype, $fontsize, 0.0, $xpad, $fontsize * 2, "Reset Zoom", "", 'id="unzoom" onclick="unzoom()" style="opacity:0.0;cursor:pointer"'); $im->stringTTF($black, $fonttype, $fontsize, 0.0, $imagewidth - $xpad - 100, $fontsize * 2, "Search", "", 'id="search" onmouseover="searchover()" onmouseout="searchout()" onclick="search_prompt()" style="opacity:0.1;cursor:pointer"'); if ($palette) { read_palette(); } # draw frames while (my ($id, $node) = each %Node) { my ($func, $depth, $etime) = split ";", $id; my $stime = $node->{stime}; my $delta = $node->{delta}; $etime = $timemax if $func eq "" and $depth == 0; my $x1 = $xpad + $stime * $widthpertime; my $x2 = $xpad + $etime * $widthpertime; my ($y1, $y2); unless ($inverted) { $y1 = $imageheight - $ypad2 - ($depth + 1) * $frameheight + $framepad; $y2 = $imageheight - $ypad2 - $depth * $frameheight; } else { $y1 = $ypad1 + $depth * $frameheight; $y2 = $ypad1 + ($depth + 1) * $frameheight - $framepad; } my $samples = sprintf "%.0f", ($etime - $stime) * $factor; (my $samples_txt = $samples) # add commas per perlfaq5 =~ s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/g; my $info; if ($func eq "" and $depth == 0) { $info = "all ($samples_txt $countname, 100%)"; } else { my $pct = sprintf "%.2f", ((100 * $samples) / ($timemax * $factor)); my $escaped_func = $func; $escaped_func =~ s/&/&/g; $escaped_func =~ s//>/g; $escaped_func =~ s/"/"/g; unless (defined $delta) { $info = "$escaped_func ($samples_txt $countname, $pct%)"; } else { my $d = $negate ? -$delta : $delta; my $deltapct = sprintf "%.2f", ((100 * $d) / ($timemax * $factor)); $deltapct = $d > 0 ? "+$deltapct" : $deltapct; $info = "$escaped_func ($samples_txt $countname, $pct%; $deltapct%)"; } } my $nameattr = { %{ $nameattr{$func}||{} } }; # shallow clone my $jsinfo = $info; $jsinfo =~ s/'/\\'/g; $nameattr->{class} ||= "func_g"; $nameattr->{onmouseover} ||= "s('".$jsinfo."')"; $nameattr->{onmouseout} ||= "c()"; $nameattr->{onclick} ||= "zoom(this)"; $nameattr->{title} ||= $info; $im->group_start($nameattr); my $color; if ($func eq "-") { $color = $vdgrey; } elsif (defined $delta) { $color = color_scale($delta, $maxdelta); } elsif ($palette) { $color = color_map($colors, $func); } else { $color = color($colors, $hash, $func); } $im->filledRectangle($x1, $y1, $x2, $y2, $color, 'rx="2" ry="2"'); my $chars = int( ($x2 - $x1) / ($fontsize * $fontwidth)); my $text = ""; if ($chars >= 3) { # room for one char plus two dots $text = substr $func, 0, $chars; substr($text, -2, 2) = ".." if $chars < length $func; $text =~ s/&/&/g; $text =~ s//>/g; } $im->stringTTF($black, $fonttype, $fontsize, 0.0, $x1 + 3, 3 + ($y1 + $y2) / 2, $text, ""); $im->group_end($nameattr); } print $im->svg; if ($palette) { write_palette(); } # vim: ts=8 sts=8 sw=8 noexpandtab Devel-NYTProf-6.06/bin/nytprofhtml000755 000766 000024 00000234725 13305236552 017366 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## ## This script is part of the Devel::NYTProf distribution ## ## Copyright, contact and other information can be found ## at the bottom of this file, or by going to: ## https://metacpan.org/pod/Devel::NYTProf ## ########################################################### =head1 NAME nytprofhtml - Generate reports from Devel::NYTProf data =head1 SYNOPSIS Typical usage: $ perl -d:NYTProf some_perl_app.pl $ nytprofhtml --open Options synopsis: $ nytprofhtml [-h] [-d] [-m] [-o ] [-f ] [--open] =encoding ISO8859-1 =cut use warnings; use strict; use Carp; use Config qw(%Config); use Getopt::Long; use List::Util qw(sum max); use File::Copy; use File::Spec; use File::Which qw(which); use File::Path qw(rmtree); # Handle --profself before loading Devel::NYTProf::Core # (because it parses NYTPROF for options) BEGIN { if (grep { $_ eq '--profself' } @ARGV) { # profile nytprofhtml itself our $profself = "nytprof-nytprofhtml.out"; $ENV{NYTPROF} .= ":file=$profself:trace=1"; require Devel::NYTProf; END { warn "Profile of $0 written to $profself\n" if our $profself; } } } use Devel::NYTProf::Reader; use Devel::NYTProf::Core; use Devel::NYTProf::Util qw( fmt_float fmt_time fmt_incl_excl_time calculate_median_absolute_deviation get_abs_paths_alternation_regex html_safe_filename ); use Devel::NYTProf::Constants qw(NYTP_SCi_CALLING_SUB); our $VERSION = '6.06'; if ($VERSION != $Devel::NYTProf::Core::VERSION) { die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n"; } my $has_json = eval { require JSON::MaybeXS; JSON::MaybeXS->import(); 1 } or warn "Can't load JSON::MaybeXS module - HTML visualizations skipped ($@)\n"; my $script_ext = ($^O eq "MSWin32") ? "" : ".pl"; my $nytprofcalls = File::Spec->catfile($Config{'bin'}, 'nytprofcalls'); $nytprofcalls = which 'nytprofcalls' if not -e $nytprofcalls; die "Unable to find nytprofcalls in $Config{bin} or on the PATH" unless $nytprofcalls; my $flamegraph = File::Spec->catfile($Config{'bin'}, 'flamegraph') . $script_ext; $flamegraph = which "flamegraph$script_ext" if not -e $flamegraph; die "Unable to find flamegraph$script_ext in $Config{bin} or on the PATH" unless $flamegraph; my @treemap_colors = (0,2,4,6,8,10,1,3,5,7,9); # These control the limits for what the script will consider ok to severe times # specified in standard deviations from the mean time use constant SEVERITY_SEVERE => 2.0; # above this deviation, a bottleneck use constant SEVERITY_BAD => 1.0; use constant SEVERITY_GOOD => 0.5; # within this deviation, okay use constant NUMERIC_PRECISION => 5; my @on_ready_js; GetOptions( 'file|f=s' => \(my $opt_file = 'nytprof.out'), 'lib|l=s' => \my $opt_lib, 'out|o=s' => \(my $opt_out = 'nytprof'), 'delete|d!' => \my $opt_delete, 'open!' => \my $opt_open, 'help|h' => sub { exit usage() }, 'minimal|m!'=> \my $opt_minimal, 'flame!' => \(my $opt_flame = 1), 'mergeevals!'=> \(my $opt_mergeevals = 1), 'flamewidth=i' => \(my $opt_flame_width = 1200), 'profself!' => sub { }, # handled in BEGIN above 'debug!' => \my $opt_debug, ) or do { exit usage(); }; DB::set_option('blocks', 0) if $opt_minimal; sub usage { print <, -f Read profile data from the specified file [default: nytprof.out] --out , -o Write report files to this directory [default: nytprof] --delete, -d Delete any old report files in first --open Open the generated report in a web browser --lib , -l Add to the beginning of \@INC --no-flame Disable flame graph (and call stacks processing) --flamewidth Width of the flame graph [default: 1200] --minimal, -m Don't generate graphviz .dot files or block/sub-level reports --no-mergeevals Disable merging of string evals --help, -h Print this message This script of part of the Devel::NYTProf distribution. See http://metacpan.org/release/Devel-NYTProf/ for details and copyright. END return 0; } # handle output location if (!-e $opt_out) { # will be created } elsif (!-d $opt_out) { die "$0: Specified output directory '$opt_out' already exists as a file!\n"; } elsif (!-w $opt_out) { die "$0: Unable to write to output directory '$opt_out'\n"; } else { if (defined($opt_delete)) { print "Deleting existing $opt_out directory\n"; rmtree($opt_out); } } # handle custom lib path if (defined($opt_lib)) { warn "$0: Specified lib directory '$opt_lib' does not exist.\n" unless -d $opt_lib; require lib; lib->import($opt_lib); } $SIG{USR2} = \&Carp::cluck if exists $SIG{USR2}; # some platforms don't have SIGUSR2 (Windows) my $reporter = new Devel::NYTProf::Reader($opt_file, { quiet => 0, skip_collapse_evals => !$opt_mergeevals, }); # place to store this $reporter->output_dir($opt_out); # set formatting for html $reporter->set_param( 'header', sub { my ($profile, $fi, $output_filestr, $level) = @_; my $profile_level_buttons = ($fi->is_eval) ? '' : get_level_buttons($profile->get_profile_levels, $output_filestr, $level); my $subhead = qq{  $profile_level_buttons
For ${ \($profile->{attribute}{application}) } }; my $html_header = get_html_header("Profile of ".$fi->filename_without_inc); my $page_header = get_page_header( profile => $profile, title => "NYTProf Performance Profile", subtitle => $subhead, ); my $filename_escaped = _escape_html($fi->filename); my @intro_rows = ( [ "Filename", $fi->is_file ? sprintf(q{%s}, $fi->filename, $filename_escaped) : $filename_escaped ], [ "Statements", sprintf "Executed %d statements in %s", $fi->sum_of_stmts_count, fmt_time($fi->sum_of_stmts_time) ], ); if ($fi->is_eval) { push @intro_rows, [ "Eval Invoked At", sprintf q{%s line %d}, $reporter->href_for_file($fi->eval_fi, $fi->eval_line), _escape_html($fi->eval_fi->filename), $fi->eval_line ]; my @sibling_html; for my $e_fi ($fi->sibling_evals) { if ($e_fi == $fi) { push @sibling_html, 1+@sibling_html; } else { push @sibling_html, sprintf qq{%d}, $reporter->href_for_file($e_fi), 1+@sibling_html; } } push @intro_rows, [ "Sibling evals", join ", ", @sibling_html ] if @sibling_html >= 2; } my $intro_table = join "\n", map { sprintf q{%s%s}, @$_ } @intro_rows; return join "\n", $html_header, $page_header, q{

}, qq{$intro_table
}, } ); $reporter->set_param( 'taintmsg', qq{
WARNING!
\n
The source file used to generate this report was modified after the profiler data was generated. The data might be out of sync with the modified source code so you should regenerate it. Meanwhile, the data on this page might not make much sense!
\n} ); $reporter->set_param( 'sawampersand', sub { my ($profile, $fi) = @_; my $line = $profile->{attribute}{sawampersand_line}; return qq{
NOTE!
\n

While profiling this file Perl noted the use of one or more special variables that impact the performance of all regular expressions in the program.

Use of the "\$`", "\$&", and "\$'" variables should be replaced with faster alternatives.
See the WARNING at the end of the Capture Buffers section of the perlre documentation.

The use is detected by perl at compile time but by NYTProf during execution. NYTProf first noted it when executing line $line. That was probably the first statement executed by the program after perl compiled the code containing the variables. If the variables can't be found by studying the source code, try using the Devel::FindAmpersand or B::Lint modules.

\n} } ) if $] < 5.017008; $reporter->set_param( 'merged_fids', sub { my ($profile, $fi) = @_; my $merged_fids = $fi->meta->{merged_fids}; my $evals_shown = 1 + scalar @$merged_fids; my @siblings = $fi->sibling_evals; my $merged_siblings = sum(map { scalar @{$_->meta->{merged_fids}||[]} } @siblings); my $evals_total = @siblings + $merged_siblings; my @msg; push @msg, sprintf qq{ The data used to generate this report page was merged from %s
of the string eval on line %d of %s. }, ($evals_shown == $evals_total) ? sprintf("all %d executions", $evals_shown) : sprintf("%d of the %d executions", $evals_shown, $evals_total), $fi->eval_line, $fi->eval_fi->filename; push @msg, qq{ The source code shown below is the text of just one of the calls to the eval.
\n This report page might not make much sense because the argument source code of those eval calls varied.
\n } if $fi->meta->{merged_fids_src_varied}; return sprintf qq{
NOTE!
\n
%s
}, join "
", @msg; }, ); sub calc_mad_from_objects { my ($ary, $meth, $ignore_zeros) = @_; return calculate_median_absolute_deviation([map { scalar $_->$meth } @$ary], $ignore_zeros); } sub subroutine_table { my ($profile, $fi, $max_subs, $sortby) = @_; $sortby ||= 'excl_time'; my $subs_in_file = ($fi) ? $profile->subs_defined_in_file($fi, 0) : $profile->subname_subinfo_map; return "" unless $subs_in_file && %$subs_in_file; my $inc_path_regex = get_abs_paths_alternation_regex([$profile->inc], qr/^|\[/); my $filestr = ($fi) ? $fi->filename : undef; # XXX slow - use Schwartzian transform or via XS or Sort::Key my @subs = sort { $b->$sortby <=> $a->$sortby or $a->subname cmp $b->subname } values %$subs_in_file; # in the overall summary, don't show subs that were never called @subs = grep { $_->calls > 0 } @subs if !$fi; my $dev_incl_time = calc_mad_from_objects(\@subs, 'incl_time', 1); my $dev_excl_time = calc_mad_from_objects(\@subs, 'excl_time', 1); my $dev_calls = calc_mad_from_objects(\@subs, 'calls', 1); my $dev_call_count = calc_mad_from_objects(\@subs, 'caller_count', 1); my $dev_call_fids = calc_mad_from_objects(\@subs, 'caller_fids', 1); my @subs_to_show = ($max_subs) ? splice @subs, 0, $max_subs : @subs; my $qualifier = (@subs > @subs_to_show) ? "Top $max_subs " : ""; my $max_pkg_name_len = max(map { length($_->package) } @subs_to_show); my $sub_links; my $sortby_desc = ($sortby eq 'excl_time') ? "exclusive time" : "inclusive time"; $sub_links .= qq{ }; my $profiler_active = $profile->{attribute}{profiler_active}; my @rows; $sub_links .= "\n"; for my $sub (@subs_to_show) { $sub_links .= ""; $sub_links .= determine_severity($sub->calls || 0, $dev_calls); $sub_links .= determine_severity($sub->caller_count || 0, $dev_call_count); $sub_links .= determine_severity($sub->caller_fids || 0, $dev_call_fids); $sub_links .= determine_severity($sub->excl_time || 0, $dev_excl_time, 1, sprintf("%.1f%%", $sub->excl_time/$profiler_active*100) ); $sub_links .= determine_severity($sub->incl_time || 0, $dev_incl_time, 1, sprintf("%.1f%%", $sub->incl_time/$profiler_active*100) ); my @hints; # package and subname my $subname = $sub->subname; if (my $merged_sub_names = $sub->meta->{merged_sub_names}) { push @hints, sprintf "merge of %d subs", 1+scalar @$merged_sub_names; } my ($pkg, $subr) = ($subname =~ /^(.*::)(.*?)$/) ? ($1, $2) : ('', $subname); # remove OWN filename from eg __ANON__[(eval 3)[/long/path/name.pm:99]:53] # becomes __ANON__[(eval 3)[:99]:53] # XXX doesn't work right if $filestr isn't full filename $subr =~ s/\Q$filestr\E:(\d+)/:$1/g if $filestr; # remove @INC prefix from other paths $subr =~ s/$inc_path_regex//; # for __ANON__[/very/long/path...] $sub_links .= qq{}, $max_pkg_name_len+2, $pkg, $reporter->href_for_sub($subname), $subr, (@hints) ? " (".join("; ",@hints).")" : ""; $sub_links .= "\n"; } $sub_links .= q{}; $sub_links .= q{
${qualifier}Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
}; # hidden span is for tablesorter to sort on $sub_links .= sprintf(qq{%s::%s}, $pkg, $subr); if ($sub->is_xsub) { my $is_opcode = ($pkg eq 'CORE' or $subr =~ /^CORE:/); unshift @hints, ($is_opcode) ? 'opcode' : 'xsub'; } if (my $recdepth = $sub->recur_max_depth) { unshift @hints, sprintf "recurses: max depth %d, inclusive time %s", $recdepth, fmt_time($sub->recur_incl_time); } $sub_links .= sprintf qq{%*s%s%s
}; # make table sortable if it contains all the subs push @on_ready_js, q< $("#subs_table").tablesorter({ sortList: [[3,1]], headers: { 3: { sorter: 'fmt_time' }, 4: { sorter: 'fmt_time' } } }); $(".floatHeaders").each( function(){ $(this).floatThead(); } ); show_fragment_target(); $(window).on('hashchange', function(e){ show_fragment_target(); }); > if @subs_to_show == @subs; return $sub_links; } $reporter->set_param( 'datastart', sub { my ($profile, $fi) = @_; my $filestr = $fi->filename; my $sub_table = subroutine_table($profile, $fi, undef, undef); if ($sub_table and not $opt_minimal) { my $dot_file = html_safe_filename($filestr) . ".dot"; $sub_table .= qq{ Call graph for these subroutines as a Graphviz dot language file. }; our %dot_file_generated; if ($dot_file_generated{$dot_file}++) { # just once for line/block/sub my $subs_in_file = $profile->subs_defined_in_file($filestr, 0); # include subs defined in this file # and/or called from subs defined in this file #warn "$dot_file: @{[ keys %$subs_in_file ]}\n"; my $sub_filter = sub { my ($si, $calledby) = @_; return 1 if not defined $calledby; my $subname = $si->subname; my $include = ($subs_in_file->{$subname} || $subs_in_file->{$calledby}); #warn "Call graph $subname<-$calledby: ".($include ? "SHOW" : "skip")."\n"; return $include; }; output_subs_callgraph_dot_file($reporter, $dot_file, $sub_filter, 0); } } return qq{ $sub_table \n }; } ); $reporter->set_param( footer => sub { my ($profile, $fi) = @_; my $footer = get_footer($profile); return "
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
$footer"; } ); $reporter->set_param(mk_report_source_line => \&mk_report_source_line); $reporter->set_param(mk_report_xsub_line => \&mk_report_xsub_line ); $reporter->set_param(mk_report_separator_line => \&mk_report_separator_line ); sub mk_report_source_line { my ($linenum, $line, $stats_for_line, $stats_for_file, $profile, $fi) = @_; my $l = sprintf(qq{%s}, $linenum, $linenum); my $s = report_src_line(undef, $linenum, $line, $profile, $fi, $stats_for_line); return "$l$s\n" if not %$stats_for_line; return join "", "$l", determine_severity($stats_for_line->{'calls'}, $stats_for_file->{'calls'}), determine_severity($stats_for_line->{'time'}, $stats_for_file->{'time'}, 1, \sprintf("Avg %s", fmt_time($stats_for_line->{'time/call'})||'--' )), determine_severity($stats_for_line->{'subcall_count'}, $stats_for_file->{subcall_count}, 0), determine_severity($stats_for_line->{'subcall_time'}, $stats_for_file->{subcall_time}, 1), $s, "\n"; } sub mk_report_xsub_line { my ($subname, $line, $stats_for_line, $stats_for_file, $profile, $fi) = @_; (my $anchor = $subname) =~ s/\W/_/g; return join "", sprintf(qq{%s}, $anchor, ''), "", report_src_line(undef, undef, $line, $profile, $fi, $stats_for_line), "\n"; } sub mk_report_separator_line { my ($profile, $fi) = @_; return join "", sprintf(qq{%s}, '', ' '), "", '', "\n"; } sub _escape_html { local $_ = shift; s/\t/ /g; # XXX incorrect for most non-leading tabs s/&/&/g; s//>/g; s{\n}{
}g; # for xsub pseudo-sub declarations s{"}{"}g; # for attributes like title="..." return $_; } sub report_src_line { my ($value, undef, $linesrc, $profile, $fi, $stats_for_line) = @_; $linesrc = _escape_html($linesrc); our $inc_path_regex ||= get_abs_paths_alternation_regex([$profile->inc]); my @prologue; # for each of the subs defined on this line, who called them my $subdef_info = $stats_for_line->{subdef_info} || []; for my $sub_info (@$subdef_info) { my $callers = $sub_info->caller_fid_line_places; next unless $callers && %$callers; my $subname = $sub_info->subname; my @callers; while (my ($fid, $fid_line_info) = each %$callers) { for my $line (keys %$fid_line_info) { my $sc = $fid_line_info->{$line}; warn "$linesrc $subname caller info missing" if !@$sc; next if !@$sc; push @callers, [ $fid, $line, @$sc ]; } } my $total_calls = sum(my @caller_calls = map { $_->[2] } @callers); push @prologue, sprintf "# spent %s within %s which was called%s:", fmt_incl_excl_time($sub_info->incl_time, $sub_info->excl_time), $subname, ($total_calls <= 1) ? "" : sprintf(" %d times, avg %s/call", $total_calls, fmt_time($sub_info->incl_time / $total_calls)); push @prologue, sprintf "# (data for this subroutine includes %d others that were merged with it)", scalar @{$sub_info->meta->{merged_sub_names}} if $sub_info->meta->{merged_sub_names}; my $max_calls = max(@caller_calls); # order by most frequent caller first, then by time @callers = sort { $b->[2] <=> $a->[2] || $b->[3] <=> $a->[3] } @callers; for my $caller (@callers) { my ($fid, $line, $count, $incl_time, $excl_time, undef, undef, undef, undef, $calling_subs) = @$caller; my @subnames = sort keys %{$calling_subs || {}}; my $subname = (@subnames) ? " by " . join(" or ", @subnames) : ""; my $caller_fi = $profile->fileinfo_of($fid); if (!$caller_fi) { # should never happen warn sprintf "Caller of %s, from fid %d line %d has no fileinfo (%s)", $sub_info, $fid, $line, $subname; die 2; next; } my $avg_time = ""; $avg_time = sprintf ", avg %s/call", fmt_time($incl_time / $count) if $count > 1; my $times = sprintf " (%s+%s)", fmt_time($excl_time), fmt_time($incl_time - $excl_time); my $filename = $caller_fi->filename($fid); my $line_desc = "line $line of $filename"; $line_desc =~ s/ of \Q$filename\E$//g if $filename eq $fi->filename; # remove @INC prefix from paths $line_desc =~ s/$inc_path_regex//g; my $href = $reporter->href_for_file($caller_fi, $line); push @prologue, sprintf q{# %*s times%s%s at %s%s}, length($max_calls), $count, $times, $subname, $href, $line_desc, $avg_time; $prologue[-1] =~ s/^(# +)1 times/$1 once/; # better English } } my $prologue = ''; $prologue = sprintf qq{
%s
}, join("\n", @prologue) if @prologue; my $epilogue = ''; my $ws; # give details of each of the subs called by this line my $subcall_info = $stats_for_line->{subcall_info}; if ($subcall_info && %$subcall_info) { my @calls_to = sort { $subcall_info->{$b}[1] <=> $subcall_info->{$a}[1] or # incl_time $a cmp $b } keys %$subcall_info; my $max_calls_to = max(map { $_->[0] } values %$subcall_info); $ws ||= ($linesrc =~ m/^((?: |\s)+)/) ? $1 : ''; my $subs_called_html = join "\n", map { my $subname = $_; my ($count, $incl_time, $reci_time, $rec_depth) = (@{$subcall_info->{$subname}})[0,1,5,6]; my $html = sprintf qq{%s# spent %s making %*d call%s to }, $ws, fmt_time($incl_time+$reci_time, 5), length($max_calls_to), $count, $count == 1 ? "" : "s"; (my $subname_trimmed = $subname) =~ s/$inc_path_regex//g; $html .= sprintf qq{%s}, $reporter->href_for_sub($subname), $subname_trimmed; $html .= sprintf qq{, avg %s/call}, fmt_time(($incl_time+$reci_time) / $count), if $count > 1; if ($rec_depth) { $html .= sprintf qq{, recursion: max depth %d, sum of overlapping time %s}, $rec_depth, fmt_time($reci_time); } $html; } @calls_to; $epilogue .= sprintf qq{
%s
}, $subs_called_html; } # give details of each of the string evals executed on this line my $evals_called = $stats_for_line->{evalcall_info}; if ($evals_called && %$evals_called) { $ws ||= ($linesrc =~ m/^((?: |\s)+)/) ? $1 : ''; my @eval_fis = sort { $b->sum_of_stmts_time(1) <=> $a->sum_of_stmts_time(1) or $a->filename cmp $b->filename } values %$evals_called; my $evals_called_html = join "\n", map { my $eval_fi = $_; my $sum_of_stmts_time = $eval_fi->sum_of_stmts_time; my ($what, $extra) = ("string eval", ""); my $merged_fids = $eval_fi->meta->{merged_fids}; if ($merged_fids) { $what = sprintf "%d string evals (merged)", 1+@$merged_fids; } my @nested_evals = $eval_fi->has_evals(1); my $nest_eval_time = 0; if (@nested_evals) { $nest_eval_time = sum map { $_->sum_of_stmts_time } @nested_evals; $extra .= sprintf ", %s here plus %s in %d nested evals", fmt_time($sum_of_stmts_time), fmt_time($nest_eval_time), scalar @nested_evals if $nest_eval_time; } if (my @subs_defined = $eval_fi->subs_defined(1)) { my $sub_count = @subs_defined; my $call_count = sum map { $_->calls } @subs_defined; my $excl_time = sum map { $_->excl_time } @subs_defined; $extra .= sprintf "
%s# includes %s spent executing %d call%s to %d sub%s defined therein.", $ws, fmt_time($excl_time, 2), $call_count, ($call_count != 1) ? 's' : '', $sub_count, ($sub_count != 1) ? 's' : '' if $call_count; } my $link = sprintf(q{%s}, $reporter->href_for_file($eval_fi), $what); my $html = sprintf qq{%s# spent %s executing statements in %s%s}, $ws, fmt_time($sum_of_stmts_time+$nest_eval_time, 5), $link, $extra; $html; } @eval_fis; $epilogue .= sprintf qq{
%s
}, $evals_called_html; } return qq{$prologue$linesrc$epilogue}; } # set output options $reporter->set_param('suffix', '.html'); # output a css file too (optional, but good for pretty pages) $reporter->_output_additional('style.css', get_css()); # generate the files $reporter->report(); output_subs_index_page($reporter, "index-subs-excl.html", 'excl_time'); output_index_page($reporter, "index.html"); output_js_files($reporter); open_browser_on("$opt_out/index.html") if $opt_open; exit 0; # # SUBROUTINES # # output an html indexing page or subroutines sub output_subs_index_page { my ($r, $filename, $sortby) = @_; my $profile = $reporter->{profile}; open my $fh, '>', "$opt_out/$filename" or croak "Unable to open file $opt_out/$filename: $!"; print $fh get_html_header("Subroutine Index - NYTProf"); print $fh get_page_header(profile => $profile, title => "Performance Profile Subroutine Index"); print $fh qq{

}; # Show top subs across all files print $fh subroutine_table($profile, undef, 0, $sortby); my $footer = get_footer($profile); print $fh "
$footer"; close $fh; } # output an html indexing page with some information to help navigate potential # large numbers of profiled files. Optional, recommended sub output_index_page { my ($r, $filename) = @_; my $profile = $reporter->{profile}; ### open my $fh, '>', "$opt_out/$filename" or croak "Unable to open file $opt_out/$filename: $!"; my $application = $profile->{attribute}{application}; (my $app = $application) =~ s:.*/::; # basename $app =~ s/ .*//; print $fh get_html_header("NYTProf $app"); print $fh get_page_header(profile => $profile, title => "Performance Profile Index", skip_link_to_index=>1); print $fh qq{

}; # overall description my @all_fileinfos = $profile->all_fileinfos; my $eval_fileinfos = $profile->eval_fileinfos; my $summary = sprintf "Profile of %s for %s (of %s),", $application, fmt_time($profile->{attribute}{profiler_active}), fmt_time($profile->{attribute}{profiler_duration}); $summary .= " executing"; $summary .= sprintf " %d statements and", $profile->{attribute}{total_stmts_measured} -$profile->{attribute}{total_stmts_discounted} if $profile->{option}{stmts}; $summary .= sprintf " %d subroutine calls", $profile->{attribute}{total_sub_calls}; $summary .= sprintf " in %d source files", @all_fileinfos - $eval_fileinfos; $summary .= sprintf " and %d string evals", $eval_fileinfos if $eval_fileinfos; printf $fh qq{
%s.
}, _escape_html($summary); # generate name-sorted select options for files, if there are many if ($profile->noneval_fileinfos > 30) { print $fh qq{
}; print $fh qq{
\n"; } my $call_stacks_file = "all_stacks_by_time.calls"; my $call_stacks_svg = "all_stacks_by_time.svg"; if ($profile->{option}{calls} && $opt_flame) { my $mk_flamegraph = sub { my $total_sub_calls = $profile->{attribute}{total_sub_calls}; my $is_big = ($total_sub_calls <= 1_000_000); warn sprintf "Extracting subroutine call data%s ...\n", ($is_big) ? "" : " (There were $total_sub_calls of them, so this may take some time, or cancel and use --no-flame to skip this step.)"; system("\"$nytprofcalls\" $opt_file > $opt_out/$call_stacks_file") == 0 or die "Generating $opt_out/$call_stacks_file failed\n"; my %subname_subinfo_map = %{ $profile->subname_subinfo_map }; warn "Extracting subroutine links\n"; my $subattr = "$opt_out/flamegraph_subattr.txt"; open my $subattrfh, ">", $subattr or die "Error creating $subattr: $!\n"; while ( my ($subname, $si) = each %subname_subinfo_map ) { next unless $si->incl_time; print $subattrfh join("\t", $subname, q{href=}.$reporter->url_for_sub($subname), )."\n"; } close $subattrfh or die "Error writing $subattr: $!\n"; warn "Generating subroutine stack flame graph ...\n"; # factor to scale the values to microseconds my $factor = 1_000_000 / $profile->{attribute}{ticks_per_sec}; # total (width) for flamegraph is profiler_active in ticks my $run_us = $profile->{attribute}{profiler_active} * $profile->{attribute}{ticks_per_sec}; system("\"$flamegraph\" --nametype=sub --countname=microseconds --factor=$factor --width=$opt_flame_width --nameattr=$subattr --hash --total=$run_us $opt_out/$call_stacks_file > $opt_out/$call_stacks_svg") == 0 or die "Generating $opt_out/$call_stacks_svg failed\n"; print $fh qq{
\n}; print $fh qq{SVG not supported\n}; print $fh qq{

The Flame Graph above is a visualization of the time spent in distinct call stacks. The colors and x-axis position are not meaningful.

\n}; print $fh qq{
\n}; 1; }; eval { $mk_flamegraph->() } or warn $@; } # Show top subs across all files my $max_subs = 15; # keep it less than a page so users can see the file table my $all_subs = keys %{$profile->{sub_subinfo}}; print $fh subroutine_table($profile, undef, $max_subs, undef); if ($all_subs > $max_subs) { print $fh sprintf qq{
See all %d subroutines
}, "index-subs-excl.html", $all_subs; } if ($has_json) { output_subs_treemap_page($reporter, "subs-treemap-excl.html", "Subroutine Exclusive Time Treemap", sub { shift->excl_time }); print $fh q{
You can view a treemap of subroutine exclusive time, grouped by package.
}; } else { print $fh q{
(Can't create visual treemap of subroutine exclusive times without the JSON::MaybeXS module.)
}; } if (not $opt_minimal) { output_subs_callgraph_dot_file($reporter, "packages-callgraph.dot", undef, 1); print $fh q{NYTProf also generates call-graph files in } .q{Graphviz format: } .q{inter-package calls}; output_subs_callgraph_dot_file($reporter, "subs-callgraph.dot", undef, 0); print $fh q{, all inter-subroutine calls}; print $fh q{ (probably too complex to render easily)} if $all_subs > 200; # arbitrary print $fh q{.
}; } print $fh q{
You can hover over some table cells and headings to view extra information.}; print $fh q{
Some table column headings can be clicked on to sort the table by that column.}; print $fh q{
}; output_file_table($fh, $profile, 1); my $footer = get_footer($profile); print $fh "
$footer"; close $fh; } # = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = # treemap subs sub js_for_new_treemap { my ($name, $new_args, $tree_data) = @_; return '' unless $has_json; my $default_new_args = { titleHeight => 0, # no titles addLeftClickHandler => 1, # zoom in #addRightClickHandler => 1, # zoom out (XXX but disables right click menu) offset => 0, # (0/2/4) extra padding around nested levels Color => { allow => 1, # value range for the $color property minValue => 0, maxValue => scalar @treemap_colors, # corresponding color range [R,G,B]: minColorValue => [0, 255, 50], maxColorValue => [255, 0, 50], }, Tips => { allow => 1, offsetX => 20, offsetY => 20, }, selectPathOnHover => 1, # adds "over-" css class to elements }; exists $new_args->{$_} or $new_args->{$_} = $default_new_args->{$_} for keys %$default_new_args; my $new_args_json = encode_json($new_args); my $tree_data_json = encode_json($tree_data); my $js = qq{ function init_$name() { var tm_args = $new_args_json; //This method is invoked when a DOM element is created. //Its useful to set DOM event handlers here or manipulate //the DOM Treemap nodes. tm_args.onCreateElement = function(content, tree, isLeaf, leaf){ //Add background image for cushion effect if(isLeaf) { var style = leaf.style, width = parseInt(style.width) - 2, height = parseInt(style.height) - 2; // don't add gradient if too small to be worth the cost if (width < 10 || height < 10) { // is narrow if (width < 50 && height < 50) // is small return; } leaf.innerHTML = tree.name + ""; style.width = width + "px"; style.height = height + "px"; } }; // add content to the tooltip when a node is hovered // move to separate function later tm_args.Tips.onShow = function(tip, node, isLeaf, domElement) { tip.innerHTML = node.data.tip; }; TM.Squarified.implement({ 'onLeftClick': function(elem) { // zoom in one level //if is leaf var node = TreeUtil.getSubtree(this.tree, elem.parentNode.id); if(node.children && node.children.length == 0) { var oldparent = node, newparent = node; while(newparent.id != this.shownTree.id) { oldparent = newparent; newparent = TreeUtil.getParent(this.tree, newparent.id); } this.view(oldparent.id); } else { this.enter(elem); } } }); TM.Squarified.implement({ createBox: function(json, coord, html) { if((coord.width * coord.height > 1) && json.data.\$area > 0) { if(!this.leaf(json)) var box = this.headBox(json, coord) + this.bodyBox(html, coord); else var box = this.leafBox(json, coord); return this.contentBox(json, coord, box); } else { return ""; //return empty string } } }); var $name = new TM.Squarified(tm_args); var json = $tree_data_json; $name.loadJSON(json); } }; return $js; } sub pl { # dumb but sufficient pluralization my ($fmt, $n) = @_; sprintf $fmt.($n == 1 ? "" : "s"), $n; } sub package_subinfo_map_to_tm_data { my ($package_tree_subinfo_map, $area_sub) = @_; my $sub_tip_html = sub { my $si = shift; my @html; push @html, sprintf "

%s

", $si->subname; push @html, sprintf "Called %s from %s in %s", pl("%d time", $si->calls), pl("%d place", scalar $si->caller_places), pl("%d file", scalar $si->caller_fids); my $total_time = $si->profile->{attribute}{profiler_duration}; my $incl_time = $si->incl_time; push @html, sprintf "Inclusive time: %s, %.2f%%", fmt_time($incl_time), $total_time ? $incl_time/$total_time*100 : 0; my $excl_time = $si->excl_time; push @html, sprintf "Exclusive time: %s, %.2f%%", fmt_time($excl_time), $total_time ? $excl_time/$total_time*100 : 0 if $excl_time ne $incl_time; if (my $mrd = $si->recur_max_depth) { push @html, sprintf "Recursion: max depth %d, recursive inclusive time %s", $mrd, fmt_time($si->recur_incl_time); } return join("
", @html)."

"; }; my $leaf_data_sub = sub { my ($subinfo, $area_from, $color) = @_; my $data = { '$area' => $area_from->($subinfo), '$color' => $color, tip => $sub_tip_html->($subinfo), map({ $_ => $subinfo->$_() } qw(subname incl_time excl_time)) }; return $data; }; our $nid; my $node_mapper; $node_mapper = sub { my ($k, $v, $title) = @_; $title = ($title) ? '::'.$k : $k; my $n = { id => "n".++$nid, name => $title, }; my @kids; for my $pkg_elem (keys %$v) { my $infos = $v->{$pkg_elem}; if (ref $infos eq 'HASH') { # recurse into subpackages push @kids, $node_mapper->($pkg_elem, $infos, $title); next; } # subs within this package our $color_seqn; # all subs in pkg get same color my $color = $treemap_colors[ $color_seqn++ % @treemap_colors ]; for my $info (@$infos) { # don't bother including subs that don't have any data # (unless we've not got any subs yet, to avoid problems elsewhere) next if $area_sub->($info) <= 0; push @kids, { id => ++$nid."-".$info->subname, name => $info->subname_without_package, data => $leaf_data_sub->($info, $area_sub, $color), children => [], }; } } $n->{data}{'$area'} = (@kids) ? sum(map { $_->{data}{'$area'} } @kids) : 0 if not defined $n->{data}{'$area'}; $n->{children} = \@kids; return $n; }; return $node_mapper->('', $package_tree_subinfo_map, ''); } sub output_treemap_code { my (%spec) = @_; my $fh = $spec{fh}; my $tm_id = 'tm'.$spec{id}; my $root_id = 'infovis'.$spec{id}; my $treemap_data = $spec{get_data}->(); $treemap_data->{name} = $spec{title} if $spec{title}; my $tm_js = js_for_new_treemap($tm_id, { rootId => $root_id }, $treemap_data); print $fh qq{\n}; push @on_ready_js, qq{init_$tm_id(); }; return $root_id; } sub output_subs_treemap_page { my ($r, $filename, $title, $area_sub) = @_; my $profile = $reporter->{profile}; open(my $fh, '>', "$opt_out/$filename") or croak "Unable to open file $opt_out/$filename: $!"; $title ||= "Subroutine Time Treemap"; print $fh get_html_header("$title - NYTProf", { add_jit => "Treemap" }); print $fh get_page_header( profile => $profile, title => $title); my @specs; push @specs, { id => 1, title => "Treemap of subroutine exclusive time", get_data => sub { package_subinfo_map_to_tm_data( $profile->package_subinfo_map(0,1), $area_sub || sub { shift->excl_time }, 0); } }; my @root_ids; for my $spec (@specs) { push @root_ids, output_treemap_code( fh => $fh, profile => $profile, %$spec ); } print $fh qq{

Boxes represent time spent in a subroutine. Coloring represents packages. Click to drill-down into package hierarchy, reload page to reset.
\n}; print $fh qq{
\n}; print $fh qq{
\n} for @root_ids; print $fh qq{
\n}; my $footer = get_footer($profile); print $fh "$footer"; close $fh; } # = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = sub output_subs_callgraph_dot_file { my ($r, $filename, $sub_filter, $only_show_packages) = @_; my $profile = $reporter->{profile}; my $subinfos = $profile->subname_subinfo_map; my $dot_file = "$opt_out/$filename"; open my $fh, '>', $dot_file or croak "Unable to open file $dot_file: $!"; my $inc_path_regex = get_abs_paths_alternation_regex([$profile->inc], qr/^|\[/); my $dotnode = sub { my $name = shift; $name =~ s/$inc_path_regex//; $name =~ s/"/\\"/g; return '"'.$name.'"'; }; print $fh "digraph {\n"; # } print $fh "graph [overlap=false]\n"; # target="???", URL="???" # gather link info my %sub2called_by; for my $subname (keys %$subinfos) { my $si = $subinfos->{$subname}; next unless $si->calls; # skip subs never called next if $sub_filter and not $sub_filter->($si, undef); my $called_by_subnames = $si->called_by_subnames; if (!%$called_by_subnames) { warn sprintf "%s has no caller subnames but a call count of %d\n", $subname, $si->calls; next; } if ($sub_filter) { my @delete = grep { !$sub_filter->($si, $_) } keys %$called_by_subnames; if (@delete) { # shallow copy so we can edit it safely $called_by_subnames = { %$called_by_subnames }; delete @{$called_by_subnames}{@delete}; } next if !keys %$called_by_subnames; } $sub2called_by{$subname} = $called_by_subnames; } # list of all subs to be included in graph (has duplicates) my %pkg_subs; for (keys %sub2called_by, map { keys %$_ } values %sub2called_by) { m/^(.*)::(.*)?$/ or warn "Strange sub name '$_'"; $pkg_subs{$1}{$_} = $sub2called_by{$_} || {}; } #stmt : node_stmt | edge_stmt | attr_stmt | ID '=' ID | subgraph #attr_stmt : (graph | node | edge) attr_list #attr_list : '[' [ a_list ] ']' [ attr_list ] #a_list : ID [ '=' ID ] [ ',' ] [ a_list ] #subgraph : [ subgraph [ ID ] ] '{' stmt_list '}' if ($only_show_packages) { my %once; # XXX many shapes cause v.large graphs with nodes v.far apart # when using neato (energy minimized) possibly a neato bug # some shapes, like doublecircle seem to avoid the problem. print $fh "node [shape=doublecircle];\n"; while ( my ($pkg, $subs) = each %pkg_subs ) { my @called_by = map { keys %$_ } values %$subs; for my $called_by (@called_by) { (my $called_by_pkg = $called_by) =~ s/^(.*)::.*?$/$1/; my $link = sprintf qq{%s -> %s;\n}, $dotnode->("$called_by_pkg"), $dotnode->("$pkg"); $once{$link} = 1; } } print $fh $_ for keys %once; } else { # output nodes and gather link info while ( my ($pkg, $pkg_subs) = each %pkg_subs) { (my $pkgmangled = $pkg) =~ s/\W+/_/g; # node_stmt: node_id [ attr_list ] printf $fh "subgraph cluster_%s {\n", $pkgmangled; # } printf $fh "\tlabel=%s;\n", $dotnode->($pkg); for my $subname (keys %$pkg_subs) { # node_stmt: node_id [ attr_list ] #printf $fh qq{\tnode [ %s ]}, ... printf $fh qq{\t%s;\n}, $dotnode->($subname); } # { - just to balance the brace below printf $fh "}\n"; } while ( my ($subname, $called_by_subnames) = each %sub2called_by ) { for my $called_by (keys %$called_by_subnames) { # edge_stmt : (node_id | subgraph) edgeRHS [ attr_list ] # edgeRHS : edgeop (node_id | subgraph) [ edgeRHS ] printf $fh qq{%s -> %s;\n}, $dotnode->($called_by), $dotnode->($subname); } } } print $fh "}\n"; close $fh; #system("open '$dot_file'"); die 1; return; } # = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = sub output_js_files { my ($profile) = @_; # find the js, gif, css etc files installed with Devel::NYTProf (my $lib = $INC{"Devel/NYTProf/Data.pm"}) =~ s/\/Data\.pm$//; _copy_dir("$lib/js", "$opt_out/js"); } sub _copy_dir { my ($srcdir, $dstdir) = @_; mkdir $dstdir or die "Can't create $dstdir directory: $!\n" unless -d $dstdir; for my $src (glob("$srcdir/*")) { (my $name = $src) =~ s{.*/}{}; next if $name =~ m/^\./; # skip . and .. etc my $dstname = "$dstdir/$name"; if (not -f $src) { _copy_dir($src, $dstname) if -d $src; # recurse next; # skip non-ordinary-files } unlink $dstname; copy($src, $dstname) or warn "Unable to copy $src to $dstname: $!"; } } sub open_browser_on { my $index = shift; my $exit_code = eval { require Browser::Open; Browser::Open::open_browser($index, 1); }; return if defined($exit_code) && $exit_code == 0; warn "$@\n" if $@ && $opt_debug; return if eval { require ActiveState::Browser; ActiveState::Browser::open($index); 1 }; warn "$@\n" if $@ && $opt_debug && $^O eq "MSWin32"; my $BROWSER; if ($^O eq "MSWin32") { $BROWSER = "start %s"; } elsif ($^O eq "darwin") { $BROWSER = "/usr/bin/open %s"; } else { my @try; if ($ENV{BROWSER}) { push(@try, split(/:/, $ENV{BROWSER})); } else { push(@try, qw(firefox galeon mozilla opera netscape)); } unshift(@try, "kfmclient") if $ENV{KDE_FULL_SESSION}; unshift(@try, "gnome-open") if $ENV{GNOME_DESKTOP_SESSION_ID}; unshift(@try, "xdg-open"); for (grep { have_prog($_) } @try) { if ($_ eq "kfmclient") { $BROWSER = "$_ openURL %s"; } elsif ($_ eq "gnome-open" || $_ eq "opera") { $BROWSER = "$_ %s"; } else { $BROWSER = "$_ %s &"; } last; } } if ($BROWSER) { (my $cmd = $BROWSER) =~ s/%s/"$index"/; warn "Running $cmd\n" if $opt_debug; system($cmd); } else { warn "Don't know how to invoke your web browser.\nPlease visit $index yourself!\n"; } } sub have_prog { my $prog = shift; for (split($Config{path_sep}, $ENV{PATH})) { return 1 if -x "$_/$prog"; } return 0; } sub output_file_table { my ($fh, $profile, $add_totals) = @_; # generate time-sorted sections for files print $fh qq{ }; print $fh qq{ }; my $inc_path_regex = get_abs_paths_alternation_regex([$profile->inc], qr/^|\[/); my $allTimes = $profile->{attribute}{total_stmts_duration}; my $allCalls = $profile->{attribute}{total_stmts_measured} - $profile->{attribute}{total_stmts_discounted}; # file in which sawampersand was noted during profiling my $sawampersand_fi = $profile->fileinfo_of($profile->{attribute}{sawampersand_fid}, 1); my (@t_stmt_exec, @t_stmt_time); my @fis = $profile->noneval_fileinfos; @fis = sort { $b->meta->{'time'} <=> $a->meta->{'time'} } @fis; my $dev_time = calculate_median_absolute_deviation([map { scalar $_->meta->{'time'} } @fis], 1); foreach my $fi (@fis) { my $meta = $fi->meta; my $fid = $fi->fid; my @extra; my $css_class = 'index'; # The stats in this table include rolled up sums of nested evals. my ($eval_stmts, $eval_time) = (0,0); if (my @has_evals = $fi->has_evals(1)) { my $n_evals = scalar @has_evals; my $msg = sprintf "including %d string eval%s", $n_evals, ($n_evals>1) ? "s" : ""; if (my @nested = grep { $_->eval_fid != $fid } @has_evals) { $msg .= sprintf ": %d direct plus %d nested", $n_evals-@nested, scalar @nested; } push @extra, $msg; $eval_stmts = sum(map { $_->sum_of_stmts_count } @has_evals); $eval_time = sum(map { $_->sum_of_stmts_time } @has_evals); } # is this file one where we sawampersand (or contains an eval that is)? if ($sawampersand_fi && $] < 5.017008 && $fi == ($sawampersand_fi->outer || $sawampersand_fi) ) { my $in_eval = ($fi == $sawampersand_fi) ? 'here' : sprintf q{in eval here}, $reporter->href_for_file($sawampersand_fi, undef, 'line'); push @extra, sprintf qq{variables that impact regex performance for whole application seen $in_eval}, $css_class = "warn $css_class"; } print $fh qq{}; my $stmts = $meta->{'calls'} + $eval_stmts; print $fh determine_severity($stmts, undef, 0, ($allCalls) ? sprintf("%.1f%%", $stmts/$allCalls*100) : '' ); push @t_stmt_exec, $stmts; my $time = $meta->{'time'} + $eval_time; print $fh determine_severity($time, $dev_time, 1, ($allTimes) ? sprintf("%.1f%%", $time/$allTimes*100) : '' ); push @t_stmt_time, $time; my %levels = reverse %{$profile->get_profile_levels}; my $rep_links = join ' • ', map { sprintf(qq{%s}, $reporter->href_for_file($fi, undef, $_), $_) } grep { $levels{$_} } qw(line block sub); print $fh ""; print $fh sprintf q{}, $fi->fid, $fi->abs_filename, $fi->filename_without_inc, (@extra) ? sprintf("(%s)", join "; ", @extra) : ""; print $fh "\n"; } print $fh "\n"; if ($add_totals) { print $fh "\n"; my $stats_fmt = qq{}; my $t_notes = ""; my $stmt_time_diff = $allTimes - sum(@t_stmt_time); if (sum(@t_stmt_exec) != $allCalls or $stmt_time_diff > 0.001) { $stmt_time_diff = ($stmt_time_diff > 0.001) ? sprintf(" and %s", fmt_time($stmt_time_diff)) : ""; $t_notes = sprintf "(%d statements%s are unaccounted for)", $allCalls - sum(@t_stmt_exec), $stmt_time_diff; } print $fh sprintf $stats_fmt, fmt_float(sum(@t_stmt_exec)), fmt_time(sum(@t_stmt_time)), "Total $t_notes" if @t_stmt_exec > 1 or $t_notes; if (@t_stmt_exec > 1) { print $fh sprintf $stats_fmt, int(fmt_float(sum(@t_stmt_exec) / @t_stmt_exec)), fmt_time( sum(@t_stmt_time) / @t_stmt_time), "Average"; print $fh sprintf $stats_fmt, '', fmt_time( $dev_time->[1]), "Median"; print $fh sprintf $stats_fmt, '', fmt_float($dev_time->[0]), "Deviation" if $dev_time->[0]; } print $fh "\n"; } print $fh '
Source Code Files — ordered by exclusive time then name
StmtsExclusive
Time		 ReportsSource File
$rep_links%s %s
%s%s%s
'; push @on_ready_js, q{ $("#filestable").tablesorter({ sortList: [[1,1],[3,1]], headers: { 1: { sorter: 'fmt_time' }, 2: { sorter: false } } }); $(".floatHeaders").each( function(){ $(this).floatThead(); } ); show_fragment_target(); $(window).on('hashchange', function(e){ show_fragment_target(); }); }; return ""; } # calculates how good or bad the time is for a file based on the others sub determine_severity { my $val = shift; return "" unless defined $val; my $stats = shift; # @_[3] is like arrayref (deviation, mean) my $is_time = shift; my $title = shift; # normalize the width/precision so that the tables look good. my $fmt_val = ($is_time) ? fmt_time($val) : fmt_float($val, NUMERIC_PRECISION); my $class; if (defined $stats) { my $devs = ($val - $stats->[1]); #stats->[1] is the mean. $devs /= $stats->[0] if $stats->[0]; # no divide by zero when all values equal if ($devs < 0) { # fast $class = 'c3'; } elsif ($devs < SEVERITY_GOOD) { $class = 'c3'; } elsif ($devs < SEVERITY_BAD) { $class = 'c2'; } elsif ($devs < SEVERITY_SEVERE) { $class = 'c1'; } else { $class = 'c0'; } } else { $class = 'n'; } if ($title) { $title = (ref $title) ? $$title : _escape_html($title); $fmt_val = qq{$fmt_val}; } return qq{$fmt_val}; } # return an html string with buttons for switching between profile levels of detail sub get_level_buttons { my $mode_ref = shift; my $file = shift; my $level = shift; my $html = join ' • ', map { my $mode = $mode_ref->{$_}; if ($mode eq $level) { qq{$mode view}; } else { my $mode_file = $file; # replace the mode specifier in the output file name -- file-name-MODE.html $mode_file =~ s/(.*-).*?\.html/$1$mode.html/o; qq{$mode view}; } } keys %$mode_ref; return qq{« $html »}; } sub get_footer { my ($profile) = @_; my $version = $Devel::NYTProf::Core::VERSION; my $js = ''; if (@on_ready_js) { # XXX I've no idea why this workaround is needed (or works). # without it the file table on the index page isn't sortable @on_ready_js = reverse @on_ready_js; $js = sprintf q{ }, join("\n", '', @on_ready_js, ''); @on_ready_js = (); }; # spacing so links to #line near can put right line at top near the bottom of the report my $spacing = "
" x 10; return qq{ $js
Report produced by the NYTProf $version Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.
$spacing }; } # returns the generic header string. Here only to make the code more readable. sub get_html_header { my $title = shift || "Profile Index - NYTProf"; my $opts = shift || {}; $title = _escape_html($title); my $html = < EOD $html = "" if $opts->{not_xhtml}; $html .= < $title EOD $html .= qq{ \n} unless $opts->{skip_style}; if (my $css = $opts->{add_jit}) { $html .= qq{ \n}; $html .= qq{ \n}; } $html .= <<'EOD' unless $opts->{skip_jquery}; EOD $html .= $opts->{head_epilogue} if $opts->{head_epilogue}; $html .= < EOD return $html; } sub get_page_header { my %args = @_; my ($profile, $head1, $head2, $right1, $right2, $skip_link_to_index) = ( $args{profile}, $args{title}, $args{subtitle}, $args{title2}, $args{subtitle2}, $args{skip_link_to_index} ); $head2 ||= qq{
For ${ \($profile->{attribute}{application}) }}; $right1 ||= " "; $right2 ||= "Run on ${ \scalar localtime($profile->{attribute}{basetime}) }
Reported on " . localtime(time); my $back_link = q//; unless ($skip_link_to_index) { $back_link = qq{
← Index
}; } my @body_attribs; push @body_attribs, qq{onload="$args{body_onload}"} if $args{body_onload}; my $body_attribs = join "; ", @body_attribs; return qq{
$back_link
$head1 $head2
$right1 $right2
\n}; } sub get_css { return <<'EOD'; /* Stylesheet for Devel::NYTProf::Reader HTML reports */ /* You may modify this file to alter the appearance of your coverage * reports. If you do, you should probably flag it read-only to prevent * future runs from overwriting it. */ /* Note: default values use the color-safe web palette. */ a { color: blue; } a:visited { color: #6d00E6; } a:hover { color: red; } body { font-family: sans-serif; margin: 0px; background-color: white; color:#222; } .body_content { margin: 8px; } .header { font-family: sans-serif; padding-left: 0.5em; padding-right: 0.5em; } .headerForeground { color: white; padding: 10px; padding-top: 50px; } .siteTitle { font-size: 2em; } .siteSubTitle { font-size: 1.2em; } .header_back { position: absolute; padding: 10px; } .header_back > a:link, .header_back > a:visited { color: white; text-decoration: none; font-size: 0.75em; } .jump_to_file { margin-top: 20px; } .footer, .footer > a:link, .footer > a:visited { color: #cccccc; } .footer { margin: 30px; } table { border-collapse: collapse; border-spacing: 0px; margin-top: 20px; } tr { text-align : center; vertical-align: top; } th,.h { background-color: #dddddd; border: solid 1px #666666; padding: 0em 0.4em 0em 0.4em; font-size:0.8em; } td { border: solid 1px #cccccc; padding: 0em 0.4em 0em 0.4em; } caption { background-color: #dddddd; text-align: left; white-space: pre; padding: 0.4em; } .table_footer { color: gray; } .table_footer > a:link, .table_footer > a:visited { color: gray; } .table_footer > a:hover { color: red; } .index { text-align: left; } .mode_btn_selected { font-style: italic; } /* subroutine dispatch table */ .sub_name { text-align: left; font-family: monospace; white-space: pre; color: gray; } /* source code */ th.left_indent_header { padding-left: 15px; text-align: left; } pre,.s { text-align: left; font-family: monospace; white-space: pre; } /* plain number */ .n { text-align: right } /* Classes for color-coding profiling information: * c0 : code not hit * c1 : coverage >= 75% * c2 : coverage >= 90% * c3 : path covered or coverage = 100% */ .c0, .c1, .c2, .c3 { text-align: right; } .c0 { background-color: #ffb3b3; } /* red */ .c1 { background-color: #ffd9b4; } /* orange */ .c2 { background-color: #ffffB4; } /* yellow */ .c3 { background-color: #B4ffB4; } /* green */ /* warnings */ .warn { background-color: #FFFFAA; border: 0; width: 96%; text-align: center; padding: 5px 0; } .warn_title { background-color: #FFFFAA; border: 0; color: red; width: 96%; font-size: 2em; text-align: center; padding: 5px 0; } /* summary of calls into and out of a sub */ .calls { display: block; color: gray; padding-top: 5px; padding-bottom: 5px; text-decoration: none; } .calls:hover { background-color: #e8e8e8; color: black; } .calls a { color: gray; text-decoration: none; } .calls:hover a { color: black; text-decoration: underline; } .calls:hover a:hover { color: red; } /* give a little headroom to the summary of calls into a sub */ .calls .calls_in { margin-top: 5px; } .vis_header { text-align:center; font-style: italic; padding-top: 5px; color: gray; } .flamegraph { margin: 20px 0px; } EOD } __END__ =head1 DESCRIPTION Devel::NYTProf is a powerful feature-rich Perl source code profiler. See L for details. C generates a set of html reports from a single data file generated by L. (If your process forks you'll probably have multiple files. See L and L.) The reports include dynamic runtime analysis wherein each line and each file is analyzed based on the performance of the other lines and files. As a result, you can quickly find the slowest module and the slowest line in a module. Slowness is measured in three ways: total calls, total time, and average time per call. Coloring is based on absolute deviations from the median. See L for more details. That might sound complicated, but in reality you can just run the command and enjoy your report! =head1 COMMAND-LINE OPTIONS =over 4 =item -f, --file Specifies the location of the file generated by L. Default: ./nytprof.out =item -o, --out The directory in which to place the generated report files. Default: ./nytprof/ =item -d, --delete Purge any existing contents of the report output directory. =item -l, --lib Add a path to the beginning of @INC to help nytprofhtml find the source files used by the code. Should not be needed in practice. =item --open Make your web browser visit the report after it has been generated. If this doesn't work well for you, try installing the L module. =item -m, --minimal Don't generate graphviz .dot files or block/sub-level reports. =item --no-flame Disable generation of the flamegraph on the index page. Also disables calculation of distinct call stacks that are used to produce the flamegraph. =item -h, --help Print the help message. =back =head1 SAMPLE OUTPUT You can see a complete report for a large application at L The report was generated by profiling L 1.121 checking its own source code using perl v5.18.2. =head1 DIAGNOSTICS =head2 "Unable to open '... (autosplit into ...)'" The profiled application executed code in a module that used L to load the code from a separate .al file. NYTProf automatically recognises this situation and tries to determine the 'parent' module file so it can associate the profile data with it. In order to do that the parent module file must already be 'known' to NYTProf, typically by already having some code profiled. You're only likely to see this warning if you're using the C option to start profiling after compile-time. The effect is that times spent in autoloaded subs won't be associated with the parent module file and you won't get annotated reports for them. You can avoid this by using the default C option, or by ensuring you execute some non-autoloaded code in the parent module, while the profiler is running, before an autoloaded sub is called. =head2 Background Subroutine-level profilers: Devel::DProf | 1995-10-31 | ILYAZ Devel::AutoProfiler | 2002-04-07 | GSLONDON Devel::Profiler | 2002-05-20 | SAMTREGAR Devel::Profile | 2003-04-13 | JAW Devel::DProfLB | 2006-05-11 | JAW Devel::WxProf | 2008-04-14 | MKUTTER Statement-level profilers: Devel::SmallProf | 1997-07-30 | ASHTED Devel::FastProf | 2005-09-20 | SALVA Devel::NYTProf | 2008-03-04 | AKAPLAN Devel::Profit | 2008-05-19 | LBROCARD Devel::NYTProf is a (now distant) fork of Devel::FastProf, which was itself an evolution of Devel::SmallProf. Adam Kaplan took Devel::FastProf and added html report generation (based on Devel::Cover) and a test suite - a tricky thing to do for a profiler. Meanwhile Tim Bunce had been extending Devel::FastProf to add novel per-sub and per-block timing, plus subroutine caller tracking. When Devel::NYTProf was released Tim switched to working on Devel::NYTProf because the html report would be a good way to show the extra profile data, and the test suite made development much easier and safer. Then he went a little crazy and added a slew of new features, in addition to per-sub and per-block timing and subroutine caller tracking. These included the 'opcode interception' method of profiling, ultra-fast and robust inclusive subroutine timing, doubling performance, plus major changes to html reporting to display all the extra profile call and timing data in richly annotated and cross-linked reports. Steve Peters came on board along the way with patches for portability and to keep NYTProf working with the latest development Perl versions. Adam's work is sponsored by The New York Times Co. L. Tim's work was partly sponsored by Shopzilla. L. =head1 SEE ALSO Mailing list and discussion at L Public Github Repository and hacking instructions at L L, L, L =head1 AUTHOR B, C<< >>. B, L and L. B, C<< >>. =head1 COPYRIGHT AND LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut # vim:ts=8:sw=4:expandtab Devel-NYTProf-6.06/bin/nytprofcsv000755 000766 000024 00000012655 13305236557 017216 0ustar00timbostaff000000 000000 #!/usr/bin/perl ########################################################## # This script is part of the Devel::NYTProf distribution # # Copyright, contact and other information can be found # at the bottom of this file, or by going to: # http://metacpan.org/release/Devel-NYTProf/ # ########################################################## use warnings; use strict; use Carp; use Getopt::Long; use Devel::NYTProf::Reader; our $VERSION = '6.06'; use constant NUMERIC_PRECISION => 5; my %delimiters = ( comma => ",", tab => "\t", ); my %opt = ( file => 'nytprof.out', out => 'nytprof', delim => 'comma', ); GetOptions(\%opt, qw/file|f=s delete|d out|o=s help|h delim=s annotated|a/) or do { usage(); exit 1; }; if (defined($opt{help})) { usage(); exit; } $opt{delim} = $delimiters{ $opt{delim} } if exists $delimiters{ $opt{delim} }; # handle file selection option if (!-r $opt{file}) { die "$0: Unable to access $opt{file}\n"; } # handle output location if (!-e $opt{out}) { # will be created } elsif (!-d $opt{out}) { die "$0: Specified output directory `$opt{out}' is a file. whoops!\n"; } elsif (!-w $opt{out}) { die "$0: Unable to write to output directory `$opt{out}'\n"; } # handle deleting old db's if (defined($opt{'delete'})) { _delete(); } print "Generating CSV report...\n"; my $reporter = new Devel::NYTProf::Reader($opt{file}); # place to store this $reporter->output_dir($opt{out}); $reporter->set_param(mk_report_source_line => sub { my ($linenum, $line, $stats_for_line, $statistics, $profile, $filestr) = @_; $line =~ s/^\s*//; # trim leading spaces my $delim = $opt{delim}; my $time = $stats_for_line->{'time'} || 0; my $calls = $stats_for_line->{'calls'} || 0; $time += $stats_for_line->{evalcall_stmts_time_nested} || 0; #$calls ||= 1 if exists $stats_for_line->{evalcall_stmts_time_nested}; my $text = sprintf("%f%s%g%s%f%s%s\n", $time, $delim, $calls, $delim, ($calls) ? $time/$calls : 0, $delim, $line, ); return $text unless $opt{annotated}; # srcline $text = "srcline$delim$text"; return $text; }); $reporter->set_param(mk_report_xsub_line => sub { "" }); # generate the files $reporter->report(); # Delete the previous database if it exists sub _delete { if (-d $opt{out}) { print "Deleting $opt{out}\n"; unlink glob($opt{out} . "/*"); unlink glob($opt{out} . "/.*"); rmdir $opt{out} or confess "Delete of $opt{out} failed: $!\n"; } } sub usage { print <, -f Use the specified file as Devel::NYTProf database file. [default: ./nytprof.out] --out , -o Place generated files here [default: ./nytprof] --delete, -d Delete the old fprofhtml output [uses --out] --help, -h Print this message This script of part of the Devel::NYTProf package See https://metacpan.org/pod/Devel::NYTProf END } __END__ =head1 NAME nytprofcsv - (DEPRECATED) L CSV format implementation =head1 SYNOPSIS $ nytprofcsv [-h] [-d] [-o ] [-f ] perl -d:NYTProf some_perl_app.pl nytprofcsv Generating CSV Output... =head1 NOTE B =head1 DESCRIPTION C is a script that implements L to create comma-seperated value formatted reports from L databases. See the L Perl code profiler for more information. =head1 COMMAND-LINE OPTIONS These are the command line options understood by C =over 4 =item -f, --file Specifies the location of the input file. The input file must be the output of L. Default: nytprof.out =item -o, --out Where to place the generated report. Default: ./nytprof/ =item -d, --delete Purge any existing database located at whatever -o (above) is set to =item -h, --help Print the help message =back =head1 SAMPLE OUTPUT # Profile data generated by Devel::NYTProf::Reader v.0.01 # Format: time,calls,time/call,code 0,0,0,#-------------------------------------------------------------------- 0,0,0,# My New Source File! 0,0,0,#-------------------------------------------------------------------- 0,0,0, 0,0,0,package NYT::Feeds::Util; 0.00047,3,0.000156666666666667,use Date::Calc qw(Add_Delta_DHMS); 0.00360,3,0.0012,use HTML::Entities; 0.00212,3,0.000706666666666667,use Encode; 0.00248,3,0.000826666666666667,use utf8; 0.00468,3,0.00156,use strict; 0,0,0, 0.00000,1,0,require Exporter; ... that's enough, get the picture? ... Note: The format line indicates what fields the numbers correspond to Note2: If the source file is modified between profiling and report generation, the source might be misaligned =head1 SEE ALSO Mailing list and discussion at L Public Github Repository and hacking instructions at L L L L is an HTML implementation of L =head1 AUTHOR Adam Kaplan, akaplan at nytimes dotcom =head1 COPYRIGHT AND LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. =cut Devel-NYTProf-6.06/demo/exclusive-sub-time.pl000644 000766 000024 00000000241 11037571407 021276 0ustar00timbostaff000000 000000 # for testing exclusive time calculations # use with NYTPROF=trace=3 sub a { sleep 2; b(); } sub b { sleep 5; c(); } sub c { sleep 3; } a(); Devel-NYTProf-6.06/demo/README000644 000766 000024 00000000141 11032761554 016065 0ustar00timbostaff000000 000000 This directory holds tools and script for demonstrating Devel::NYTProf (Feel free to ignore it.) Devel-NYTProf-6.06/demo/demo-code.pl000644 000766 000024 00000002541 12124030601 017365 0ustar00timbostaff000000 000000 use strict 0.1; # use UNIVERSAL::VERSION use English; # demo detection of $& et al use Benchmark; use File::Find; my $count = shift || 100; my $do_io = shift || (not -t STDIN); sub add { $a = $a + 1; foo(); } sub foo { 1; for (1..1000) { ++$a; ++$a; } 1; } BEGIN { add() } BEGIN { add() } sub inc { 1; # call foo and then execute a slow expression *in the same statement* # With all line profilers except NYTProf, the time for that expression gets # assigned to the previous statement, i.e., the last statement executed in foo()! # XXX this doesn't seem to be slow in 5.12+ - need a better example foo() && 'aaaaaaaaaaa' =~ /((a{0,5}){0,5})*[c]/; 1; } timethese( $count, { add => \&add, bar => \&inc, }); END { warn "ENDING\n"; add() } # --- recursion --- sub fib { my $n = shift; return $n if $n < 2; fib($n-1) + fib($n-2); } fib(7); # --- File::Find --- sub wanted { return 1; } find( \&wanted, '.'); # --- while with slow conditional --- if ($do_io) { print "Enter text. Enter empty line to end.\n" if -t STDIN; # time waiting for the second and subsequent inputs # should get assigned to the condition statement # not the last statement executed in the loop while (<>) { chomp; last if not $_; 1; } } Devel-NYTProf-6.06/demo/1m_stmts.pl000644 000766 000024 00000000206 12130047577 017315 0ustar00timbostaff000000 000000 # execute 1 million iterations of a 3 statement + condition loop my $i = shift || 1_000_000; while (--$i) { 1; ++$a; 1; } Devel-NYTProf-6.06/demo/cpucache.pl000644 000766 000024 00000000350 12130047577 017321 0ustar00timbostaff000000 000000 my $subref = sub { return }; for my $i (1..100_000) { some_expensive_sub(); $subref->(); $subref->(); # identical but faster! 1; # loop } sub some_expensive_sub{ my @x = (1000..1010); m/x/ for @x; } Devel-NYTProf-6.06/demo/demo-run.pl000644 000766 000024 00000002261 11313511176 017270 0ustar00timbostaff000000 000000 #!/bin/env perl -w use strict; use IO::Handle; my $NYTPROF = ($ENV{NYTPROF}) ? "$ENV{NYTPROF}:" : ""; my %runs = ( start_begin => { skip => 0, NYTPROF => 'start=begin:optimize=0', }, start_check => { skip => 1, NYTPROF => 'start=init:optimize=0', }, start_end => { skip => 1, NYTPROF => 'start=end:optimize=0', }, ); for my $run (keys %runs) { next if $runs{$run}{skip}; $ENV{NYTPROF} = $NYTPROF . $runs{$run}{NYTPROF} || ''; $ENV{NYTPROF_HTML} = $runs{$run}{NYTPROF_HTML} || ''; my $cmd = "perl -d:NYTProf demo/demo-code.pl @ARGV"; open my $fh, "| $cmd" or die "Error starting $cmd\n"; # feed data into the stdin read loop in demo/demo-code.pl $fh->autoflush; print $fh "$_\n" for (1..10); sleep 2; print $fh "$_\n" for (1..10); close $fh or die "Error closing pipe to $cmd: $!\n"; my $outdir = "demo-out/profiler-$run"; system("rm -rf $outdir") == 0 or exit 0; system("mkdir -p $outdir") == 0 or exit 0; system("perl -Mblib bin/nytprofhtml --open --out=$outdir") == 0 or exit 0; #system "ls -lrt $outdir/."; sleep 1; } Devel-NYTProf-6.06/demo/closure.pl000644 000766 000024 00000000654 12130047577 017231 0ustar00timbostaff000000 000000 our $o; for my $i (1..100_000) { my $named2 = \&bar; sub bar { return 1; 1+$l } # non-closure my $named1 = \&foo; sub foo { return 1; 1+$o } # non-closure my $anon1 = sub { return 1; 1+$o }; # non-closure my $anon2 = sub { return 1; 1+$l }; # closure $named2->(); $named1->(); # faster because of cpu cache of opcode logic? $anon1->(); $anon2->(); 1; # loop }