Devel-MAT-0.52000755001750001750 014550507443 11646 5ustar00leoleo000000000000Devel-MAT-0.52/Build.PL000444001750001750 214414550507443 13300 0ustar00leoleo000000000000use v5.14; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Devel::MAT', requires => { 'perl' => '5.014', # s///r 'Syntax::Keyword::Match' => 0, 'Commandable::Invocation' => '0.04', # ->peek_remaining 'Devel::MAT::Dumper' => '0.35', 'Feature::Compat::Try' => '0', 'File::ShareDir' => 0, 'File::Spec' => 0, 'Heap' => 0, 'List::Util' => '1.44', # uniq 'List::UtilsBy' => 0, # sort_by 'Module::Pluggable' => 0, 'String::Tagged' => '0.15', # sprintf 'String::Tagged::Terminal' => '0.03', 'Struct::Dumb' => '0.07', }, test_requires => { 'Test::Identity' => 0, 'Test::More' => '0.88', # done_testing }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, share_dir => { module => { "Devel::MAT::UI" => "share" }, }, license => 'perl', create_license => 1, create_readme => 1, ); if( $build->args( "DEBUG" ) ) { $build->extra_compiler_flags( @{ $build->extra_compiler_flags }, "-ggdb" ); } $build->create_build_script; Devel-MAT-0.52/Changes000444001750001750 4777014550507443 13335 0ustar00leoleo000000000000Revision history for Devel-MAT 0.52 2024-01-13 [CHANGES] * Ensure that `packages -V` can cope with version objects as well as plain numerical SVs * Make sure to load `Devel::MAT` only after processing the `--blib` commandline option [BUGFIXES] * Print a warning and skip attempts to apply SVx annotations to unrecognised SV addresses (alleviates but does not fix RT134117) 0.51 2023-03-23 [BUGFIXES] * Don't crash when loading files that claim non-existent SVs are mortalized 0.50 2023-03-03 [CHANGES] * Improved tree-forming algorithm in `pmat-diff` that produces better output shapes * Annotate SVs as being mortalized if the dumpfile contains that information [BUGFIXES] * Ensure pmat-diff doesn't get stuck in a loop trying to break cycles when forming tree shapes * Ensure Reachability tool understands that CLASS is a kind of stash (RT146630) 0.49 2022-10-03 [CHANGES] * Much improved output from pmat-diff: + Attempt to group up unique SVs into small trees by reference + Annotate SVs that are MRO caches and hence dumper noise * Added `$sv->outref_named`, `$sv->maybe_outref_named`, `$struct->maybe_field_named` and similar methods * Migrate `pmat-list-dangling-ptrs` script into a real tool command * Have `list-dangling-ptrs` test fields of C_STRUCTs as well [BUGFIXES] * Ensure that `packages` command doesn't get upset about non-globs in the toplevel stash 0.48 2022-08-30 [CHANGES] * Recognise 'quit' as an exit command from the pmat shell * Added 'find cv' filter * Have ->format_sv_with_value pick out a single array element or hash value to show as an example * Have ->format_sv_with_value show GLOB names * Allow extension tools to insert extra output into 'show SV' command * Added 'tools' and 'tool' commands * Expermental, work-in-progress handling of PMAT 0.5 file format, which adds support for core 'feature-class' classes and instances 0.47 2022-04-02 [CHANGES] * Improved handling of root SVs including custom ones annotated by the dumpfile itself * Handle the magic VTBL pointer field in latest dumpfile format * Added `find magic` filter [BUGFIXES] * 'show' tool should inspect `$sv->type` instead of relying on actual blessed type of SV wrapper * Fix default provided `Devel::MAT::Cmd->format_heading` method 0.46 2022-03-29 [CHANGES] * Support the new STRUCT types in .pmat files + Added `show` STRUCT support + Added `find struct` filter + Added a nice shiney new icon for STRUCT SV type * Added `pmat --blib` option for convenient testing of thirdparty helper modules * Stop stealing GVs or constant SVs out of the first pad on ithreads 0.45 2022-02-26 [CHANGES] * Add support for perl 5.35's boolean types * Added a nice shiney new icon for BOOL SV type 0.44 2021-03-27 [CHANGES] * Rename `find lexical --all` to `--inactive` * Have `find lexical` indicate if it was found in an inactive pad * Paginate output of `outrefs` and `inrefs` commands * Use Feature::Compat::Try * Style modernisations for perl v5.14+ 0.43 2020-04-24 [CHANGES] * Have `callers` print the actual CV identity of subs * Many improvements to `show` command: + Added `show --full-pv` for SCALAR + Added `show --pad` for CODE + Have `show CODE` print the protosub if applicable + Have `show PAD|CODE` indicate `our`/`state` and outer-capture lexicals * Added `find lexical` filter * Support Devel::MAT::Dumper 0.44's CODEx_PADNAME_FLAGS annotations * Display CODE() using more friendly "proto" or "closure" flags instead of "P" and "C" [BUGFIXES] * Fix `find blessed` command (RT131079) 0.42 2019-03-21 22:36:09 [CHANGES] * Rename `callstack` to `callers` * Optionally show pad in `callers` output * Check symbol table before using ->symname in `identify` * Added `find num` filter * Load the -DDEBUG_LEAKING_SCALARS dumper extension 0.41 2019-01-14 18:19:44 [CHANGES] * Nicer table output in command tools * Added `pmat-counts` for giving a quick summary of a series of heapdump files * Load the SV->SV annotations written by DMD_helper code in thirdparty XS modules * Added a `stack` command 0.40 2018-09-07 14:57:06 [CHANGES] * Read dumpfile format v0.4 - SV extension size table * Elide glob symbol names if possible in 'identify' output * If `identify` doesn't find any SVs, try harder by ignoring filtering options * Track `local` modified variables * Optionally print $VERSION in `packages` command * Have `find` tool respect pagination [BUGFIXES] * Don't collide .pmat files during parallel build testing (RT126041) 0.39 2018-08-09 13:37:24 [BUGFIXES] * Fix unit test script for now-removed tool file (RT125994) 0.38 2018-08-02 17:47:44 [CHANGES] * Improvements to 'pmat-diff' + Added --one mode * Improvements to 'find' command + Added 'blessed' filter + Allow filters to be combined + Added --count option * Added --quiet option to main 'pmat' script * Report progress to STDERR, not STDOUT 0.37 2018-07-24 16:56:49 [CHANGES] * Optional splitting of SCALAR by subtype in 'count' command * Small improvements to 'pmat-diff' * Added $sv->basetype method * Added 'pmat-leakreport' * Handle upcoming PMAT v0.3 format with compressed undefs 0.36 2018-07-17 10:42:41 [CHANGES] * Migrated Devel::MAT::Dumper into its own distribution 0.35 2018-07-03 14:58:53 [CHANGES] * Various improvements to 'count' command * Remove 'sizes' command because 'count' does the same thing now * Added new 'size' command for individual SVs * Added new 'packages' command for walking the symbol table * Support pagination of long-output commands via 'more' 0.34 2018-04-02 18:39:36 [CHANGES] * Have 'show' on a PAD use ->format_sv_with_value and ->format_note * Better external API for $sv->magic_svs * Print details of magic in 'show' command [BUGFIXES] * Fix for Sizes tool to use $cv->padnames_av (RT124834) 0.33 2018-01-23 01:22:25 [CHANGES] * Added `inrefs` and `outrefs` commands * Improvements to output of `show` command * Indicate circular vs. non-circular self-references in `identify` command output * Accept names of symbols as valid SV addresses * Renamed $cv->padnames to ->padnames_av` * Added $cv->max_padix 0.32 2017-12-17 00:31:53 [CHANGES] * Only elide single-referrant RVs in `identify` output * "Loading file ..." message should mention that its count is in bytes (thanks DAKKAR) * Extract the `callstack` command's stringify behaviour into a new shared ->format_sv_with_value method 0.31 2017-11-23 22:25:08 [CHANGES] * Annotate each root SV with its rootname in formatted output * Expanded userguide docs [BUGFIXES] * Use File::Spec->rel2abs() instead of Cwd::abs_path() to hopefully keep MSWin32 happier (RT123235) * chmod +x all the bin/ scripts 0.30 2017-10-14 20:00:58 [CHANGES] * Migrate `pmat-sizes` and `pmat-find-pv` stand-alone scripts into Tool commands * Move the 'io find' tool to 'find io' [BUGFIXES] * Correct handling of strong vs weak root references in inref_graph method and 'identify' command (fixes RT123233) 0.29 2017-10-11 21:16:12 [CHANGES] * Slightly more efficient file loading by combining some steps * Further optimisation of Inrefs tool CPU performance * Much improved 'help' command and command system metadata * Neater table formatting of tabular command output * Default --depth 10 to 'identify' command [BUGFIXES] * Capture the string values from the shared string table 0.28 2017-10-10 00:55:37 [CHANGES] * Further reworking of the way command-providing Tools can format their output * Richer display of detail in many commands, including 'identify' * Have 'show' tool give overall byte-size of the SV * Elide PADs and PADLISTs when identifying lexicals * Make Inrefs tool more efficient in CPU and memory requirements 0.27 2017-09-29 19:09:11 [CHANGES] * Major reworking of the way command-providing Tools work, and supply output to their containing user interface. * Elide symbol table entries in 'identify' output * Don't accept __ANON__ symbol names as valid roots for inrefs graph * Added command tools for listing the root SVs and the symbol table * General improvements to output format and commandline structure of other tools 0.26 2017/05/09 19:14:57 [BUGFIXES] * Handle perl 5.25.6's moving of OP_PUSHRE to OP_SPLIT * Don't bother #include'ing as we don't need it 0.25 2017/03/27 14:09:55 [CHANGES] * Attempt to elide RVs in `identify` output * Add a 'help' command to pmat shell * Added the start of Devel::MAT::UserGuide * Moved `pmat-callstack` to `pmat> callstack` * Removed used of given/when syntax [BUGFIXES] * Fix for perl 5.25.x's removal of ->op_sibling (RT114581) * Avoid creating files called -e.pmat (RT119164) * abs_path() the dumpfile path at startup time in case of chdir() (RT117842) 0.24 2016/06/03 19:07:47 [CHANGES] * Capture the input/output fileno values of IO handles * Moved more standalone commands into 'pmat' command Tools + pmat-identify-sv becomes pmat> identify + pmat-show-sv becomes pmat> show * Added pmat> io commands * Make main 'pmat' into an interactive repl-like program if run with no additional arguments 0.23 2016/04/05 16:32:43 [CHANGES] * Allow -dump_at_SIGNAME for any named signal * Added simple 'pmat-diff' script * Distinguish undefined scalars from defined ones, using a new icon * Initial experiment at generic 'command' ability * Moved GTK explorer to its own distribution; App-Devel-MAT-Explorer-GTK 0.22 2016/03/16 16:22:19 [CHANGES] * Added a simple script to find PVs by content * Updated documentation to =head2 barename style [BUGFIXES] * Fix back-compat loading of v0.1 files with EVAL contexts in * Fix perl5.22/ithreads that lacks padnames * Fix perl5.23.8 that removes blk_sub.argarray 0.21 2015/10/29 20:58:29 [CHANGES] * Compatibility with perl 5.22 (RT100458): + Added/removed roots + Correctly handle GV-less CVs * Updated dumpfile format + Store the CvDEPTH of CVs and the olddepth of SUB contexts (RT108094) + Capture CvLEXICAL flag and the name of CvNAMED CVs * Allow lookup of PAD index from padname for lexicals (RT100967) * Improved output format of pmat-callstack, showing the value of a $self lexical if one exists * Increased dump format minor version to 2 [BUGFIXES] * No need to emit two copies of the default stash if perl has heap- allocated it (RT103499) 0.20 2014/12/04 18:35:09 [CHANGES] * Allow serial-numbering of .pmat files in the Dumper * Totally refactored $pmat->identify to return an abstract Graph structure * Much improved pmat-identify-sv output; sort strong-refs first, use Unicode linedrawing, identify "already seen" SVs clearer * GTK Explorer improvements: + Allow search by symbol + Show longer PV strings in tooltip + Selectable SV detail labels 0.19 2014/11/18 13:17:28 [CHANGES] * No need to annotate 'directly' or 'indirectly' on outref names * Added -dump_at_DIE option to Devel::MAT::Dumper * Added icon for INVLIST from perl 5.20 0.18 2014/07/14 22:45:08 [CHANGES] * Improved for Tools to create custom UIs + Widget trees + Label text + icon + Tool-localised icon load paths * Support loading Tools automatically * Neater API for inrefs/outrefs that also indicates link strength 0.17 2014/01/22 21:33:45 [CHANGES] * Also dump SvUTF8() flag of PVs * Added pmat-cat-svpv [BUGFIXES] * Don't crash on NULL PADLIST elements (RT92290) 0.16 2014/01/15 18:18:53 [CHANGES] * More accurate format for dumping SV MAGIC annotations - note that older files will contain incorrect information * More accurate backref information * Improvements to analysis of PAD lexicals [BUGFIXES] * Fix many cases of optree dumping to get correct PAD indexes * Further minor fixes that improve SvREFCNT / inrefs accuracy 0.15 2014/01/14 11:12:37 [CHANGES] * Remember to basename() $0 for default dumpfile name * Added -eager_option import option * Added $df->roots_strong * Added options to $pmat->identify and pmat-identify-sv command [BUGFIXES] * Avoid infinite loop in $pmat->identify in cyclic cases * Fix docs on ->rv method (RT92122) 0.14 2014/01/04 20:25:16 [CHANGES] * Move much core data storage into XS structs, for reduced memory consumption of analyser and some CPU performance gains * Display human-readable size information in GTK explorer * Added a size totals summary commandline tool * Improved recursion logic in Inrefs tool; avoids multiple recursions into shared structures [BUGFIXES] * Fix for 5.10.0 0.13 2013/12/06 21:37:35 [CHANGES] * Performance improvement to inrefs counting * Added Sizes tool - calculates structure and owned set and sizes * Allow Tools to declare UI radiobutton sets * Improved Tools ability to interact with the SV list * Disable Tools menu items for loaded tools to avoid loading them twice [BUGFIXES] * Add List::UtilsBy to requirements * Our version of dopoptosub_at() doesn't need aTHX_ 0.12 2013/12/03 15:18:43 [CHANGES] * Classify outrefs and inrefs into various kinds * Subclass ARRAY into PADLIST, PADNAMES, PAD for CODE * Allow selection of what kinds of refs to count/display on the GTK explorer * Store more flags (CvWEAKOUTSIDE, CvCVGV_RC, AvREAL) so as to get strong/weak references correct * Store the SvOUTSTASH of SCALARs and REFs * Added a commandline wrapper for $pmat->identify [BUGFIXES] * require() tool .pm files automatically when calling ->load_tool 0.11 2013/11/28 14:30:32 [CHANGES] * Complete redesign of dumpfile format so it is more extensible in future * Represent RVs by their own type, REF, rather than being a kind of SCALAR * Store caller()-like context in dumpfiles as well * Store CLONE/CLONED/ISXSUB CV flags and oproot * Attempt to match CLONE protosubs with CLONED closures * Added SCALAR->iv method * Neaten the names of STASHes whose names begin with a control character * Pretty-print PVs and limit length to 32 characters in GTK explorer * Added icons for REF and LVALUE types [BUGFIXES] * Guard against PL_main_root being NULL, as it can be early in compilation * Improved Reachability tool logic for CODE PAD slots 0.10 2013/11/26 00:42:14 [CHANGES] * Display dumped perl version, SV and byte counts in GTK explorer status bar * Dump all GVs, even those without GPs * Store size information about all SVs + TODO: CODE size does not take account of optree * Have dump_at_{END,SIGABRT,SIGQUIT} print to STDERR * Limit the capture size of PVs, but still note the full length * Dump FILE and LINE of CVs and GVs * Redrawn type icons [BUGFIXES] * Fix for NVLEN=16 architectures 0.09 2013/11/22 00:25:17 [CHANGES] * Remove orphan count unit test as it is too unreliable [BUGFIXES] * Sometimes a PAD(0) slot is NULL * ->identify is now a $pmat method * ->identify should load Inrefs tool * Try harder to clear PL_tmpsv when making an unreachable cycle 0.08 2013/11/10 19:27:30 [CHANGES] * Chase more fields of an HV's mro_meta * Document how Tools may interact with the UI * Allow Tools to register and use icons on the UI * Rework Reachability tool to analyse kinds of reachability * Move inrefs logic into its own new Inrefs Tool * Slight performance improvement to dumpfile loading * Display icons also for general SV type [BUGFIXES] * Ensure ->find_symbol actually works for deeply-nested symbols 0.07 2013/11/08 01:33:01 [CHANGES] * Added new concept of Devel::MAT::Tool::* and Devel::MAT::UI * Implement SV type counting and reachability analysis Tools * Allow dumping on SIGABRT [BUGFIXES] * Support perl 5.10 * Support NVSIZE==16 architectures 0.06 2013/10/28 00:14:24 [CHANGES] * Don't yield constants from both anonymous subs -and- constix/constsv lists * Don't bother including all the PL_sv_undef lexnames [BUGFIXES] * Remember to store padlist in pre-5.18 perls * PL_main_cv does not have a CvROOT(); need to use PL_main_root (fixes unit test failures on non-threaded perls) 0.05 2013/10/22 01:34:44 [CHANGES] * Added ->find_symbol and ->find_glob * Identify weakrefs in descriptions and in GTK explorer * All hashes have the backrefs AV field, not just stashes * Recognise import() options on D:M:Dumper * Grab padnames and pad AVs on 5.18 * Added a toolbar with back/forward buttons in GTK explorer [BUGFIXES] * Don't crash when ->identify'ing SVs that are stack temporaries 0.04 2013/10/09 23:23:27 [CHANGES] * Renamed dumpfile() to just dump() * Don't delete elided RVs; include both direct and via-RV outrefs [BUGFIXES] * Start 'identify' with the initial SV already seen so it doesn't infinitely recurse * Remember to still fix up consts_at from constix on ithreaded 5.18 * Need to check if SVs are actually magical (SvMAGICAL), not just potentially magical (>= SVt_PVMG) 0.03 CHANGES: * Altered handling of PADLISTs for perl 5.18.0 * Ensure that UINTs and PTRs are written in correct platform sizes 0.02 CHANGES: * Bugfixes for non-threaded perls * Trace constants/GVs/etc... through optrees * Handle SVt_PVLV 0.01 First version, released on an unsuspecting world. Devel-MAT-0.52/LICENSE000444001750001750 4375514550507443 13046 0ustar00leoleo000000000000This software is copyright (c) 2024 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2024 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2024 by Paul Evans . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Devel-MAT-0.52/MANIFEST000444001750001750 424514550507443 13141 0ustar00leoleo000000000000bin/pmat bin/pmat-cat-svpv bin/pmat-counts bin/pmat-diff bin/pmat-leakreport bin/pmat-list-orphans Build.PL Changes doc/format.txt lib/Devel/MAT.pm lib/Devel/MAT.xs lib/Devel/MAT/Cmd.pod lib/Devel/MAT/Cmd/Terminal.pm lib/Devel/MAT/Context.pm lib/Devel/MAT/Dumpfile.pm lib/Devel/MAT/Graph.pm lib/Devel/MAT/InternalTools.pm lib/Devel/MAT/SV.pm lib/Devel/MAT/Tool.pm lib/Devel/MAT/Tool.pod lib/Devel/MAT/Tool/Callers.pm lib/Devel/MAT/Tool/Count.pm lib/Devel/MAT/Tool/Find.pm lib/Devel/MAT/Tool/Identify.pm lib/Devel/MAT/Tool/Inrefs.pm lib/Devel/MAT/Tool/ListDanglingPtrs.pm lib/Devel/MAT/Tool/Outrefs.pm lib/Devel/MAT/Tool/Reachability.pm lib/Devel/MAT/Tool/Roots.pm lib/Devel/MAT/Tool/Show.pm lib/Devel/MAT/Tool/Sizes.pm lib/Devel/MAT/Tool/Stack.pm lib/Devel/MAT/Tool/Summary.pm lib/Devel/MAT/Tool/Symbols.pm lib/Devel/MAT/Tool/Tools.pm lib/Devel/MAT/ToolBase/GraphWalker.pm lib/Devel/MAT/UI.pod lib/Devel/MAT/UserGuide.pod lib/Devel/MAT/UserGuide/IdentifyingAnSV.pod LICENSE MANIFEST This list of files META.json META.yml README share/icons/reachable-internal.svg share/icons/reachable-lexical.svg share/icons/reachable-none.svg share/icons/reachable-padlist.svg share/icons/reachable-symtab.svg share/icons/reachable-user.svg share/icons/reachable-yes.svg share/icons/refs-All.svg share/icons/refs-Direct.svg share/icons/refs-Strong.svg share/icons/size-Owned.svg share/icons/size-Structure.svg share/icons/size-SV.svg share/icons/strength-indirect.svg share/icons/strength-inferred.svg share/icons/strength-strong.svg share/icons/strength-weak.svg share/icons/type-ARRAY.svg share/icons/type-BOOL.svg share/icons/type-C_STRUCT.svg share/icons/type-CODE.svg share/icons/type-FORMAT.svg share/icons/type-GLOB.svg share/icons/type-HASH.svg share/icons/type-INVLIST.svg share/icons/type-IO.svg share/icons/type-LVALUE.svg share/icons/type-PAD.svg share/icons/type-PADLIST.svg share/icons/type-PADNAMES.svg share/icons/type-REF.svg share/icons/type-REGEXP.svg share/icons/type-SCALAR.svg share/icons/type-STASH.svg share/icons/type-UNDEF.svg t/00use.t t/01self.t t/02contexts.t t/03local.t t/04objects.t t/10tool-identify.t t/10tool-inrefs.t t/10tool-reachability.t t/10tool-sizes.t t/50cmd-print-table.t t/99pod.t Devel-MAT-0.52/META.json000444001750001750 1740714550507443 13455 0ustar00leoleo000000000000{ "abstract" : "Perl Memory Analysis Tool", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Devel-MAT", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "Commandable::Invocation" : "0.04", "Devel::MAT::Dumper" : "0.35", "Feature::Compat::Try" : "0", "File::ShareDir" : "1.00", "File::Spec" : "0", "Heap" : "0", "List::Util" : "1.44", "List::UtilsBy" : "0", "Module::Pluggable" : "0", "String::Tagged" : "0.15", "String::Tagged::Terminal" : "0.03", "Struct::Dumb" : "0.07", "Syntax::Keyword::Match" : "0", "perl" : "5.014" } }, "test" : { "requires" : { "Test::Identity" : "0", "Test::More" : "0.88" } } }, "provides" : { "Devel::MAT" : { "file" : "lib/Devel/MAT.pm", "version" : "0.52" }, "Devel::MAT::Cmd::Terminal" : { "file" : "lib/Devel/MAT/Cmd/Terminal.pm", "version" : "0.52" }, "Devel::MAT::Context" : { "file" : "lib/Devel/MAT/Context.pm", "version" : "0.52" }, "Devel::MAT::Context::EVAL" : { "file" : "lib/Devel/MAT/Context.pm", "version" : "0.52" }, "Devel::MAT::Context::SUB" : { "file" : "lib/Devel/MAT/Context.pm", "version" : "0.52" }, "Devel::MAT::Context::TRY" : { "file" : "lib/Devel/MAT/Context.pm", "version" : "0.52" }, "Devel::MAT::Dumpfile" : { "file" : "lib/Devel/MAT/Dumpfile.pm", "version" : "0.52" }, "Devel::MAT::Graph" : { "file" : "lib/Devel/MAT/Graph.pm", "version" : "0.52" }, "Devel::MAT::Graph::Node" : { "file" : "lib/Devel/MAT/Graph.pm", "version" : "0.52" }, "Devel::MAT::InternalTools" : { "file" : "lib/Devel/MAT/InternalTools.pm", "version" : "0.52" }, "Devel::MAT::SV" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::ARRAY" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::BOOL" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::CLASS" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::CODE" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::C_STRUCT" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::FORMAT" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::GLOB" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::HASH" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::INVLIST" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::IO" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::Immortal" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::LVALUE" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::NO" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::OBJECT" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::PAD" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::PADLIST" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::PADNAMES" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::REF" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::REGEXP" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::SCALAR" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::STASH" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::UNDEF" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::Unknown" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::SV::YES" : { "file" : "lib/Devel/MAT/SV.pm", "version" : "0.52" }, "Devel::MAT::Tool" : { "file" : "lib/Devel/MAT/Tool.pm", "version" : "0.52" }, "Devel::MAT::Tool::Callers" : { "file" : "lib/Devel/MAT/Tool/Callers.pm", "version" : "0.52" }, "Devel::MAT::Tool::Count" : { "file" : "lib/Devel/MAT/Tool/Count.pm", "version" : "0.52" }, "Devel::MAT::Tool::Find" : { "file" : "lib/Devel/MAT/Tool/Find.pm", "version" : "0.52" }, "Devel::MAT::Tool::Identify" : { "file" : "lib/Devel/MAT/Tool/Identify.pm", "version" : "0.52" }, "Devel::MAT::Tool::Inrefs" : { "file" : "lib/Devel/MAT/Tool/Inrefs.pm", "version" : "0.52" }, "Devel::MAT::Tool::ListDanglingPtrs" : { "file" : "lib/Devel/MAT/Tool/ListDanglingPtrs.pm", "version" : "0.52" }, "Devel::MAT::Tool::Outrefs" : { "file" : "lib/Devel/MAT/Tool/Outrefs.pm", "version" : "0.52" }, "Devel::MAT::Tool::Reachability" : { "file" : "lib/Devel/MAT/Tool/Reachability.pm", "version" : "0.52" }, "Devel::MAT::Tool::Roots" : { "file" : "lib/Devel/MAT/Tool/Roots.pm", "version" : "0.52" }, "Devel::MAT::Tool::Show" : { "file" : "lib/Devel/MAT/Tool/Show.pm", "version" : "0.52" }, "Devel::MAT::Tool::Sizes" : { "file" : "lib/Devel/MAT/Tool/Sizes.pm", "version" : "0.52" }, "Devel::MAT::Tool::Stack" : { "file" : "lib/Devel/MAT/Tool/Stack.pm", "version" : "0.52" }, "Devel::MAT::Tool::Summary" : { "file" : "lib/Devel/MAT/Tool/Summary.pm", "version" : "0.52" }, "Devel::MAT::Tool::Symbols" : { "file" : "lib/Devel/MAT/Tool/Symbols.pm", "version" : "0.52" }, "Devel::MAT::Tool::Tools" : { "file" : "lib/Devel/MAT/Tool/Tools.pm", "version" : "0.52" }, "Devel::MAT::Tool::help" : { "file" : "lib/Devel/MAT/InternalTools.pm" }, "Devel::MAT::Tool::more" : { "file" : "lib/Devel/MAT/InternalTools.pm" }, "Devel::MAT::Tool::time" : { "file" : "lib/Devel/MAT/InternalTools.pm" }, "Devel::MAT::ToolBase::GraphWalker" : { "file" : "lib/Devel/MAT/ToolBase/GraphWalker.pm", "version" : "0.52" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.52", "x_serialization_backend" : "JSON::PP version 4.07" } Devel-MAT-0.52/META.yml000444001750001750 1230614550507443 13276 0ustar00leoleo000000000000--- abstract: 'Perl Memory Analysis Tool' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::Identity: '0' Test::More: '0.88' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Devel-MAT provides: Devel::MAT: file: lib/Devel/MAT.pm version: '0.52' Devel::MAT::Cmd::Terminal: file: lib/Devel/MAT/Cmd/Terminal.pm version: '0.52' Devel::MAT::Context: file: lib/Devel/MAT/Context.pm version: '0.52' Devel::MAT::Context::EVAL: file: lib/Devel/MAT/Context.pm version: '0.52' Devel::MAT::Context::SUB: file: lib/Devel/MAT/Context.pm version: '0.52' Devel::MAT::Context::TRY: file: lib/Devel/MAT/Context.pm version: '0.52' Devel::MAT::Dumpfile: file: lib/Devel/MAT/Dumpfile.pm version: '0.52' Devel::MAT::Graph: file: lib/Devel/MAT/Graph.pm version: '0.52' Devel::MAT::Graph::Node: file: lib/Devel/MAT/Graph.pm version: '0.52' Devel::MAT::InternalTools: file: lib/Devel/MAT/InternalTools.pm version: '0.52' Devel::MAT::SV: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::ARRAY: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::BOOL: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::CLASS: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::CODE: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::C_STRUCT: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::FORMAT: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::GLOB: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::HASH: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::INVLIST: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::IO: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::Immortal: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::LVALUE: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::NO: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::OBJECT: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::PAD: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::PADLIST: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::PADNAMES: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::REF: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::REGEXP: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::SCALAR: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::STASH: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::UNDEF: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::Unknown: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::SV::YES: file: lib/Devel/MAT/SV.pm version: '0.52' Devel::MAT::Tool: file: lib/Devel/MAT/Tool.pm version: '0.52' Devel::MAT::Tool::Callers: file: lib/Devel/MAT/Tool/Callers.pm version: '0.52' Devel::MAT::Tool::Count: file: lib/Devel/MAT/Tool/Count.pm version: '0.52' Devel::MAT::Tool::Find: file: lib/Devel/MAT/Tool/Find.pm version: '0.52' Devel::MAT::Tool::Identify: file: lib/Devel/MAT/Tool/Identify.pm version: '0.52' Devel::MAT::Tool::Inrefs: file: lib/Devel/MAT/Tool/Inrefs.pm version: '0.52' Devel::MAT::Tool::ListDanglingPtrs: file: lib/Devel/MAT/Tool/ListDanglingPtrs.pm version: '0.52' Devel::MAT::Tool::Outrefs: file: lib/Devel/MAT/Tool/Outrefs.pm version: '0.52' Devel::MAT::Tool::Reachability: file: lib/Devel/MAT/Tool/Reachability.pm version: '0.52' Devel::MAT::Tool::Roots: file: lib/Devel/MAT/Tool/Roots.pm version: '0.52' Devel::MAT::Tool::Show: file: lib/Devel/MAT/Tool/Show.pm version: '0.52' Devel::MAT::Tool::Sizes: file: lib/Devel/MAT/Tool/Sizes.pm version: '0.52' Devel::MAT::Tool::Stack: file: lib/Devel/MAT/Tool/Stack.pm version: '0.52' Devel::MAT::Tool::Summary: file: lib/Devel/MAT/Tool/Summary.pm version: '0.52' Devel::MAT::Tool::Symbols: file: lib/Devel/MAT/Tool/Symbols.pm version: '0.52' Devel::MAT::Tool::Tools: file: lib/Devel/MAT/Tool/Tools.pm version: '0.52' Devel::MAT::Tool::help: file: lib/Devel/MAT/InternalTools.pm Devel::MAT::Tool::more: file: lib/Devel/MAT/InternalTools.pm Devel::MAT::Tool::time: file: lib/Devel/MAT/InternalTools.pm Devel::MAT::ToolBase::GraphWalker: file: lib/Devel/MAT/ToolBase/GraphWalker.pm version: '0.52' requires: Commandable::Invocation: '0.04' Devel::MAT::Dumper: '0.35' Feature::Compat::Try: '0' File::ShareDir: '1.00' File::Spec: '0' Heap: '0' List::Util: '1.44' List::UtilsBy: '0' Module::Pluggable: '0' String::Tagged: '0.15' String::Tagged::Terminal: '0.03' Struct::Dumb: '0.07' Syntax::Keyword::Match: '0' perl: '5.014' resources: license: http://dev.perl.org/licenses/ version: '0.52' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-MAT-0.52/README000444001750001750 1017714550507443 12711 0ustar00leoleo000000000000NAME Devel::MAT - Perl Memory Analysis Tool USER GUIDE NEW USERS: If you are new to the Devel::MAT set of tools, this is probably not the document you want to start with. If you are interested in using Devel::MAT to help diagnose memory-related problems in a perl program you instead want to read the user guide, at Devel::MAT::UserGuide. If you are writing tooling modules to extend the abilities of Devel::MAT then this may indeed by the document for you; read on... DESCRIPTION A Devel::MAT instance loads a heapdump file, and provides a container to store analysis tools to work on it. Tools may be provided that conform to the Devel::MAT::Tool API, which can help analyse the data and interact with the explorer user interface by using the methods in the Devel::MAT::UI package. File Format The dump file format is still under development, so at present no guarantees are made on whether files can be loaded over mismatching versions of Devel::MAT. However, as of version 0.11 the format should be more extensible, allowing new SV fields to be added without breaking loading - older tools will ignore new fields and newer tools will just load undef for fields absent in older files. As the distribution approaches maturity the format will be made more stable. CONSTRUCTOR load $pmat = Devel::MAT->load( $path, %args ) Loads a heap dump file from the given path, and returns a new Devel::MAT instance wrapping it. METHODS dumpfile $df = $pmat->dumpfile Returns the underlying Devel::MAT::Dumpfile instance backing this analysis object. available_tools @tools = $pmat->available_tools Lists the Devel::MAT::Tool classes that are installed and available. load_tool $tool = $pmat->load_tool( $name ) Loads the named Devel::MAT::Tool class. has_tool $bool = $pmat->has_tool( $name ) Returns true if the named tool is already loaded. run_command $pmat->run_command( $inv ) Runs a tool command given by the Commandable::Invocation instance. inref_graph $node = $pmat->inref_graph( $sv, %opts ) Traces the tree of inrefs from $sv back towards the known roots, returning a Devel::MAT::Graph node object representing it, within a graph of reverse references back to the known roots. This method will load Devel::MAT::Tool::Inrefs if it isn't yet loaded. The following named options are recognised: depth => INT If specified, stop recursing after the specified count. A depth of 1 will only include immediately referring SVs, 2 will print the referrers of those, etc. Nodes with inrefs that were trimmed because of this limit will appear to be roots with a special name of EDEPTH. strong => BOOL direct => BOOL Specifies the type of inrefs followed. By default all inrefs are followed. Passing strong will follow only strong direct inrefs. Passing direct will follow only direct inrefs. elide => BOOL If true, attempt to neaten up the output by skipping over certain structures. REF()-type SVs will be skipped to their referrant. Members of the symbol table will be printed as being a 'root' element of the given symbol name. PADs and PADLISTs will be skipped to their referring CODE, giving shorter output for lexical variables. find_symbol $sv = $pmat->find_symbol( $name ) Attempts to walk the symbol table looking for a symbol of the given name, which must include the sigil. $Package::Name::symbol_name => to return a SCALAR SV @Package::Name::symbol_name => to return an ARRAY SV %Package::Name::symbol_name => to return a HASH SV &Package::Name::symbol_name => to return a CODE SV find_glob $gv = $pmat->find_glob( $name ) Attempts to walk the symbol table looking for a symbol of the given name, returning the GLOB object if found. find_stash $stash = $pmat->find_stash( $name ) Attempts to walk the symbol table looking for a stash of the given name. AUTHOR Paul Evans Devel-MAT-0.52/bin000755001750001750 014550507443 12416 5ustar00leoleo000000000000Devel-MAT-0.52/bin/pmat000555001750001750 441214550507443 13443 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Feature::Compat::Try; use Devel::MAT::Cmd::Terminal; use Getopt::Long qw( :config no_permute ); use Commandable::Invocation 0.03; # ->new_from_tokens use constant CAN_COLOUR => -t STDERR; GetOptions( 'quiet|q' => \( my $QUIET ), 'blib' => sub { require blib; blib->import }, ) or exit 1; # Some tools might want to draw pretty graphs with line drawing / similar STDOUT->binmode( ":encoding(UTF-8)" ); STDOUT->autoflush(1); require Devel::MAT; my $file = shift @ARGV or die "Need dumpfile\n"; my $progress = ( CAN_COLOUR && !$QUIET ? sub { print STDERR "\r\e[K" . ( shift // "" ); } : undef ); my $pmat = Devel::MAT->load( $file, progress => $progress, ); $progress->() if $progress; my $df = $pmat->dumpfile; if( !$QUIET ) { $pmat->run_command( Commandable::Invocation->new( "summary" ) ); } if( @ARGV ) { $pmat->run_command( Commandable::Invocation->new_from_tokens( @ARGV ), progress => $progress, ); # Finish the pagination output Devel::MAT::Tool::more->run while Devel::MAT::Tool::more->can_more; exit } require Term::ReadLine; my $rl = Term::ReadLine->new( 'pmat' ); while( defined( my $line = $rl->readline( sprintf 'pmat%s> ', Devel::MAT::Tool::more->can_more ? " [more]" : "" ) ) ) { my $inv = Commandable::Invocation->new( $line ); defined $inv->peek_token or $inv = Commandable::Invocation->new( "more" ) if Devel::MAT::Tool::more->can_more; next unless defined $inv->peek_token; # blank line last if $inv->peek_token eq "exit" or $inv->peek_token eq "quit"; try { # We just have to hope nobody catches this one. # It would be nice to next COMMAND but awkward perl internals reasons # mean we can't do that from a signal handler local $SIG{INT} = sub { die "\nAborted\n"; }; $pmat->run_command( $inv, progress => $progress, ); } catch ($e) { print STDERR "$e"; } print "\n"; } print "\n"; =head1 NAME pmat - Perl Memory Analysis Tool =head1 SYNOPSIS $ pmat my-file.pmat =head1 OPTIONS =over 4 =item --quiet, -q Don't print progress reports or welcome banner. =back =head1 DESCRIPTION See L. =head1 AUTHOR Paul Evans =cut Devel-MAT-0.52/bin/pmat-cat-svpv000555001750001750 64014550507443 15163 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Devel::MAT; my $df = Devel::MAT->load( $ARGV[0] // die "Need dumpfile\n" )->dumpfile; my $addr = $ARGV[1] // die "Need addr\n"; $addr = hex $addr if $addr =~ m/^0x/; my $sv = $df->sv_at( $addr ); $sv or die sprintf "No SV at %#x\n", $addr; $sv->type eq "SCALAR" or die "SV is not a SCALAR\n"; defined( my $pv = $sv->pv ) or die "SV does not have a PV\n"; print $pv; Devel-MAT-0.52/bin/pmat-counts000555001750001750 476414550507443 14766 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Devel::MAT; use Devel::MAT::Cmd::Terminal; use Commandable::Invocation 0.03; use Devel::MAT::Tool::Count; use constant TAG_INCR => fgindex => 2; # green use constant TAG_DECR => fgindex => 1; # red my $progress = ( -t STDERR ) ? sub { print STDERR "\r\e[K"; print STDERR "$_[0]" if @_; } : undef; my $cinv = Commandable::Invocation->new_from_tokens( @ARGV ); my @args = Devel::MAT::Tool::Count->parse_cmd( $cinv ); ref $args[0] eq "HASH" or die "ARGH! Expected HASH as first parsed result\n"; my %opts = %{ +shift @args }; my %lastcount; $opts{emit_count} = sub { my ( $kind, $blessed, $count ) = @_; my $lastcount = $lastcount{"$kind/$blessed"}; $lastcount{"$kind/$blessed"} = $count; return "", "" unless $count || $lastcount; my @ret = sprintf "%d", $count; if( !defined $lastcount or $count == $lastcount ) { push @ret, ""; } elsif( $count > $lastcount ) { push @ret, String::Tagged->new_tagged( sprintf( "(+%d)", $count - $lastcount ), TAG_INCR ); } else { push @ret, String::Tagged->new_tagged( sprintf( "(-%d)", $lastcount - $count ), TAG_DECR ); } return @ret; }; my %lastbytes; $opts{emit_bytes} = sub { my ( $kind, $blessed, $bytes ) = @_; my $lastbytes = $lastbytes{"$kind/$blessed"}; $lastbytes{"$kind/$blessed"} = $bytes; return "", "" unless $bytes || $lastbytes; my @ret = Devel::MAT::Cmd->format_bytes( $bytes ); if( !defined $lastbytes or $bytes == $lastbytes ) { push @ret, ""; } elsif( $bytes > $lastbytes ) { push @ret, String::Tagged->from_sprintf( "(+%s)", Devel::MAT::Cmd->format_bytes( $bytes - $lastbytes ) ) ->apply_tag( 0, -1, TAG_INCR ); } else { push @ret, String::Tagged->from_sprintf( "(-%s)", Devel::MAT::Cmd->format_bytes( $lastbytes - $bytes ) ) ->apply_tag( 0, -1, TAG_DECR ); } return @ret; }; $opts{table_args} = { headings => [ "Kind", "Count","", "(blessed)","", "Bytes","", "(blessed)","" ], sep => [ " ", ""," ","", " ", ""," ","" ], align => [ undef, "right","left", "right","left", "right","left", "right","left" ], }; while( my $file = $cinv->pull_token ) { Devel::MAT::Cmd->printf( "%s\n", Devel::MAT::Cmd->format_heading( $file, 2 ) ); my $pmat = Devel::MAT->load( $file, progress => $progress ); $progress->() if $progress; $pmat->load_tool( "Count", progress => $progress ) ->count_svs( %opts ); } Devel-MAT-0.52/bin/pmat-diff000555001750001750 1170514550507443 14374 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use feature qw( say ); use utf8; use Devel::MAT; use Devel::MAT::Cmd::Terminal; use List::Util qw( any ); use List::UtilsBy qw( nsort_by ); # We're drawing pretty graphs with line drawing STDOUT->binmode( ":encoding(UTF-8)" ); my $progress = ( -t STDERR ) ? sub { print STDERR "\r\e[K" . ( shift // "" ); } : undef; my $pmatA = Devel::MAT->load( my $fileA = ( $ARGV[0] // die "Need dumpfile A\n" ), progress => $progress, ); my $pmatB = Devel::MAT->load( my $fileB = ( $ARGV[1] // die "Need dumpfile B\n" ), progress => $progress, ); $progress->( "Sorting,.." ) if $progress; my @svsA = nsort_by { $_->addr } $pmatA->dumpfile->heap; my @svsB = nsort_by { $_->addr } $pmatB->dumpfile->heap; $progress->() if $progress; my $countC = 0; my @onlyA; my @onlyB; while( @svsA && @svsB ) { my $svA = $svsA[0]; my $svB = $svsB[0]; my $addrA = $svA->addr; my $addrB = $svB->addr; if( $addrA < $addrB ) { push @onlyA, $svA; shift @svsA; } elsif( $addrB < $addrA ) { push @onlyB, $svB; shift @svsB; } else { # common - no print $countC++; shift @svsA; shift @svsB; } } push @onlyA, @svsA; push @onlyB, @svsB; my %notesA; my %notesB; sub add_notes { my ( $svs, $notes, $pmat ) = @_; my %addrs = map { $_->addr => 1 } @$svs; foreach my $sv ( $pmat->dumpfile->heap ) { next unless $sv->type eq "STASH"; my $stash = $sv; foreach my $field (qw( mro_isa mro_linearcurrent )) { my $sv = $stash->$field or next; $addrs{ $sv->addr } or next; $notes->{ $sv->addr } = "$field of " . Devel::MAT::Cmd->format_symbol( $stash->stashname, $stash ); } } } add_notes \@onlyA, \%notesA, $pmatA; add_notes \@onlyB, \%notesB, $pmatB; sub svtrees_from_set { my @svs = @_; # In general the set of SVs and their cross-linkages are not yet suitable # to print in a simple tree, because of cycles and multiple paths. We have # to reduce the linkages down to something more well-behaved. my %svs_by_addr = map { $_->addr => $_ } @svs; my %sv_outrefs; # {$addr} => [other svs here that it refers to] foreach my $sv ( @svs ) { $sv_outrefs{ $sv->addr } = []; foreach my $ref ( $sv->outrefs ) { next unless $svs_by_addr{ $ref->sv->addr }; push $sv_outrefs{ $sv->addr }->@*, $ref->sv; } } my %sv_trees; # {$addr} => [$sv, other SV trees it refers to] my %seen; # {$addr} => bool my %toplevel; # {$addr} => bool foreach my $origsv ( @svs ) { my @queue = $origsv; while( @queue ) { my $sv = shift @queue; my $addr = $sv->addr; if( !$sv_trees{ $addr } ) { $toplevel{ $addr }++; } $seen{ $addr }++; my $node = $sv_trees{ $addr } //= [ $sv ]; my @new_outrefs = grep { !$seen{ $_->addr }++ } $sv_outrefs{ $addr }->@*; foreach my $outref ( nsort_by { $_->addr } @new_outrefs ) { push @queue, $outref; push $node->@*, $sv_trees{ $outref->addr } //= [ $outref ]; delete $toplevel{ $outref->addr }; } } } return @sv_trees{ sort { $a <=> $b } keys %toplevel }; } our $Indent = ""; sub print_svtree { my ( $tree, $leader0, $leader1, $notes ) = @_; my ( $sv, @subtrees ) = @$tree; my $note = $notes->{ $sv->addr } ? " (" . $notes->{ $sv->addr } . ")" : ""; Devel::MAT::Cmd->printf( " %s%s%s%s\n", $Indent, $leader0, Devel::MAT::Cmd->format_sv( $sv ), $note, ); return unless @subtrees; local $Indent = "$Indent$leader1"; my $final_subtree = pop @subtrees; { print_svtree( $_, "├─ ", "│ ", $notes ) for @subtrees; } { print_svtree( $final_subtree, "└─ ", " ", $notes ); } } print "\n"; printf "%d unique to %s:\n", scalar @onlyA, $fileA; my @treesA = svtrees_from_set @onlyA; print_svtree $_, "- ", " ", \%notesA for @treesA; print "\n"; printf "%d unique to %s:\n", scalar @onlyB, $fileB; my @treesB = svtrees_from_set @onlyB; print_svtree $_, "+ ", " ", \%notesB for @treesB; print "\n"; printf "%d common\n", $countC; =head1 NAME pmat-diff - print a list of SVs unique to each of two given files =head1 SYNOPSIS $ pmat-diff test-1.pmat test-1-after.pmat =head1 DESCRIPTION Given two F<.pmat> files, compares them and prints a list of SVs unique to each, and a count of those found common to both. This is only useful if the two files were generated by the same process, usually at similar times, such as either side of a memory leak test as created by C. For each file, the SVs unique to it are gathered up into a forest of trees by reference, because in typical usage patterns it usually ends up that several SVs are all referenced by one container. It often helps when tracking down memory leaks to focus on those outer containers, rather than the inner SVs they contain. =head1 AUTHOR Paul Evans =cut Devel-MAT-0.52/bin/pmat-leakreport000555001750001750 376214550507443 15620 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Devel::MAT; use Getopt::Long; use List::UtilsBy qw( nsort_by ); GetOptions( '1|onefile' => \( my $ONE ), ) or exit 1; my $findex = 0; my $progress = ( -t STDERR ) ? sub { print STDERR "\r\e[K"; print STDERR "[$findex]: $_[0]" if @_; } : undef; # A leaking SV is one that appears and then never gets touched again # To detect them, we need to look for SVs that appear between two files, # and then don't disappear again. Any that do disappear were simply # temporaries and can be ignored. # In order to try to detect reused arena slots we'll use the combination of # address and basetype as the key sub sv_key { return join ":", $_[0]->addr, $_[0]->basetype } my %candidates; # To detect newly-allocated SVs, keep a set of the previous file's ones. my $previous_svs; my $pmat; sub list_svs { return { map { sv_key($_) => 1 } $pmat->dumpfile->heap }; } # Initialise the set of previous SVs from the first file $pmat = Devel::MAT->load( shift @ARGV, progress => $progress ); $previous_svs = list_svs; $findex++; while( my $file = shift @ARGV ) { $pmat = Devel::MAT->load( $file, progress => $progress ); my $svs = list_svs; $findex++; # Any current candidates that aren't now still allocated, are definitely not # leaks exists $svs->{$_} or delete $candidates{$_} for keys %candidates; # No point looking for more candidates if there's no files left to # invalidate any new temporaries with last unless @ARGV; next if $ONE and %candidates; # Any new SV that wasn't seen previously is a candidate for leaking exists $previous_svs->{$_} or $candidates{$_} = $findex for keys %$svs; $previous_svs = $svs; } $progress->() if $progress; my $df = $pmat->dumpfile; foreach my $svkey ( nsort_by { $candidates{$_} } keys %candidates ) { my $findex = $candidates{$svkey}; my ( $addr ) = split m/:/, $svkey; my $sv = $df->sv_at( $addr ); printf "LEAK[%d] %s\n", $findex, $sv->desc_addr; } Devel-MAT-0.52/bin/pmat-list-orphans000555001750001750 57614550507443 16053 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use feature qw( say ); use Devel::MAT; my $pmat = Devel::MAT->load( $ARGV[0] // die "Need dumpfile\n" ); $pmat->load_tool( "Inrefs" ); my $df = $pmat->dumpfile; my %orphans; foreach my $sv ( $df->heap ) { $orphans{$sv->addr} = $sv unless $sv->inrefs; } foreach my $addr ( sort keys %orphans ) { say $orphans{$addr}->desc_addr; } Devel-MAT-0.52/doc000755001750001750 014550507443 12413 5ustar00leoleo000000000000Devel-MAT-0.52/doc/format.txt000444001750001750 1637414550507443 14634 0ustar00leoleo000000000000File consists sections: Header Roots Stack Heap Context Header: CHAR[4] MAGIC "PMAT" U8 FLAGS 0x01 : big-endian 0x02 : INT/UV/IV are 64-bit 0x04 : PTR is 64-bit 0x08 : NV is long double 0x10 : ithreads U8 zero U8 FORMATVER_MAJOR 0 U8 FORMATVER_MINOR 4 U32 PERLVER rev<<24 | ver<<16 | sub U8 NTYPES {U8 HEADERLEN U8 NPTRS U8 NSTRS}*$NTYPES -- type=0 is common, then actual SV types U8 NEXTNS {U8 HEADERLEN U8 NPTRS U8 NSTRS}*$NEXTNS U8 NCONTEXTS {U8 HEADERLEN U8 NPTRS U8 NSTRS}*$NTYPES -- type=0 is common, then actual Context types Roots: PTR UNDEF the "undef" immortal PTR YES the "yes" immortal PTR NO the "no" immortal U32 NROOTS=$n {STR ROOTNAME PTR ROOT} * $n main_cv = the main code defstash = the default stash mainstack = the main stack AV beginav = the BEGIN list checkav = the CHECK list unitcheckav = the UNITCHECK list initav = the INIT list endav = the END list strtab = the shared string table HV envgv = the ENV GV incgv = the INC GV statgv = the stat GV statname = the statname SV tmpsv = the temporary SV defgv = the default GV argvgv = the ARGV GV argoutgv = the argvout GV argvout_stack = the argout stack AV fdpidav = the FD-to-PID mapping AV preambleav = the compiler preamble AV modglobalhv = the module data globals HV regex_padav = the REGEXP pad AV sortstash = the sort stash firstgv = the *a GV secondgv = the *b GV debstash = the debugger stash stashcache = the stash cache isarev = the reverse map of @ISA dependencies registered_mros = the registered MROs HV rs = the IRS last_in_gv = the last input GV ofsgv = the OFS GV defoutgv = the default output GV hintgv = the hints (%^H) GV patchlevel = the patch level apiversion = the API version e_script = the '-e' script mess_sv = the message SV ors_sv = the ORS SV encoding = the encoding blockhooks = the block hooks custom_ops = the custom ops HV custom_op_names = the custom op names HV custom_op_descs = the custom op descriptions HV # Plus miscellaneous other internal UTF-8 / text encoding support SVs Stack: UINT SIZE = $n {PTR ELEM}*$n Heap: type==0-terminated list of SVs An SV: U8 TYPE (0xff == UNKNOWN) Header(4+P+I): PTR ADDRESS U32 REFCNT UINT SIZE PTRs(1): BLESSED STRs(0) type: SCALAR: Header(1+2I+N): U8 FLAGS 0x01 : has IV 0x02 : IV is UV 0x04 : has NV 0x08 : has STR 0x10 : STR is UTF8 UINT IV double NV UINT PVLEN PTRs(1): OURSTASH STRs(1): PV type: REF: Header(1): U8 FLAGS 0x01 : RV is weak PTRs(2): RV OURSTASH type: GLOB Header(I): UINT LINE PTRs(8): STASH SCALAR ARRAY HASH CODE EGV IO FORM STRs(2): NAME FILE type: ARRAY Header(1+I): UINT COUNT = $n U8 FLAGS 0x01 : AV is not REAL PTRs(0) STRs(0) Body: {PTR ELEM}*$n type: HASH Header(I): UINT COUNT = $n PTRs(1): BACKREFS Body: {STR KEY PTR VALUE}*$n type: STASH [extends fields of a hash] PTRs(4): MRO_LINEAR_ALL MRO_LINEAR_CURRENT MRO_NEXTMETHOD MRO_ISA STRs(1): NAME type: CODE Header(1+I+P): UINT LINE U8 FLAGS 0x01 : CLONE 0x02 : CLONED 0x04 : XSUB 0x08 : WEAKOUTSIDE 0x10 : CVGV_RC 0x20 : LEXICAL PTR OPROOT U32 DEPTH PTRs(5): STASH GLOB OUTSIDE PADLIST CONSTVAL STRs(2): FILE NAME Body: {U8 TYPE ... } until TYPE==0 type: CONSTSV PTR SV type: CONSTIX UINT PADIX type: GVSV PTR SV type: GVIX UINT PADIX type: PADNAMES PTR PADNAMES type: PAD UINT DEPTH PTR PAD type: PADNAME UINT PADIX STR PADNAME PTR OURSTASH type: PADNAME_FLAGS UINT PADIX U8 FLAGS 0x01 : OUTER 0x02 : STATE 0x04 : LVALUE 0x08 : TYPED 0x10 : OUR type: IO Header(2I): UINT IFILENO UINT OFILENO PTRs(3): TOP FORMAT BOTTOM type: LVALUE Header(1 + 2I): U8 TYPE UINT OFF UINT LEN PTRs(1): TARG type: REGEXP type: FORMAT type: UNDEF type: YES type: NO type: STRUCT Header(0): FIELD(n): -- given by META SV extensions: PTR SV type: MAGIC (0x80) Header(2): U8 TYPE U8 FLAGS 0x01 : MGf_REFCOUNTED PTRs(3): MG_OBJ MG_PTR MG_VTBL type: SAVED_SV (0x81) Header(0) PTRs(1): SV type: SAVED_AV (0x82) Header(0) PTRs(1): AV type: SAVED_HV (0x83) Header(0) PTRs(1): HV type: SAVED_AELEM (0x84) Header(I): UINT INDEX PTRs(1): SV type: SAVED_HELEM (0x85) Header(0) PTRs(2): KEY SV type: SAVED_CV (0x86) Header(0) PTRs(1): CV type: SVSV note (0x87) Header(0) PTRs(1): SV STRs(1): NAME type: DEBUGREPORT (DEBUG_LEAKING_SCALARS) (0x88) Header(2I): UINT SERIAL UINT LINE STRs(1): FILE type: META_STRUCT (0xF0) Header(2I): UINT STRUCTID UINT NFIELDS STRs(1) NAME Body: {STR FIELDNAME U8 TYPE 0x00 : Pointer (PTR) 0x01 : Boolean (U8) 0x02 : Number (U8) 0x03 : Number (U32) 0x04 : Number (UINT) }*$n Context: type==0-terminated list of CTXs CTX: U8 TYPE U8 GIMME UINT LINE STR FILE type: SUB U32 OLDDEPTH PTR CV PTR ARGS type: TRY type: EVAL PTR CODESV Devel-MAT-0.52/lib000755001750001750 014550507443 12414 5ustar00leoleo000000000000Devel-MAT-0.52/lib/Devel000755001750001750 014550507443 13453 5ustar00leoleo000000000000Devel-MAT-0.52/lib/Devel/MAT.pm000444001750001750 4172214550507443 14615 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2022 -- leonerd@leonerd.org.uk package Devel::MAT 0.52; use v5.14; use warnings; use Carp; use List::Util qw( first pairs ); use List::UtilsBy qw( sort_by ); use Syntax::Keyword::Match; use Devel::MAT::Dumpfile; use Devel::MAT::Graph; use Devel::MAT::InternalTools; use Module::Pluggable sub_name => "_available_tools", search_path => [ "Devel::MAT::Tool" ], require => 1; require XSLoader; XSLoader::load( __PACKAGE__, our $VERSION ); =head1 NAME C - Perl Memory Analysis Tool =head1 USER GUIDE B If you are new to the C set of tools, this is probably not the document you want to start with. If you are interested in using C to help diagnose memory-related problems in a F program you instead want to read the user guide, at L. If you are writing tooling modules to extend the abilities of C then this may indeed by the document for you; read on... =head1 DESCRIPTION A C instance loads a heapdump file, and provides a container to store analysis tools to work on it. Tools may be provided that conform to the L API, which can help analyse the data and interact with the explorer user interface by using the methods in the L package. =head2 File Format The dump file format is still under development, so at present no guarantees are made on whether files can be loaded over mismatching versions of C. However, as of version 0.11 the format should be more extensible, allowing new SV fields to be added without breaking loading - older tools will ignore new fields and newer tools will just load undef for fields absent in older files. As the distribution approaches maturity the format will be made more stable. =cut =head1 CONSTRUCTOR =cut =head2 load $pmat = Devel::MAT->load( $path, %args ) Loads a heap dump file from the given path, and returns a new C instance wrapping it. =cut sub load { my $class = shift; my $df = Devel::MAT::Dumpfile->load( @_ ); return bless { df => $df, }, $class; } =head1 METHODS =cut =head2 dumpfile $df = $pmat->dumpfile Returns the underlying L instance backing this analysis object. =cut sub dumpfile { my $self = shift; return $self->{df}; } =head2 available_tools @tools = $pmat->available_tools Lists the L classes that are installed and available. =cut { my @TOOLS; my $TOOLS_LOADED; sub available_tools { my $self = shift; return @TOOLS if $TOOLS_LOADED; $TOOLS_LOADED++; @TOOLS = map { $_ =~ s/^Devel::MAT::Tool:://; $_ } $self->_available_tools; foreach my $name ( @TOOLS ) { my $tool_class = "Devel::MAT::Tool::$name"; next unless $tool_class->can( "AUTOLOAD_TOOL" ) and $tool_class->AUTOLOAD_TOOL( $self ); $self->{tools}{$name} ||= $tool_class->new( $self ); } return @TOOLS; } } =head2 load_tool $tool = $pmat->load_tool( $name ) Loads the named L class. =cut sub load_tool { my $self = shift; my ( $name, %args ) = @_; # Ensure tools are 'require'd $self->available_tools; my $tool_class = "Devel::MAT::Tool::$name"; return $self->{tools}{$name} ||= $tool_class->new( $self, %args ); } sub load_tool_for_command { my $self = shift; my ( $cmd, %args ) = @_; return $self->{tools_by_command}{$cmd} ||= do { my $name = first { my $class = "Devel::MAT::Tool::$_"; $class->can( "CMD" ) and $class->CMD eq $cmd } $self->available_tools or die "Unrecognised command '$cmd'\n"; $self->load_tool( $name, %args ); }; } =head2 has_tool $bool = $pmat->has_tool( $name ) Returns true if the named tool is already loaded. =cut sub has_tool { my $self = shift; my ( $name ) = @_; return defined $self->{tools}{$name}; } =head2 run_command $pmat->run_command( $inv ) Runs a tool command given by the L instance. =cut sub run_command { my $self = shift; my ( $inv, %args ) = @_; my $cmd = $inv->pull_token; $self->load_tool_for_command( $cmd, progress => $args{process}, )->run_cmd( $inv ); } =head2 inref_graph $node = $pmat->inref_graph( $sv, %opts ) Traces the tree of inrefs from C<$sv> back towards the known roots, returning a L node object representing it, within a graph of reverse references back to the known roots. This method will load L if it isn't yet loaded. The following named options are recognised: =over 4 =item depth => INT If specified, stop recursing after the specified count. A depth of 1 will only include immediately referring SVs, 2 will print the referrers of those, etc. Nodes with inrefs that were trimmed because of this limit will appear to be roots with a special name of C. =item strong => BOOL =item direct => BOOL Specifies the type of inrefs followed. By default all inrefs are followed. Passing C will follow only strong direct inrefs. Passing C will follow only direct inrefs. =item elide => BOOL If true, attempt to neaten up the output by skipping over certain structures. C-type SVs will be skipped to their referrant. Members of the symbol table will be printed as being a 'root' element of the given symbol name. Cs and Cs will be skipped to their referring C, giving shorter output for lexical variables. =back =cut sub inref_graph { my $self = shift; my ( $sv, %opts ) = @_; my $graph = $opts{graph} //= Devel::MAT::Graph->new( $self->dumpfile ); # TODO: allow separate values for these my $elide_rv = $opts{elide}; my $elide_sym = $opts{elide}; my $elide_pad = $opts{elide}; $self->load_tool( "Inrefs" ); if( $sv->immortal ) { my $desc = $sv->type eq "UNDEF" ? "undef" : $sv->uv ? "true" : "false"; $graph->add_root( $sv, Devel::MAT::SV::Reference( $desc, strong => undef ) ); return $graph->get_sv_node( $sv ); } my $name; my $foundsv; if( $elide_sym and $name = $sv->symname and $name !~ m/^&.*::__ANON__$/ and $foundsv = eval { $self->find_symbol( $sv->symname ) } and $foundsv->addr == $sv->addr ) { $graph->add_root( $sv, Devel::MAT::SV::Reference( "the symbol '" . Devel::MAT::Cmd->format_symbol( $name, $sv ) . "'", strong => undef ) ); return $graph->get_sv_node( $sv ); } if( $elide_sym and $sv->type eq "GLOB" and $name = $sv->stashname ) { $graph->add_root( $sv, Devel::MAT::SV::Reference( "the glob '" . Devel::MAT::Cmd->format_symbol( "*$name", $sv ) . '"', strong => undef ) ); return $graph->get_sv_node( $sv ); } $graph->add_sv( $sv ); my @inrefs = $opts{strong} ? $sv->inrefs_strong : $opts{direct} ? $sv->inrefs_direct : $sv->inrefs; # If we didn't find anything at the given option level, try harder if( !@inrefs and $opts{strong} ) { @inrefs = $sv->inrefs_direct; } if( !@inrefs and $opts{direct} ) { @inrefs = $sv->inrefs; } if( $elide_rv ) { @inrefs = map { sub { return $_ unless $_->sv and $_->sv->type eq "REF" and $_->name eq "the referrant"; my $rv = $_->sv; my @rvrefs = $opts{strong} ? $rv->inrefs_strong : $opts{direct} ? $rv->inrefs_direct : $rv->inrefs; return $_ unless @rvrefs == 1; # Add 'via RV' marker return map { Devel::MAT::SV::Reference( Devel::MAT::Cmd->format_note( "(via RV)" ) . " " . $_->name, $_->strength, $_->sv ) } @rvrefs; }->() } @inrefs; } if( $elide_pad ) { @inrefs = map { sub { return $_ unless $_->sv and $_->sv->type eq "PAD"; my $pad = $_->sv; my $cv = $pad->padcv; # Even if the CV isn't active, this might be a state variable so we # must always consider pad(1) at least. my ( $depth ) = grep { $cv->pad( $_ ) == $pad } ( 1 .. ( $cv->depth || 1 ) ); return Devel::MAT::SV::Reference( $_->name . " at depth $depth", $_->strength, $cv ); }->() } @inrefs; } if( $sv->is_mortal ) { $graph->add_root( $sv, Devel::MAT::SV::Reference( "a mortal", strong => undef ) ); } foreach my $ref ( sort_by { $_->name } @inrefs ) { if( !defined $ref->sv ) { $graph->add_root( $sv, $ref ); next; } if( defined $opts{depth} and not $opts{depth} ) { $graph->add_root( $sv, "EDEPTH" ); last; } my @me; if( $graph->has_sv( $ref->sv ) ) { $graph->add_ref( $ref->sv, $sv, $ref ); # Don't recurse into it as it was already found } else { $graph->add_sv( $ref->sv ); # add first to stop inf. loops defined $opts{depth} ? $self->inref_graph( $ref->sv, %opts, depth => $opts{depth}-1 ) : $self->inref_graph( $ref->sv, %opts ); $graph->add_ref( $ref->sv, $sv, $ref ); } } return $graph->get_sv_node( $sv ); } =head2 find_symbol $sv = $pmat->find_symbol( $name ) Attempts to walk the symbol table looking for a symbol of the given name, which must include the sigil. $Package::Name::symbol_name => to return a SCALAR SV @Package::Name::symbol_name => to return an ARRAY SV %Package::Name::symbol_name => to return a HASH SV &Package::Name::symbol_name => to return a CODE SV =cut sub find_symbol { my $self = shift; my ( $name ) = @_; my ( $sigil, $globname ) = $name =~ m/^([\$\@%&])(.*)$/ or croak "Could not parse sigil from $name"; my $stashvalue = $self->find_stashvalue( $globname ); # Perl 5.22 may take CODE shortcuts if( $sigil eq '&' and $stashvalue->type eq "REF" ) { return $stashvalue->rv; } $stashvalue->type eq "GLOB" or croak "$globname is not a GLOB"; my $slot = ( $sigil eq '$' ) ? "scalar" : ( $sigil eq '@' ) ? "array" : ( $sigil eq '%' ) ? "hash" : ( $sigil eq '&' ) ? "code" : die "ARGH"; # won't happen my $sv = $stashvalue->$slot or croak "\*$globname has no $slot slot"; return $sv; } =head2 find_glob $gv = $pmat->find_glob( $name ) Attempts to walk the symbol table looking for a symbol of the given name, returning the C object if found. =head2 find_stash $stash = $pmat->find_stash( $name ) Attempts to walk the symbol table looking for a stash of the given name. =cut sub find_stashvalue { my $self = shift; my ( $name ) = @_; my ( $parent, $shortname ) = $name =~ m/^(?:(.*)::)?(.+?)$/; my $stash; if( defined $parent and length $parent ) { $stash = $self->find_stash( $parent ); } else { $stash = $self->dumpfile->defstash; } my $sv = $stash->value( $shortname ) or croak $stash->stashname . " has no symbol $shortname"; return $sv; } sub find_glob { my $self = shift; my ( $name ) = @_; my $sv = $self->find_stashvalue( $name ) or return; $sv->type eq "GLOB" or croak "$name is not a GLOB"; return $sv; } sub find_stash { my $self = shift; my ( $name ) = @_; my $gv = $self->find_glob( $name . "::" ); return $gv->hash || croak "$name has no hash"; } # Some base implementations of Devel::MAT::Cmd formatters push @Devel::MAT::Cmd::ISA, qw( Devel::MAT::Cmd::_base ); package Devel::MAT::Cmd::_base; use B qw( perlstring ); use List::Util qw( max ); sub print_table { my $self = shift; my ( $rows, %opts ) = @_; if( $opts{headings} ) { my @headings = map { $self->format_heading( $_ ) } @{ $opts{headings} }; $rows = [ \@headings, @$rows ]; } return unless @$rows; my $cols = max map { scalar @$_ } @$rows; my @colwidths = map { my $colidx = $_; # TODO: consider a unicode/terminal-aware version of length here max map { length($_->[$colidx]) // 0 } @$rows; } 0 .. $cols-1; my $align = $opts{align} // ""; $align = [ ( $align ) x $cols ] if !ref $align; my $sep = $opts{sep} // " "; $sep = [ ( $sep ) x ($cols - 1) ] if !ref $sep; my @leftalign = map { ($align->[$_]//"") ne "right" } 0 .. $cols-1; my $format = join( "", ( " " x ( $opts{indent} // 0 ) ), ( map { my $col = $_; my $width = $colwidths[$col]; my $flags = $leftalign[$col] ? "-" : ""; # If final column should be left-aligned don't bother with width $width = "" if $col == $cols-1 and $leftalign[$col]; ( $col ? $sep->[$col-1] : "" ) . "%${flags}${width}s" } 0 .. $cols-1 ), ) . "\n"; foreach my $row ( @$rows ) { my @row = @$row; @row or @row = map { "-"x$colwidths[$_] } ( 0 .. $cols-1 ); push @row, "" while @row < $cols; # pad with spaces $self->printf( $format, @row ); } } sub format_note { shift; my ( $str, $idx ) = @_; return $str; } sub _format_sv { shift; my ( $ret ) = @_; return $ret; } sub format_sv { shift; my ( $sv ) = @_; my $ret = $sv->desc; if( my $blessed = $sv->blessed ) { $ret .= "=" . Devel::MAT::Cmd->format_symbol( $blessed->stashname, $blessed ); } $ret .= sprintf " at %#x", $sv->addr; if( my $rootname = $sv->rootname ) { $ret .= "=" . Devel::MAT::Cmd->format_note( $rootname, 1 ); } return Devel::MAT::Cmd->_format_sv( $ret, $sv ); } sub _format_value { shift; my ( $val ) = @_; return $val; } sub format_value { shift; my ( $val, %opts ) = @_; my $text; if( $opts{key} ) { my $strval = $val; if( $opts{stash} && $strval =~ m/^([\x00-\x1f])([a-zA-Z0-9_]*)$/ ) { $strval = "^" . chr( 64 + ord $1 ) . $2; } elsif( $strval !~ m/^[a-zA-Z_][a-zA-Z0-9_]*$/ ) { $strval = perlstring( $val ); } return "{" . Devel::MAT::Cmd->_format_value( $strval ) . "}"; } elsif( $opts{index} ) { return "[" . Devel::MAT::Cmd->_format_value( $val+0 ) . "]"; } elsif( $opts{pv} ) { my $truncated; if( my $maxlen = $opts{maxlen} // 64 ) { ( $truncated = length $val > $maxlen ) and substr( $val, $maxlen ) = ""; } return Devel::MAT::Cmd->_format_value( perlstring( $val ) . ( $truncated ? "..." : "" ) ); } else { return Devel::MAT::Cmd->_format_value( $val ); } } sub format_symbol { shift; my ( $name ) = @_; return $name; } sub format_bytes { shift; my ( $bytes ) = @_; if( $bytes < 1024 ) { return sprintf "%d bytes", $bytes; } if( $bytes < 1024**2 ) { return sprintf "%.1f KiB", $bytes / 1024; } if( $bytes < 1024**3 ) { return sprintf "%.1f MiB", $bytes / 1024**2; } if( $bytes < 1024**4 ) { return sprintf "%.1f GiB", $bytes / 1024**3; } return sprintf "%.1f TiB", $bytes / 1024**4; } sub format_sv_with_value { my $self = shift; my ( $sv ) = @_; my $repr = $self->format_sv( $sv ); match( $sv->type : eq ) { case( "SCALAR" ) { my @reprs; my $num; defined( $num = $sv->nv // $sv->uv ) and push @reprs, $self->format_value( $num, nv => 1 ); defined $sv->pv and push @reprs, $self->format_value( $sv->pv, pv => 1 ); # Dualvars return "$repr = $reprs[0] / $reprs[1]" if @reprs > 1; return "$repr = $reprs[0]" if @reprs; } case( "BOOL" ) { return "$repr = " . $self->format_value( $sv->uv ? "true" : "false" ); } case( "REF" ) { #return "REF => NULL" if !$sv->rv; return "$repr => " . $self->format_sv_with_value( $sv->rv ) if $sv->rv; } case( "ARRAY" ) { return $repr if $sv->blessed; my $n_elems = $sv->elems; return "$repr = []" if !$n_elems; my $elem = $self->format_sv( $sv->elem( 0 ) ); $elem .= ", ..." if $n_elems > 1; return "$repr = [$elem]"; } case( "HASH" ) { return $repr if $sv->blessed; my $n_values = $sv->values; return "$repr = {}" if !$n_values; my $key = ( $sv->keys )[0]; # pick one at random my $value = $self->format_value( $key, key => 1 ) . " => " . $self->format_sv( $sv->value( $key ) ); $value .= ", ..." if $n_values > 1; return "$repr = {$value}"; } case( "GLOB" ) { return "$repr is " . $self->format_symbol( "*" . $sv->stashname, $sv ); } case( "STASH" ) { return "$repr is " . $self->format_symbol( $sv->stashname, $sv ); } } return $repr; } sub format_heading { shift; my ( $text, $level ) = @_; return "$text"; } =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-0.52/lib/Devel/MAT.xs000444001750001750 5221214550507443 14627 0ustar00leoleo000000000000/* You may distribute under the terms of either the GNU General Public License * or the Artistic License (the same terms as Perl itself) * * (C) Paul Evans, 2014-2022 -- leonerd@leonerd.org.uk */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef av_count # define av_count(av) (AvFILL(av) + 1) #endif struct pmat_sv { SV *df; long addr; long refcnt; long size; long blessed_at; long glob_at; }; /* Some subtypes */ struct pmat_sv_glob { struct pmat_sv _parent; long stash_at; long scalar_at, array_at, hash_at, code_at, egv_at, io_at, form_at; long line; const char *file; const char *name; }; struct pmat_sv_scalar { struct pmat_sv _parent; long uv; long double nv; char *pv; size_t pv_strlen; /* length of the pv member data */ size_t pvlen; /* original PV length */ long ourstash_at; char flags; }; struct pmat_sv_ref { struct pmat_sv _parent; long rv_at; long ourstash_at; char is_weak; }; struct pmat_sv_array { struct pmat_sv _parent; int flags; char is_backrefs; long n_elems; long *elems_at; long padcv_at; }; struct pmat_sv_hash { struct pmat_sv _parent; long backrefs_at; long n_values; struct pmat_hval { const char *key; size_t klen; long value; } *values_at; }; struct pmat_sv_code { struct pmat_sv _parent; long line; long flags; long oproot; long depth; long stash_at, outside_at, padlist_at, constval_at; const char *file; const char *name; long protosub_at; long padnames_at; }; struct pmat_sv_struct { struct pmat_sv _parent; long n_fields; struct pmat_sv_struct_field { int type; long val; } *fields; }; struct pmat_sv_object { struct pmat_sv _parent; long n_fields; long *fields_at; }; #if (PERL_REVISION == 5) && (PERL_VERSION < 14) static MAGIC *mg_findext(const SV *sv, int type, const MGVTBL *vtbl) { MAGIC *mg; for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) if(mg->mg_type == type && mg->mg_virtual == vtbl) return mg; return NULL; } #endif /* Empty magic just for identity purposes */ const MGVTBL vtbl = { 0 }; static struct pmat_sv *get_pmat_sv(HV *obj) { MAGIC *mg = mg_findext((SV *)obj, PERL_MAGIC_ext, &vtbl); if(mg) return (struct pmat_sv *)mg->mg_ptr; else return NULL; } static void free_pmat_sv(struct pmat_sv *sv) { SvREFCNT_dec(sv->df); Safefree(sv); } /* An HV mapping strings to SvIVs of their usage count */ static HV *strings; static const char *save_string(const char *s, size_t len) { if(!strings) strings = newHV(); HE *ent = hv_fetch_ent(strings, sv_2mortal(newSVpv(s, len)), 1, 0); SV *count = HeVAL(ent); if(!SvIOK(count)) sv_setuv(count, 0); /* incr usage count */ sv_setuv(count, SvUV(count) + 1); return HeKEY(ent);; } static void drop_string(const char *s, size_t len) { HE *ent = hv_fetch_ent(strings, sv_2mortal(newSVpv(s, len)), 0, 0); if(!ent) return; /* decr usage count */ SV *count = HeVAL(ent); if(SvUV(count) > 1) { sv_setuv(count, SvUV(count) - 1); return; } hv_delete(strings, s, 0, G_DISCARD); } MODULE = Devel::MAT PACKAGE = Devel::MAT::SV void _set_core_fields(self, type, df, addr, refcnt, size, blessed_at) HV *self int type SV *df long addr long refcnt long size long blessed_at CODE: { void *ptr; struct pmat_sv *sv; switch(type) { case 1: /* PMAT_SVtGLOB */ Newx(ptr, 1, struct pmat_sv_glob); break; case 2: /* PMAT_SVtSCALAR */ case 13: /* PMAT_SVtUNDEF */ case 14: /* PMAT_SVtYES */ case 15: /* PMAT_SVtNO */ Newx(ptr, 1, struct pmat_sv_scalar); break; case 3: /* PMAT_SVtREF */ Newx(ptr, 1, struct pmat_sv_ref); break; case 4: /* PMAT_SVtARRAY */ Newx(ptr, 1, struct pmat_sv_array); break; case 5: /* PMAT_SVtHASH */ case 6: /* PMAT_SVtSTASH */ case 17: /* PMAT_SVtCLASS */ Newx(ptr, 1, struct pmat_sv_hash); break; case 7: /* PMAT_SVtCODE */ Newx(ptr, 1, struct pmat_sv_code); break; case 16: /* PMAT_SVtOBJECT */ Newx(ptr, 1, struct pmat_sv_object); break; case 0x7F: /* PMAT_SVtSTRUCT */ Newx(ptr, 1, struct pmat_sv_struct); break; default: Newx(ptr, 1, struct pmat_sv); break; } sv = ptr; sv->df = newSVsv(df); sv->addr = addr; sv->refcnt = refcnt; sv->size = size; sv->blessed_at = blessed_at; sv->glob_at = 0; sv_rvweaken(sv->df); sv_magicext((SV *)self, NULL, PERL_MAGIC_ext, &vtbl, (char *)sv, 0); } void DESTROY(self) HV *self CODE: { struct pmat_sv *sv = get_pmat_sv(self); free_pmat_sv(sv); } void _set_glob_at(self, glob_at) HV *self long glob_at CODE: { struct pmat_sv *sv = get_pmat_sv(self); sv->glob_at = glob_at; } SV *df(self) HV *self CODE: { struct pmat_sv *sv = get_pmat_sv(self); RETVAL = SvREFCNT_inc(sv->df); /* return it directly */ } OUTPUT: RETVAL long addr(self) HV *self ALIAS: addr = 0 refcnt = 1 size = 2 blessed_at = 3 glob_at = 4 CODE: { struct pmat_sv *sv = get_pmat_sv(self); if(sv) switch(ix) { case 0: RETVAL = sv->addr; break; case 1: RETVAL = sv->refcnt; break; case 2: RETVAL = sv->size; break; case 3: RETVAL = sv->blessed_at; break; case 4: RETVAL = sv->glob_at; break; } } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::GLOB void _set_glob_fields(self, stash_at, scalar_at, array_at, hash_at, code_at, egv_at, io_at, form_at, line, file, name) HV *self long stash_at long scalar_at long array_at long hash_at long code_at long egv_at long io_at long form_at long line SV *file SV *name CODE: { struct pmat_sv_glob *gv = (struct pmat_sv_glob *)get_pmat_sv(self); gv->stash_at = stash_at; gv->scalar_at = scalar_at; gv->array_at = array_at; gv->hash_at = hash_at; gv->code_at = code_at; gv->egv_at = egv_at; gv->io_at = io_at; gv->form_at = form_at; if(SvPOK(file)) gv->file = save_string(SvPV_nolen(file), 0); else gv->file = NULL; gv->line = line; if(SvPOK(name)) gv->name = savepv(SvPV_nolen(name)); else gv->name = NULL; } void DESTROY(self) HV *self CODE: { struct pmat_sv_glob *gv = (struct pmat_sv_glob *)get_pmat_sv(self); if(gv->file) drop_string(gv->file, 0); if(gv->name) Safefree(gv->name); free_pmat_sv((struct pmat_sv *)gv); } long stash_at(self) HV *self ALIAS: stash_at = 0 scalar_at = 1 array_at = 2 hash_at = 3 code_at = 4 egv_at = 5 io_at = 6 form_at = 7 line = 8 CODE: { struct pmat_sv_glob *gv = (struct pmat_sv_glob *)get_pmat_sv(self); if(gv) switch(ix) { case 0: RETVAL = gv->stash_at; break; case 1: RETVAL = gv->scalar_at; break; case 2: RETVAL = gv->array_at; break; case 3: RETVAL = gv->hash_at; break; case 4: RETVAL = gv->code_at; break; case 5: RETVAL = gv->egv_at; break; case 6: RETVAL = gv->io_at; break; case 7: RETVAL = gv->form_at; break; case 8: RETVAL = gv->line; break; } } OUTPUT: RETVAL const char * file(self) HV *self ALIAS: file = 0 name = 1 CODE: { struct pmat_sv_glob *gv = (struct pmat_sv_glob *)get_pmat_sv(self); if(gv) switch(ix) { case 0: RETVAL = gv->file; break; case 1: RETVAL = gv->name; break; } } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::SCALAR void _set_scalar_fields(self, flags, uv, nv, pv, pvlen, ourstash_at) HV *self int flags long uv SV *nv SV *pv long pvlen long ourstash_at CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); sv->flags = flags; sv->uv = uv; sv->pvlen = pvlen; sv->ourstash_at = ourstash_at; if(flags & 0x04) if(SvNOK(nv)) sv->nv = SvNV(nv); else sv->flags &= ~0x04; if(flags & 0x08) { sv->pv_strlen = SvCUR(pv); if(SvLEN(pv) && !SvOOK(pv)) { /* Swipe pv's buffer */ sv->pv = SvPVX(pv); SvPVX(pv) = NULL; SvCUR(pv) = 0; SvLEN(pv) = 0; SvPOK_off(pv); } else { sv->pv = savepvn(SvPV_nolen(pv), SvCUR(pv)); } } } void DESTROY(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); // TODO: don't crash //if(sv->pv) // Safefree(sv->pv); free_pmat_sv((struct pmat_sv *)sv); } int pv_is_utf8(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); if(sv) RETVAL = sv->flags & 0x10; } OUTPUT: RETVAL SV *uv(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = newSV(0); if(sv && sv->flags & 0x01 && !(sv->flags & 0x02)) sv_setuv(RETVAL, sv->uv); } OUTPUT: RETVAL SV *iv(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = newSV(0); if(sv && sv->flags & 0x01 && sv->flags & 0x02) sv_setiv(RETVAL, sv->uv); } OUTPUT: RETVAL SV *nv(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = newSV(0); if(sv && sv->flags & 0x04) sv_setnv(RETVAL, sv->nv); } OUTPUT: RETVAL SV *pv(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = newSV(0); if(sv && sv->flags & 0x08) sv_setpvn(RETVAL, sv->pv, sv->pv_strlen); if(sv && sv->flags & 0x10) SvUTF8_on(RETVAL); } OUTPUT: RETVAL SV *pvlen(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = newSV(0); if(sv && sv->flags & 0x08) sv_setuv(RETVAL, sv->pvlen); } OUTPUT: RETVAL long ourstash_at(self) HV *self CODE: { struct pmat_sv_scalar *sv = (struct pmat_sv_scalar *)get_pmat_sv(self); RETVAL = sv ? sv->ourstash_at : 0; } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::REF void _set_ref_fields(self, rv_at, ourstash_at, is_weak) HV *self long rv_at long ourstash_at char is_weak CODE: { struct pmat_sv_ref *rv = (struct pmat_sv_ref *)get_pmat_sv(self); rv->rv_at = rv_at; rv->ourstash_at = ourstash_at; rv->is_weak = is_weak; } long rv_at(self) HV *self ALIAS: rv_at = 0 ourstash_at = 1 CODE: { struct pmat_sv_ref *rv = (struct pmat_sv_ref *)get_pmat_sv(self); if(rv) switch(ix) { case 0: RETVAL = rv->rv_at; break; case 1: RETVAL = rv->ourstash_at; break; } } OUTPUT: RETVAL char is_weak(self) HV *self CODE: { struct pmat_sv_ref *rv = (struct pmat_sv_ref *)get_pmat_sv(self); RETVAL = rv ? rv->is_weak : 0; } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::ARRAY void _set_array_fields(self, flags, elems_at) HV *self int flags AV *elems_at CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); long n, i; av->flags = flags; av->is_backrefs = 0; av->padcv_at = 0; n = av_count(elems_at); av->n_elems = n; Newx(av->elems_at, n, long); for(i = 0; i < n; i++) av->elems_at[i] = SvUV(AvARRAY(elems_at)[i]); } void DESTROY(self) HV *self CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); Safefree(av->elems_at); free_pmat_sv((struct pmat_sv *)av); } void _set_backrefs(self, is_backrefs) HV *self int is_backrefs CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); av->is_backrefs = !!is_backrefs; if(is_backrefs) { /* All backrefs ARRAYs are always UNREAL */ av->flags |= 0x01; } } void _clear_elem(self, i) HV *self unsigned long i CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); if(av && i < av->n_elems) av->elems_at[i] = 0; } void _set_padcv_at(self, padcv_at) HV *self long padcv_at CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); av->padcv_at = padcv_at; } int is_unreal(self) HV *self CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); RETVAL = av ? av->flags & 0x01 : 0; } OUTPUT: RETVAL int is_backrefs(self) HV *self CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); RETVAL = av ? av->is_backrefs : 0; } OUTPUT: RETVAL long n_elems(self) HV *self ALIAS: n_elems = 0 padcv_at = 1 CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); if(av) switch(ix) { case 0: RETVAL = av->n_elems; break; case 1: RETVAL = av->padcv_at; break; } } OUTPUT: RETVAL long elem_at(self, i) HV *self unsigned long i CODE: { struct pmat_sv_array *av = (struct pmat_sv_array *)get_pmat_sv(self); if(av && i < av->n_elems) RETVAL = av->elems_at[i]; } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::HASH void _set_hash_fields(self, backrefs_at, values_at) HV *self long backrefs_at HV *values_at CODE: { long i, n; HE *ent; struct pmat_sv_hash *hv = (struct pmat_sv_hash *)get_pmat_sv(self); n = hv_iterinit(values_at); hv->backrefs_at = backrefs_at; hv->n_values = n; Newx(hv->values_at, n, struct pmat_hval); for(i = 0; ent = hv_iternext(values_at); i++) { I32 klen; const char *key = hv_iterkey(ent, &klen); hv->values_at[i].key = save_string(key, klen); hv->values_at[i].klen = klen; hv->values_at[i].value = SvUV(hv_iterval(values_at, ent)); } // TODO: sort the values so we can binsearch for them later } void DESTROY(self) HV *self CODE: { struct pmat_sv_hash *hv = (struct pmat_sv_hash *)get_pmat_sv(self); long i; for(i = 0; i < hv->n_values; i++) drop_string(hv->values_at[i].key, hv->values_at[i].klen); Safefree(hv->values_at); free_pmat_sv((struct pmat_sv *)hv); } long backrefs_at(self) HV *self ALIAS: backrefs_at = 0 n_values = 1 CODE: { struct pmat_sv_hash *hv = (struct pmat_sv_hash *)get_pmat_sv(self); if(hv) switch(ix) { case 0: RETVAL = hv->backrefs_at; break; case 1: RETVAL = hv->n_values; break; } } OUTPUT: RETVAL void keys(self) HV *self ALIAS: keys = 0 values_at = 1 PPCODE: { struct pmat_sv_hash *hv = (struct pmat_sv_hash *)get_pmat_sv(self); long i; EXTEND(SP, hv->n_values); for(i = 0; i < hv->n_values; i++) switch(ix) { case 0: // keys mPUSHp(hv->values_at[i].key, hv->values_at[i].klen); break; case 1: // values_at mPUSHu(hv->values_at[i].value); break; } XSRETURN(hv->n_values); } SV * value_at(self, key) HV *self SV *key CODE: { struct pmat_sv_hash *hv = (struct pmat_sv_hash *)get_pmat_sv(self); long i; long klen = SvCUR(key); RETVAL = &PL_sv_undef; // TODO: store values sorted so we can binsearch for(i = 0; i < hv->n_values; i++) { if(hv->values_at[i].klen != klen) continue; if(memcmp(hv->values_at[i].key, SvPV_nolen(key), klen) != 0) continue; RETVAL = newSVuv(hv->values_at[i].value); break; } } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::CODE void _set_code_fields(self, line, flags, oproot, depth, stash_at, outside_at, padlist_at, constval_at, file, name) HV *self long line long flags long oproot long depth long stash_at long outside_at long padlist_at long constval_at SV *file SV *name CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); cv->line = line; cv->flags = flags; cv->oproot = oproot; cv->depth = depth; cv->stash_at = stash_at; cv->outside_at = outside_at; cv->padlist_at = padlist_at; cv->constval_at = constval_at; cv->protosub_at = 0; cv->padnames_at = 0; if(SvPOK(file)) cv->file = save_string(SvPV_nolen(file), 0); else cv->file = NULL; if(SvPOK(name)) cv->name = save_string(SvPV_nolen(name), 0); else cv->name = NULL; } void DESTROY(self) HV *self CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); if(cv->file) drop_string(cv->file, 0); free_pmat_sv((struct pmat_sv *)cv); } void _set_protosub_at(self, addr) HV *self long addr ALIAS: _set_protosub_at = 0 _set_padnames_at = 1 CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); switch(ix) { case 0: cv->protosub_at = addr; break; case 1: cv->padnames_at = addr; break; } } int is_clone(self) HV *self ALIAS: is_clone = 0x01 is_cloned = 0x02 is_xsub = 0x04 is_weakoutside = 0x08 is_cvgv_rc = 0x10 is_lexical = 0x20 CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); RETVAL = cv ? cv->flags & ix : 0; } OUTPUT: RETVAL long line(self) HV *self ALIAS: line = 0 oproot = 1 depth = 2 stash_at = 3 outside_at = 4 padlist_at = 5 constval_at = 6 protosub_at = 7 padnames_at = 8 CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); if(cv) switch(ix) { case 0: RETVAL = cv->line; break; case 1: RETVAL = cv->oproot; break; case 2: RETVAL = cv->depth; break; case 3: RETVAL = cv->stash_at; break; case 4: RETVAL = cv->outside_at; break; case 5: RETVAL = cv->padlist_at; break; case 6: RETVAL = cv->constval_at; break; case 7: RETVAL = cv->protosub_at; break; case 8: RETVAL = cv->padnames_at; break; } } OUTPUT: RETVAL const char * file(self) HV *self ALIAS: file = 0 hekname = 1 CODE: { struct pmat_sv_code *cv = (struct pmat_sv_code *)get_pmat_sv(self); if(cv) switch(ix) { case 0: RETVAL = cv->file; break; case 1: RETVAL = cv->name; break; } } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::OBJECT void _set_object_fields(self, fields_at) HV *self AV *fields_at CODE: { struct pmat_sv_object *obj = (struct pmat_sv_object *)get_pmat_sv(self); long n, i; n = av_count(fields_at); obj->n_fields = n; Newx(obj->fields_at, n, long); for(i = 0; i < n; i++) obj->fields_at[i] = SvUV(AvARRAY(fields_at)[i]); } void DESTROY(self) HV *self CODE: { struct pmat_sv_object *obj = (struct pmat_sv_object *)get_pmat_sv(self); Safefree(obj->fields_at); free_pmat_sv((struct pmat_sv *)obj); } long n_fields(self) HV *self CODE: { struct pmat_sv_object *obj = (struct pmat_sv_object *)get_pmat_sv(self); if(obj) RETVAL = obj->n_fields; } OUTPUT: RETVAL long field_at(self, i) HV *self unsigned long i CODE: { struct pmat_sv_object *obj = (struct pmat_sv_object *)get_pmat_sv(self); if(obj && i < obj->n_fields) RETVAL = obj->fields_at[i]; } OUTPUT: RETVAL MODULE = Devel::MAT PACKAGE = Devel::MAT::SV::C_STRUCT long structid(self) HV *self ALIAS: structid = 0 blessed_at = 1 CODE: { struct pmat_sv *sv = get_pmat_sv(self); switch(ix) { case 0: RETVAL = sv->blessed_at; break; case 1: RETVAL = 0; break; } } OUTPUT: RETVAL void _set_struct_fields(self, ...) HV *self CODE: { struct pmat_sv_struct *st = (struct pmat_sv_struct *)get_pmat_sv(self); long n, i; n = (items-1) / 2; st->n_fields = n; Newx(st->fields, n, struct pmat_sv_struct_field); for(i = 0; i < n; i++) { int type = SvIV(ST(1 + 2*i)); st->fields[i].type = type; switch(type) { case 0x00: // PTR case 0x01: // BOOL case 0x02: // U8 case 0x03: // U32 case 0x04: // UINT st->fields[i].val = SvUV(ST(2 + 2*i)); break; default: croak("ARGH TODO _set_struct_fields from type=%d\n", type); } } } long n_fields(self) HV *self CODE: { struct pmat_sv_struct *st = (struct pmat_sv_struct *)get_pmat_sv(self); RETVAL = st->n_fields; } OUTPUT: RETVAL long field(self, i) HV *self unsigned long i CODE: { struct pmat_sv_struct *st = (struct pmat_sv_struct *)get_pmat_sv(self); if(i < st->n_fields) RETVAL = st->fields[i].val; } OUTPUT: RETVAL Devel-MAT-0.52/lib/Devel/MAT000755001750001750 014550507443 14074 5ustar00leoleo000000000000Devel-MAT-0.52/lib/Devel/MAT/Cmd.pod000444001750001750 1127714550507443 15470 0ustar00leoleo000000000000=head1 NAME C - abstractions for providing commands for C =head1 METHODS =head2 printf Devel::MAT::Cmd->printf( $fmt, @args ) Behaves like perl's core C function. Additionally, any argument for a C<%s> conversion may also be the result of one of the following C methods, which may return a L instance. =head2 print_table Devel::MAT::Cmd->print_table( $rows, %opts ) Given a 2D array-of-arrays containing strings (which may be plain or formatted ones returned by the various C methods), prints them formatted in a table shape, aligning the columns. An element of C<$rows> may be an empty arrayref. This will cause a row of divisions to be drawn using hyphens (C<->) the full width of each column. The following named C<%ops> may be supplied: =over 4 =item headings => ARRAY[STRING] A list of strings per column to place at the top of the table. These may be formatted differently to distinguish them. =item sep => ARRAY[STRING] or STRING A list of strings per column (or one single string to apply equally to them all) specifying the separator string to print after each columns. Will default to a single space if not supplied. Note that this string is interpolated into a C format string, so any C<%> marks it may contain should be doubled. =item align => ARRAY[STRING] or STRING A list of strings per column (or one single string to apply equally to them all) specifying the alignment of data in the column. Aligns to the right if the value is C<"right">. =item indent => INT A number of spaces to prefix before every row of output. Defaults to zero if not supplied. =back =head2 format_note $str = Devel::MAT::Cmd->format_note( $str, $idx ) Apply some sort of styling to the a given string. Starting from zero, successively higher integer values for C<$idx> may influence the style further. Output with the same index value will appear the same. The implementation should support at least 3 different styles, but may wrap after this. For stylistic consistency, tools should try to stick to the following conventions for note indexes: 0 - regular notes 1 - secondary notes, lexical variable names 2 - unusual or erroneous conditions, symbol table names =head2 format_sv $str = Devel::MAT::Cmd->format_sv( $sv ) Returns a string encoding the address and description of the given SV, possibly stylised in some way, subject to user customisation, or possibly made interactive if the UI allows it to be so. =head2 format_value $str = Devel::MAT::Cmd->format_value( $val, %opts ) Returns a string formatting a given plain scalar value (which should either be a string or a number) to indicate it's a value from the user program. If given a string value, this will be escaped and quoted appropriately. The following named C<%opts> may be supplied: =over 4 =item key => BOOL If true, the value represents a hash key value. Wraps the result in braces C<{...}> and removes redundant quote marks if the string is valid as a bareword identifier. =item index => BOOL If true, the value represents an array index. Wraps the result in square brackets C<[...]> and expects the value to be an integer. =item pv => BOOL If true, the value represents a string from the user code. Wraps the result in quote marks C<"..."> and limits the length to a maximum of 64 characters (or as specified by the C argument). No truncation if C is zero. =back =head2 format_symbol $str = Devel::MAT::Cmd->format_symbol( $name, $sv ) Returns a string formatting the given symbol name to indicate that it is a symbol name. Optionally, the SV object itself can be passed too, which may save the UI having to look it up from the dumpfile in case it wishes to make the printed value interactive in some way. =head2 format_bytes $str = Devel::MAT::Cmd->format_bytes( $bytes ) Returns a string showing the given byte count in suitably scaled units. This will use base-1024 sizes in C, C, C or C if necessary. =head2 format_sv_with_value $str = Devel::MAT::Cmd->format_sv_with_value( $sv ) Similar to L, but printing additional information on some kinds of SVs to avoid the user needing to use the C to identify it. For C SVs it will show the value directly by using L, for C SVs it will show the referrant SV, and for C SVs it will show the symbol name. =head2 format_heading $str = Devel::MAT::Cmd->format_heading( $text, $level ) Returns a string applying some formatting to the given text to make it stand out as a section or table heading. C<$level> may be used to distinguish different styles; at least 3 should be provided. =head1 AUTHOR Paul Evans =cut Devel-MAT-0.52/lib/Devel/MAT/Context.pm000444001750001750 1130114550507443 16227 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2016 -- leonerd@leonerd.org.uk package Devel::MAT::Context 0.52; use v5.14; use warnings; use Carp; use Scalar::Util qw( weaken ); =head1 NAME C - represent a single call context state =head1 DESCRIPTION Objects in this class represent a single level of state from the call context. These contexts represent function calls between perl functions. =cut my %types; sub register_type { $types{$_[1]} = $_[0]; # generate the ->type constant method ( my $typename = $_[0] ) =~ s/^Devel::MAT::Context:://; no strict 'refs'; *{"$_[0]::type"} = sub () { $typename }; } sub new { shift; my ( $type, $df, $bytes, undef, $strs ) = @_; $types{$type} or croak "Cannot load unknown CTX type $type"; my $self = bless {}, $types{$type}; weaken( $self->{df} = $df ); ( $self->{gimme}, $self->{line} ) = unpack "C $df->{uint_fmt}", $bytes; ( $self->{file} ) = @$strs; return $self; } sub load_v0_1 { my $class = shift; my ( $type, $df ) = @_; $types{$type} or croak "Cannot load unknown CTX type $type"; my $self = bless {}, $types{$type}; weaken( $self->{df} = $df ); # Standard fields all Contexts have $self->{gimme} = $df->_read_u8; $self->{file} = $df->_read_str; $self->{line} = $df->_read_uint; $self->_load_v0_1( $df ); return $self; } =head1 COMMON METHODS =cut =head2 gimme $gimme = $ctx->gimme Returns the gimme value of the call context. =cut my @GIMMES = ( undef, qw( void scalar array ) ); sub gimme { my $self = shift; return $GIMMES[ $self->{gimme} ]; } =head2 file =head2 line =head2 location $file = $ctx->file $line = $ctx->line $location = $ctx->location Returns the file, line or location as (C). =cut sub file { my $self = shift; return $self->{file} } sub line { my $self = shift; return $self->{line} } sub location { my $self = shift; return "$self->{file} line $self->{line}"; } package Devel::MAT::Context::SUB 0.52; use base qw( Devel::MAT::Context ); __PACKAGE__->register_type( 1 ); =head1 Devel::MAT::Context::SUB Represents a context which is a subroutine call. =cut sub load { my $self = shift; my ( $bytes, $ptrs, undef ) = @_; my $df = $self->{df}; ( $self->{olddepth} ) = unpack "$df->{u32_fmt}", $bytes; ( $self->{cv_at}, $self->{args_at} ) = @$ptrs; undef $self->{args_at} if $df->perlversion ge "5.23.8"; } sub _load_v0_1 { my $self = shift; my ( $df ) = @_; $self->{olddepth} = -1; $self->{cv_at} = $df->_read_ptr; $self->{args_at} = $df->_read_ptr; undef $self->{args_at} if $df->perlversion ge "5.23.8"; } =head2 cv $cv = $ctx->cv Returns the CV which this call is to. =head2 args $args = $ctx->args Returns the arguments AV which represents the C<@_> argument array. =head2 olddepth $olddepth = $ctx->olddepth Returns the old depth of the context (that is, the depth the CV would be at after this context returns). =head2 depth $depth = $ctx->depth Returns the actual depth of the context. This is inferred at load time by considering the C of the next inner-nested call to the same CV, or from the actual C of the CV is no other call exists. =cut sub cv { my $self = shift; return $self->{df}->sv_at( $self->{cv_at} ) } sub args { my $self = shift; # Perl 5.23.8 removed blk_sub.argarray so we have to go the long way round $self->{args_at} //= do { my $cv = $self->cv; my $args = $cv->pad( $self->depth )->elem( 0 ); $args->addr; }; return $self->{df}->sv_at( $self->{args_at} ); } sub olddepth { return $_[0]->{olddepth} } sub _set_depth { $_[0]->{depth} = $_[1] } sub depth { return $_[0]->{depth} } package Devel::MAT::Context::TRY 0.52; use base qw( Devel::MAT::Context ); __PACKAGE__->register_type( 2 ); =head1 Devel::MAT::Context::TRY Represents a context which is a block C call. =cut sub load {} sub _load_v0_1 {} package Devel::MAT::Context::EVAL 0.52; use base qw( Devel::MAT::Context ); __PACKAGE__->register_type( 3 ); =head1 Devel::MAT::Context::EVAL Represents a context which is a string C call. =cut sub load { my $self = shift; my ( undef, $ptrs, undef ) = @_; ( $self->{code_at} ) = @$ptrs; } sub _load_v0_1 { my $self = shift; my ( $df ) = @_; $self->{code_at} = $df->_read_ptr; } =head2 code $sv = $ctx->code Returns the SV containing the text string being evaluated. =cut sub code { my $self = shift; return $self->{df}->sv_at( $self->{code_at} ) } =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/Dumpfile.pm000444001750001750 5167614550507443 16373 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2024 -- leonerd@leonerd.org.uk package Devel::MAT::Dumpfile 0.52; use v5.14; use warnings; use Carp; use IO::Handle; # ->read use IO::Seekable; # ->tell use List::Util qw( pairmap ); use Devel::MAT::SV; use Devel::MAT::Context; use Struct::Dumb 0.07 qw( readonly_struct ); readonly_struct StructType => [qw( name fields )]; readonly_struct StructField => [qw( name type )]; use constant { PMAT_SVxMAGIC => 0x80, }; =head1 NAME C - load and analyse a heap dump file =head1 SYNOPSIS use Devel::MAT::Dumpfile; my $df = Devel::MAT::Dumpfile->load( "path/to/the/file.pmat" ); TODO =head1 DESCRIPTION This module provides a class that loads a heap dump file previously written by L. It provides accessor methods to obtain various well-known root starting addresses, or to find arbitrary SVs by address. Each SV is represented by an instance of L. =cut my @ROOTS; my %ROOTDESC; foreach ( [ sv_undef => "+the undef SV" ], [ sv_yes => "+the true SV" ], [ sv_no => "+the false SV" ], [ main_cv => "+the main code" ], [ defstash => "+the default stash" ], [ mainstack => "+the main stack AV" ], [ beginav => "+the BEGIN list" ], [ checkav => "+the CHECK list" ], [ unitcheckav => "+the UNITCHECK list" ], [ initav => "+the INIT list" ], [ endav => "+the END list" ], [ strtab => "+the shared string table HV" ], [ envgv => "-the ENV GV" ], [ incgv => "+the INC GV" ], [ statgv => "+the stat GV" ], [ statname => "+the statname SV" ], [ tmpsv => "-the temporary SV" ], [ defgv => "+the default GV" ], [ argvgv => "-the ARGV GV" ], [ argvoutgv => "+the argvout GV" ], [ argvout_stack => "+the argvout stack AV" ], [ errgv => "+the *@ GV" ], [ fdpidav => "+the FD-to-PID mapping AV" ], [ preambleav => "+the compiler preamble AV" ], [ modglobalhv => "+the module data globals HV" ], [ regex_padav => "+the REGEXP pad AV" ], [ sortstash => "+the sort stash" ], [ firstgv => "-the *a GV" ], [ secondgv => "-the *b GV" ], [ debstash => "-the debugger stash" ], [ stashcache => "+the stash cache" ], [ isarev => "+the reverse map of \@ISA dependencies" ], [ registered_mros => "+the registered MROs HV" ], [ rs => "+the IRS" ], [ last_in_gv => "+the last input GV" ], [ ofsgv => "+the OFS GV" ], [ defoutgv => "+the default output GV" ], [ hintgv => "-the hints (%^H) GV" ], [ patchlevel => "+the patch level" ], [ apiversion => "+the API version" ], [ e_script => "+the '-e' script" ], [ mess_sv => "+the message SV" ], [ ors_sv => "+the ORS SV" ], [ encoding => "+the encoding" ], [ blockhooks => "+the block hooks" ], [ custom_ops => "+the custom ops HV" ], [ custom_op_names => "+the custom op names HV" ], [ custom_op_descs => "+the custom op descriptions HV" ], map { [ $_ => "+the $_" ] } qw( Latin1 UpperLatin1 AboveLatin1 NonL1NonFinalFold HasMultiCharFold utf8_mark utf8_X_regular_begin utf8_X_extend utf8_toupper utf8_totitle utf8_tolower utf8_tofold utf8_charname_begin utf8_charname_continue utf8_idstart utf8_idcont utf8_xidstart utf8_perl_idstart utf8_perl_idcont utf8_xidcont utf8_foldclosures utf8_foldable ), ) { my ( $name, $desc ) = @$_; push @ROOTS, $name; $ROOTDESC{$name} = $desc; # Autogenerate the accessors my $code = sub { my $self = shift; $self->{roots}{$name} ? $self->sv_at( $self->{roots}{$name}[0] ) : undef; }; no strict 'refs'; *$name = $code; } *ROOTS = sub { @ROOTS }; =head1 CONSTRUCTOR =cut =head2 load $df = Devel::MAT::Dumpfile->load( $path, %args ) Loads a heap dump file from the given path, and returns a new C instance representing it. Takes the following named arguments: =over 8 =item progress => CODE If given, should be a CODE reference to a function that will be called regularly during the loading process, and given a status message to update the user. =back =cut sub load { my $class = shift; my ( $path, %args ) = @_; my $progress = $args{progress}; $progress->( "Loading file $path..." ) if $progress; open my $fh, "<", $path or croak "Cannot read $path - $!"; my $self = bless { fh => $fh }, $class; my $filelen = -s $fh; # Header $self->_read(4) eq "PMAT" or croak "File magic signature not found"; my $flags = $self->_read_u8; my $endian = ( $self->{big_endian} = $flags & 0x01 ) ? ">" : "<"; my $u32_fmt = $self->{u32_fmt} = "L$endian"; my $u64_fmt = $self->{u64_fmt} = "Q$endian"; @{$self}{qw( uint_len uint_fmt )} = ( $flags & 0x02 ) ? ( 8, $u64_fmt ) : ( 4, $u32_fmt ); @{$self}{qw( ptr_len ptr_fmt )} = ( $flags & 0x04 ) ? ( 8, $u64_fmt ) : ( 4, $u32_fmt ); @{$self}{qw( nv_len nv_fmt )} = ( $flags & 0x08 ) ? ( 10, "D$endian" ) : ( 8, "d$endian" ); $self->{ithreads} = !!( $flags & 0x10 ); $flags &= ~0x1f; die sprintf "Cannot read %s - unrecognised flags %x\n", $path, $flags if $flags; $self->{minus_1} = unpack $self->{uint_fmt}, pack $self->{uint_fmt}, -1; $self->_read_u8 == 0 or die "Cannot read $path - 'zero' header field is not zero"; $self->_read_u8 == 0 or die "Cannot read $path - format version major unrecognised"; # minor version 5 is the still-experimental support for feature-class ( $self->{format_minor} = $self->_read_u8 ) <= 5 or die "Cannot read $path - format version minor unrecognised ($self->{format_minor})"; warnings::warnif experimental => "Support for PMAT file format v0.5 is experimental" if $self->{format_minor} == 5; if( $self->{format_minor} < 1 ) { warn "Loading an earlier format of dumpfile - SV MAGIC annotations may be incorrect\n"; } $self->{perlver} = $self->_read_u32; my $n_types = $self->_read_u8; my @sv_sizes = unpack "(a3)*", my $tmp = $self->_read( $n_types * 3 ); $self->{sv_sizes} = [ map [ unpack "C C C", $_ ], @sv_sizes ]; if( $self->{format_minor} >= 4 ) { my $n_extns = $self->_read_u8; my @extn_sizes = unpack "(a3)*", my $tmp = $self->_read( $n_extns * 3 ); $self->{svx_sizes} = [ map [ unpack "C C C", $_ ], @extn_sizes ]; } else { # versions < 4 had just one, PMAT_SVxMAGIC $self->{svx_sizes} = [ [ 2, 2, 0 ], # PMAT_SVxMAGIC ]; } if( $self->{format_minor} >= 2 ) { my $n_ctxs = $self->_read_u8; my @ctx_sizes = unpack "(a3)*", my $tmp = $self->_read( $n_ctxs * 3 ); $self->{ctx_sizes} = [ map [ unpack "C C C", $_ ], @ctx_sizes ]; } $self->{structtypes_by_id} = {}; # Roots foreach (qw( undef yes no )) { my $addr = $self->{"${_}_at"} = $self->_read_ptr; my $class = "Devel::MAT::SV::\U$_"; $self->{uc $_} = $class->new( $self, $addr ); } $self->{roots} = \my %roots; # The three immortals $roots{"sv_$_"} = [ $self->{"\U$_"}->addr, $ROOTDESC{"sv_$_"} ] for qw( undef yes no ); foreach ( 1 .. $self->_read_u32 ) { my $name = $self->_read_str; my $desc = $ROOTDESC{$name} // $name; $desc =~ m/^[+-]/ or $desc = "+$desc"; $roots{$name} = [ $self->_read_ptr, $desc ]; } # Stack my $stacksize = $self->_read_uint; $self->{stack_at} = [ map { $self->_read_ptr } 1 .. $stacksize ]; # Heap $self->{heap} = \my %heap; $self->{protosubs_by_oproot} = \my %protosubs_by_oproot; while( my $sv = $self->_read_sv ) { $heap{$sv->addr} = $sv; # Also identify the protosub of every oproot if( $sv->type eq "CODE" and $sv->oproot and $sv->is_clone ) { $protosubs_by_oproot{$sv->oproot} = $sv; } my $pos = $fh->IO::Seekable::tell; # fully-qualified method for 5.010 $progress->( sprintf "Loading file %d of %d bytes (%.2f%%)", $pos, $filelen, 100*$pos / $filelen ) if $progress and (keys(%heap) % 5000) == 0; } # Contexts $self->{contexts} = \my @contexts; while( my $ctx = $self->_read_ctx ) { push @contexts, $ctx; } # From here onwards newer files have mortals, older ones don't if( my $mortalcount = $self->_read_uint ) { $self->{mortals_at} = \my @mortals_at; push @mortals_at, $self->_read_ptr for 1 .. $mortalcount; foreach my $addr ( @mortals_at ) { my $sv = $self->sv_at( $addr ); unless( $sv ) { warn sprintf "SV address 0x%x is marked mortal but there is no SV", $addr; next; } $sv->_set_is_mortal; } $self->{mortal_floor} = $self->_read_uint; } $self->_fixup( %args ) unless $args{no_fixup}; return $self; } sub structtype { my $self = shift; my ( $id ) = @_; return $self->{structtypes_by_id}{$id} // croak "Dumpfile does not define a struct type of ID=$id\n"; } sub _fixup { my $self = shift; my %args = @_; my $progress = $args{progress}; my $heap = $self->{heap}; my $heap_total = scalar keys %$heap; # Annotate each root SV foreach my $name ( keys %{ $self->{roots} } ) { my $sv = $self->root( $name ) or next; $sv->{rootname} = $name; } my $count = 0; while( my ( $addr ) = each %$heap ) { my $sv = $heap->{$addr} or next; # While dumping we weren't able to determine what ARRAYs were really # PADLISTs. Now we can fix them up $sv->_fixup if $sv->can( "_fixup" ); $count++; $progress->( sprintf "Fixing %d of %d (%.2f%%)", $count, $heap_total, 100*$count / $heap_total ) if $progress and ($count % 20000) == 0; } # Walk the SUB contexts setting their true depth if( $self->{format_minor} >= 2 ) { my %prev_depth_by_cvaddr; foreach my $ctx ( @{ $self->{contexts} } ) { next unless $ctx->type eq "SUB"; my $cvaddr = $ctx->{cv_at}; $ctx->_set_depth( $prev_depth_by_cvaddr{$cvaddr} // $ctx->cv->depth ); $prev_depth_by_cvaddr{$cvaddr} = $ctx->olddepth; } } return $self; } # Nicer interface to IO::Handle sub _read { my $self = shift; my ( $len ) = @_; return "" if $len == 0; defined( $self->{fh}->read( my $buf, $len ) ) or croak "Cannot read - $!"; return $buf; } sub _read_u8 { my $self = shift; defined( $self->{fh}->read( my $buf, 1 ) ) or croak "Cannot read - $!"; return unpack "C", $buf; } sub _read_u32 { my $self = shift; defined( $self->{fh}->read( my $buf, 4 ) ) or croak "Cannot read - $!"; return unpack $self->{u32_fmt}, $buf; } sub _read_u64 { my $self = shift; defined( $self->{fh}->read( my $buf, 8 ) ) or croak "Cannot read - $!"; return unpack $self->{u64_fmt}, $buf; } sub _read_uint { my $self = shift; defined( $self->{fh}->read( my $buf, $self->{uint_len} ) ) or croak "Cannot read - $!"; return unpack $self->{uint_fmt}, $buf; } sub _read_ptr { my $self = shift; defined( $self->{fh}->read( my $buf, $self->{ptr_len} ) ) or croak "Cannot read - $!"; return unpack $self->{ptr_fmt}, $buf; } sub _read_ptrs { my $self = shift; my ( $n ) = @_; defined( $self->{fh}->read( my $buf, $self->{ptr_len} * $n ) ) or croak "Cannot read - $!"; return unpack "$self->{ptr_fmt}$n", $buf; } sub _read_nv { my $self = shift; defined( $self->{fh}->read( my $buf, $self->{nv_len} ) ) or croak "Cannot read - $!"; return unpack $self->{nv_fmt}, $buf; } sub _read_str { my $self = shift; my $len = $self->_read_uint; return undef if $len == $self->{minus_1}; return $self->_read($len); } sub _read_bytesptrsstrs { my $self = shift; my ( $nbytes, $nptrs, $nstrs ) = @_; return ( $nbytes ? $self->_read( $nbytes ) : "" ), ( $nptrs ? [ $self->_read_ptrs( $nptrs ) ] : undef ), ( $nstrs ? [ map { $self->_read_str } 1 .. $nstrs ] : undef ); } sub _read_sv { my $self = shift; while(1) { my $type = $self->_read_u8; return if !$type; if( $type >= 0xF1 ) { die sprintf "Unrecognised META tag %02X\n", $type; } elsif( $type == 0xF0 ) { # META_STRUCT my $id = $self->_read_uint; my $nfields = $self->_read_uint; my $name = $self->_read_str; my @fields; push @fields, StructField( $self->_read_str, $self->_read_u8, ) for 1 .. $nfields; $self->{structtypes_by_id}{$id} = StructType( $name, \@fields, ); next; } elsif( $type >= 0x80 ) { my $sizes = $self->{svx_sizes}[$type - 0x80]; if( $self->{format_minor} == 0 and $type == PMAT_SVxMAGIC ) { # legacy magic support my ( $sv_addr, $obj ) = $self->_read_ptrs(2); my $type = chr $self->_read_u8; my $sv = $self->sv_at( $sv_addr ); # Legacy format didn't have flags, and didn't distinguish obj from ptr # However, the only objs it ever saved were refcounted ones. Lets just # pretend all of them are refcounted objects. $sv->more_magic( $type => 0x01, $obj, 0, 0 ); } elsif( !$sizes ) { die sprintf "Unrecognised SV extension type %02x\n", $type; } else { my $sv_addr = $self->_read_ptr; my @args = $self->_read_bytesptrsstrs( @$sizes ); my $sv = $self->sv_at( $sv_addr ) or warn( sprintf "Skipping SVx 0x%02X on missing SV at addr 0x%X\n", $type, $sv_addr ), next; my $code = $self->can( sprintf "_read_svx_%02X", $type ) or warn( sprintf "Skipping unrecognised SVx 0x%02X\n", $type ), next; $self->$code( $sv, @args ); } next; } # First read the "common" header my $sv = Devel::MAT::SV->new( $type, $self, $self->_read_bytesptrsstrs( @{ $self->{sv_sizes}[0] } ) ); if( $type == 0x7F ) { my $structtype = $self->structtype( $sv->structid ); $sv->load( $structtype->fields ); } else { my ( $bytes, $nptrs, $nstrs ) = @{ $self->{sv_sizes}[$type] }; $sv->load( $self->_read_bytesptrsstrs( $bytes, $nptrs, $nstrs ) ); } return $sv; } } sub _read_svx_80 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; my ( $type, $flags ) = unpack "A1 C", $bytes; $sv->more_magic( $type => $flags, @$ptrs ); } sub _read_svx_81 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; $sv->_more_saved( SCALAR => $ptrs->[0] ); } sub _read_svx_82 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; $sv->_more_saved( ARRAY => $ptrs->[0] ); } sub _read_svx_83 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; $sv->_more_saved( HASH => $ptrs->[0] ); } sub _read_svx_84 { my $self = shift; my ( $av, $bytes, $ptrs, $strs ) = @_; my $index = unpack $self->{uint_fmt}, $bytes; $av->isa( "Devel::MAT::SV::ARRAY" ) and $av->_more_saved( $index, $ptrs->[0] ); } sub _read_svx_85 { my $self = shift; my ( $hv, $bytes, $ptrs, $strs ) = @_; $hv->isa( "Devel::MAT::SV::HASH" ) and $hv->_more_saved( $ptrs->[0], $ptrs->[1] ); } sub _read_svx_86 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; $sv->_more_saved( CODE => $ptrs->[0] ); } sub _read_svx_87 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; $sv->_more_annotations( $ptrs->[0], $strs->[0] ); } sub _read_svx_88 { my $self = shift; my ( $sv, $bytes, $ptrs, $strs ) = @_; my ( $serial, $line ) = unpack "($self->{uint_fmt})2", $bytes; my $file = $strs->[0]; $sv->_debugdata( $serial, $line, $file ); } sub _read_ctx { my $self = shift; my $type = $self->_read_u8; return if !$type; if( $self->{format_minor} >= 2 ) { my $ctx = Devel::MAT::Context->new( $type, $self, $self->_read_bytesptrsstrs( @{ $self->{ctx_sizes}[0] } ) ); $ctx->load( $self->_read_bytesptrsstrs( @{ $self->{ctx_sizes}[$type] } ) ); return $ctx; } else { return Devel::MAT::Context->load_v0_1( $type, $self ); } } =head1 METHODS =cut =head2 perlversion $version = $df->perlversion Returns the version of perl that the heap dump file was created by, as a string in the form C<5.14.2>. =cut sub perlversion { my $self = shift; my $v = $self->{perlver}; return join ".", $v>>24, ($v>>16) & 0xff, $v&0xffff; } =head2 endian $endian = $df->endian Returns the endian direction of the perl that the heap dump was created by, as either C or C. =cut sub endian { my $self = shift; return $self->{big_endian} ? "big" : "little"; } =head2 uint_len $len = $df->uint_len Returns the length in bytes of a uint field of the perl that the heap dump was created by. =cut sub uint_len { my $self = shift; return $self->{uint_len}; } =head2 ptr_len $len = $df->ptr_len Returns the length in bytes of a pointer field of the perl that the heap dump was created by. =cut sub ptr_len { my $self = shift; return $self->{ptr_len}; } =head2 nv_len $len = $df->nv_len Returns the length in bytes of a double field of the perl that the heap dump was created by. =cut sub nv_len { my $self = shift; return $self->{nv_len}; } =head2 ithreads $ithreads = $df->ithreads Returns a boolean indicating whether ithread support was enabled in the perl that the heap dump was created by. =cut sub ithreads { my $self = shift; return $self->{ithreads}; } =head2 roots %roots = $df->roots Returns a key/value pair list giving the names and SVs at each of the roots. =head2 roots_strong %roots = $df->roots_strong Returns a key/value pair list giving the names and SVs at each of the roots that count as strong references. =head2 roots_weak %roots = $df->roots_weak Returns a key/value pair list giving the names and SVs at each of the roots that count as strong references. =cut sub _roots { my $self = shift; return map { my ( $root_at, $desc ) = @$_; $desc => $self->sv_at( $root_at ) } values %{ $self->{roots} }; } sub roots { my $self = shift; return pairmap { substr( $a, 1 ) => $b } $self->_roots; } sub roots_strong { my $self = shift; return pairmap { $a =~ m/^\+(.*)/ ? ( $1 => $b ) : () } $self->_roots; } sub roots_weak { my $self = shift; return pairmap { $a =~ m/^\-(.*)/ ? ( $1 => $b ) : () } $self->_roots; } =head2 ROOTS $sv = $df->ROOT For each of the root names given below, a method exists with that name which returns the SV at that root: main_cv defstash mainstack beginav checkav unitcheckav initav endav strtabhv envgv incgv statgv statname tmpsv defgv argvgv argvoutgv argvout_stack fdpidav preambleav modglobalhv regex_padav sortstash firstgv secondgv debstash stashcache isarev registered_mros =cut =head2 root_descriptions %rootdescs = $df->root_descriptions Returns a key/value pair list giving the (method) name and description text of each of the possible roots. =cut sub root_descriptions { my $self = shift; my $roots = $self->{roots}; return map { $_ => substr $roots->{$_}[1], 1 } keys %$roots; } =head2 root_at $addr = $df->root_at( $name ) Returns the SV address of the given named root. =cut sub root_at { my $self = shift; my ( $name ) = @_; return $self->{roots}{$name} ? $self->{roots}{$name}[0] : undef; } =head2 root $sv = $df->root( $name ) Returns the given root SV. =cut sub root { my $self = shift; my $root_at = $self->root_at( @_ ) or return; return $self->sv_at( $root_at ); } =head2 heap @svs = $df->heap Returns all of the heap-allocated SVs, in no particular order =cut sub heap { my $self = shift; return values %{ $self->{heap} }; } =head2 stack @svs = $df->stack Returns all the SVs on the stack =cut sub stack { my $self = shift; return map { $self->sv_at( $_ ) } @{ $self->{stack_at} }; } =head2 contexts @ctxs = $df->contexts Returns a list of L objects representing the call context stack in the dumpfile. =cut sub contexts { my $self = shift; return @{ $self->{contexts} }; } =head2 sv_at $sv = $df->sv_at( $addr ) Returns the SV at the given address, or C if one does not exist. (Note that this is unambiguous, as a Perl-level C is represented by the immortal C SV). =cut sub sv_at { my $self = shift; my ( $addr ) = @_; return undef if !$addr; return $self->{UNDEF} if $addr == $self->{undef_at}; return $self->{YES} if $addr == $self->{yes_at}; return $self->{NO} if $addr == $self->{no_at}; return $self->{heap}{$addr}; } =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/Graph.pm000444001750001750 1335514550507443 15657 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014-2016 -- leonerd@leonerd.org.uk package Devel::MAT::Graph 0.52; use v5.14; use warnings; use Struct::Dumb 0.07 'readonly_struct'; =head1 NAME C - a set of references between related SVs =head1 DESCRIPTION Instances of this class represent an entire graph of references between related SVs, as a helper method for return values from various L methods, which might be used for some sort of screen layout or other analysis tasks. =cut =head1 CONSTRUCTOR =cut =head2 new $graph = Devel::MAT::Graph->new( $dumpfile ) Constructs a new C instance backed by the given dumpfile (which is only actually used to make the C<< $node->sv >> method work). =cut sub new { my $class = shift; my ( $df ) = @_; bless { df => $df, edges_from => {}, edges_to => {}, roots_from => {}, }, $class; } =head1 MUTATION METHODS =cut =head2 add_sv $graph->add_sv( $sv ) Makes the graph aware of the given L. This is not strictly necessary before calling C or C, but ensures that C will return true immediately after it, and so can be used as a sentinel for recursion control. =cut sub add_sv { my $self = shift; my ( $sv ) = @_; $self->{edges_from}{$sv->addr} ||= []; return $self; } =head2 add_ref $graph->add_ref( $from_sv, $to_sv, $desc ) Adds an edge to the graph, from and to the given SVs, with the given description. =cut sub add_ref { my $self = shift; my ( $from_sv, $to_sv, $desc ) = @_; my $from_addr = $from_sv->addr; my $to_addr = $to_sv->addr; push @{ $self->{edges_from}{$from_addr} }, [ $to_addr, $desc ]; push @{ $self->{edges_to} {$to_addr} }, [ $from_addr, $desc ]; return $self; } =head2 add_root $graph->add_root( $from_sv, $desc ) Adds a root edge to the graph, at the given SV with the given description. =cut sub add_root { my $self = shift; my ( $from_sv, $desc ) = @_; push @{ $self->{roots_from}{$from_sv->addr} }, $desc; return $self; } =head1 QUERY METHODS =cut =head2 has_sv $bool = $graph->has_sv( $sv ) Returns true if the graph has edges or roots for the given SV, or it has at least been given to C. =cut sub has_sv { my $self = shift; my ( $sv ) = @_; my $addr = $sv->addr; return !!( $self->{edges_from}{$addr} || $self->{edges_to} {$addr} || $self->{roots_from}{$addr} ); } =head2 get_sv_node $node = $graph->get_sv_node( $sv ) Returns a C object for the given SV. =cut sub get_sv_node { my $self = shift; my ( $sv ) = @_; my $addr = ref $sv ? $sv->addr : $sv; return Devel::MAT::Graph::Node->new( graph => $self, addr => $addr, ); } =head2 get_root_nodes @desc_nodes = $graph->get_root_nodes Returns an even-sized list of pairs, containing root descriptions and the nodes having those roots, in no particular order. =cut sub get_root_nodes { my $self = shift; return map { my $node = $self->get_sv_node( $_ ); map { $_, $node } @{ $self->{roots_from}{$_} } } keys %{ $self->{roots_from} }; } package Devel::MAT::Graph::Node 0.52; =head1 NODE OBJECTS The values returned by C respond to the following methods: =cut sub new { my $class = shift; bless { @_ }, $class } =head2 graph $graph = $node->graph Returns the containing C instance. =head2 addr $addr = $node->addr Returns the address of the SV represented by this node. =cut sub graph { $_[0]->{graph} } sub addr { $_[0]->{addr} } =head2 sv $sv = $node->sv Returns the SV object itself, as taken from the dumpfile instance. =cut sub sv { $_[0]->graph->{df}->sv_at( $_[0]->addr ) } =head2 roots @roots = $node->roots Returns any root descriptions given (by calls to C<< $graph->add_root >> for the SV at this node. $graph->add_root( $sv, $desc ); ( $desc, ... ) = $graph->get_sv_node( $sv )->roots =cut sub roots { my $self = shift; return @{ $self->graph->{roots_from}{$self->addr} // [] }; } =head2 edges_out @edges = $node->edges_out Returns an even-sized list of any edge descriptions and more C objects given as references (by calls to C<< $graph->add_ref >>) from the SV at this node. $graph->add_ref( $from_sv, $to_sv, $desc ) ( $desc, $to_edge, ... ) = $graph->get_sv_node( $from_sv )->edges_out =head2 edges_out (scalar) $n_edges = $node->edges_out In scalar context, returns the I that exist; i.e. half the size of the pairlist that would be returned in list context. =cut sub edges_out { my $self = shift; return unless my $edges = $self->graph->{edges_from}{$self->addr}; return scalar @$edges unless wantarray; return map { $_->[1], ( ref $self )->new( graph => $self->graph, addr => $_->[0] ) } @$edges; } =head2 edges_in @edges = $node->edges_in Similar to C, but returns edges in the opposite direction; i.e. edges of references to this node. $graph->add_ref( $from_sv, $to_sv, $desc ) ( $desc, $from_edge, ... ) = $graph->get_sv_node( $to_sv )->edges_in =head2 edges_in (scalar) $n_edges = $node->edges_out In scalar context, returns the I that exist; i.e. half the size of the pairlist that would be returned in list context. =cut sub edges_in { my $self = shift; return unless my $edges = $self->graph->{edges_to}{$self->addr}; return scalar @$edges unless wantarray; return map { $_->[1], ( ref $self )->new( graph => $self->graph, addr => $_->[0] ) } @$edges; } =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/InternalTools.pm000444001750001750 1057414550507443 17413 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2018 -- leonerd@leonerd.org.uk package Devel::MAT::InternalTools 0.52; use v5.14; use warnings; package Devel::MAT::Tool::help; use base qw( Devel::MAT::Tool ); use constant CMD => "help"; use constant CMD_DESC => "Display a list of available commands"; use constant CMD_ARGS => ( { name => "cmdname", help => "name of a command to display more help", slurpy => 1 }, ); sub run { my $self = shift; my ( $cmdname, @subnames ) = @_; if( defined $cmdname ) { $self->help_cmd( $cmdname, @subnames ); } else { $self->help_summary; } } sub help_summary { my $self = shift; my $pmat = $self->{pmat}; my @commands = sort map { my $class = "Devel::MAT::Tool::$_"; $class->can( "CMD" ) ? [ $class->CMD => $class->CMD_DESC ] : () } $pmat->available_tools; Devel::MAT::Cmd->print_table( [ map { [ Devel::MAT::Cmd->format_note( $_->[0] ), $_->[1], ] } sort { $a->[0] cmp $b->[0] } @commands ], sep => " - ", ); } # A join() that respects stringify overloading sub _join { my $sep = shift; my $ret = shift; $ret .= "$sep$_" for @_; return $ret; } sub help_cmd { my $self = shift; my ( $cmdname, @subnames ) = @_; my $fullname = join " ", $cmdname, @subnames; my $tool = $self->{pmat}->load_tool_for_command( $cmdname ); $tool = $tool->find_subcommand( $_ ) for @subnames; Devel::MAT::Cmd->printf( "%s - %s\n", Devel::MAT::Cmd->format_note( $fullname ), $tool->CMD_DESC, ); if( my $code = $tool->can( "help_cmd" ) ) { $tool->$code(); return; } my %optspec = $tool->CMD_OPTS; my @argspec = $tool->CMD_ARGS; Devel::MAT::Cmd->printf( "\nSYNOPSIS:\n" ); Devel::MAT::Cmd->printf( " %s\n", join " ", $fullname, %optspec ? "[OPTIONS...]" : (), $tool->CMD_ARGS_SV ? "[SV ADDR]" : (), @argspec ? ( map { "\$\U$_->{name}" } @argspec ) : (), ); if( %optspec ) { Devel::MAT::Cmd->printf( "\nOPTIONS:\n" ); Devel::MAT::Cmd->print_table( [ map { my $optname = $_; my $opt = $optspec{$_}; my @names = $optname; push @names, $opt->{alias} if $opt->{alias}; s/_/-/g for @names; my $synopsis = _join ", ", map { Devel::MAT::Cmd->format_note( length > 1 ? "--$_" : "-$_", 1 ) } @names; if( my $type = $opt->{type} ) { $synopsis .= " INT" if $type eq "i"; $synopsis .= " STR" if $type eq "s"; } [ $synopsis, $opt->{help} ], } sort keys %optspec ], sep => " ", indent => 2, ); } if( @argspec ) { Devel::MAT::Cmd->printf( "\nARGUMENTS:\n" ); Devel::MAT::Cmd->print_table( [ map { my $arg = $_; [ "\$\U$arg->{name}" . ( $arg->{slurpy} ? "..." : $arg->{repeated} ? "*" : "" ), $arg->{help} ], } @argspec ], sep => " ", indent => 2, ); } } package Devel::MAT::Tool::more; use base qw( Devel::MAT::Tool ); use constant CMD => "more"; use constant CMD_DESC => "Continue the previous listing"; my $more; sub run { if( $more ) { $more->() or undef $more; } else { Devel::MAT::Cmd->printf( "%s\n", Devel::MAT::Cmd->format_note( "No more" ) ); } } sub paginate { shift; my $opts = ( ref $_[0] eq "HASH" ) ? shift : {}; my ( $func ) = @_; $more = sub { $func->( $opts->{pagesize} // 30 ) }; $more->() or undef $more; } sub can_more { return defined $more; } package Devel::MAT::Tool::time; use base qw( Devel::MAT::Tool ); use constant CMD => "time"; use constant CMD_DESC => "Measure the runtime of a command"; use Time::HiRes qw( gettimeofday tv_interval ); sub run_cmd { my $self = shift; my ( $inv ) = @_; my $cmd = $inv->pull_token; my $starttime = [gettimeofday]; my $tool = $self->pmat->load_tool_for_command( $cmd ); my $loadtime = tv_interval( $starttime ); $tool->run_cmd( $inv ); my $runtime = tv_interval( $starttime ); Devel::MAT::Cmd->printf( "\nLoaded in %.03fs, ran in %.03fs\n", $loadtime, $runtime - $loadtime, ); } 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/SV.pm000444001750001750 17672214550507443 15176 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2022 -- leonerd@leonerd.org.uk package Devel::MAT::SV 0.52; use v5.14; use warnings; use Carp; use Scalar::Util qw( weaken ); use Syntax::Keyword::Match; # Load XS code require Devel::MAT; use constant immortal => 0; use List::Util qw( first ); use Struct::Dumb 0.07 qw( readonly_struct ); readonly_struct Reference => [qw( name strength sv )]; readonly_struct Magic => [qw( type obj ptr vtbl )]; =head1 NAME C - represent a single SV from a heap dump =head1 DESCRIPTION Objects in this class represent individual SV variables found in the arena during a heap dump. Actual types of SV are represented by subclasses, which are documented below. =cut my $CONSTANTS; BEGIN { $CONSTANTS = { STRENGTH_STRONG => (1 << 0), STRENGTH_WEAK => (1 << 1), STRENGTH_INDIRECT => (1 << 2), STRENGTH_INFERRED => (1 << 3), }; $CONSTANTS->{STRENGTH_DIRECT} = $CONSTANTS->{STRENGTH_STRONG}|$CONSTANTS->{STRENGTH_WEAK}; $CONSTANTS->{STRENGTH_ALL} = $CONSTANTS->{STRENGTH_STRONG}|$CONSTANTS->{STRENGTH_WEAK}|$CONSTANTS->{STRENGTH_INDIRECT}|$CONSTANTS->{STRENGTH_INFERRED}; } use constant $CONSTANTS; my %types; sub register_type { $types{$_[1]} = $_[0]; # generate the ->type constant method ( my $typename = $_[0] ) =~ s/^Devel::MAT::SV:://; no strict 'refs'; *{"$_[0]::type"} = sub () { $typename } unless defined *{"$_[0]::type"}{CODE}; } sub new { shift; my ( $type, $df, $header, $ptrs, $strs ) = @_; my $class = $types{$type} or croak "Cannot load unknown SV type $type"; my $self = bless {}, $class; $self->_set_core_fields( $type, $df, ( unpack "$df->{ptr_fmt} $df->{u32_fmt} $df->{uint_fmt}", $header ), $ptrs->[0], ); return $self; } =head1 COMMON METHODS =cut =head2 type $type = $sv->type Returns the major type of the SV. This is the class name minus the C prefix. =cut =head2 basetype $type = $sv->basetype Returns the inner perl API type of the SV. This is one of SV AV HV CV GV LV PVIO PVFM REGEXP INVLIST OBJ =head2 desc $desc = $sv->desc Returns a string describing the type of the SV and giving a short detail of its contents. The exact details depends on the SV type. =cut =head2 desc_addr $desc = $sv->desc_addr Returns a string describing the SV as with C and giving its address in hex. A useful way to uniquely identify the SV when printing. =cut sub desc_addr { my $self = shift; return sprintf "%s at %#x", $self->desc, $self->addr; } =head2 addr $addr = $sv->addr Returns the address of the SV =cut # XS accessor =head2 refcnt $count = $sv->refcnt Returns the C reference count of the SV =head2 refcount_adjusted $count = $sv->refcount_adjusted Returns the reference count of the SV, adjusted to take account of the fact that the C value of the backrefs list of a hash or weakly-referenced object is artificially high. =cut # XS accessor sub refcount_adjusted { shift->refcnt } =head2 blessed $stash = $sv->blessed If the SV represents a blessed object, returns the stash SV. Otherwise returns C. =cut sub blessed { my $self = shift; return $self->df->sv_at( $self->blessed_at ); } =head2 symname $name = $sv->symname Called on an SV which is a member of the symbol table, this method returns the perl representation of the full symbol name, including sigil. Otherwise, returns C. A leading C prefix is removed for symbols in packages other than C
. =cut my $mksymname = sub { my ( $sigil, $glob ) = @_; my $stashname = $glob->stashname; $stashname =~ s/^main::// if $stashname =~ m/^main::.+::/; return $sigil . $stashname; }; sub symname {} =head2 size $size = $sv->size Returns the (approximate) size in bytes of the SV =cut # XS accessor =head2 magic @magics = $sv->magic Returns a list of magic applied to the SV; each giving the type and target SVs as struct fields: $type = $magic->type $sv = $magic->obj $sv = $magic->ptr $ptr = $magic->vtbl =cut sub magic { my $self = shift; return unless my $magic = $self->{magic}; my $df = $self->df; return map { my ( $type, undef, $obj_at, $ptr_at, $vtbl_ptr ) = @$_; Magic( $type, $df->sv_at( $obj_at ), $df->sv_at( $ptr_at ), $vtbl_ptr ); } @$magic; } =head2 magic_svs @svs = $sv->magic_svs A more efficient way to retrieve just the SVs associated with the applied magic. =cut sub magic_svs { my $self = shift; return unless my $magic = $self->{magic}; my $df = $self->df; return map { my ( undef, undef, $obj_at, $ptr_at ) = @$_; ( $obj_at ? ( $df->sv_at( $obj_at ) ) : () ), ( $ptr_at ? ( $df->sv_at( $ptr_at ) ) : () ) } @$magic; } =head2 backrefs $av_or_rv = $sv->backrefs Returns backrefs SV, which may be an AV containing the back references, or if there is only one, the REF SV itself referring to this. =cut sub backrefs { my $self = shift; return undef unless my $magic = $self->{magic}; foreach my $mg ( @$magic ) { my ( $type, undef, $obj_at ) = @$mg; # backrefs list uses "<" magic type return $self->df->sv_at( $obj_at ) if $type eq "<"; } return undef; } =head2 rootname $rootname = $sv->rootname If the SV is a well-known root, this method returns its name. Otherwise returns C. =cut sub rootname { my $self = shift; return $self->{rootname}; } # internal sub more_magic { my $self = shift; my ( $type, $flags, $obj_at, $ptr_at, $vtbl_ptr ) = @_; push @{ $self->{magic} }, [ $type => $flags, $obj_at, $ptr_at, $vtbl_ptr ]; } sub _more_annotations { my $self = shift; my ( $val_at, $name ) = @_; push @{ $self->{annotations} }, [ $val_at, $name ]; } # DEBUG_LEAKING_SCALARS sub _debugdata { my $self = shift; my ( $serial, $line, $file ) = @_; $self->{debugdata} = [ $serial, $line, $file ]; } sub debug_serial { my $self = shift; return $self->{debugdata} && $self->{debugdata}[0]; } sub debug_line { my $self = shift; return $self->{debugdata} && $self->{debugdata}[1]; } sub debug_file { my $self = shift; return $self->{debugdata} && $self->{debugdata}[2]; } =head2 outrefs @refs = $sv->outrefs Returns a list of Reference objects for each of the SVs that this one refers to, either directly by strong or weak reference, indirectly via RV, or inferred by C itself. Each object is a structure of three fields: =over 4 =item name => STRING A human-readable string for identification purposes. =item strength => "strong"|"weak"|"indirect"|"inferred" Identifies what kind of reference it is. C references contribute to the C of the referrant, others do not. C and C references are SV addresses found directly within the referring SV structure; C and C references are extra return values added here for convenience by examining the surrounding structure. =item sv => SV The referrant SV itself. =back =cut sub _outrefs_matching { my $self = shift; my ( $match, $no_desc ) = @_; # In scalar context we're just counting so we might as well count just SVs $no_desc ||= !wantarray; my @outrefs = $self->_outrefs( $match, $no_desc ); if( $match & STRENGTH_WEAK and my $blessed = $self->blessed ) { push @outrefs, $no_desc ? ( weak => $blessed ) : Reference( "the bless package", weak => $blessed ); } foreach my $mg ( @{ $self->{magic} || [] } ) { my ( $type, $flags, $obj_at, $ptr_at ) = @$mg; if( my $obj = $self->df->sv_at( $obj_at ) ) { my $is_strong = ( $flags & 0x01 ); if( $match & ( $is_strong ? STRENGTH_STRONG : STRENGTH_WEAK ) ) { my $strength = $is_strong ? "strong" : "weak"; push @outrefs, $no_desc ? ( $strength => $obj ) : Reference( "'$type' magic object", $strength => $obj ); } } if( $match & STRENGTH_STRONG and my $ptr = $self->df->sv_at( $ptr_at ) ) { push @outrefs, $no_desc ? ( strong => $ptr ) : Reference( "'$type' magic pointer", strong => $ptr ); } } foreach my $ann ( @{ $self->{annotations} || [] } ) { my ( $val_at, $name ) = @$ann; my $val = $self->df->sv_at( $val_at ) or next; push @outrefs, $no_desc ? ( strong => $val ) : Reference( $name, strong => $val ); } return @outrefs / 2 if !wantarray; return @outrefs; } sub outrefs { $_[0]->_outrefs_matching( STRENGTH_ALL, $_[1] ) } =head2 outrefs_strong @refs = $sv->outrefs_strong Returns the subset of C that are direct strong references. =head2 outrefs_weak @refs = $sv->outrefs_weak Returns the subset of C that are direct weak references. =head2 outrefs_direct @refs = $sv->outrefs_direct Returns the subset of C that are direct strong or weak references. =head2 outrefs_indirect @refs = $sv->outrefs_indirect Returns the subset of C that are indirect references via RVs. =head2 outrefs_inferred @refs = $sv->outrefs_inferred Returns the subset of C that are not directly stored in the SV structure, but instead inferred by C itself. =cut sub outrefs_strong { $_[0]->_outrefs_matching( STRENGTH_STRONG, $_[1] ) } sub outrefs_weak { $_[0]->_outrefs_matching( STRENGTH_WEAK, $_[1] ) } sub outrefs_direct { $_[0]->_outrefs_matching( STRENGTH_DIRECT, $_[1] ) } sub outrefs_indirect { $_[0]->_outrefs_matching( STRENGTH_INDIRECT, $_[1] ) } sub outrefs_inferred { $_[0]->_outrefs_matching( STRENGTH_INFERRED, $_[1] ) } =head2 outref_named $ref = $sv->outref_named( $name ) I Looks for a reference whose name is exactly that given, and returns it if so. Throws an exception if the SV has no such outref of that name. =head2 maybe_outref_named $ref = $sv->maybe_outref_named( $name ) I As L but returns C if there is no such reference. =cut sub maybe_outref_named { my $self = shift; my ( $name ) = @_; return first { $_->name eq $name } $self->outrefs; } sub outref_named { my $self = shift; my ( $name ) = @_; return $self->maybe_outref_named( $name ) // croak "No outref named $name"; } =head2 is_mortal $mortal = $sv->is_mortal Returns true if this SV is referenced by the temps stack. =cut sub _set_is_mortal { my $self = shift; $self->{is_mortal} = 1; } sub is_mortal { my $self = shift; return $self->{is_mortal}; } =head1 IMMORTAL SVs Three special SV objects exist outside of the heap, to represent C and boolean true and false. They are =over 4 =item * Devel::MAT::SV::UNDEF =item * Devel::MAT::SV::YES =item * Devel::MAT::SV::NO =back =cut package Devel::MAT::SV::Immortal 0.52; use base qw( Devel::MAT::SV ); use constant immortal => 1; use constant basetype => "SV"; sub new { my $class = shift; my ( $df, $addr ) = @_; my $self = bless {}, $class; $self->_set_core_fields( 0, $df, $addr, 0, 0, 0 ); return $self; } sub _outrefs { () } package Devel::MAT::SV::UNDEF 0.52; use base qw( Devel::MAT::SV::Immortal ); sub desc { "UNDEF" } sub type { "UNDEF" } package Devel::MAT::SV::YES 0.52; use base qw( Devel::MAT::SV::Immortal ); sub desc { "YES" } sub type { "SCALAR" } # Pretend to be 1 / "1" sub uv { 1 } sub iv { 1 } sub nv { 1.0 } sub pv { "1" } sub rv { undef } sub is_weak { '' } package Devel::MAT::SV::NO 0.52; use base qw( Devel::MAT::SV::Immortal ); sub desc { "NO" } sub type { "SCALAR" } # Pretend to be 0 / "" sub uv { 0 } sub iv { 0 } sub nv { 0.0 } sub pv { "0" } sub rv { undef } sub is_weak { '' } package Devel::MAT::SV::Unknown 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 0xff ); sub desc { "UNKNOWN" } sub _outrefs {} package Devel::MAT::SV::GLOB 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 1 ); use constant $CONSTANTS; use constant basetype => "GV"; =head1 Devel::MAT::SV::GLOB Represents a glob; an SV of type C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $line ) = unpack "$df->{uint_fmt}", $header; $self->_set_glob_fields( @{$ptrs}[0..7], $line, $strs->[1], $strs->[0], ); } sub _fixup { my $self = shift; $_ and $_->_set_glob_at( $self->addr ) for $self->scalar, $self->array, $self->hash, $self->code; } =head2 file =head2 line =head2 location $file = $gv->file $line = $gv->line $location = $gv->location Returns the filename, line number, or combined location (C) that the GV first appears at. =head2 name $name = $gv->name Returns the value of the C field, for named globs. =cut # XS accessors sub location { my $self = shift; my $file = $self->file; my $line = $self->line; defined $file ? "$file line $line" : undef } =head2 stash $stash = $gv->stash Returns the stash to which the GV belongs. =cut sub stash { my $self = shift; $self->df->sv_at( $self->stash_at ) } =head2 scalar =head2 array =head2 hash =head2 code =head2 egv =head2 io =head2 form $sv = $gv->scalar $av = $gv->array $hv = $gv->hash $cv = $gv->code $gv = $gv->egv $io = $gv->io $form = $gv->form Return the SV in the various glob slots. =cut sub scalar { my $self = shift; $self->df->sv_at( $self->scalar_at ) } sub array { my $self = shift; $self->df->sv_at( $self->array_at ) } sub hash { my $self = shift; $self->df->sv_at( $self->hash_at ) } sub code { my $self = shift; $self->df->sv_at( $self->code_at ) } sub egv { my $self = shift; $self->df->sv_at( $self->egv_at ) } sub io { my $self = shift; $self->df->sv_at( $self->io_at ) } sub form { my $self = shift; $self->df->sv_at( $self->form_at ) } sub stashname { my $self = shift; my $name = $self->name; $name =~ s(^([\x00-\x1f])){"^" . chr(64 + ord $1)}e; return $self->stash->stashname . "::" . $name; } sub desc { my $self = shift; my $sigils = ""; $sigils .= '$' if $self->scalar; $sigils .= '@' if $self->array; $sigils .= '%' if $self->hash; $sigils .= '&' if $self->code; $sigils .= '*' if $self->egv; $sigils .= 'I' if $self->io; $sigils .= 'F' if $self->form; return "GLOB($sigils)"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG ) { foreach my $slot (qw( scalar array hash code io form )) { my $sv = $self->$slot or next; push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the $slot", strong => $sv ); } } if( my $egv = $self->egv ) { # the egv is weakref if if it points back to itself my $egv_is_self = $egv == $self; if( $match & ( $egv_is_self ? STRENGTH_WEAK : STRENGTH_STRONG ) ) { my $strength = $egv_is_self ? "weak" : "strong"; push @outrefs, $no_desc ? ( $strength => $egv ) : Devel::MAT::SV::Reference( "the egv", $strength => $egv ); } } foreach my $saved ( @{ $self->{saved} } ) { my $sv = $self->df->sv_at( $saved->[1] ); push @outrefs, $no_desc ? ( inferred => $sv ) : Devel::MAT::SV::Reference( "saved value of " . Devel::MAT::Cmd->format_note( $saved->[0] ) . " slot", "inferred", $sv ); } return @outrefs; } sub _more_saved { my $self = shift; my ( $slot, $addr ) = @_; push @{ $self->{saved} }, [ $slot => $addr ]; } package Devel::MAT::SV::SCALAR 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 2 ); use constant $CONSTANTS; use constant basetype => "SV"; =head1 Devel::MAT::SV::SCALAR Represents a non-referential scalar value; an SV of any of the types up to and including C (that is, C, C, C, C, C or C). This includes all numbers, integers and floats, strings, and dualvars containing multiple parts. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $flags, $uv, $nvbytes, $pvlen ) = unpack "C $df->{uint_fmt} A$df->{nv_len} $df->{uint_fmt}", $header; my $nv = unpack "$df->{nv_fmt}", $nvbytes; # $strs->[0] will be swiped $self->_set_scalar_fields( $flags, $uv, $nv, $strs->[0], $pvlen, $ptrs->[0], # OURSTASH ); # $strs->[0] is now undef $flags &= ~0x1f; $flags and die sprintf "Unrecognised SCALAR flags %02x\n", $flags; } =head2 uv $uv = $sv->uv Returns the integer numeric portion as an unsigned value, if valid, or C. =head2 iv $iv = $sv->iv Returns the integer numeric portion as a signed value, if valid, or C. =head2 nv $nv = $sv->nv Returns the floating numeric portion, if valid, or C. =head2 pv $pv = $sv->pv Returns the string portion, if valid, or C. =head2 pvlen $pvlen = $sv->pvlen Returns the length of the string portion, if valid, or C. =cut # XS accessors =head2 qq_pv $str = $sv->qq_pv( $maxlen ) Returns the PV string, if defined, suitably quoted. If C<$maxlen> is defined and the PV is longer than this, it is truncated and C<...> is appended after the containing quote marks. =cut sub qq_pv { my $self = shift; my ( $maxlen ) = @_; defined( my $pv = $self->pv ) or return undef; $pv = substr( $pv, 0, $maxlen ) if defined $maxlen and $maxlen < length $pv; my $truncated = $self->pvlen > length $pv; if( $pv =~ m/^[\x20-\x7e]*$/ ) { $pv =~ s/(['\\])/\\$1/g; $pv = qq('$pv'); } else { $pv =~ s{(\") | (\r) | (\n) | ([\x00-\x1f\x80-\xff])} {$1?'\\"' : $2?"\\r" : $3?"\\n" : sprintf "\\x%02x", ord $4}egx; $pv = qq("$pv"); } $pv .= "..." if $truncated; return $pv; } =head2 ourstash $stash = $sv->ourstash Returns the stash of the SCALAR, if it is an 'C' variable. After perl 5.20 this is no longer used, and will return C. =cut sub ourstash { my $self = shift; return $self->df->sv_at( $self->ourstash_at ) } sub symname { my $self = shift; return unless my $glob_at = $self->glob_at; return $mksymname->( '$', $self->df->sv_at( $glob_at ) ); } sub type { my $self = shift; return "SCALAR" if defined $self->uv or defined $self->iv or defined $self->nv or defined $self->pv; return "UNDEF"; } sub desc { my $self = shift; my @flags; push @flags, "UV" if defined $self->uv; push @flags, "IV" if defined $self->iv; push @flags, "NV" if defined $self->nv; push @flags, "PV" if defined $self->pv; local $" = ","; return "UNDEF()" unless @flags; return "SCALAR(@flags)"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG and my $ourstash = $self->ourstash ) { push @outrefs, $no_desc ? ( strong => $ourstash ) : Devel::MAT::SV::Reference( "the our stash", strong => $ourstash ); } return @outrefs; } package Devel::MAT::SV::REF 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 3 ); use constant $CONSTANTS; use constant basetype => "SV"; =head1 Devel::MAT::SV::REF Represents a referential scalar; any SCALAR-type SV with the C flag set. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; ( my $flags ) = unpack "C", $header; $self->_set_ref_fields( @{$ptrs}[0,1], # RV, OURSTASH $flags & 0x01, # RV_IS_WEAK ); $flags &= ~0x01; $flags and die sprintf "Unrecognised REF flags %02x\n", $flags; } =head2 rv $svrv = $sv->rv Returns the SV referred to by the reference. =cut sub rv { my $self = shift; return $self->df->sv_at( $self->rv_at ) } =head2 is_weak $weak = $sv->is_weak Returns true if the SV is a weakened RV reference. =cut # XS accessor =head2 ourstash $stash = $sv->ourstash Returns the stash of the SCALAR, if it is an 'C' variable. =cut sub ourstash { my $self = shift; return $self->df->sv_at( $self->ourstash_at ) } sub desc { my $self = shift; return sprintf "REF(%s)", $self->is_weak ? "W" : ""; } *symname = \&Devel::MAT::SV::SCALAR::symname; sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; my $is_weak = $self->is_weak; if( $match & ( $is_weak ? STRENGTH_WEAK : STRENGTH_STRONG ) and my $rv = $self->rv ) { my $strength = $is_weak ? "weak" : "strong"; push @outrefs, $no_desc ? ( $strength => $rv ) : Devel::MAT::SV::Reference( "the referrant", $strength => $rv ); } if( $match & STRENGTH_STRONG and my $ourstash = $self->ourstash ) { push @outrefs, $no_desc ? ( strong => $ourstash ) : Devel::MAT::SV::Reference( "the our stash", strong => $ourstash ); } return @outrefs; } package Devel::MAT::SV::BOOL 0.52; use base qw( Devel::MAT::SV::SCALAR ); sub type { return "BOOL" } sub desc { my $self = shift; return "BOOL(YES)" if $self->uv; return "BOOL(NO)"; } package Devel::MAT::SV::ARRAY 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 4 ); use constant $CONSTANTS; use constant basetype => "AV"; =head1 Devel::MAT::SV::ARRAY Represents an array; an SV of type C. =cut sub refcount_adjusted { my $self = shift; # AVs that are backrefs lists have an SvREFCNT artificially high return $self->refcnt - ( $self->is_backrefs ? 1 : 0 ); } sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $n, $flags ) = unpack "$df->{uint_fmt} C", $header; $self->_set_array_fields( $flags || 0, [ $n ? $df->_read_ptrs($n) : () ] ); } sub _more_saved { my $self = shift; my ( $index, $addr ) = @_; push @{ $self->{saved} }, [ $index => $addr ]; } =head2 is_unreal $unreal = $av->is_unreal Returns true if the C flag is not set on the array - i.e. that its SV pointers do not contribute to the C of the SVs it points at. =head2 is_backrefs $backrefs = $av->is_backrefs Returns true if the array contains the backrefs list of a hash or weakly-referenced object. =cut # XS accessors sub symname { my $self = shift; return unless my $glob_at = $self->glob_at; return $mksymname->( '@', $self->df->sv_at( $glob_at ) ); } =head2 elems @svs = $av->elems Returns all of the element SVs in a list =cut sub elems { my $self = shift; my $n = $self->n_elems; return $n unless wantarray; my $df = $self->df; return map { $df->sv_at( $self->elem_at( $_ ) ) } 0 .. $n-1; } =head2 elem $sv = $av->elem( $index ) Returns the SV at the given index =cut sub elem { my $self = shift; return $self->df->sv_at( $self->elem_at( $_[0] ) ); } sub desc { my $self = shift; my @flags = $self->n_elems; push @flags, "!REAL" if $self->is_unreal; $" = ","; return "ARRAY(@flags)"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my $n = $self->n_elems; my @outrefs; if( $self->is_unreal ) { if( $match & STRENGTH_WEAK ) { foreach my $idx ( 0 .. $n-1 ) { my $sv = $self->elem( $idx ) or next; push @outrefs, $no_desc ? ( weak => $sv ) : Devel::MAT::SV::Reference( "element " . Devel::MAT::Cmd->format_value( $idx, index => 1 ), weak => $sv ); } } } else { foreach my $idx ( 0 .. $n-1 ) { my $sv = $self->elem( $idx ) or next; my $name = $no_desc ? undef : "element " . Devel::MAT::Cmd->format_value( $idx, index => 1 ); if( $match & STRENGTH_STRONG ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( $name, strong => $sv ); } if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) { push @outrefs, $no_desc ? ( indirect => $rv ) : Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv ); } } } foreach my $saved ( @{ $self->{saved} } ) { my $sv = $self->df->sv_at( $saved->[1] ); push @outrefs, $no_desc ? ( inferred => $sv ) : Devel::MAT::SV::Reference( "saved value of element " . Devel::MAT::Cmd->format_value( $saved->[0], index => 1 ), inferred => $sv ); } return @outrefs; } package Devel::MAT::SV::PADLIST 0.52; # Synthetic type use base qw( Devel::MAT::SV::ARRAY ); use constant type => "PADLIST"; use constant $CONSTANTS; =head1 Devel::MAT::SV::PADLIST A subclass of ARRAY, this is used to represent the PADLIST of a CODE SV. =cut sub padcv { my $self = shift; return $self->df->sv_at( $self->padcv_at ) } sub desc { my $self = shift; return "PADLIST(" . $self->n_elems . ")"; } # Totally different outrefs format than ARRAY sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG ) { my $df = $self->df; my $n = $self->n_elems; if( my $padnames = $df->sv_at( $self->elem_at( 0 ) ) ) { push @outrefs, $no_desc ? ( strong => $padnames ) : Devel::MAT::SV::Reference( "the padnames", strong => $padnames ); } foreach my $idx ( 1 .. $n-1 ) { my $pad = $df->sv_at( $self->elem_at( $idx ) ) or next; push @outrefs, $no_desc ? ( strong => $pad ) : Devel::MAT::SV::Reference( "pad at depth $idx", strong => $pad ); } } return @outrefs; } package Devel::MAT::SV::PADNAMES 0.52; # Synthetic type use base qw( Devel::MAT::SV::ARRAY ); use constant type => "PADNAMES"; use constant $CONSTANTS; =head1 Devel::MAT::SV::PADNAMES A subclass of ARRAY, this is used to represent the PADNAMES of a CODE SV. =cut sub padcv { my $self = shift; return $self->df->sv_at( $self->padcv_at ) } =head2 padname $padname = $padnames->padname( $padix ) Returns the name of the lexical at the given index, or C =cut sub padname { my $self = shift; my ( $padix ) = @_; my $namepv = $self->elem( $padix ) or return undef; $namepv->type eq "SCALAR" or return undef; return $namepv->pv; } =head2 padix_from_padname $padix = $padnames->padix_from_padname( $padname ) Returns the index of the lexical with the given name, or C =cut sub padix_from_padname { my $self = shift; my ( $padname ) = @_; foreach my $padix ( 1 .. scalar( $self->elems ) - 1 ) { my $namepv; return $padix if $namepv = $self->elem( $padix ) and $namepv->type eq "SCALAR" and $namepv->pv eq $padname; } return undef; } sub desc { my $self = shift; return "PADNAMES(" . scalar($self->elems) . ")"; } # Totally different outrefs format than ARRAY sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG ) { my $df = $self->df; my $n = $self->n_elems; foreach my $idx ( 1 .. $n-1 ) { my $padname = $df->sv_at( $self->elem_at( $idx ) ) or next; push @outrefs, $no_desc ? ( strong => $padname ) : Devel::MAT::SV::Reference( "padname " . Devel::MAT::Cmd->format_value( $idx, index => 1 ), strong => $padname ); } } return @outrefs; } package Devel::MAT::SV::PAD 0.52; # Synthetic type use base qw( Devel::MAT::SV::ARRAY ); use constant type => "PAD"; use constant $CONSTANTS; =head1 Devel::MAT::SV::PAD A subclass of ARRAY, this is used to represent a PAD of a CODE SV. =cut sub desc { my $self = shift; return "PAD(" . scalar($self->elems) . ")"; } =head2 padcv $cv = $pad->padcv Returns the C SV for which this is a pad. =cut sub padcv { my $self = shift; return $self->df->sv_at( $self->padcv_at ) } =head2 lexvars ( $name, $sv, $name, $sv, ... ) = $pad->lexvars Returns a name/value list of the lexical variables in the pad. =cut sub lexvars { my $self = shift; my $padcv = $self->padcv; my @svs = $self->elems; return map { my $padname = $padcv->padname( $_ ); $padname ? ( $padname->name => $svs[$_] ) : () } 1 .. $#svs; } =head2 maybe_lexvar $sv = $pad->maybe_lexvar( $padname ) I Returns the SV associated with the given padname if one exists, or C if not. Used to be named C. =cut sub maybe_lexvar { my $self = shift; my ( $padname ) = @_; my $padix = $self->padcv->padix_from_padname( $padname ) or return undef; return $self->elem( $padix ); } *lexvar = \&maybe_lexvar; # Totally different outrefs format than ARRAY sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my $padcv = $self->padcv; my @svs = $self->elems; my @outrefs; if( $match & STRENGTH_STRONG and my $argsav = $svs[0] ) { push @outrefs, $no_desc ? ( strong => $argsav ) : Devel::MAT::SV::Reference( "the " . Devel::MAT::Cmd->format_note( '@_', 1 ) . " av", strong => $argsav ); } foreach my $idx ( 1 .. $#svs ) { my $sv = $svs[$idx] or next; my $name; if( !$no_desc ) { my $padname = $padcv->padname( $idx ); $name = $padname ? $padname->name : undef; if( $name ) { $name = "the lexical " . Devel::MAT::Cmd->format_note( $name, 1 ); } else { $name = "pad temporary $idx"; } } if( $match & STRENGTH_STRONG ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( $name, strong => $sv ); } if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) { push @outrefs, $no_desc ? ( indirect => $rv ) : Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv ); } } return @outrefs; } package Devel::MAT::SV::HASH 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 5 ); use constant $CONSTANTS; use constant basetype => "HV"; =head1 Devel::MAT::SV::HASH Represents a hash; an SV of type C. The C subclass is used to represent hashes that are used as stashes. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; ( my $n ) = unpack "$df->{uint_fmt} a*", $header; my %values_at; foreach ( 1 .. $n ) { my $key = $df->_read_str; $values_at{$key} = $df->_read_ptr; } $self->_set_hash_fields( $ptrs->[0], # BACKREFS \%values_at, ); } # Back-compat. for loading old .pmat files that didn't store AvREAL sub _fixup { my $self = shift; if( my $backrefs = $self->backrefs ) { $backrefs->_set_backrefs( 1 ) if $backrefs->type eq "ARRAY"; } } sub _more_saved { my $self = shift; my ( $keyaddr, $valaddr ) = @_; push @{ $self->{saved} }, [ $keyaddr, $valaddr ]; } sub symname { my $self = shift; return unless my $glob_at = $self->glob_at; return $mksymname->( '%', $self->df->sv_at( $glob_at ) ); } # HVs have a backrefs field directly, rather than using magic sub backrefs { my $self = shift; return $self->df->sv_at( $self->backrefs_at ); } =head2 keys @keys = $hv->keys Returns the set of keys present in the hash, as plain perl strings, in no particular order. =cut # XS accessor =head2 value $sv = $hv->value( $key ) Returns the SV associated with the given key =cut sub value { my $self = shift; my ( $key ) = @_; return $self->df->sv_at( $self->value_at( $key ) ); } =head2 values @svs = $hv->values Returns all of the SVs stored as values, in no particular order (though, in an order corresponding to the order returned by C). =cut sub values { my $self = shift; return $self->n_values if !wantarray; my $df = $self->df; return map { $df->sv_at( $_ ) } $self->values_at; } sub desc { my $self = shift; my $named = $self->{name} ? " named $self->{name}" : ""; return "HASH(" . $self->n_values . ")"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my $df = $self->df; my @outrefs; if( my $backrefs = $self->backrefs ) { # backrefs are optimised so if there's only one backref, it is stored # in the backrefs slot directly if( $backrefs->type eq "ARRAY" ) { if( $match & STRENGTH_STRONG ) { push @outrefs, $no_desc ? ( strong => $backrefs ) : Devel::MAT::SV::Reference( "the backrefs list", strong => $backrefs ); } if( $match & STRENGTH_INDIRECT ) { foreach my $sv ( $self->backrefs->elems ) { push @outrefs, $no_desc ? ( indirect => $sv ) : Devel::MAT::SV::Reference( "a backref", indirect => $sv ); } } } else { if( $match & STRENGTH_WEAK ) { push @outrefs, $no_desc ? ( weak => $backrefs ) : Devel::MAT::SV::Reference( "a backref", weak => $backrefs ); } } } foreach my $key ( $self->keys ) { my $sv = $df->sv_at( $self->value_at( $key ) ) or next; my $name = $no_desc ? undef : "value " . Devel::MAT::Cmd->format_value( $key, key => 1 ); if( $match & STRENGTH_STRONG ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( $name, strong => $sv ); } if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) { push @outrefs, $no_desc ? ( indirect => $sv ) : Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv ); } } foreach my $saved ( @{ $self->{saved} } ) { my $keysv = $self->df->sv_at( $saved->[0] ); my $valsv = $self->df->sv_at( $saved->[1] ); push @outrefs, $no_desc ? ( inferred => $keysv ) : Devel::MAT::SV::Reference( "a key for saved value", inferred => $keysv ); push @outrefs, $no_desc ? ( inferred => $valsv ) : Devel::MAT::SV::Reference( "saved value of value " . Devel::MAT::Cmd->format_value( $keysv->pv, key => 1 ), inferred => $valsv ); } return @outrefs; } package Devel::MAT::SV::STASH 0.52; use base qw( Devel::MAT::SV::HASH ); __PACKAGE__->register_type( 6 ); use constant $CONSTANTS; =head1 Devel::MAT::SV::STASH Represents a hash used as a stash; an SV of type C whose C is non-NULL. This is a subclass of C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $hash_bytes, $hash_ptrs, $hash_strs ) = @{ $df->{sv_sizes}[5] }; $self->SUPER::load( substr( $header, 0, $hash_bytes, "" ), [ splice @$ptrs, 0, $hash_ptrs ], [ splice @$strs, 0, $hash_strs ], ); @{$self}{qw( mro_linearall_at mro_linearcurrent_at mro_nextmethod_at mro_isa_at )} = @$ptrs; ( $self->{name} ) = @$strs; } =head2 mro_linear_all =head2 mro_linearcurrent =head2 mro_nextmethod =head2 mro_isa $hv = $stash->mro_linear_all $sv = $stash->mro_linearcurrent $sv = $stash->mro_nextmethod $av = $stash->mro_isa Returns the fields from the MRO structure =cut sub mro_linearall { my $self = shift; return $self->df->sv_at( $self->{mro_linearall_at} ) } sub mro_linearcurrent { my $self = shift; return $self->df->sv_at( $self->{mro_linearcurrent_at} ) } sub mro_nextmethod { my $self = shift; return $self->df->sv_at( $self->{mro_nextmethod_at} ) } sub mro_isa { my $self = shift; return $self->df->sv_at( $self->{mro_isa_at} ) } =head2 value_code $cv = $stash->value_code( $key ) Returns the CODE associated with the given symbol name, if it exists, or C if not. This is roughly equivalent to $cv = $stash->value( $key )->code Except that it is aware of the direct reference to CVs that perl 5.22 will optimise for. This method should be used in preference to the above construct. =cut sub value_code { my $self = shift; my ( $key ) = @_; my $sv = $self->value( $key ) or return undef; if( $sv->type eq "GLOB" ) { return $sv->code; } elsif( $sv->type eq "REF" ) { return $sv->rv; } die "TODO: value_code on non-GLOB, non-REF ${\ $sv->desc }"; } =head2 stashname $name = $stash->stashname Returns the name of the stash =cut sub stashname { my $self = shift; return $self->{name}; } sub desc { my $self = shift; my $desc = $self->SUPER::desc; $desc =~ s/^HASH/STASH/; return $desc; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs = $self->SUPER::_outrefs( @_ ); if( $match & STRENGTH_STRONG ) { if( my $sv = $self->mro_linearall ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the mro linear all HV", strong => $sv ); } if( my $sv = $self->mro_linearcurrent ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the mro linear current", strong => $sv ); } if( my $sv = $self->mro_nextmethod ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the mro next::method", strong => $sv ); } if( my $sv = $self->mro_isa ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the mro ISA cache", strong => $sv ); } } return @outrefs; } package Devel::MAT::SV::CODE 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 7 ); use constant $CONSTANTS; use constant basetype => "CV"; use Carp; use List::Util 1.44 qw( uniq ); use Struct::Dumb 0.07 qw( struct ); struct Padname => [qw( name ourstash flags fieldix fieldstash_at )]; { no strict 'refs'; *{__PACKAGE__."::Padname::is_outer"} = sub { shift->flags & 0x01 }; *{__PACKAGE__."::Padname::is_state"} = sub { shift->flags & 0x02 }; *{__PACKAGE__."::Padname::is_lvalue"} = sub { shift->flags & 0x04 }; *{__PACKAGE__."::Padname::is_typed"} = sub { shift->flags & 0x08 }; *{__PACKAGE__."::Padname::is_our"} = sub { shift->flags & 0x10 }; # Internal flags, not appearing in the file itself *{__PACKAGE__."::Padname::is_field"} = sub { shift->flags & 0x100 }; } =head1 Devel::MAT::SV::CODE Represents a function or closure; an SV of type C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $line, $flags, $oproot, $depth ) = unpack "$df->{uint_fmt} C $df->{ptr_fmt} $df->{u32_fmt}", $header; defined $depth or $depth = -1; $self->_set_code_fields( $line, $flags, $oproot, $depth, @{$ptrs}[0, 2..4], # STASH, OUTSIDE, PADLIST, CONSTVAL @{$strs}[0, 1], # FILE, NAME ); $self->_set_glob_at( $ptrs->[1] ); # After perl 5.20 individual padname structs are no longer arena-allocated $self->{padnames} = [] if $df->{perlver} > ( ( 5 << 24 ) | ( 20 << 16 ) | 0xffff ); while( my $type = $df->_read_u8 ) { match( $type : == ) { case( 1 ) { push @{ $self->{consts_at} }, $df->_read_ptr } case( 2 ) { push @{ $self->{constix} }, $df->_read_uint } case( 3 ) { push @{ $self->{gvs_at} }, $df->_read_ptr } case( 4 ) { push @{ $self->{gvix} }, $df->_read_uint } case( 5 ) { my $padix = $df->_read_uint; $self->{padnames}[$padix] = _load_padname( $df ); } case( 6 ) { # ignore - used to be padsvs_at $df->_read_uint; $df->_read_uint; $df->_read_ptr; } case( 7 ) { $self->_set_padnames_at( $df->_read_ptr ); } case( 8 ) { my $depth = $df->_read_uint; $self->{pads_at}[$depth] = $df->_read_ptr; } case( 9 ) { my $padname = $self->{padnames}[ $df->_read_uint ]; $padname->flags = $df->_read_u8; } case( 10 ) { my $padname = $self->{padnames}[ $df->_read_uint ]; $padname->flags |= 0x100; $padname->fieldix = $df->_read_uint; $padname->fieldstash_at = $df->_read_ptr; } default { die "TODO: unhandled CODEx type $type"; } } } } sub _load_padname { my ( $df ) = @_; return Padname( $df->_read_str, $df->_read_ptr, 0, 0, 0 ); } sub _fixup { my $self = shift; my $df = $self->df; my $padlist = $self->padlist; if( $padlist ) { bless $padlist, "Devel::MAT::SV::PADLIST"; $padlist->_set_padcv_at( $self->addr ); } my $padnames; my @pads; # 5.18.0 onwards has a totally different padlist arrangement if( $df->{perlver} >= ( ( 5 << 24 ) | ( 18 << 16 ) ) ) { $padnames = $self->padnames_av; @pads = map { $df->sv_at( $_ ) } @{ $self->{pads_at} }; shift @pads; # always zero } elsif( $padlist ) { # PADLIST[0] stores the names of the lexicals # The rest stores the actual pads ( $padnames, @pads ) = $padlist->elems; $self->_set_padnames_at( $padnames->addr ); } if( $padnames ) { bless $padnames, "Devel::MAT::SV::PADNAMES"; $padnames->_set_padcv_at( $self->addr ); $self->{padnames} = \my @padnames; foreach my $padix ( 1 .. $padnames->elems - 1 ) { my $padnamesv = $padnames->elem( $padix ) or next; $padnamesv->immortal and next; # UNDEF $padnames[$padix] = Padname( $padnamesv->pv, $padnamesv->ourstash, 0, 0, 0 ); } } foreach my $pad ( @pads ) { next unless $pad; bless $pad, "Devel::MAT::SV::PAD"; $pad->_set_padcv_at( $self->addr ); } $self->{pads} = \@pads; # Under ithreads, constants and captured GVs are actually stored in the first padlist if( $df->ithreads ) { my $pad0 = $pads[0]; foreach my $type (qw( const gv )) { my $idxes = $self->{"${type}ix"} or next; my $svs_at = $self->{"${type}s_at"} ||= []; @$svs_at = map { my $e = $pad0->elem($_); $e ? $e->addr : undef } uniq @$idxes; } } if( $self->is_cloned and my $oproot = $self->oproot ) { if( my $protosub = $df->{protosubs_by_oproot}{$oproot} ) { $self->_set_protosub_at( $protosub->addr ); } } } =head2 stash =head2 glob =head2 file =head2 line =head2 scope =head2 padlist =head2 constval =head2 oproot =head2 depth $stash = $cv->stash $gv = $cv->glob $filename = $cv->file $line = $cv->line $scope_cv = $cv->scope $av = $cv->padlist $sv = $cv->constval $addr = $cv->oproot $depth = $cv->depth Returns the stash, glob, filename, line number, scope, padlist, constant value, oproot or depth of the code. =cut sub stash { my $self = shift; return $self->df->sv_at( $self->stash_at ) } sub glob { my $self = shift; return $self->df->sv_at( $self->glob_at ) } # XS accessors: file, line sub scope { my $self = shift; return $self->df->sv_at( $self->outside_at ) } sub padlist { my $self = shift; return $self->df->sv_at( $self->padlist_at ) } sub constval { my $self = shift; return $self->df->sv_at( $self->constval_at ) } # XS accessors: oproot, depth =head2 location $location = $cv->location Returns C if the line is defined, or C if not. =cut sub location { my $self = shift; my $line = $self->line; my $file = $self->file; # line 0 is invalid return $line ? "$file line $line" : $file; } =head2 is_clone =head2 is_cloned =head2 is_xsub =head2 is_weakoutside =head2 is_cvgv_rc =head2 is_lexical $clone = $cv->is_clone $cloned = $cv->is_cloned $xsub = $cv->is_xsub $weak = $cv->is_weakoutside $rc = $cv->is_cvgv_rc $lexical = $cv->is_lexical Returns the C, C, C, C, C and C flags. =cut # XS accessors =head2 protosub $protosub = $cv->protosub Returns the protosub CV, if known, for a closure CV. =cut sub protosub { my $self = shift; return $self->df->sv_at( $self->protosub_at ); } =head2 constants @svs = $cv->constants Returns a list of the SVs used as constants or method names in the code. On ithreads perl the constants are part of the padlist structure so this list is constructed from parts of the padlist at loading time. =cut sub constants { my $self = shift; my $df = $self->df; return map { $df->sv_at($_) } @{ $self->{consts_at} || [] }; } =head2 globrefs @svs = $cv->globrefs Returns a list of the SVs used as GLOB references in the code. On ithreads perl the constants are part of the padlist structure so this list is constructed from parts of the padlist at loading time. =cut sub globrefs { my $self = shift; my $df = $self->df; return map { $df->sv_at($_) } @{ $self->{gvs_at} }; } sub stashname { my $self = shift; return $self->stash ? $self->stash->stashname : undef } sub symname { my $self = shift; # CvLEXICALs or CVs with non-reified CvGVs may still have a hekname if( defined( my $hekname = $self->hekname ) ) { my $stashname = $self->stashname; $stashname =~ s/^main:://; return '&' . $stashname . "::" . $hekname; } elsif( my $glob = $self->glob ) { return '&' . $glob->stashname; } return undef; } =head2 padname $padname = $cv->padname( $padix ) Returns the name of the $padix'th lexical variable, or C if it doesn't have a name. The returned padname is a structure of the following fields: $name = $padname->name $bool = $padname->is_outer $bool = $padname->is_state $bool = $padname->is_lvalue $bool = $padname->is_typed $bool = $padname->is_our $bool = $padname->is_field =cut sub padname { my $self = shift; my ( $padix ) = @_; return $self->{padnames}[$padix]; } =head2 padix_from_padname $padix = $cv->padix_from_padname( $padname ) Returns the index of the first lexical variable with the given pad name, or C if one does not exist. =cut sub padix_from_padname { my $self = shift; my ( $padname ) = @_; my $padnames = $self->{padnames}; foreach my $padix ( 1 .. $#$padnames ) { my $thisname; return $padix if defined $padnames->[$padix] and defined( $thisname = $padnames->[$padix]->name ) and $thisname eq $padname; } return undef; } =head2 max_padix $max_padix = $cv->max_padix Returns the maximum valid pad index. This is typically used to create a list of potential pad indexes, such as 0 .. $cv->max_padix Note that since pad slots may contain things other than lexical variables, not every pad slot between 0 and this index will necessarily contain a lexical variable or have a pad name. =cut sub max_padix { my $self = shift; return $#{ $self->{padnames} }; } =head2 padnames_av $padnames_av = $cv->padnames_av Returns the AV reference directly which stores the pad names. After perl version 5.20, this is no longer used directly and will return C. The individual pad names themselves can still be found via the C method. =cut sub padnames_av { my $self = shift; return $self->df->sv_at( $self->padnames_at or return undef ) // croak "${\ $self->desc } PADNAMES is not accessible"; } =head2 pads @pads = $cv->pads Returns a list of the actual pad AVs. =cut sub pads { my $self = shift; return $self->{pads} ? @{ $self->{pads} } : (); } =head2 pad $pad = $cv->pad( $depth ) Returns the PAD at the given depth (given by 1-based index). =cut sub pad { my $self = shift; my ( $depth ) = @_; return $self->{pads} ? $self->{pads}[$depth-1] : undef; } =head2 maybe_lexvar $sv = $cv->maybe_lexvar( $padname, $depth ) I Returns the SV on the PAD associated with the given padname, at the optionally-given depth (1-based index). If I<$depth> is not provided, the topmost live PAD will be used. If no variable exists of the given name returns C. Used to be called C. =cut sub maybe_lexvar { my $self = shift; my ( $padname, $depth ) = @_; $depth //= $self->depth; $depth or croak "Cannot fetch current pad of a non-live CODE"; return $self->pad( $depth )->maybe_lexvar( $padname ); } *lexvar = \&maybe_lexvar; sub desc { my $self = shift; my @flags; push @flags, "PP" if $self->oproot; push @flags, "CONST" if $self->constval; push @flags, "XS" if $self->is_xsub; push @flags, "closure" if $self->is_cloned; push @flags, "proto" if $self->is_clone; local $" = ","; return "CODE(@flags)"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my $pads = $self->{pads}; my $maxdepth = $pads ? scalar @$pads : 0; my $have_padlist = defined $self->padlist; my @outrefs; my $is_weakoutside = $self->is_weakoutside; if( $match & ( $is_weakoutside ? STRENGTH_WEAK : STRENGTH_STRONG ) and my $scope = $self->scope ) { my $strength = $is_weakoutside ? "weak" : "strong"; push @outrefs, $no_desc ? ( $strength => $scope ) : Devel::MAT::SV::Reference( "the scope", $strength => $scope ); } if( $match & STRENGTH_WEAK and my $stash = $self->stash ) { push @outrefs, $no_desc ? ( weak => $stash ) : Devel::MAT::SV::Reference( "the stash", weak => $stash ); } my $is_strong_gv = $self->is_cvgv_rc; if( $match & ( $is_strong_gv ? STRENGTH_STRONG : STRENGTH_WEAK ) and my $glob = $self->glob ) { my $strength = $is_strong_gv ? "strong" : "weak"; push @outrefs, $no_desc ? ( $strength => $glob ) : Devel::MAT::SV::Reference( "the glob", $strength => $glob ); } if( $match & STRENGTH_STRONG and my $constval = $self->constval ) { push @outrefs, $no_desc ? ( strong => $constval ) : Devel::MAT::SV::Reference( "the constant value", strong => $constval ); } if( $match & STRENGTH_INFERRED and my $protosub = $self->protosub ) { push @outrefs, $no_desc ? ( inferred => $protosub ) : Devel::MAT::SV::Reference( "the protosub", inferred => $protosub ); } # Under ithreads, constants and captured GVs are actually stored in the # first padlist, so they're only here. my $ithreads = $self->df->ithreads; if( $match & ( $ithreads ? STRENGTH_INDIRECT : STRENGTH_STRONG ) ) { my $strength = $ithreads ? "indirect" : "strong"; foreach my $sv ( $self->constants ) { $sv or next; push @outrefs, $no_desc ? ( $strength => $sv ) : Devel::MAT::SV::Reference( "a constant", $strength => $sv ); } foreach my $sv ( $self->globrefs ) { $sv or next; push @outrefs, $no_desc ? ( $strength => $sv ) : Devel::MAT::SV::Reference( "a referenced glob", $strength => $sv ); } } if( $match & STRENGTH_STRONG and $have_padlist ) { push @outrefs, $no_desc ? ( strong => $self->padlist ) : Devel::MAT::SV::Reference( "the padlist", strong => $self->padlist ); } # If we have a PADLIST then its contents are indirect; if not then they # are direct strong if( $match & ( $have_padlist ? STRENGTH_INDIRECT : STRENGTH_STRONG ) ) { my $strength = $have_padlist ? "indirect" : "strong"; if( my $padnames_av = $self->padnames_av ) { push @outrefs, $no_desc ? ( $strength => $padnames_av ) : Devel::MAT::SV::Reference( "the padnames", $strength => $padnames_av ); } foreach my $depth ( 1 .. $maxdepth ) { my $pad = $pads->[$depth-1] or next; push @outrefs, $no_desc ? ( $strength => $pad ) : Devel::MAT::SV::Reference( "pad at depth $depth", $strength => $pad ); } } return @outrefs; } package Devel::MAT::SV::IO 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 8 ); use constant $CONSTANTS; use constant basetype => "IO"; =head1 Devel::MAT::SV::IO Represents an IO handle; an SV type of C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; @{$self}{qw( ifileno ofileno )} = unpack "$df->{uint_fmt}2", $header; defined $_ and $_ == $df->{minus_1} and $_ = -1 for @{$self}{qw( ifileno ofileno )}; @{$self}{qw( topgv_at formatgv_at bottomgv_at )} = @$ptrs; } =head2 ifileno =head2 ofileno $ifileno = $io->ifileno $ofileno = $io->ofileno Returns the input or output file numbers. =cut sub ifileno { my $self = shift; return $self->{ifileno} } sub ofileno { my $self = shift; return $self->{ofileno} } sub topgv { my $self = shift; $self->df->sv_at( $self->{topgv_at} ) } sub formatgv { my $self = shift; $self->df->sv_at( $self->{formatgv_at} ) } sub bottomgv { my $self = shift; $self->df->sv_at( $self->{bottomgv_at} ) } sub desc { "IO()" } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG ) { if( my $gv = $self->topgv ) { push @outrefs, $no_desc ? ( strong => $gv ) : Devel::MAT::SV::Reference( "the top GV", strong => $gv ); } if( my $gv = $self->formatgv ) { push @outrefs, $no_desc ? ( strong => $gv ) : Devel::MAT::SV::Reference( "the format GV", strong => $gv ); } if( my $gv = $self->bottomgv ) { push @outrefs, $no_desc ? ( strong => $gv ) : Devel::MAT::SV::Reference( "the bottom GV", strong => $gv ); } } return @outrefs; } package Devel::MAT::SV::LVALUE 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 9 ); use constant $CONSTANTS; use constant basetype => "LV"; sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; ( $self->{type}, $self->{off}, $self->{len} ) = unpack "a1 $df->{uint_fmt}2", $header; ( $self->{targ_at} ) = @$ptrs; } sub lvtype { my $self = shift; return $self->{type} } sub off { my $self = shift; return $self->{off} } sub len { my $self = shift; return $self->{len} } sub target { my $self = shift; return $self->df->sv_at( $self->{targ_at} ) } sub desc { "LVALUE()" } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs; if( $match & STRENGTH_STRONG and my $sv = $self->target ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the target", strong => $sv ); } return @outrefs; } package Devel::MAT::SV::REGEXP 0.52; use base qw( Devel::MAT::SV ); use constant basetype => "REGEXP"; __PACKAGE__->register_type( 10 ); sub load {} sub desc { "REGEXP()" } sub _outrefs { () } package Devel::MAT::SV::FORMAT 0.52; use base qw( Devel::MAT::SV ); use constant basetype => "PVFM"; __PACKAGE__->register_type( 11 ); sub load {} sub desc { "FORMAT()" } sub _outrefs { () } package Devel::MAT::SV::INVLIST 0.52; use base qw( Devel::MAT::SV ); use constant basetype => "INVLIST"; __PACKAGE__->register_type( 12 ); sub load {} sub desc { "INVLIST()" } sub _outrefs { () } # A hack to compress files package Devel::MAT::SV::_UNDEFSV 0.52; use base qw( Devel::MAT::SV::SCALAR ); __PACKAGE__->register_type( 13 ); sub load { my $self = shift; bless $self, "Devel::MAT::SV::SCALAR"; $self->_set_scalar_fields( 0, 0, 0, "", 0, 0, ); } package Devel::MAT::SV::_YESSV 0.52; use base qw( Devel::MAT::SV::BOOL ); __PACKAGE__->register_type( 14 ); sub load { my $self = shift; bless $self, "Devel::MAT::SV::BOOL"; $self->_set_scalar_fields( 0x01, 1, 1.0, "1", 1, 0, ); } package Devel::MAT::SV::_NOSV 0.52; use base qw( Devel::MAT::SV::BOOL ); __PACKAGE__->register_type( 15 ); sub load { my $self = shift; bless $self, "Devel::MAT::SV::BOOL"; $self->_set_scalar_fields( 0x01, 0, 0, "", 0, 0, ); } package Devel::MAT::SV::OBJECT 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 16 ); use constant $CONSTANTS; use constant basetype => "OBJ"; =head1 Devel::MAT::SV::OBJECT Represents an object instance; an SV of type C. These are only present in files from perls with C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $n ) = unpack "$df->{uint_fmt} a*", $header; my @fields_at = $n ? $df->_read_ptrs( $n ) : (); $self->_set_object_fields( \@fields_at ); } =head2 fields @svs = $obj->fields Returns all the values of all the fields in a list. Note that to find the names of the fields you'll have to enquire with the class =cut sub fields { my $self = shift; my $n = $self->n_fields; return $n unless wantarray; my $df = $self->df; return map { $df->sv_at( $self->field_at( $_ ) ) } 0 .. $n-1; } =head2 field $sv = $obj->field( $name_or_fieldix ) Returns the value of the given field; which may be specified by name or index directly. =cut sub field { my $self = shift; my ( $name_or_fieldix ) = @_; my $fieldix; if( $name_or_fieldix =~ m/^\d+$/ ) { $fieldix = $name_or_fieldix; } else { $fieldix = $self->blessed->field( $name_or_fieldix )->fieldix; } return $self->df->sv_at( $self->field_at( $fieldix ) ); } sub desc { my $self = shift; return "OBJ()"; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my $n = $self->n_fields; my @outrefs; foreach my $field ( $self->blessed->fields ) { my $sv = $self->field( $field->fieldix ) or next; my $name = $no_desc ? undef : "the " . Devel::MAT::Cmd->format_note( $field->name, 1 ) . " field"; if( $match & STRENGTH_STRONG ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( $name, strong => $sv ); } if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) { push @outrefs, $no_desc ? ( indirect => $rv ) : Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv ); } } return @outrefs; } package Devel::MAT::SV::CLASS 0.52; use base qw( Devel::MAT::SV::STASH ); __PACKAGE__->register_type( 17 ); use constant $CONSTANTS; use Carp; use Struct::Dumb 0.07 qw( readonly_struct ); readonly_struct Field => [qw( fieldix name )]; use List::Util qw( first ); =head1 Devel::MAT::SV::CLASS Represents a class; a sub-type of stash for implementing object classes. These are only present in files from perls with C. =cut sub load { my $self = shift; my ( $header, $ptrs, $strs ) = @_; my $df = $self->df; my ( $stash_bytes, $stash_ptrs, $stash_strs ) = @{ $df->{sv_sizes}[6] }; $self->SUPER::load( substr( $header, 0, $stash_bytes, "" ), [ splice @$ptrs, 0, $stash_ptrs ], [ splice @$strs, 0, $stash_strs ], ); @{$self}{qw( adjust_blocks_at )} = @$ptrs; while( my $type = $df->_read_u8 ) { match( $type : == ) { case( 1 ) { push @{ $self->{fields} }, [ $df->_read_uint, $df->_read_str ] } default { die "TODO: unhandled CLASSx type $type"; } } } } sub adjust_blocks { my $self = shift; return $self->df->sv_at( $self->{adjust_blocks_at} ) } =head2 fields @fields = $class->fields Returns a list of the field definitions of the class, in declaration order. Each is a structure whose form is given below. =cut sub fields { my $self = shift; return map { Field( @$_ ) } @{ $self->{fields} }; } =head2 field $field = $class->field( $name_or_fieldix ) Returns the field definition of the given field; which may be specified by name or index directly. Throws an exception if none such exists. The returned field is a structure of the following fields: $fieldix = $field->fieldix $name = $field->name =head2 maybe_field $field = $class->maybe_field( $name_or_fieldix ) I Similar to L but returns undef if none such exists. =cut sub maybe_field { my $self = shift; my ( $name_or_fieldix ) = @_; if( $name_or_fieldix =~ m/^\d+$/ ) { return first { $_->fieldix == $name_or_fieldix } $self->fields; } else { return first { $_->name eq $name_or_fieldix } $self->fields } } sub field { my $self = shift; return $self->maybe_field( @_ ) // do { my ( $name_or_fieldix ) = @_; croak "No field at index $name_or_fieldix" if $name_or_fieldix =~ m/^\d+$/; croak "No field named '$name_or_fieldix'"; }; } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; my @outrefs = $self->SUPER::_outrefs( @_ ); if( $match & STRENGTH_STRONG ) { if( my $sv = $self->adjust_blocks ) { push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( "the ADJUST blocks AV", strong => $sv ); } } return @outrefs; } # A "SV" type that isn't really an SV, but has many of the same methods. These # aren't created by core perl, but are used by XS extensions package Devel::MAT::SV::C_STRUCT 0.52; use base qw( Devel::MAT::SV ); __PACKAGE__->register_type( 0x7F ); use constant $CONSTANTS; use constant { FIELD_PTR => 0x00, FIELD_BOOL => 0x01, FIELD_U8 => 0x02, FIELD_U32 => 0x03, FIELD_UINT => 0x04, }; use Carp; use List::Util qw( first ); =head1 Devel::MAT::SV::C_STRUCT Represents a C-level c type. =cut sub desc { my $self = shift; my $typename = $self->structtype->name; "C_STRUCT($typename)"; } sub load { my $self = shift; my ( $fields ) = @_; my $df = $self->df; my @vals; foreach my $field ( @$fields ) { push @vals, my $type = $field->type; if( $type == FIELD_PTR ) { push @vals, $df->_read_ptr; } elsif( $type == FIELD_BOOL or $type == FIELD_U8 ) { push @vals, $df->_read_u8; } elsif( $type == FIELD_U32 ) { push @vals, $df->_read_u32; } elsif( $type == FIELD_UINT ) { push @vals, $df->_read_uint; } else { croak "TODO: load struct field type = $type\n"; } } $self->_set_struct_fields( @vals ); } =head2 fields @kvlist = $struct->fields Returns an even-sized name/value list of all the field values stored by the struct; each preceeded by its field type structure. =cut sub fields { my $self = shift; my $df = $self->df; my $fields = $self->structtype->fields; return map { my $field = $fields->[$_]; if( $field->type == FIELD_PTR ) { $field => $df->sv_at( $self->field( $_ ) ) } else { $field => $self->field( $_ ); } } 0 .. $#$fields; } =head2 field_named $val = $struct->field_named( $name ) Looks for a field whose name is exactly that given, and returns its value. Throws an exception if the struct has no such field of that name. =head2 maybe_field_named $val = $struct->maybe_field_named( $name ) I As L but returns C if there is no such field. =cut sub maybe_field_named { my $self = shift; my ( $name ) = @_; my $fields = $self->structtype->fields; defined( my $idx = first { $fields->[$_]->name eq $name } 0 .. $#$fields ) or return undef; my $field = $fields->[$idx]; if( $field->type == FIELD_PTR ) { return $self->df->sv_at( $self->field( $idx ) ); } else { return $self->field( $idx ); } } sub field_named { my $self = shift; my ( $name ) = @_; return $self->maybe_field_named( $name ) // croak "No field named $name"; } =head2 structtype $structtype = $struct->structtype Returns a metadata structure describing the type of the struct itself. Has the following named accessors =over 4 =item name => STRING The name of the struct type, as given by the dumpfile. =item fields => ARRAY[ Field ] An ARRAY reference containing the definitions of each field in turn =back =cut sub structtype { my $self = shift; return $self->df->structtype( $self->structid ); } sub _outrefs { my $self = shift; my ( $match, $no_desc ) = @_; return unless $match & STRENGTH_STRONG; my $df = $self->df; my @outrefs; my $fields = $self->structtype->fields; foreach my $idx ( 0 .. $#$fields ) { my $field = $fields->[$idx]; $field->type == FIELD_PTR or next; # Is PTR my $sv = $df->sv_at( $self->field( $idx ) ) or next; push @outrefs, $no_desc ? ( strong => $sv ) : Devel::MAT::SV::Reference( $field->name, strong => $sv ); } return @outrefs; } =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/Tool.pm000444001750001750 1144314550507443 15527 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2018 -- leonerd@leonerd.org.uk package Devel::MAT::Tool 0.52; use v5.14; use warnings; use Syntax::Keyword::Match; use List::Util qw( any ); use Commandable::Invocation; Commandable::Invocation->VERSION( '0.04' ); # ->peek_remaining sub new { my $class = shift; my ( $pmat, %args ) = @_; my $self = bless { pmat => $pmat, df => $pmat->dumpfile, progress => $args{progress}, }, $class; $self->init_tool if $self->can( 'init_tool' ); return $self; } sub pmat { my $self = shift; return $self->{pmat}; } sub df { my $self = shift; return $self->{df}; } sub report_progress { my $self = shift; $self->{progress}->( @_ ) if $self->{progress}; } sub get_sv_from_inv { my $self = shift; my ( $inv ) = @_; my $sv = Devel::MAT::UI->can( "current_sv" ) && Devel::MAT::UI->current_sv; if( defined( my $addr = $inv->pull_token ) ) { # Acccept any root name symbolically if( any { $addr eq $_ } Devel::MAT::Dumpfile->ROOTS ) { $sv = $self->df->$addr; } # Accept named symbols elsif( $addr =~ m/^[\$\@\%\&]/ ) { $sv = $self->pmat->find_symbol( $addr ); } else { $addr = do { no warnings 'portable'; hex $addr; } if $addr =~ m/^0x/; do { no warnings 'numeric'; $addr eq $addr+0 } or die "Expected numerical SV address\n"; $sv = $self->df->sv_at( $addr ) or die sprintf "No such SV at address %x\n", $addr; } } $sv or die "Need an SV address\n"; return $sv; } # Some empty defaults use constant CMD_OPTS => (); use constant CMD_ARGS_SV => 0; use constant CMD_ARGS => (); sub find_subcommand { my $self = shift; my ( $subname ) = @_; # TODO: sanity check return ( ref($self) . "::" . $subname )->new( $self->pmat, progress => $self->{progress}, ); } sub parse_cmd { my $self = shift; my ( $inv ) = @_; my @args; if( my %optspec = $self->CMD_OPTS ) { push @args, $self->get_opts_from_inv( $inv, \%optspec ); } if( $self->CMD_ARGS_SV ) { push @args, $self->get_sv_from_inv( $inv ); } if( my @argspec = $self->CMD_ARGS ) { push @args, $self->get_args_from_inv( $inv, @argspec ); } return @args; } sub run_cmd { my $self = shift; my ( $inv ) = @_; $self->run( $self->parse_cmd( $inv ) ); } sub get_opts_from_inv { my $self = shift; my ( $inv, $optspec, %args ) = @_; my $permute = $args{permute} // 1; my %opts; my %aliases; foreach my $name ( keys %$optspec ) { my $spec = $optspec->{$name}; $opts{$name} = $spec->{default}; $aliases{ $spec->{alias} } = $name if defined $spec->{alias}; } my @remaining; while( defined( my $opt = $inv->pull_token ) ) { last if $opt eq "--"; if( $opt =~ m/^--(.*)$/ ) { $opt = $1; } elsif( $opt =~ m/^-(.)$/ ) { $opt = $aliases{$1} or die "No such option '-$1'\n"; } else { push @remaining, $opt; last if !$permute; next; } my $spec = $optspec->{$opt} or die "No such option '--$opt'\n"; my $val; match( $spec->{type} // "" : eq ) { case( "" ) { $val = 1; } case( "s" ) { defined( $val = $inv->pull_token ) or die "Option --$opt requires a value\n"; } case( "i" ) { defined( $val = $inv->pull_token ) or die "Option --$opt requires a value\n"; $val =~ m/^-?\d+$/ or die "Option --$opt value '$val' is not a number\n"; } case( "x" ) { defined( $val = $inv->pull_token ) or die "Option --$opt requires a value\n"; $val =~ m/^-?\d+$/ or $val =~ m/^0x[0-9a-f]+$/i or die "Option --$opt value '$val' is not a (hex)number\n"; no warnings 'portable'; $val = hex $val if $val =~ m/^0x/; } default { die "TODO: unrecognised type $_\n"; } } $opts{$opt} = $val; } $inv->putback_tokens( @remaining ); return \%opts; } sub get_args_from_inv { my $self = shift; my ( $inv, @argspec ) = @_; my @args; foreach my $argspec ( @argspec ) { my $val = $inv->pull_token; defined $val or !$argspec->{required} or die "Expected a value for '$argspec->{name}' argument\n"; defined $val or last; push @args, $val; if( $argspec->{slurpy} ) { push @args, $inv->pull_token while length $inv->peek_remaining; } redo if $argspec->{repeated}; } return @args; } 0x55AA; Devel-MAT-0.52/lib/Devel/MAT/Tool.pod000444001750001750 420414550507443 15652 0ustar00leoleo000000000000=head1 NAME C - extend the ability of C =head1 DESCRIPTION The C namespace provides a place to store plugins that extend the abilities of L. Such tools can be used to provide extra analysis or display capabilities on the UI. It can interact with the UI by calling methods in the L package. A tool should be placed in the namespace and provide an object class. It does not need to inherit from anything specific. Tools will be constructed lazily by the UI as requested by the user. =head1 METHODS The following methods should provided on a tool class. =head2 FOR_UI $display = CLASS->FOR_UI If the tool should be displayed on the UI's C menu, this constant method should be provided to return a true value. =head2 CMD $cname = CLASS->CMD If the tool provides a named command for the commandline, this constant method should be provided to return its name. =head2 AUTOLOAD_TOOL $load = CLASS->AUTOLOAD_TOOL( $pmat ) If the tool should be automatically loaded for the given file, this method should be provided to return a true value. This might be useful to provide extra analysis if the tool detects it can provide something useful; for example when the tool peeks inside objects of specific classes, and those classes are found in the file. =head2 init_tool $tool->init_tool() Performs any required initialisation, typically tasks such as further bulk analysis performed on the entire dumpfile heap. =head2 init_ui $tool->init_ui( $ui ) Asks the tool to initialise any UI elements it may require, by calling methods on the given C<$ui>. This may be an object, or the package name C directly. =cut =head1 SVs Tools may, and are encouraged to where appropriate, add methods to the C package to access results of analysis or perform other related activities. All SVs are implemented as blessed HASH references, and tools may use keys beginning C in it. Key and method names should be namespaced appropriately according to the tool name, to avoid collisions. =cut =head1 AUTHOR Paul Evans =cut Devel-MAT-0.52/lib/Devel/MAT/UI.pod000444001750001750 1153114550507443 15273 0ustar00leoleo000000000000=head1 NAME C - extend the user interface of a C explorer =head1 DESCRIPTION This virtual package provides methods that L classes can use to extend the user interface provided by a L explorer program. This package does not exist in a real F<.pm> file; instead, the methods should be provided directly by the explorer program. A tool class can rely on being able to call them without doing anything special - do not attempt to C. =head1 METHODS =head2 register_icon Devel::MAT::UI->register_icon( name => $name, ... ) A tool may call this to register a named icon image with the UI, for later use in an SV list column or SV detail. The name of the icon is taken from the C key, and the specific UI implementation will use one of the other keys to provide the value for its type. This icon is used by SV list columns or SV details where the C is C. The value set gives the name the icon was registered with. =over 4 =item svg => PATH (GTK) Gives a path name to an F file containing image data. This path is relative to the share directory of the package, managed by L. =back =head2 provides_radiobutton_set Devel::MAT::UI->provides_radiobutton_set( @buttons ) A tool may call this to declare that it wishes to have a set of radiobuttons as a choice of options to be displayed in the toolbar of the user interface. Each button is specified in a HASH reference in the C<@buttons> list containing the following keys: =over 4 =item text => STRING The text to display on the button =item icon => STRING The name of the previously-registered icon to display with the button =item tooltip => STRING Descriptive text to associate with the button to further explain it =item code => CODE A code reference to invoke when the button is activated. =back The buttons will be displayed in a group of their own, such that selecting one will deactivate all the others in the same set. =head2 provides_svlist_column $column = Devel::MAT::UI->provides_svlist_column( type => ..., title => ... ) A tool may call this to declare that it wishes to provide a new column to display in the main SV list on the user interface. It returns an opaque column value that should be passed to C to provide data for the column. =over 4 =item type => STRING The type of the column. This may be C, C or C. =item title => STRING The title to display in the column header. =back =head2 COLUMN_TYPE =head2 COLUMN_ADDR =head2 COLUMN_DESC =head2 COLUMN_SIZE =head2 COLUMN_BLESSED =head2 COLUMN_OUTREFS =head2 COLUMN_INREFS Opaque column values to represent the predefined SV list columns. =head2 set_svlist_column_values Devel::MAT::UI->set_svlist_column_values( column => $column, from => $from ) A tool may call this to provide the values to display in the SV list column it earlier created by calling C, or to replace the values in any of the predefined columns. =over 4 =item column => SCALAR The value returned from C. =item from => CODE A function to generate the value to store for each SV. Is invoked with each SV in the SV list, and should return the value to set in the column. $value = $from->( $sv ) =back =head2 provides_sv_detail Devel::MAT::UI->provides_sv_detail( type => $type, title => $title, render => $render ) A tool may call this to declare that it provides a section of detail about an SV. =over 4 =item type => STRING The type of the column. This may be C, C or C. =item title => STRING The title to display alongside the detail cell on the main SV display pane. =item render => CODE A function to generate the display for a given SV address. It is invoked with an SV to display, and should a value whose meaning depends on the type. If it returns undef then the row is not displayed for this SV. $value = $render->( $sv ) =back If the type is C, any of the following C methods can be used by the render function to generate a widget to display. =cut =head2 make_widget_text $widget = Devel::MAT::UI->make_widget_text( $text ) Constructs a widget displaying a fixed text string. =head2 make_widget_text_icon $widget = Devel::MAT::UI->make_widget_text_icon( $text, $icon ) Constructs a widget displaying a fixed text string next to an icon. =head2 make_table $widget = Devel::MAT::UI->make_table( $label => $widget, $label => $widget, ... ) Constructs a widget displaying a labeled table of other widgets. =head2 current_sv $sv = Devel::MAT::UI->current_sv If the UI has a concept of the "current" SV that the user is viewing, this method returns it. This may be used by tools to pick a default SV on which to operate, in case one was not supplied on the commandline. =head1 AUTHOR Paul Evans =cut �����������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/UserGuide.pod����������������������������������������������������������000444��001750��001750�� 16354�14550507443� 16662� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������=head1 NAME C - a users' introduction to C =head1 OVERVIEW The C ecosystem allows developers of F programs to inspect and analyse memory-related problems such as memory leaks, unexpected memory consumption, or odd state. This is an "offline" analysis system, in the sense that the analysis tools all run in a different process, possibly at a later time, than the F process that is being analysed. The basic workflow consists of two main stages: first a I file is generated from the F process being debugged, at or around the time that the problem becomes apparent, and secondly this file is loaded by an analysis tool in order to inspect the contents. These two stages are described here separately. It is important to note that they don't have to be done at the same time, on the same F process, or even on the same sort of machine. It is fully possible to capture the heap from a process on, say, a small server, then copy the file to a development workstation or laptop and analyse it there at a later time. It is for this reason that the heap-dumping part, L, is now separated into its own CPAN distribution. This means it can be installed on its own, without all the extra dependencies the full set of analysis tools require. =head1 CAPTURING THE HEAP To generate the heap dump file that captures the contents of the heap, the L module is used. Ultimately the C function within it needs to be called, but usually one of the module load options can be used on the F commandline to achieve this without requiring the running code to be modified. For example, the C<-dump_at_DIE> option means that a heap dump will be written just before the process quits due to an uncaught exception: $ perl -MDevel::MAT::Dumper=-dump_at_DIE program.pl At this point, the program will start up and run normally, but if it is about to die, it will first write a F<.pmat> file capturing the contents of the memory. ... Dumping to program.pl.pmat because of DIE Can't call method "method" on an undefined value at program.pl line 123. There are a variety of other options for other situations, to suit other sorts of bugs and issues under investigation. For more options, see the documentation at L. =head1 ANALYSING THE HEAP Now that we have a F<.pmat> file, we can load it and start to inspect the contents. A lot of the smaller, simpler tools are built as plugins for the main F command shell, so we can start by loading the heap file there. $ pmat program.pl.pmat Perl memory dumpfile from perl 5.24.1 Heap contains 15624 objects pmat> In this shell a collection of commands is available to help analyse and inspect the contents of memory represented by this heap dump, which can be used in an interactive way, trying to narrow down to find the cause of the memory issue. It is hard in general to describe exactly what sequence of analysis commands will be best to find the problem, as the specifics of each individual case will call for different kinds of analysis and require us to ask different questions of the toolset. Ultimately there is quite a variety of possible underlying causes of memory growth in a Perl program; a few possible causes could be: =over 2 =item * A single large SV such as a hash or array containing millions of items, or a single string possibly gigabytes in length. =item * A large number of SVs being created retained indefinitely, never being reclaimed. =item * A large number of temporary SVs being created, but due to internal reference cycles their memory is never reclaimed despite them now being unreachable. =back This list of course is quite incomplete - there are as many different variations of erroenous memory usage as there are possible programs to write. Additionally, a lot of more interesting programs often suffer multiple overlapping issues at once. Nevertheless, this broad categorisation can help to describe some overall approaches to finding memory usage issues. A good first step to take in the F shell to try to distinguish these cases is to use the C command. This command requires no additional arguments, and by default will print (in size order), the five largest individual SVs in the entire heap. pmat> largest For more information about the C command, see also L. =head2 One Large SV Sometimes you'll find a single SV that far outweighs all the others; for example: pmat> largest SCALAR(PV) at 0x6a47708: 1.6 GiB SCALAR(PV) at 0x1a59488: 4.0 MiB HASH(0) at 0xfb4770=strtab: 1.5 MiB SCALAR(PV) at 0x71b6468: 707.3 KiB SCALAR(PV) at 0x71be2f0: 609.6 KiB others: 46.2 MiB In this output, we see that the topmost SV reported, at address C<0x6a47708> is much larger than everything else put together. In this case we have essentially already found the cause of the memory usage growth, and we can proceed by identifying what this particular SV actually is, by following the process in L. For a brief overview, we can just count the total number of objects of various kinds in the heap: pmat> count Kind Count (blessed) Bytes (blessed) ARRAY 182 0 16.0 KiB CODE 182 0 22.8 KiB GLOB 325 0 48.2 KiB ... We can inspect the callstack at the time the heap dump was made: pmat> callers caller(0): CODE(PP) at 0x55555582a4e8=&main::__ANON__ => void at t/test.pl line 49 $_[0]: SCALAR(PV) at 0x55c2bdce2778 = "arguments" $_[1]: SCALAR(PV) at 0x55c2bdce2868 = "go" $_[2]: SCALAR(PV) at 0x55c2bdce26e8 = "here" ... =head1 COMMAND HELP A list of the commands currently available in the shell can be found by the C command: pmat> help callers - Display the caller stack count - Count the various kinds of SV elems - List the elements of an ARRAY SV ... For more information about a particular command, give its name as an argument to the C command: pmat> help sizes sizes - Summarize object and byte counts across different SV types SYNOPSIS: sizes [OPTIONS...] OPTIONS: --owned sum SVs by owned size --struct sum SVs by structural size Also note that each command is implemented by a (correctly-cased) package under the C namespace. For example, the C tool is implemented by, and therefore more documentation can be found in, the L package. =head2 Specifying SVs Many commands operate on a particular given SV. This can be specified in several ways: =over 4 =item * A numerical address directly: pmat> show 0x55a7e4e59f78 IO()=IO::File at 0x55a7e4e59f78 with refcount 1 ... =item * A named root SV (see the C command for a list of them all): pmat> show defstash STASH(61) at 0x55a7e4d69060=defstash with refcount 2 =item * A named symbol from the symbol table. Note that subs require the C<&> sigil: pmat> show $warnings::VERSION SCALAR(PV) at 0x55a7e4d96550 with refcount 1 ... pmat> show &warnings::import CODE(PP) at 0x55a7e4dc3458 with refcount 1 ... =back =head1 AUTHOR Paul Evans =cut ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Cmd��������������������������������������������������������������������000755��001750��001750�� 0�14550507443� 14577� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Cmd/Terminal.pm��������������������������������������������������������000444��001750��001750�� 3625�14550507443� 17053� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2018 -- leonerd@leonerd.org.uk package Devel::MAT::Cmd::Terminal 0.52; use v5.14; use warnings; use String::Tagged 0.15; # sprintf use String::Tagged::Terminal 0.03; # ->print_to_terminal use constant CAN_COLOUR => -t STDOUT; =head1 NAME C - provide the L API on a terminal =head1 DESCRIPTION This module provides an implementation of the methods required for the L API that outputs formatted text to a terminal. This is performed by using L. =cut my @FG = ( 3, # yellow 6, # cyan 5, # magenta ); sub Devel::MAT::Cmd::printf { shift; my ( $fmt, @args ) = @_; my $str = String::Tagged::Terminal->from_sprintf( $fmt, @args ); CAN_COLOUR ? $str->print_to_terminal : print "$str"; return length $str; } sub Devel::MAT::Cmd::format_note { shift; my ( $str, $idx ) = @_; $idx //= 0; return String::Tagged->new_tagged( $str, bold => 1, fgindex => $FG[$idx % 3], ); } sub Devel::MAT::Cmd::_format_sv { shift; my ( $ret, $sv ) = @_; return String::Tagged->new_tagged( $ret, bold => 1, italic => 1 ); } sub Devel::MAT::Cmd::_format_value { shift; return String::Tagged->new_tagged( $_[0], fgindex => 5+8 ); } sub Devel::MAT::Cmd::format_symbol { shift; my ( $name ) = @_; return String::Tagged->new_tagged( $name, fgindex => 2, ); } sub Devel::MAT::Cmd::format_heading { shift; my ( $text, $level ) = @_; $level //= 1; $level %= 3; return String::Tagged->new_tagged( $text, $level == 0 ? ( bold => 1 ) : $level == 1 ? ( under => 1 ) : $level == 2 ? ( fgindex => 6, under => 1 ) : (), ); } =head1 AUTHOR Paul Evans =cut 0x55AA; �����������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool�������������������������������������������������������������������000755��001750��001750�� 0�14550507443� 15011� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Callers.pm��������������������������������������������������������000444��001750��001750�� 7406�14550507443� 17100� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2017-2019 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Callers 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "callers"; use constant CMD_DESC => "Display the caller stack"; use constant CMD_OPTS => ( pad => { help => "show PAD contents", alias => "P" }, ); =head1 NAME C - display the caller stack =head1 DESCRIPTION This C tool displays the captured state of the caller stack, showing which functions have been called, and what their arguments were. =cut =head1 COMMANDS =head2 callers pmat> callers caller(0): &main::func => void at program.pl line 4 $_[0]: SCALAR(PV) at 0x55c2bdce2778 = "arguments" $_[1]: SCALAR(PV) at 0x55c2bdce2868 = "go" $_[2]: SCALAR(PV) at 0x55c2bdce26e8 = "here" Prints details of the caller stack, including arguments to functions. Takes the following named options: =over 4 =item --pad, -P Additionally show the contents of the active PAD at this depth. =back =cut sub run { my $self = shift; my %opts = %{ +shift }; my @contexts = $self->df->contexts; foreach my $idx ( 0 .. $#contexts ) { my $ctx = $contexts[$idx]; my $what; for( $ctx->type ) { if( $_ eq "SUB" ) { $what = String::Tagged->from_sprintf( "%s=%s", Devel::MAT::Cmd->format_sv( $ctx->cv ), Devel::MAT::Cmd->format_symbol( $ctx->cv->symname ), ); } elsif( $_ eq "TRY" ) { $what = "eval {...}"; } elsif( $_ eq "EVAL" ) { $what = String::Tagged->from_sprintf( "eval (%s)", Devel::MAT::Cmd->format_value( $ctx->code->pv, pv => 1 ), ); } } Devel::MAT::Cmd->printf( "%s: %s => %s\n", Devel::MAT::Cmd->format_note( sprintf "caller(%d)", $idx ), $what, Devel::MAT::Cmd->format_note( $ctx->gimme ), ); Devel::MAT::Cmd->printf( " at %s\n", $ctx->location, ); next unless $ctx->type eq "SUB"; my $args = $ctx->args or next; my @args = $args->elems; my $doneargs; $doneargs++, Devel::MAT::Cmd->printf( " %s: %s\n", Devel::MAT::Cmd->format_note( "\$_[$_]", 1 ), Devel::MAT::Cmd->format_sv_with_value( $args[$_] ) ) for 0 .. $#args; my $cv = $ctx->cv; Devel::MAT::Cmd->printf( " cv=%s\n", Devel::MAT::Cmd->format_sv( $cv ), ); ( my $depth = $ctx->depth ) > -1 or next; my $pad = $cv->pad( $depth ); if( $opts{pad} ) { Devel::MAT::Cmd->printf( " curpad=%s\n", Devel::MAT::Cmd->format_sv( $pad ) ); require Devel::MAT::Tool::Show; Devel::MAT::Tool::Show->show_PAD_contents( $pad ); } else { foreach my $name ( '$self' ) { my $self_padix = $cv->padix_from_padname( $name ) or next; if( my $sv = $pad->elem( $self_padix ) ) { $doneargs++; Devel::MAT::Cmd->printf( " %s: %s\n", Devel::MAT::Cmd->format_note( $name, 1 ), Devel::MAT::Cmd->format_sv_with_value( $sv ), ); } else { $doneargs++; Devel::MAT::Cmd->printf( " no %s\n", Devel::MAT::Cmd->format_note( $name, 1 ), ); } } } $doneargs or Devel::MAT::Cmd->printf( " %s\n", Devel::MAT::Cmd->format_note( "(no args)", 1 ), ); } } =head1 AUTHOR Paul Evans =cut 0x55AA; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Count.pm����������������������������������������������������������000444��001750��001750�� 13612�14550507443� 16617� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2018 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Count 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "count"; use constant CMD_DESC => "Count the various kinds of SV"; use List::Util qw( sum ); use List::UtilsBy qw( rev_nsort_by ); use Struct::Dumb; =head1 NAME C - count the various kinds of SV =head1 DESCRIPTION This C tool counts the different kinds of SV in the heap. =cut =head1 COMMANDS =head2 count pmat> count Kind Count (blessed) Bytes (blessed) ARRAY 170 0 15.1 KiB CODE 166 0 20.8 KiB Prints a summary of the count of each type of object. Takes the following named options: =over 4 =item --blessed, -b Additionally classify blessed references per package =item --scalars, -S Additionally classify SCALAR SVs according to which fields they have present =item --struct Use the structural size to sum byte counts =item --owned Use the owned size to sum byte counts =back =cut use constant CMD_OPTS => ( blessed => { help => "classify blessed references per package", alias => "b" }, scalars => { help => "classify SCALARs according to present fields", alias => "S" }, struct => { help => "sum SVs by structural size" }, owned => { help => "sum SVs by owned size" }, ); struct Counts => [qw( svs bytes blessed_svs blessed_bytes )]; sub run { my $self = shift; $self->count_svs( %{ +shift } ); } sub count_svs { my $self = shift; my %opts = @_; # TODO: consider options for # sorting # filtering my $size_meth = $opts{owned} ? "owned_size" : $opts{struct} ? "structure_size" : "size"; # Options for bin/pmat-counts my $emit_count = $opts{emit_count} // sub { ( !$_[1] || $_[2] ) ? $_[2] : "" }; my $emit_bytes = $opts{emit_bytes} // sub { ( !$_[1] || $_[2] ) ? Devel::MAT::Cmd->format_bytes( $_[2] ) : "" }; my %counts; my %counts_SCALAR; my %counts_per_package; foreach my $sv ( $self->df->heap ) { my $c = $counts{ref $sv} //= Counts( ( 0 ) x 4 ); my $bytes = $sv->$size_meth; $c->svs++; $c->bytes += $bytes; if( $sv->blessed ) { $c->blessed_svs++; $c->blessed_bytes += $bytes; } if( $opts{scalars} and $sv->isa( "Devel::MAT::SV::SCALAR" ) ) { my $desc = $sv->desc; $c = $counts_SCALAR{$desc} //= Counts( ( 0 ) x 4 ); $c->svs++; $c->bytes += $bytes; if( $sv->blessed ) { $c->blessed_svs++; $c->blessed_bytes += $bytes; } } $opts{blessed} or next; if( $sv->blessed ) { $c = $counts_per_package{ref $sv}{ $sv->blessed->stashname } //= Counts( ( 0 ) x 4 ); $c->blessed_svs++; $c->blessed_bytes += $bytes; } } my @table; foreach ( sort keys %counts ) { my $kind = $_ =~ s/^Devel::MAT::SV:://r; my $c = $counts{$_}; push @table, [ $kind, $emit_count->( $kind, 0, $c->svs ), $emit_count->( $kind, 1, $c->blessed_svs ), $emit_bytes->( $kind, 0, $c->bytes ), $emit_bytes->( $kind, 1, $c->blessed_bytes ) ]; push @table, _gen_package_breakdown( $counts_per_package{$_}, $emit_count, $emit_bytes ) if $opts{blessed}; if( $kind eq "SCALAR" and $opts{scalars} ) { foreach ( sort keys %counts_SCALAR ) { my $c = $counts_SCALAR{$_}; push @table, [ " $_", $emit_count->( $_, 0, $c->svs ), $emit_count->( $_, 1, $c->blessed_svs ), $emit_bytes->( $_, 0, $c->bytes ), $emit_bytes->( $_, 1, $c->blessed_bytes ) ]; } } } push @table, []; # HR my $total = Counts( ( 0 ) x 4 ); foreach my $method (qw( svs bytes blessed_svs blessed_bytes )) { $total->$method = sum map { $_->$method } values %counts; } push @table, [ "(total)", $emit_count->( "(total)", 0, $total->svs ), $emit_count->( "(total)", 1, $total->blessed_svs ), $emit_bytes->( "(total)", 0, $total->bytes ), $emit_bytes->( "(total)", 1, $total->blessed_bytes ) ]; Devel::MAT::Cmd->print_table( \@table, indent => 2, headings => [ "Kind", "Count", "(blessed)", "Bytes", "(blessed)" ], sep => [ " ", " ", " ", " " ], align => [ undef, "right", "right", "right", "right" ], %{ $opts{table_args} || {} }, ); } sub _gen_package_breakdown { my ( $counts, $emit_count, $emit_bytes ) = @_; my @packages = rev_nsort_by { $counts->{$_}->blessed_svs } sort keys %$counts; my @ret; my $count; while( @packages ) { my $package = shift @packages; push @ret, [ " " . Devel::MAT::Cmd->format_symbol( $package ), $emit_count->( $package, 0, 0 ), $emit_count->( $package, 1, $counts->{$package}->blessed_svs ), $emit_bytes->( $package, 0, 0 ), $emit_bytes->( $package, 1, $counts->{$package}->blessed_bytes ), ]; $count++; last if $count >= 10; } my $remaining = Counts( ( 0 ) x 4 ); foreach my $method (qw( blessed_svs blessed_bytes )) { $remaining->$method = sum map { $counts->{$_}->$method } @packages; } push @ret, [ " " . Devel::MAT::Cmd->format_note( "(others)" ), $emit_count->( "(others)", 0, 0 ), $emit_count->( "(others)", 1, $remaining->blessed_svs ), $emit_bytes->( "(others)", 0, 0 ), $emit_bytes->( "(others)", 1, $remaining->blessed_bytes ), ] if @packages; return @ret; } =head1 AUTHOR Paul Evans =cut 0x55AA; ����������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Find.pm�����������������������������������������������������������000444��001750��001750�� 34711�14550507443� 16412� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2017-2020 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Find 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use Scalar::Util qw( blessed ); use constant CMD => "find"; use constant CMD_DESC => "List SVs matching given criteria"; use constant CMD_OPTS => ( count => { help => "Just print a count of the matching SVs", alias => "C" }, ); use Module::Pluggable sub_name => "FILTERS", search_path => [ "Devel::MAT::Tool::Find::filter" ], require => 1; =head1 NAME C - list SVs matching given criteria =head1 DESCRIPTION This C tool provides a command to search for SVs matching given criteria. =cut =head1 COMMANDS =cut =head2 find pmat> find io IO()=IO::File at 0x55a7e4d88760: ifileno=1 ofileno=1 ... Prints a list of all the SVs that match the given filter criteria. Takes the following named options: =over 4 =item --count, -C Just count the matching SVs and print the total =back =cut # TODO(leonerd): This is ugly; taking over ->run_cmd directly. See if we can # integrate it better sub run_cmd { my $self = shift; my ( $inv ) = @_; my %opts = %{ $self->get_opts_from_inv( $inv, { $self->CMD_OPTS }, permute => 0, ) }; my @filters; while( length $inv->peek_remaining ) { push @filters, $self->build_filter( $inv ); } if( $opts{count} ) { my $count = 0; SV: foreach my $sv ( $self->df->heap ) { foreach my $filter ( @filters ) { my $ret = $filter->( $sv ) or next SV; if( !blessed $ret and ref $ret eq "HASH" ) { $sv = $ret->{sv} if $ret->{sv}; } } $count++; } Devel::MAT::Cmd->printf( "Total: %s SVs\n", $count ) if $opts{count}; return; } my @svs = $self->df->heap; my ( $sv, @output ); Devel::MAT::Tool::more->paginate( sub { my ( $count ) = @_; SV: while( $sv = shift @svs ) { @output = (); foreach my $filter ( @filters ) { my $ret = $filter->( $sv ) or next SV; # Allow filters to alter the search as we go if( !blessed $ret and ref $ret eq "HASH" ) { $sv = $ret->{sv} if $ret->{sv}; push @output, $ret->{output} if $ret->{output}; } else { push @output, $ret; } } my $fmt = "%s"; $fmt .= ": " . join( " ", ( "%s" ) x @output ) if @output; Devel::MAT::Cmd->printf( "$fmt\n", Devel::MAT::Cmd->format_sv( $sv ), @output ); last SV unless $count--; } return !!@svs; } ); } sub help_cmd { Devel::MAT::Cmd->printf( "\nSYNOPSIS:\n" ); Devel::MAT::Cmd->printf( " find [FILTER...]\n" ); Devel::MAT::Cmd->printf( "\nFILTERS:\n" ); foreach my $pkg ( FILTERS ) { my $name = $pkg =~ s/^Devel::MAT::Tool::Find::filter:://r; Devel::MAT::Cmd->printf( " %s %s - %s\n", Devel::MAT::Cmd->format_note( "find" ), Devel::MAT::Cmd->format_note( $name ), $pkg->FILTER_DESC, ); } } # to make help work sub find_subcommand { return "Devel::MAT::Tool::Find::filter::$_[1]" } sub build_filter { my $self = shift; my ( $inv ) = @_; my $name = $inv->pull_token; my $filterpkg = "Devel::MAT::Tool::Find::filter::$name"; $filterpkg->can( "build" ) or die "Unknown filter type '$name'"; my @args; if( my %optspec = $filterpkg->FILTER_OPTS ) { push @args, $self->get_opts_from_inv( $inv, \%optspec ); } if( my @argspec = $filterpkg->FILTER_ARGS ) { push @args, $self->get_args_from_inv( $inv, @argspec ); } return $filterpkg->build( $inv, @args ); } =head1 FILTERS =cut package # hide Devel::MAT::Tool::Find::filter; sub CMD_DESC { return "find " . shift->FILTER_DESC } use constant FILTER_OPTS => (); sub CMD_OPTS { shift->FILTER_OPTS } use constant CMD_ARGS_SV => 0; use constant FILTER_ARGS => (); sub CMD_ARGS { shift->FILTER_ARGS } package # hide Devel::MAT::Tool::Find::filter::num; use base qw( Devel::MAT::Tool::Find::filter ); use constant FILTER_DESC => "Numerical (IV, UV or NV) SVs"; use constant FILTER_OPTS => ( iv => { help => "Include IVs" }, uv => { help => "Include UVs" }, nv => { help => "Include NVs" }, ); use constant FILTER_ARGS => ( { name => "value", help => "match value" }, ); =head2 num pmat> find num SCALAR(UV) at 0x555555a1e9c0: 5 SCALAR(UV) at 0x555555c4f1b0: 2 SCALAR(UV) at 0x555555aa0dc0: 18446744073709551615 Prints a list of all the scalar SVs that have a numerical value, optionally filtering for only an exact value. Takes the following named options: =over 4 =item --nv, --iv, --uv Find only numerical SVs of the given types. If no options present, any numerical SV will be found. =back =cut sub build { my $self = shift; shift; # inv my %opts = %{ +shift }; my ( $value ) = @_; $opts{iv} or $opts{uv} or $opts{nv} or $opts{iv} = $opts{uv} = $opts{nv} = 1; return sub { my ( $sv ) = @_; return unless $sv->type eq "SCALAR"; if( $opts{nv} and defined( my $nv = $sv->nv ) ) { defined $value and $nv != $value and return; return Devel::MAT::Cmd->format_value( $nv, nv => 1 ); } if( $opts{iv} and defined( my $iv = $sv->iv ) ) { defined $value and $iv != $value and return; return Devel::MAT::Cmd->format_value( $iv, iv => 1 ); } if( $opts{uv} and defined( my $uv = $sv->uv ) ) { defined $value and $uv != $value and return; return Devel::MAT::Cmd->format_value( $uv, uv => 1 ); } }; } package # hide Devel::MAT::Tool::Find::filter::pv; use base qw( Devel::MAT::Tool::Find::filter ); use constant FILTER_DESC => "PV (string) SVs"; use constant FILTER_OPTS => ( eq => { help => "Pattern is an exact equality match" }, regexp => { help => "Pattern is a regular expression", alias => "r" }, ignorecase => { help => "Match case-insensitively", alias => "i" }, ); use constant FILTER_ARGS => ( { name => "pattern", help => "string pattern", required => 1 }, ); =head2 pv pmat> find pv "boot" SCALAR(PV) at 0x556e4737d968: "boot_Devel::MAT::Dumper" SCALAR(PV) at 0x556e4733a160: "boot_Cwd" ... Prints a list of all the scalar SVs that have a PV (string value) matching the supplied pattern. Normally, the pattern is interpreted as a substring match, but the C<--eq> and C<--regexp> options can alter this. Takes the following named options: =over 4 =item --eq Interpret the pattern as a full string equality match, instead of substring. =item --regexp, -r Interpret the pattern as a regular expression, instead of a literal substring. =item --ignorecase, -i Match case-insensitively, for any of substring, equality or regexp match. =back =cut sub build { my $self = shift; shift; # inv my %opts = %{ +shift }; my ( $pattern ) = @_; my $flags = $opts{ignorecase} ? "i" : ""; if( $opts{eq} ) { $pattern = qr/(?$flags)^\Q$pattern\E$/; } elsif( $opts{regexp} ) { $pattern = qr/(?$flags)$pattern/; } else { # substring $pattern = qr/(?$flags)\Q$pattern\E/; } return sub { my ( $sv ) = @_; return unless $sv->type eq "SCALAR"; return unless defined( my $pv = $sv->pv ); return unless $pv =~ $pattern; return Devel::MAT::Cmd->format_value( $pv, pv => 1 ); }; } package # hide Devel::MAT::Tool::Find::filter::cv; use base qw( Devel::MAT::Tool::Find::filter ); use constant FILTER_DESC => "Code CVs"; use constant FILTER_OPTS => ( xsub => { help => "Is an XSUB" }, package => { help => "In the given package", type => "s", alias => "p" }, file => { help => "Location is the given file", type => "s", alias => "f" }, ); sub build { my $self = shift; my $inv = shift; my %opts = %{ +shift }; return sub { my ( $sv ) = @_; return unless $sv->type eq "CODE"; if( $opts{xsub} ) { return if !$sv->is_xsub; } if( $opts{package} ) { my $stash = $sv->glob ? $sv->glob->stash : return; return if $stash->stashname ne $opts{package}; } if( $opts{file} ) { return if $sv->file ne $opts{file}; } # Selected if( my $symname = $sv->symname ) { return Devel::MAT::Cmd->format_symbol( $symname ); } else { return "__ANON__"; } }; } package # hide Devel::MAT::Tool::Find::filter::io; use base qw( Devel::MAT::Tool::Find::filter ); use constant FILTER_DESC => "IO SVs"; use constant FILTER_OPTS => ( fileno => { help => "Match only this filenumber", type => "i", alias => "f" }, ); =head2 io pmat> find io IO()=IO::File at 0x55a7e4d88760: ifileno=1 ofileno=1 ... pmat> find io -f 2 IO()=IO::File at 0x55582b87f430: ifileno=2 ofileno=2 Searches for IO handles Takes the following named options: =over 4 =item --fileno, -f INT Match only IO handles associated with the given filenumber. =back =cut sub build { my $self = shift; my $inv = shift; my %opts = %{ +shift }; # Back-compat if( !defined $opts{fileno} and ( $inv->peek_token // "" ) =~ m/^\d+$/ ) { $opts{fileno} = $inv->pull_token; } if( defined( my $fileno = $opts{fileno} ) ) { return sub { my ( $sv ) = @_; return unless $sv->type eq "IO"; my $imatch = $sv->ifileno == $fileno; my $omatch = $sv->ofileno == $fileno; return unless $imatch or $omatch; return String::Tagged->from_sprintf( "ifileno=%s ofileno=%s", $imatch ? Devel::MAT::Cmd->format_note( $sv->ifileno ) : $sv->ifileno, $omatch ? Devel::MAT::Cmd->format_note( $sv->ofileno ) : $sv->ofileno, ); } } else { return sub { my ( $sv ) = @_; return unless $sv->type eq "IO"; return String::Tagged->from_sprintf( "ifileno=%s ofileno=%s", $sv->ifileno, $sv->ofileno, ); } } } package # hide Devel::MAT::Tool::Find::filter::blessed; use base qw( Devel::MAT::Tool::Find::filter ); =head2 blessed pmat> find blessed Config HASH(26)=Config at 0x55bd56c28930 Searches for SVs blessed into the given package name. =cut use constant FILTER_DESC => "blessed SVs"; use constant FILTER_ARGS => ( { name => "package", help => "the blessed package", required => 1 }, ); sub build { my $self = shift; my ( $inv, $package ) = @_; defined $package or die "Expected package name for 'blessed' filter"; return sub { my ( $sv ) = @_; return unless my $stash = $sv->blessed; return unless $stash->stashname eq $package; return Devel::MAT::Cmd->format_value( $stash->stashname ); }; } package # hide Devel::MAT::Tool::Find::filter::lexical; use base qw( Devel::MAT::Tool::Find::filter ); =head2 lexical pmat> find lexical $x UNDEF() at 0x56426e97c8b0: $x at depth 1 of CODE(PP) at 0x56426e97c5e0 ... Searches for SVs that are lexical variables of the given name. =cut use constant FILTER_DESC => "lexical variables"; use constant FILTER_ARGS => ( { name => "name", help => "the variable name", required => 1 }, ); use constant FILTER_OPTS => ( inactive => { help => "Include variables in non-live pads", alias => "I" }, ); sub build { my $self = shift; my $inv = shift; my %opts = %{ +shift }; my ( $name ) = @_; defined $name or die "Expected variable name for 'lexical' filter"; # We'll actually match pad which contains such a lexical. then redirect the # search onto the SV itself return sub { my ( $pad ) = @_; return unless $pad->type eq "PAD"; return unless my $sv = $pad->maybe_lexvar( $name ); my $cv = $pad->padcv; my $depth; my @pads = $cv->pads; $pad == $pads[$_] and $depth = $_+1 and last for 0 .. $#pads; # This isn't a real hit unless the pad is live my $is_live = $depth <= $cv->depth; return unless $is_live || $opts{inactive}; return { sv => $sv, output => String::Tagged->from_sprintf( "%s at depth %d%s of %s", Devel::MAT::Cmd->format_note( $name, 1 ), $depth, $is_live ? "" : Devel::MAT::Cmd->format_note( " [inactive]", 2 ), Devel::MAT::Cmd->format_sv( $cv ) ), }; }; } package # hide Devel::MAT::Tool::Find::filter::struct; use base qw( Devel::MAT::Tool::Find::filter ); =head2 struct pmat> find struct Module::Name/Type C_STRUCT(Module::Name/Type) at 0x55e0c3017bf0: Module::Name/Type ... Searches for SVs that are C structures of the given type name. =cut use constant FILTER_DESC => "structs"; use constant FILTER_ARGS => ( { name => "name", help => "the structure type name", required => 1 }, ); sub build { my $self = shift; my $inv = shift; my ( $name ) = @_; defined $name or die "Expected structure type name for 'struct' filter"; return sub { my ( $struct ) = @_; return unless $struct->type eq "C_STRUCT"; my $type = $struct->structtype; return unless $type->name eq $name; return Devel::MAT::Cmd->format_value( $type->name ); }; } package # hide Devel::MAT::Tool::Find::filter::magic;; use base qw( Devel::MAT::Tool::Find::filter ); =head2 magic =cut use constant FILTER_DESC => "SVs with magic"; use constant FILTER_OPTS => ( vtbl => { help => "the VTBL pointer", type => "x", alias => "v" }, ); sub build { my $self = shift; my $inv = shift; my %opts = %{ +shift }; if( my $vtbl = $opts{vtbl} ) { return sub { my ( $sv ) = @_; my @magics = $sv->magic or return; foreach my $magic ( @magics ) { next unless defined $magic->vtbl and $magic->vtbl == $vtbl; my $ret = String::Tagged->from_sprintf( "magic type '%s'", $magic->type, ); $ret .= ", with object " . Devel::MAT::Cmd->format_sv( $magic->obj ) if $magic->obj; $ret .= ", with pointer " . Devel::MAT::Cmd->format_sv( $magic->ptr ) if $magic->ptr; return $ret; } }; } die "Expected --vtbl\n"; } =head1 AUTHOR Paul Evans =cut 0x55AA; �������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Identify.pm�������������������������������������������������������000444��001750��001750�� 11474�14550507443� 17306� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2017 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Identify 0.52; use v5.14; use warnings; use base qw( Devel::MAT::ToolBase::GraphWalker ); use utf8; use constant CMD => "identify"; use constant CMD_DESC => "Identify an SV by its referrers"; =encoding UTF-8 =head1 NAME C - identify an SV by its referrers =head1 DESCRIPTION This C tool provides a command to identify an SV by walking up its tree of inrefs, printing useful information that helps to identify what it is by how it can be reached from well-known program roots. =cut =head1 COMMANDS =cut =head2 identify pmat> identify 0x1bbf640 IO() at 0x1bbf640 is: └─the io of GLOB(@*I) at 0x1bbf628, which is: └─the ARGV GV Prints a tree of the identification of the SV at the given address. Takes the following named options: =over 4 =item --depth D, -d D Limits the output to the given number of steps away from the given initial SV. =item --weak Include weak direct references in the output (by default only strong direct ones will be included). =item --all Include both weak and indirect references in the output. =item --no-elide, -n Don't elide structure in the output. By default, C-type SVs will be skipped over, leading to a shorter neater output by removing this usually-unnecessary noise. If this option is not given, elided reference SVs will be notated by adding C<(via RV)> to the reference description. Additionally, members of the symbol table will be printed as being root SVs, noting their symbol table name. This avoids additional nesting due to the stashes and globs that make up the symbol table. This can also cause SVs to be recognised as symbol table entries, when without it they might be cut off due to the depth limit. =back =cut use constant CMD_OPTS => ( depth => { help => "maximum depth to recurse", type => "i", alias => "d", default => 10 }, weak => { help => "include weak references" }, all => { help => "include weak and indirect references", alias => "a" }, no_elide => { help => "don't elide REF, PAD and symbol structures", alias => "n" }, ); use constant CMD_ARGS_SV => 1; sub run { my $self = shift; my %opts = %{ +shift }; my ( $sv ) = @_; $self->reset; my $STRONG = 1; my $DIRECT = 1; my $ELIDE = !$opts{no_elide}; $STRONG = 0 if $opts{weak}; $STRONG = 0, $DIRECT = 0 if $opts{all}; $self->pmat->load_tool( "Inrefs", progress => $self->{progress} ); Devel::MAT::Cmd->printf( "%s is:\n", Devel::MAT::Cmd->format_sv( $sv ), ); $self->walk_graph( $self->pmat->inref_graph( $sv, depth => $opts{depth}, strong => $STRONG, direct => $DIRECT, elide => $ELIDE, ), "" ); } sub _strength_label { my ( $strength ) = @_; $strength eq "strong" ? "" : Devel::MAT::Cmd->format_note( "[$strength]", 1 ) . " ", } sub on_walk_nothing { shift; my ( $node, $indent ) = @_; Devel::MAT::Cmd->printf( "$indent└─not found\n" ); } sub on_walk_EDEPTH { shift; my ( $node, $indent ) = @_; Devel::MAT::Cmd->printf( "$indent└─not found at this depth\n" ); } sub on_walk_again { shift; my ( $node, $cyclic, $id, $indent ) = @_; Devel::MAT::Cmd->printf( "$indent└─already found " ); Devel::MAT::Cmd->printf( "%s ", Devel::MAT::Cmd->format_note( "circularly" ) ) if $cyclic; if( defined $id ) { Devel::MAT::Cmd->printf( "as %s\n", Devel::MAT::Cmd->format_note( "*$id" ), ); } else { Devel::MAT::Cmd->printf( "%s\n", Devel::MAT::Cmd->format_note( "circularly" ), ); } } sub on_walk_root { shift; my ( $node, $root, $isfinal, $indent ) = @_; Devel::MAT::Cmd->printf( $indent . ( $isfinal ? "└─%s%s\n" : "├─%s%s\n" ), _strength_label( $root->strength ), $root->name, ); } sub on_walk_ref { shift; my ( $node, $ref, $sv, $ref_id, $is_final, $indent ) = @_; Devel::MAT::Cmd->printf( $indent . ( $is_final ? "└─" : "├─" ) ); Devel::MAT::Cmd->printf( "%s%s of %s, which is", _strength_label( $ref->strength ), $ref->name, Devel::MAT::Cmd->format_sv( $sv ), ); if( $ref_id ) { Devel::MAT::Cmd->printf( " %s", Devel::MAT::Cmd->format_note( "(*$ref_id)" ), ); } Devel::MAT::Cmd->printf( ":\n" ); # return recursion args: return ( $indent . ( $is_final ? " " : "│ " ) ); } sub on_walk_itself { shift; my ( $node, $indent ) = @_; Devel::MAT::Cmd->printf( "${indent}itself\n" ); } =head1 AUTHOR Paul Evans =cut 0x55AA; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Inrefs.pm���������������������������������������������������������000444��001750��001750�� 14310�14550507443� 16751� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2017 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Inrefs 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use List::Util qw( any pairs ); my %STRENGTH_TO_IDX = ( strong => 0, weak => 1, indirect => 2, inferred => 3, ); use constant { IDX_ROOTS_STRONG => 4, IDX_ROOTS_WEAK => 5, IDX_STACK => 6, }; =head1 NAME C - annotate which SVs are referred to by others =head1 DESCRIPTION This C tool annotates each SV with back-references from other SVs that refer to it. It follows the C method of every heap SV and annotates the referred SVs with back-references pointing back to the SVs that refer to them. =cut sub init_tool { my $self = shift; my $df = $self->df; my $heap_total = scalar $df->heap; my $count = 0; foreach my $sv ( $df->heap ) { foreach ( pairs $sv->outrefs( "NO_DESC" ) ) { my ( $strength, $refsv ) = @$_; push @{ $refsv->{tool_inrefs}[ $STRENGTH_TO_IDX{ $strength } ] }, $sv->addr if !$refsv->immortal; } $count++; $self->report_progress( sprintf "Patching refs in %d of %d (%.2f%%)", $count, $heap_total, 100*$count / $heap_total ) if ($count % 10000) == 0 } # Most SVs are not roots or on the stack. To save time later on we'll make # a note of those rare ones that are foreach ( pairs $df->roots_strong ) { my ( undef, $sv ) = @$_; next unless $sv; $sv->{tool_inrefs}[IDX_ROOTS_STRONG]++; } foreach ( pairs $df->roots_weak ) { my ( undef, $sv ) = @$_; next unless $sv; $sv->{tool_inrefs}[IDX_ROOTS_WEAK]++; } foreach my $sv ( $df->stack ) { $sv->{tool_inrefs}[IDX_STACK]++; } $self->report_progress(); } =head1 SV METHODS This tool adds the following SV methods. =head2 inrefs @refs = $sv->inrefs Returns a list of Reference objects for each of the SVs that refer to this one. This is formed by the inverse mapping along the SV graph from C. =head2 inrefs_strong =head2 inrefs_weak =head2 inrefs_direct =head2 inrefs_indirect =head2 inrefs_inferred @refs = $sv->inrefs_strong @refs = $sv->inrefs_weak @refs = $sv->inrefs_direct @refs = $sv->inrefs_indirect @refs = $sv->inrefs_inferred Returns lists of Reference objects filtered by type, analogous to the various C methods. =cut sub Devel::MAT::SV::_inrefs { my $self = shift; my ( @strengths ) = @_; # In scalar context we don't need to return SVs or Reference instances, # just count them. This allows a lot of optimisations. my $just_count = !wantarray; $self->{tool_inrefs} ||= []; my $df = $self->df; my @inrefs; foreach my $strength ( @strengths ) { my %seen; foreach my $addr ( @{ $self->{tool_inrefs}[ $STRENGTH_TO_IDX{$strength} ] // [] } ) { if( $just_count ) { push @inrefs, 1; } else { $seen{$addr}++ and next; my $sv = $df->sv_at( $addr ); push @inrefs, Devel::MAT::SV::Reference( $_->name, $_->strength, $sv ) for grep { $_->strength eq $strength and $_->sv == $self } $sv->outrefs; } } } if( $self->{tool_inrefs}[IDX_ROOTS_STRONG] and $strengths[0] eq "strong" ) { if( $just_count ) { push @inrefs, ( 1 ) x $self->{tool_inrefs}[IDX_ROOTS_STRONG]; } else { foreach ( pairs $df->roots_strong ) { my ( $name, $sv ) = @$_; push @inrefs, Devel::MAT::SV::Reference( $name, strong => undef ) if defined $sv and $sv == $self; } } } if( $self->{tool_inrefs}[IDX_ROOTS_WEAK] and any { $_ eq "weak" } @strengths ) { if( $just_count ) { push @inrefs, ( 1 ) x $self->{tool_inrefs}[IDX_ROOTS_WEAK]; } else { foreach ( pairs $df->roots_weak ) { my ( $name, $sv ) = @$_; push @inrefs, Devel::MAT::SV::Reference( $name, weak => undef ) if defined $sv and $sv == $self; } } } if( $self->{tool_inrefs}[IDX_STACK] and any { $_ eq "weak" } @strengths ) { if( $just_count ) { push @inrefs, ( 1 ) x $self->{tool_inrefs}[IDX_STACK]; } else { foreach my $stacksv ( $df->stack ) { next unless $stacksv->addr == $self->addr; push @inrefs, Devel::MAT::SV::Reference( "a value on the stack", strong => undef ); } } } return @inrefs; } # If 'strong' is included in these lists it must be first sub Devel::MAT::SV::inrefs { shift->_inrefs( qw( strong weak indirect inferred )) } sub Devel::MAT::SV::inrefs_strong { shift->_inrefs( qw( strong )) } sub Devel::MAT::SV::inrefs_weak { shift->_inrefs( qw( weak )) } sub Devel::MAT::SV::inrefs_direct { shift->_inrefs( qw( strong weak )) } sub Devel::MAT::SV::inrefs_indirect { shift->_inrefs( qw( indirect )) } sub Devel::MAT::SV::inrefs_inferred { shift->_inrefs( qw( inferred )) } =head1 COMANDS =cut =head2 inrefs pmat> inrefs defstash s the hash GLOB(%*) at 0x556e47243e40 Shows the incoming references that refer to a given SV. Takes the following named options: =over 4 =item --weak Include weak direct references in the output (by default only strong direct ones will be included). =item --all Include both weak and indirect references in the output. =back =cut use constant CMD => "inrefs"; use constant CMD_DESC => "Show incoming references to a given SV"; use constant CMD_OPTS => ( weak => { help => "include weak references" }, all => { help => "include weak and indirect references", alias => "a" }, ); use constant CMD_ARGS_SV => 1; sub run { my $self = shift; my %opts = %{ +shift }; my ( $sv ) = @_; my $method = $opts{all} ? "inrefs" : $opts{weak} ? "inrefs_direct" : "inrefs_strong"; require Devel::MAT::Tool::Outrefs; Devel::MAT::Tool::Outrefs->show_refs_by_method( $method, $sv ); } =head1 AUTHOR Paul Evans =cut 0x55AA; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/ListDanglingPtrs.pm�����������������������������������������������000444��001750��001750�� 5725�14550507443� 20745� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::ListDanglingPtrs 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use List::Util qw( pairs ); use constant CMD => "list-dangling-ptrs"; use constant CMD_DESC => "Show pointers in SVs that don't lead anywhere"; =head1 NAME C - display a list of SV pointer fields that do not point at known SVs =head1 DESCRIPTION This C tool displays a list of fields from known SVs containing non-NULL addresses, but which do not point to other known SVs. These are so-called "dangling pointers". =cut =head1 COMMANDS =head2 list-dangling-ptrs pmat> list-dangling-ptrs CODE(proto) at 0x55b9d83ae3d8 has no constval SV at addr 0x55b9d83963f0 ... Prints a list of fields in SVs which do not point at other valid SVs. =cut my %methodcache; sub methods_of { my ( $pkg ) = @_; my $methods = $methodcache{$pkg} //= do { no strict 'refs'; my @syms = keys %{"${pkg}::"}; [ ( grep { *{"${pkg}::$_"}{CODE} } @syms ), map { methods_of( $_ ) } @{"${pkg}::ISA"} ] }; return @$methods; } sub run { my $self = shift; my $df = $self->df; my %roots_at; foreach ( pairs $df->roots ) { my ( $name, $sv ) = @$_; $sv and $roots_at{ $sv->addr } = $name; } my $test_ptr = sub { my $self = shift; my ( $sv, $name, $addr ) = @_; $addr or return; $roots_at{$addr} and return; $df->{heap}{$addr} and return; Devel::MAT::Cmd->printf( "%s has no %s SV at addr 0x%x\n", Devel::MAT::Cmd->format_sv( $sv ), $name, $addr, ); }; foreach my $sv ( $self->df->heap ) { # Quite a bit of cheating here. We'll presume that any _at method gives # a number that should be a raw SV pointer address foreach my $meth ( methods_of ref $sv ) { if( $meth eq "field" ) { # Struct fields might or mightnot be SV pointers. We'll have to ask them my $fields = $sv->structtype->fields; foreach my $idx ( 0 .. $#$fields ) { my $field = $fields->[$idx]; if( $field->type == 0 ) { $self->$test_ptr( $sv, "field <${\$field->name}>", $sv->$meth( $idx ) ); } } } next unless $meth =~ m/^([^_].*)_at$/; my $outref = $1; if( $outref eq "elem" ) { $self->$test_ptr( $sv, "$outref [$_]", $sv->$meth( $_ ) ) for 0 .. $sv->elems-1; } elsif( $outref eq "value" ) { $self->$test_ptr( $sv, "$outref {$_}", $sv->$meth( $_ ) ) for $sv->keys; } else { $self->$test_ptr( $sv, $outref, $sv->$meth ); } } } } =head1 AUTHOR Paul Evans =cut 0x55AA; �������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Outrefs.pm��������������������������������������������������������000444��001750��001750�� 4263�14550507443� 17140� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Outrefs 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use List::UtilsBy qw( sort_by ); =head1 NAME C - show SVs referred to by a given SV =head1 COMANDS =cut =head2 outrefs pmat> outrefs defstash ... Shows the outgoing references that refer to other SVs. Takes the following named options: =over 4 =item --weak Include weak direct references in the output (by default only strong direct ones will be included). =item --all Include both weak and indirect references in the output. =back =cut use constant CMD => "outrefs"; use constant CMD_DESC => "Show outgoing references from a given SV"; use constant CMD_OPTS => ( weak => { help => "include weak references" }, all => { help => "include weak and indirect references", alias => "a" }, ); use constant CMD_ARGS_SV => 1; my %NOTES_BY_STRENGTH = ( strong => Devel::MAT::Cmd->format_note( "s" ), weak => Devel::MAT::Cmd->format_note( "w", 1 ), indirect => Devel::MAT::Cmd->format_note( "i", 2 ), inferred => Devel::MAT::Cmd->format_note( "~", 2 ), ); sub run { my $self = shift; my %opts = %{ +shift }; my ( $sv ) = @_; my $method = $opts{all} ? "outrefs" : $opts{weak} ? "outrefs_direct" : "outrefs_strong"; $self->show_refs_by_method( $method, $sv ); } sub show_refs_by_method { my $self = shift; my ( $method, $sv ) = @_; my @refs = grep { $_->sv } sort_by { $_->name } $sv->$method; Devel::MAT::Tool::more->paginate( sub { my ( $count ) = @_; my @table; my $ref; $ref = shift @refs and push @table, [ $NOTES_BY_STRENGTH{ $ref->strength }, $ref->name, Devel::MAT::Cmd->format_sv( $ref->sv ), ] while $count--; Devel::MAT::Cmd->print_table( \@table, sep => " " ); return scalar @refs; } ); } =head1 AUTHOR Paul Evans =cut 0x55AA; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Reachability.pm���������������������������������������������������000444��001750��001750�� 21105�14550507443� 20123� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2018 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Reachability 0.52; use v5.14; use warnings; use constant FOR_UI => 1; use List::Util qw( pairvalues ); =head1 NAME C - analyse how SVs are reachable =head1 DESCRIPTION This C tool determines which SVs are reachable via any known roots and which are not. For reachable SVs, they are classified into several broad categories: =over 2 =item * SVs that directly make up the symbol table. =item * SVs that form the padlist of functions or store the names of lexical variables. =item * SVs that hold the value of lexical variables. =item * User data stored in package globals, lexical variables, or referenced recursively via structures stored in them. =item * Miscellaneous other SVs that are used to implement the internals of the interpreter. =back =cut use constant { REACH_SYMTAB => 1, REACH_USER => 2, REACH_PADLIST => 3, REACH_LEXICAL => 4, REACH_INTERNAL => 5, }; sub new { my $class = shift; my ( $pmat, %args ) = @_; *Devel::MAT::SV::reachable = sub { my $sv = shift; return $sv->{tool_reachable}; }; $class->mark_reachable( $pmat->dumpfile, progress => $args{progress} ); return $class; } my @ICONS = ( "none", "symtab", "user", "padlist", "lexical", "internal" ); sub _reach2icon { my ( $sv ) = @_; my $reach = $sv->{tool_reachable} // 0; my $icon = $ICONS[$reach] // die "Unknown reachability value $reach"; return "reachable-$icon"; } sub init_ui { my $self = shift; my ( $ui ) = @_; foreach ( @ICONS ) { $ui->register_icon( name => "reachable-$_", svg => "icons/reachable-$_.svg" ); } my $column = $ui->provides_svlist_column( title => "R", type => "icon", ); $ui->provides_sv_detail( title => "Reachable", type => "icon", render => \&_reach2icon, ); $ui->set_svlist_column_values( column => $column, from => \&_reach2icon, ); } sub mark_reachable { my $self = shift; my ( $df, %args ) = @_; my $progress = $args{progress}; my @user; my @internal; # First, walk the symbol table { my @symtab = ( $df->defstash ); $symtab[0]->{tool_reachable} = REACH_SYMTAB; my $count = 0; while( @symtab ) { my $stash = shift @symtab; $stash->type =~ m/^(?:STASH|CLASS)$/ or die "ARGH! Encountered non-stash ".$stash->desc_addr; my @more_symtab; my @more_user; foreach my $key ( $stash->keys ) { my $value = $stash->value( $key ); # Keys ending :: signify sub-stashes if( $key =~ m/::$/ ) { push @more_symtab, $value->hash; } # Otherwise it might be a glob elsif( $value->type eq "GLOB" ) { my $gv = $value; $gv->{tool_reachable} = REACH_SYMTAB; defined $_ and push @more_user, $_ for $gv->scalar, $gv->array, $gv->hash, $gv->code, $gv->io, $gv->form; } # Otherwise it might be a SCALAR/ARRAY/HASH directly in the STASH else { push @more_user, $value; } $count++; $progress->( sprintf "Walking symbol table %d...", $count ) if $progress and $count % 1000 == 0; } !$_->{tool_reachable} and $_->{tool_reachable} = REACH_SYMTAB, push @symtab, $_ for @more_symtab; !$_->{tool_reachable} and $_->{tool_reachable} = REACH_USER, push @user, $_ for @more_user; !$_->{tool_reachable} and $_->{tool_reachable} = REACH_INTERNAL, push @internal, $_ for grep { defined } $stash->backrefs, $stash->mro_linearall, $stash->mro_linearcurrent, $stash->mro_nextmethod, $stash->mro_isa, $stash->magic_svs; $count++; $progress->( sprintf "Walking symbol table %d...", $count ) if $progress and $count % 1000 == 0; } } # Next the reachable user data, recursively { push @user, $df->main_cv; my $count = 0; while( @user ) { my $sv = shift @user or next; my @more_user; my @more_internal; for( $sv->type ) { if ( $_ eq "REF" ) { push @more_user, $sv->rv if $sv->rv } elsif( $_ eq "ARRAY" ) { push @more_user, $sv->elems; } elsif( $_ eq "HASH" ) { push @more_user, $sv->values; } elsif( $_ eq "GLOB" ) { my $gv = $sv; next if $gv->{tool_reachable}; # already on symbol table warn "Found non-SYMTAB GLOB " . $gv->desc_addr . " user reachable\n"; # Hard to know if the GV is being used for GVSV, GVAV, GVHV or GVCV push @more_user, $gv->scalar, $gv->array, $gv->hash, $gv->code, $gv->egv, $gv->io, $gv->form; } elsif( $_ eq "CODE" ) { my $cv = $sv; my @more_padlist; my @more_lexical; push @more_padlist, $cv->padlist; my $padnames_av = $cv->padnames_av; if( $padnames_av ) { push @more_padlist, $padnames_av, $padnames_av->elems; } foreach my $pad ( $cv->pads ) { $pad or next; push @more_padlist, $pad; # PAD slot 0 is always @_ if( my $argsav = $pad->elem( 0 ) ) { push @more_internal, $argsav; } foreach my $padix ( 1 .. $pad->elems-1 ) { my $padname_sv = $padnames_av ? $padnames_av->elem( $padix ) : undef; my $padname = $padname_sv && $padname_sv->type eq "SCALAR" ? $padname_sv->pv : undef; my $padsv = $pad->elem( $padix ) or next; $padsv->immortal and next; if( $padname and $padname eq "&" ) { # Slots named "&" are closure prototype subs push @more_user, $padsv; } elsif( $padname ) { # Other named slots are lexical vars push @more_lexical, $padsv; } else { # Unnamed slots are just part of the padlist push @more_internal, $padsv; } } } $_ and push @more_user, $_ for $cv->scope, $cv->constval, $cv->constants, $cv->globrefs; $_ and !$_->{tool_reachable} and $_->{tool_reachable} = REACH_PADLIST for @more_padlist; $_ and !$_->{tool_reachable} and $_->{tool_reachable} = REACH_LEXICAL, push @user, $_ for @more_lexical; } elsif( $_ eq "LVALUE" ) { my $lv = $sv; push @more_internal, $lv->target if $lv->target; } elsif( $_ =~ m/^(?:UNDEF|BOOL|SCALAR|IO|REGEXP|FORMAT)$/ ) { } # ignore else { warn "Not sure what to do with user data item ".$sv->desc_addr."\n"; } } $_ and !$_->{tool_reachable} and !$_->immortal and $_->{tool_reachable} = REACH_USER, push @user, $_ for @more_user; $_ and !$_->{tool_reachable} and !$_->immortal and $_->{tool_reachable} = REACH_INTERNAL, push @internal, $_ for @more_internal, grep { defined } $sv->magic_svs; $count++; $progress->( sprintf "Marking user reachability %d...", $count ) if $progress and $count % 1000 == 0; } } # Finally internals { push @internal, pairvalues $df->roots; my $count = 0; while( @internal ) { my $sv = shift @internal or next; next if $sv->{tool_reachable}; $sv->{tool_reachable} = REACH_INTERNAL; push @internal, map { $_->sv ? $_->sv : () } $sv->outrefs; $count++; $progress->( sprintf "Marking internal reachability %d...", $count ) if $progress and $count % 1000 == 0; } } } =head1 SV METHODS This tool adds the following SV methods. =head2 reachable $r = $sv->reachable Returns true if the SV is reachable from a known root. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Roots.pm����������������������������������������������������������000444��001750��001750�� 2473�14550507443� 16620� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2017 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Roots 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use List::Util qw( pairs ); use constant CMD => "roots"; use constant CMD_DESC => "Display a list of the root SVs"; =head1 NAME C - display a list of the root SVs =head1 DESCRIPTION This C tool displays a list of all the root SVs. =cut =head1 COMMANDS =head2 roots pmat> roots the *@ GV : GLOB($*) at 0x1381ed0/errgv the ARGV GV : GLOB(@*I) at 0x139f618/argvgv ... Prints a list of every root SV in the heap. =cut sub run { my $self = shift; my $df = $self->df; Devel::MAT::Cmd->print_table( [ map { my ( $name, $description ) = @$_; my $addr = $df->root_at( $name ); my $sv = $df->sv_at( $addr ); $sv ? [ "$description", Devel::MAT::Cmd->format_sv( $sv ) ] : $addr ? [ "$description", sprintf( "PTR(0x%x)", $addr ) ] : () } pairs $df->root_descriptions ], sep => ": ", ); } =head1 AUTHOR Paul Evans =cut 0x55AA; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Show.pm�����������������������������������������������������������000444��001750��001750�� 35711�14550507443� 16453� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2016-2022 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Show 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use List::Util qw( max ); use constant CMD => "show"; use constant CMD_DESC => "Show information about a given SV"; use constant CMD_OPTS => ( full_pv => { help => "show the full captured PV", alias => "F" }, pad => { help => "show the first PAD of a CODE", alias => "P" }, ); =head1 NAME C - show information about a given SV =head1 DESCRIPTION This C tool provides a command that prints interesting information from within an SV. Its exact output will depend on the type of SV it is applied to. =cut =head1 COMMANDS =cut =head2 show pmat> show 0x1bbf598 IO() at 0x1bbf598 with refcount 2 blessed as IO::File ifileno=2 ofileno=2 Prints information about the given SV. =cut use constant CMD_ARGS_SV => 1; my @SHOW_EXTRA; sub register_extra { shift; my ( $code ) = @_; push @SHOW_EXTRA, $code; } sub run { my $self = shift; my %opts = %{ +shift }; my ( $sv ) = @_; Devel::MAT::Cmd->printf( "%s with refcount %d%s\n", Devel::MAT::Cmd->format_sv( $sv ), $sv->refcnt, $sv->is_mortal ? ( " " . Devel::MAT::Cmd->format_note( "(mortalized)", 1 ) ) : "", ); my $size = $sv->size; if( $size < 1024 ) { Devel::MAT::Cmd->printf( " size %d bytes\n", $size, ); } else { Devel::MAT::Cmd->printf( " size %s (%d bytes)\n", Devel::MAT::Cmd->format_bytes( $size ), $size, ); } if( my $stash = $sv->blessed ) { Devel::MAT::Cmd->printf( " blessed as %s\n", $stash->stashname ); } if( my $symname = $sv->symname ) { Devel::MAT::Cmd->printf( " named as %s\n", Devel::MAT::Cmd->format_symbol( $symname ) ); } foreach my $magic ( $sv->magic ) { my $type = $magic->type; $type = "^" . chr( 0x40 + ord $type ) if ord $type < 0x20; Devel::MAT::Cmd->printf( " has %s magic", Devel::MAT::Cmd->format_note( $type, 1 ), ); Devel::MAT::Cmd->printf( " with object at %s", Devel::MAT::Cmd->format_sv( $magic->obj ) ) if $magic->obj; Devel::MAT::Cmd->printf( " with pointer at %s", Devel::MAT::Cmd->format_sv( $magic->ptr ) ) if $magic->ptr; Devel::MAT::Cmd->printf( "\n with virtual table at 0x%x", $magic->vtbl ) if $magic->vtbl; Devel::MAT::Cmd->printf( "\n" ); } if( defined( my $serial = $sv->debug_serial ) ) { Devel::MAT::Cmd->printf( " debug serial %d\n", $serial ); my $file = $sv->debug_file; Devel::MAT::Cmd->printf( " created at %s:%d\n", $file, $sv->debug_line ) if defined $file; } foreach my $extra ( @SHOW_EXTRA ) { $extra->( $sv ); # TODO: consider opts? } my $type = $sv->type; my $method = "show_$type"; $self->$method( $sv, \%opts ); } sub say_with_sv { my ( $str, @args ) = @_; my $sv = pop @args; Devel::MAT::Cmd->printf( $str . "%s\n", @args, Devel::MAT::Cmd->format_sv( $sv ), ); } sub show_GLOB { my $self = shift; my ( $gv ) = @_; Devel::MAT::Cmd->printf( " name=%s\n", $gv->name ) if $gv->name; say_with_sv ' stash=', $gv->stash if $gv->stash; say_with_sv ' SCALAR=', $gv->scalar if $gv->scalar; say_with_sv ' ARRAY=', $gv->array if $gv->array; say_with_sv ' HASH=', $gv->hash if $gv->hash; say_with_sv ' CODE=', $gv->code if $gv->code; say_with_sv ' EGV=', $gv->egv if $gv->egv; say_with_sv ' IO=', $gv->io if $gv->io; say_with_sv ' FORM=', $gv->form if $gv->form; } sub show_SCALAR { my $self = shift; my ( $sv, $opts ) = @_; Devel::MAT::Cmd->printf( " UV=%s\n", Devel::MAT::Cmd->format_value( $sv->uv, nv => 1 ), ) if defined $sv->uv; Devel::MAT::Cmd->printf( " IV=%s\n", Devel::MAT::Cmd->format_value( $sv->iv, nv => 1 ), ) if defined $sv->iv; Devel::MAT::Cmd->printf( " NV=%s\n", Devel::MAT::Cmd->format_value( $sv->nv, nv => 1 ), ) if defined $sv->nv; if( defined( my $pv = $sv->pv ) ) { Devel::MAT::Cmd->printf( " PV=%s\n", Devel::MAT::Cmd->format_value( $pv, pv => 1, ( $opts->{full_pv} ? ( maxlen => 0 ) : () ), ), ); Devel::MAT::Cmd->printf( " PVLEN %d\n", $sv->pvlen ); } } sub show_BOOL { my $self = shift; my ( $sv, $opts ) = @_; Devel::MAT::Cmd->printf( " BOOL=%s\n", Devel::MAT::Cmd->format_value( $sv->uv ? "true" : "false" ) ); } sub show_REF { my $self = shift; my ( $sv ) = @_; say_with_sv ' RV=', $sv->rv if $sv->rv; } sub show_ARRAY { my $self = shift; my ( $av ) = @_; Devel::MAT::Cmd->printf( " %d elements (use 'elems' command to show)\n", $av->n_elems, ); } sub show_STASH { my $self = shift; my ( $hv ) = @_; Devel::MAT::Cmd->printf( " stashname=%s\n", $hv->stashname ); $self->show_HASH( $hv ); } sub show_HASH { my $self = shift; my ( $hv ) = @_; Devel::MAT::Cmd->printf( " %d values (use 'values' command to show)\n", $hv->n_values, ); } sub show_CODE { my $self = shift; my ( $cv, $opts ) = @_; $cv->hekname ? Devel::MAT::Cmd->printf( " hekname=%s\n", $cv->hekname ) : Devel::MAT::Cmd->printf( " no hekname\n" ); $cv->stash ? say_with_sv( " stash=", $cv->stash ) : Devel::MAT::Cmd->printf( " no stash\n" ); $cv->glob ? say_with_sv( " glob=", $cv->glob ) : Devel::MAT::Cmd->printf( " no glob\n" ); $cv->location ? Devel::MAT::Cmd->printf( " location=%s\n", $cv->location ) : Devel::MAT::Cmd->printf( " no location\n" ); $cv->scope ? say_with_sv( " scope=", $cv->scope ) : Devel::MAT::Cmd->printf( " no scope\n" ); $cv->padlist ? say_with_sv( " padlist=", $cv->padlist ) : (); $cv->padnames_av ? say_with_sv( " padnames_av=", $cv->padnames_av ) : (); $cv->protosub ? say_with_sv( " protosub=", $cv->protosub ) : (); my @pads = $cv->pads; foreach my $depth ( 0 .. $#pads ) { next unless $pads[$depth]; say_with_sv( " pad[$depth]=", $pads[$depth] ); } if( $opts->{pad} and my $pad0 = ( $cv->pads )[0] ) { Devel::MAT::Cmd->printf( "PAD[0]:\n" ); $self->show_PAD_contents( $pad0 ); } if( my @globs = $cv->globrefs ) { Devel::MAT::Cmd->printf( "Referenced globs:\n " ); Devel::MAT::Cmd->printf( "%s, ", Devel::MAT::Cmd->format_sv( $_ ) ) for @globs; Devel::MAT::Cmd->printf( "\n" ); } } sub show_PAD { my $self = shift; my ( $pad ) = @_; my $padcv = $pad->padcv; $padcv ? say_with_sv( " padcv=", $padcv ) : Devel::MAT::Cmd->printf( " no padcv\n" ); $self->show_PAD_contents( $pad ); } sub _join { # Like CORE::join but respects string concat operator my ( $sep, @elems ) = @_; my $ret = shift @elems; $ret = $ret . $sep . $_ for @elems; return $ret; } sub show_PAD_contents { my $self = shift; my ( $pad ) = @_; my $padcv = $pad->padcv; my @elems = $pad->elems; my @padnames = map { my $padname = $padcv->padname( $_ ); # is_outer is always set for is_our; it's only interesting without is_our my $is_just_outer = $padname && $padname->is_outer && !$padname->is_our; $padname ? _join( " ", ( $padname->is_state ? Devel::MAT::Cmd->format_note( "state" ) : () ), ( $padname->is_our ? Devel::MAT::Cmd->format_note( "our" ) : () ), ( $padname->is_field ? Devel::MAT::Cmd->format_note( "field" ) : () ), Devel::MAT::Cmd->format_note( $padname->name, 1 ), ( $is_just_outer ? Devel::MAT::Cmd->format_note( "*OUTER", 2 ) : () ), # is_typed and is_lvalue not indicated ) : undef } 0 .. $#elems; my $idxlen = length $#elems; my $namelen = max map { defined $_ ? length $_ : 0 } @padnames; my %padtype; if( my $gvix = $padcv->{gvix} ) { $padtype{$_} = "GLOB" for @$gvix; } if( my $constix = $padcv->{constix} ) { $padtype{$_} = "CONST" for @$constix; } Devel::MAT::Cmd->printf( " [%*d/%-*s]=%s\n", $idxlen, 0, $namelen, Devel::MAT::Cmd->format_note( '@_', 1 ), ( $elems[0] ? Devel::MAT::Cmd->format_sv_with_value( $elems[0] ) : "NULL" ), ); foreach my $padix ( 1 .. $#elems ) { my $sv = $elems[$padix]; if( $padnames[$padix] ) { Devel::MAT::Cmd->printf( " [%*d/%-*s]=%s\n", $idxlen, $padix, $namelen, $padnames[$padix], ( $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL" ), ); } else { Devel::MAT::Cmd->printf( " [%*d %-*s]=%s\n", $idxlen, $padix, $namelen, $padtype{$padix} // "", ( $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL" ), ); } } } # TODO: PADLIST sub show_PADNAMES { my $self = shift; my ( $padnames ) = @_; $padnames->padcv ? say_with_sv( " padcv=", $padnames->padcv ) : Devel::MAT::Cmd->printf( " no padcv\n" ); my @elems = $padnames->elems; # Every PADNAMES element is either NULL or a SCALAR(PV) # PADIX 0 is always @_ foreach my $padix ( 1 .. $#elems ) { my $slot = $elems[$padix]; if( $slot and $slot->type eq "SCALAR" ) { Devel::MAT::Cmd->printf( " [%d] is %s\n", $padix, Devel::MAT::Cmd->format_note( $slot->pv, 1 ) ); } } } sub show_IO { my $self = shift; my ( $io ) = @_; Devel::MAT::Cmd->printf( " ifileno=%d\n", $io->ifileno ) if defined $io->ifileno; Devel::MAT::Cmd->printf( " ofileno=%d\n", $io->ofileno ) if defined $io->ofileno; } sub show_OBJECT { my $self = shift; my ( $obj ) = @_; my @fields = $obj->fields; foreach my $field ( $obj->blessed->fields ) { my $val = $obj->field( $field->fieldix ); Devel::MAT::Cmd->printf( " %s=%s\n", Devel::MAT::Cmd->format_note( $field->name, 1 ), Devel::MAT::Cmd->format_sv_with_value( $val ) ); } } sub show_CLASS { my $self = shift; my ( $cls ) = @_; Devel::MAT::Cmd->printf( " is CLASS\n" ); $cls->adjust_blocks ? say_with_sv( " adjust_blocks=", $cls->adjust_blocks ) : (); $self->show_STASH( $cls ); } sub show_C_STRUCT { my $self = shift; my ( $struct ) = @_; my @fields = $struct->fields; while( @fields ) { my $field = shift @fields; my $val = shift @fields; next unless defined $val; if( $field->type == 0x00 ) { # PTR Devel::MAT::Cmd->printf( " %s=%s\n", $field->name, Devel::MAT::Cmd->format_sv_with_value( $val ) ); } elsif( $field->type == 0x01 ) { # BOOL Devel::MAT::Cmd->printf( " %s=%s\n", $field->name, Devel::MAT::Cmd->format_value( $val ? "true" : "false" ) ); } else { # various number types Devel::MAT::Cmd->printf( " %s=%s\n", $field->name, Devel::MAT::Cmd->format_value( $val ), ); } } } package # hide Devel::MAT::Tool::Show::_elems; use base qw( Devel::MAT::Tool ); use List::Util qw( min ); use constant CMD => "elems"; use constant CMD_DESC => "List the elements of an ARRAY SV"; =head2 elems pmat> elems endav [0] CODE(PP) at 0x562e93222dc8 Prints elements of an ARRAY SV. Takes the following named options: =over 4 =item --count, -c MAX Show at most this number of elements (default 50). =back Takes the following positional arguments: =over 4 =item * Optional start index (default 0). =back =cut use constant CMD_OPTS => ( count => { help => "maximum count of elements to print", type => "i", alias => "c", default => 50 }, ); use constant CMD_ARGS_SV => 1; use constant CMD_ARGS => ( { name => "startidx", help => "starting index" }, ); sub run { my $self = shift; my %opts = %{ +shift }; my ( $av, $startidx ) = @_; my $type = $av->type; if( $type eq "HASH" or $type eq "STASH" ) { die "Cannot 'elems' of a $type - maybe you wanted 'values'?\n"; } elsif( $type ne "ARRAY" ) { die "Cannot 'elems' of a non-ARRAY\n"; } $startidx //= 0; my $stopidx = min( $startidx + $opts{count}, $av->n_elems ); my @rows; foreach my $idx ( $startidx .. $stopidx-1 ) { my $sv = $av->elem( $idx ); push @rows, [ Devel::MAT::Cmd->format_value( $idx, index => 1 ), $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL", ]; } Devel::MAT::Cmd->print_table( \@rows, indent => 2 ); my $morecount = $av->n_elems - $stopidx; Devel::MAT::Cmd->printf( " ... (%d more)\n", $morecount ) if $morecount; } package # hide Devel::MAT::Tool::Show::_values; use base qw( Devel::MAT::Tool ); use constant CMD => "values"; use constant CMD_DESC => "List the values of a HASH-like SV"; =head2 values pmat> values defstash {"\b"} GLOB($%*) at 0x562e93114eb8 {"\017"} GLOB($*) at 0x562e9315a428 ... Prints values of a HASH or STASH SV. Takes the following named options: =over 4 =item --count, -c MAX Show at most this number of values (default 50). =back Takes the following positional arguments: =over 4 =item * Optional skip count (default 0). If present, will skip over this number of keys initially to show more of them. =back =cut use constant CMD_OPTS => ( count => { help => "maximum count of values to print", type => "i", alias => "c", default => 50 }, ); use constant CMD_ARGS_SV => 1; use constant CMD_ARGS => ( { name => "skipcount", help => "skip over this many keys initially" }, ); sub run { my $self = shift; my %opts = %{ +shift }; my ( $hv, $skipcount ) = @_; my $type = $hv->type; if( $type eq "ARRAY" ) { die "Cannot 'values' of a $type - maybe you wanted 'elems'?\n"; } elsif( $type ne "HASH" and $type ne "STASH" ) { die "Cannot 'elems' of a non-HASHlike\n"; } # TODO: control of sorting, start at, filtering my @keys = sort $hv->keys; splice @keys, 0, $skipcount if $skipcount; Devel::MAT::Tool::more->paginate( { pagesize => $opts{count} }, sub { my ( $count ) = @_; my @rows; foreach my $key ( splice @keys, 0, $count ) { my $sv = $hv->value( $key ); push @rows, [ Devel::MAT::Cmd->format_value( $key, key => 1, stash => ( $type eq "STASH" ) ), $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL", ]; } Devel::MAT::Cmd->print_table( \@rows, indent => 2 ); my $morecount = @keys; Devel::MAT::Cmd->printf( " ... (%d more)\n", $morecount ) if $morecount; return $morecount; } ); } =head1 AUTHOR Paul Evans =cut 0x55AA; �������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Sizes.pm����������������������������������������������������������000444��001750��001750�� 21201�14550507443� 16615� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2017 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Sizes 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant FOR_UI => 1; use List::Util qw( sum0 ); use List::UtilsBy qw( rev_nsort_by ); =head1 NAME C - calculate sizes of SV structures =head1 DESCRIPTION This C tool calculates the sizes of the structures around SVs. The individual size of each individual SV is given by the C method, though in several cases SVs can be considered to be part of larger structures of a combined aggregate size. This tool calculates those sizes and adds them to the UI. The structural size is calculated from the basic size of the SV, added to which for various types is: =over 2 =item ARRAY Arrays add the basic size of every non-mortal element SV. =item HASH Hashes add the basic size of every non-mortal value SV. =item CODE Codes add the basic size of their padlist and constant value, and all their padnames, pads, constants and globrefs. =back The owned size is calculated by starting at the given SV and accumulating the set of every strong outref whose refcount is 1. This is the set of all SVs the original directly owns. =cut sub init_ui { my $self = shift; my ( $ui ) = @_; my %size_tooltip = ( SV => "Display the size of each SV individually", Structure => "Display the size of SVs including its internal structure", Owned => "Display the size of SVs including all owned referrents", ); $ui->provides_radiobutton_set( map { my $size = $_ eq "SV" ? "size" : "\L${_}_size"; $ui->register_icon( name => "size-$_", svg => "icons/size-$_.svg", ); { text => $_, icon => "size-$_", tooltip => $size_tooltip{$_}, code => sub { $ui->set_svlist_column_values( column => Devel::MAT::UI->COLUMN_SIZE, from => sub { shift->$size }, ); }, } } qw( SV Structure Owned ) ); } =head1 SV METHODS This tool adds the following SV methods. =head2 structure_set @svs = $sv->structure_set Returns the total set of the SV's structure. =head2 structure_size $size = $sv->structure_size Returns the size, in bytes, of the structure that the SV contains. =cut # Most SVs' structual set is just themself sub Devel::MAT::SV::structure_set { shift } # ARRAY structure includes the element SVs sub Devel::MAT::SV::ARRAY::structure_set { my $av = shift; my @svs = ( $av, grep { $_ && !$_->immortal } $av->elems ); return @svs; } # HASH structure includes the value SVs sub Devel::MAT::SV::HASH::structure_set { my $hv = shift; my @svs = ( $hv, grep { $_ && !$_->immortal } $hv->values ); return @svs; } # CODE structure includes PADLIST, PADNAMES, PADs, and all pad name and pad SVs sub Devel::MAT::SV::CODE::structure_set { my $cv = shift; my @svs = ( $cv, grep { $_ && !$_->immortal } $cv->padlist, $cv->padnames_av, $cv->pads, $cv->constval, $cv->constants, $cv->globrefs ); return @svs; } sub Devel::MAT::SV::structure_size { return sum0 map { $_->size } shift->structure_set } =head2 owned_set @svs = $sv->owned_set Returns the set of every SV owned by the given one. =head2 owned_size $size = $sv->owned_size Returns the total size, in bytes, of the SVs owned by the given one. =cut sub Devel::MAT::SV::owned_set { my @more = ( shift ); my %seen; my @owned; while( @more ) { my $next = pop @more; push @owned, $next; $seen{$next->addr}++; push @more, grep { !$seen{$_->addr} and !$_->immortal and $_->refcnt == 1 } map { $_->sv } $next->outrefs_strong; } return @owned; } sub Devel::MAT::SV::owned_size { my $sv = shift; return $sv->{tool_sizes_owned} //= sum0 map { $_->size } $sv->owned_set; } =head1 COMMANDS =cut =head2 size Prints the sizes of a given SV pmat> size defstash STASH(61) at 0x556e47243e10=defstash consumes: 2.1 KiB directly 11.2 KiB structurally 54.2 KiB including owned referrants =cut use constant CMD => "size"; use constant CMD_DESC => "Show the size of a given SV"; use constant CMD_ARGS_SV => 1; sub run { my $self = shift; my ( $sv ) = @_; Devel::MAT::Cmd->printf( "%s consumes:\n", Devel::MAT::Cmd->format_sv( $sv ) ); Devel::MAT::Cmd->printf( " %s directly\n", Devel::MAT::Cmd->format_bytes( $sv->size ) ); Devel::MAT::Cmd->printf( " %s structurally\n", Devel::MAT::Cmd->format_bytes( $sv->structure_size ) ); Devel::MAT::Cmd->printf( " %s including owned referrants\n", Devel::MAT::Cmd->format_bytes( $sv->owned_size ) ); } package # hide Devel::MAT::Tool::Sizes::_largest; use base qw( Devel::MAT::Tool ); =head2 largest pmat> largest -owned STASH(61) at 0x55e4317dfe10: 54.2 KiB: of which | GLOB(%*) at 0x55e43180be60: 16.9 KiB: of which | | STASH(40) at 0x55e43180bdd0: 16.7 KiB | | GLOB(&*) at 0x55e4318ad330: 2.8 KiB | | others: 15.0 KiB | GLOB(%*) at 0x55e4317fdf28: 4.1 KiB: of which | | STASH(34) at 0x55e4317fdf40: 4.0 KiB bytes ... Finds and prints the largest SVs by size. The 5 largest SVs are shown. If counting sizes in a way that includes referred SVs, a tree is printed showing the 3 largest SVs within these, and of those the 2 largest referred SVs again. This should help identify large memory occupiers. Takes the following named options: =over 4 =item --struct Count SVs using the structural size. =item --owned Count SVs using the owned size. =back By default, only the individual SV size is counted. =cut use constant CMD => "largest"; use constant CMD_DESC => "Find the largest SVs by size"; use Heap; use List::UtilsBy qw( max_by ); my %seen; sub list_largest_svs { my ( $svlist, $metric, $indent, @counts ) = @_; my $method = $metric ? "${metric}_size" : "size"; my $heap = Heap::Fibonacci->new; $heap->add( Devel::MAT::Tool::Sizes::_Elem->new( $_->$method, $_ ) ) for @$svlist; my $count = shift @counts; while( $count-- ) { my $topelem = $heap->extract_top or last; my $largest = $topelem->sv; $seen{$largest->addr}++; Devel::MAT::Cmd->printf( "$indent%s: %s", Devel::MAT::Cmd->format_sv( $largest ), Devel::MAT::Cmd->format_bytes( $largest->$method ), ); if( !defined $metric or !@counts ) { Devel::MAT::Cmd->printf( "\n" ); next; } my $set_method = "${metric}_set"; my @set = $largest->$set_method; shift @set; # SV itself is always first if( !@set ) { Devel::MAT::Cmd->printf( "\n" ); next; } Devel::MAT::Cmd->printf( ": of which\n" ); list_largest_svs( \@set, $metric, "${indent} | ", @counts ); $seen{$_->addr}++ for @set; } my $others = 0; $others += $_->size for grep { !$seen{$_->addr} } @$svlist; if( $others ) { Devel::MAT::Cmd->printf( "$indent%s: %s\n", Devel::MAT::Cmd->format_note( "others" ), Devel::MAT::Cmd->format_bytes( $others ), ); } } package Devel::MAT::Tool::Sizes::_Elem { sub new { my ( $class, $val, $sv ) = @_; bless [ $val, $sv ], $class } sub sv { my $self = shift; return $self->[1]; } sub heap { my $self = shift; $self->[2] = shift if @_; return $self->[2] } sub cmp { my ( $self, $other ) = @_; return $other->[0] <=> $self->[0] } } use constant CMD_OPTS => ( struct => { help => "count SVs by structural size" }, owned => { help => "count SVs by owned size" }, ); use constant CMD_ARGS => ( { name => "count", help => "how many items to display", repeated => 1 }, ); sub run { my $self = shift; my %opts = %{ +shift }; my @counts = ( 5, 3, 2 ); $counts[$_] = $_[$_] for 0 .. $#_; my $df = $self->df; my $METRIC; $METRIC = "structure" if $opts{struct}; $METRIC = "owned" if $opts{owned}; my @svs = $df->heap; my $method = $METRIC ? "${METRIC}_size" : "size"; my $heap_total = scalar @svs; my $count = 0; foreach my $sv ( @svs ) { $count++; $self->report_progress( sprintf "Calculating sizes in %d of %d (%.2f%%)", $count, $heap_total, 100*$count / $heap_total ) if $count % 20000 == 0; $sv->$method; } $self->report_progress(); undef %seen; list_largest_svs( \@svs, $METRIC, "", @counts ); } =head1 AUTHOR Paul Evans =cut 0x55AA; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Stack.pm����������������������������������������������������������000444��001750��001750�� 1771�14550507443� 16557� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2019 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Stack 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "stack"; use constant CMD_DESC => "Display the value stack"; =head1 NAME C - display the value stack =head1 DESCRIPTION This C tool displays the captured state of the value stack, showing the SVs in place there. =cut =head1 COMMANDS =head2 stack pmat> stack [1]: SCALAR(PV) at 0x55cde0fa0830 = "tiny.pmat" [0]: UNDEF at 0x55cde0f71398 Prints SVs on the value stack. =cut sub run { my $self = shift; my @stacksvs = $self->df->stack; foreach my $idx ( reverse 0 .. $#stacksvs ) { my $sv = $stacksvs[$idx]; Devel::MAT::Cmd->printf( "[%d]: %s\n", $idx, Devel::MAT::Cmd->format_sv_with_value( $sv ) ); } } 0x55AA; �������Devel-MAT-0.52/lib/Devel/MAT/Tool/Summary.pm��������������������������������������������������������000444��001750��001750�� 2106�14550507443� 17140� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2018 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Summary 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "summary"; use constant CMD_DESC => "Print basic information about the loaded dumpfile"; =head1 NAME C - show basic information about the dumpfile =head1 COMANDS =cut =head2 summary pmat> summary Perl memory dumpfile from perl 5.26.1 threaded Heap contains 3315 objects Prints basic information about the dumpfile - the version of perl that created it, and the number of SVs it contains. =cut sub run { my $self = shift; my $df = $self->df; Devel::MAT::Cmd->printf( "Perl memory dumpfile from perl %s %s\n", $df->perlversion, $df->ithreads ? "threaded" : "non-threaded" ); Devel::MAT::Cmd->printf( "Heap contains %d objects\n", scalar $df->heap ); } =head1 AUTHOR Paul Evans =cut 0x55AA; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Symbols.pm��������������������������������������������������������000444��001750��001750�� 13165�14550507443� 17162� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2017-2018 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Symbols 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "symbols"; use constant CMD_DESC => "Display a list of the symbol table"; =head1 NAME C - display a list of the symbol table =head1 DESCRIPTION This C tool displays a list names from the symbol table. =cut =head1 COMMANDS =head2 symbols pmat> symbols strict $strict::VERSION &strict::all_bits &strict::all_explicit_bits &strict::bits &strict::import &strict::unimport Prints a list of every name inside a symbol table hash ("stash"), starting from the one given by name, or the toplevel default stash if none is provided. Takes the following named options: =over 4 =item --recurse, -R Recursively show the inner symbols inside stashes. =back =cut sub extract_symbols { my ( $stash, $prefix ) = @_; my @ret; foreach my $key ( sort $stash->keys ) { my $gv = $stash->value( $key ); my $name; if( $key =~ m/^([\0-\x1f])/ ) { $name = "{^" . chr(ord($1)+0x40) . substr( $key, 1 ) . "}"; } else { $name = $prefix . $key; } push @ret, [ $gv, $name ]; } return @ret; } sub _show_symbol { my ( $name, $sv ) = @_; Devel::MAT::Cmd->printf( "%s at %s\n", Devel::MAT::Cmd->format_symbol( $name, $sv ), Devel::MAT::Cmd->format_sv( $sv ), ); } use constant CMD_OPTS => ( recurse => { help => "recursively show inner symbols", alias => "R" }, ); use constant CMD_ARGS => ( { name => "start", help => "show symbols within this symbol, rather than %main::" }, ); sub run { my $self = shift; my %opts = %{ +shift }; my $df = $self->df; my @queue; if( @_ ) { my $name = shift @_; @queue = extract_symbols( $self->pmat->find_stash( $name ), $name . "::" ); } else { # Don't recurse into self-referential 'main::' symbol @queue = grep { $_->[1] ne "main::" } extract_symbols( $df->defstash, "" ); # Also skip the "debug location" symbols, whatever those are @queue = grep { $_->[1] !~ m/^_paginate( sub { my ( $count ) = @_; while( $count and @queue ) { $_ = shift @queue; if( $_->[0]->isa( "Devel::MAT::SV::GLOB" ) ) { my ( $gv, $name ) = @$_; _show_symbol( '$' . $name, $gv->scalar ), $count-- if $gv->scalar; _show_symbol( '@' . $name, $gv->array ), $count-- if $gv->array; _show_symbol( '%' . $name, $gv->hash ), $count-- if $gv->hash; _show_symbol( '&' . $name, $gv->code ), $count-- if $gv->code; unshift @queue, [ $gv->hash, $name ] if $gv->hash; } elsif( $opts{recurse} and $_->[0]->isa( "Devel::MAT::SV::STASH" ) ) { my ( $stash, $prefix ) = @$_; unshift @queue, extract_symbols( $stash, $prefix ); } } return !!@queue; } ); } package Devel::MAT::Tool::Symbols::_packages; use base qw( Devel::MAT::Tool ); use constant CMD => "packages"; use constant CMD_DESC => "Display a list of the packages in the symbol table"; =head2 packages Prints a list of every package name in the symbol table. pmat> packages package CORE at STASH(1) at 0x55cde0f74240 package CORE::GLOBAL at STASH(0) at 0x55cde0f74270 package Carp at STASH(4) at 0x55cde0fa1508 ... Takes the following named options: =over 4 =item --versions, -V Include the value of the I<$VERSION> of each package, if relevant. =back =cut use constant CMD_OPTS => ( versions => { help => "show the \$VERSION of each package", alias => "V" }, ); sub _versionof { my ( $stash ) = @_; # TODO: might be nice to have $stash->find_symbol my $versiongv = $stash->value( 'VERSION' ) or return ""; my $versionsv = $versiongv->scalar or return ""; my $rv; my $version; if( $versionsv->type eq "REF" and ( $rv = $versionsv->rv )->blessed and $rv->blessed->stashname eq "version" ) { # Stringify a "version" object $versionsv = $rv->value( "original" ); $version = ( $versionsv->pv // $versionsv->nv // $versionsv->uv ); $version =~ m/^v/ or $version = "v$version"; } else { $version = $versionsv->pv // $versionsv->nv // $versionsv->uv; } return " " . Devel::MAT::Cmd->format_value( $version ); } sub run { my $self = shift; my %opts = %{ +shift }; my @queue = grep { $_->[0]->isa( "Devel::MAT::SV::GLOB" ) and $_->[1] ne "main::" } Devel::MAT::Tool::Symbols::extract_symbols( $self->df->defstash, "" ); Devel::MAT::Tool::more->paginate( sub { my ( $count ) = @_; while( $count and @queue ) { $_ = shift @queue; my ( $gv, $name ) = @$_; next unless my $stash = $gv->hash; next unless $stash->isa( "Devel::MAT::SV::STASH" ); Devel::MAT::Cmd->printf( "%s %s at %s\n", Devel::MAT::Cmd->format_note( "package" ), Devel::MAT::Cmd->format_symbol( $name =~ s/::$//r, $stash ) . ( $opts{versions} ? _versionof( $stash ) : "" ), Devel::MAT::Cmd->format_sv( $stash ), ); $count--; unshift @queue, grep { $_->[0]->isa( "Devel::MAT::SV::GLOB" ) } Devel::MAT::Tool::Symbols::extract_symbols( $stash, $name ); } return !!@queue; } ); } =head1 AUTHOR Paul Evans =cut 0x55AA; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/Tool/Tools.pm����������������������������������������������������������000444��001750��001750�� 2721�14550507443� 16606� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2022 -- leonerd@leonerd.org.uk package Devel::MAT::Tool::Tools 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use constant CMD => "tools"; use constant CMD_DESC => "List the available tools"; sub run { my $self = shift; my @table; foreach my $tool ( sort Devel::MAT->available_tools ) { my $tool_class = "Devel::MAT::Tool::$tool"; next unless $tool_class->can( "FOR_UI" ) and $tool_class->FOR_UI; my $desc = $tool_class->can( "TOOL_DESC" ) ? $tool_class->TOOL_DESC : undef; my $loaded = $self->pmat->has_tool( $tool ); push @table, [ String::Tagged->from_sprintf( "%s %s", ( $loaded ? Devel::MAT::Cmd->format_note( "*", 1 ) : " " ), Devel::MAT::Cmd->format_note( $tool, 0 ), ), $desc // "" ]; } Devel::MAT::Cmd->print_table( \@table, sep => " - " ); } package # hide Devel::MAT::Tool::Tools::_tool; use base qw( Devel::MAT::Tool ); use constant CMD => "tool"; use constant CMD_DESC => "Load an extension tool"; use constant CMD_ARGS => ( { name => "tool", help => "the name of the tool to load" }, ); sub run { my $self = shift; my ( $toolname ) = @_; my $tool = $self->pmat->load_tool( $toolname, progress => $self->{progress} ); $self->report_progress(); } 0x55AA; �����������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/ToolBase���������������������������������������������������������������000755��001750��001750�� 0�14550507443� 15604� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/ToolBase/GraphWalker.pm������������������������������������������������000444��001750��001750�� 4163�14550507443� 20512� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020 -- leonerd@leonerd.org.uk package Devel::MAT::ToolBase::GraphWalker 0.52; use v5.14; use warnings; use base qw( Devel::MAT::Tool ); use utf8; use List::Util qw( any pairs ); use List::UtilsBy qw( nsort_by ); my %STRENGTH_ORDER = ( strong => 1, weak => 2, indirect => 3, inferred => 4, ); my $next_id; my %id_for; my %seen; sub reset { $next_id = "A"; undef %id_for; undef %seen; } sub walk_graph { my $self = shift; my ( $node, @args ) = @_; my $addr = $node->addr; my @roots = $node->roots; my @edges = $node->edges_in; if( !@roots and !@edges ) { $self->on_walk_nothing( $node, @args ); return; } if( @roots == 1 and $roots[0] eq "EDEPTH" ) { $self->on_walk_EDEPTH( $node, @args ); return; } # Don't bother showing any non-root edges if we have a strong root @edges = () if any { $_->strength eq "strong" } @roots; if( @edges > 0 and $seen{$addr} ) { my $cyclic = $seen{$addr} == 1; my $id = $id_for{$addr}; $self->on_walk_again( $node, $cyclic, $id, @args ); return; } $seen{$addr}++; foreach my $idx ( 0 .. $#roots ) { my $root = $roots[$idx]; my $isfinal = $idx == $#roots && !@edges; $self->on_walk_root( $node, $root, $isfinal, @args ); } my @refs = nsort_by { $STRENGTH_ORDER{$_->[0]->strength} } pairs @edges; foreach my $idx ( 0 .. $#refs ) { my ( $ref, $refnode ) = @{ $refs[$idx] }; my $is_final = $idx == $#refs; my $ref_id; if( $refnode->edges_out > 1 and not $refnode->roots and not $id_for{$refnode->addr} ) { $ref_id = $id_for{$refnode->addr} = $next_id++; } my @subargs = $self->on_walk_ref( $node, $ref, $refnode->sv, $ref_id, $is_final, @args ); if( $refnode->addr == $addr ) { $self->on_walk_itself( $node, @subargs ); } else { $self->walk_graph( $refnode, @subargs ); } } $seen{$addr}++; } 0x55AA; �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/UserGuide��������������������������������������������������������������000755��001750��001750�� 0�14550507443� 15770� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/lib/Devel/MAT/UserGuide/IdentifyingAnSV.pod������������������������������������������000444��001750��001750�� 6515�14550507443� 21641� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������=encoding UTF-8 =head1 NAME C - working out what an SV actually is =head1 OVERVIEW Often when analysing a heap dump file to determine the cause of a memory issue the problem can be narrowed down to a single SV at a particular address. Even though the SV is often printed with a general type name, this simple address as a raw hex number does not directly help to find what part of the program is actually responsible for this SV. =head1 IDENTIFYING THE SV To find out more about what the SV is, in terms of what things can reach it, use the C command on its address. pmat> identify 0x6a47708 The output will form a tree of back-references, leading down ultimately to known roots of the program; fixed points in the F interpreter. Sometimes this will be a short and simple tree leading directly to a known root: pmat> identify 0xfb4770 HASH(0) at 0xfb4770=strtab is: └─the shared string table HV In this case, the SV is actually a known root directly; a particularly simple result. Other times this may be a longer less-direct path, perhaps having multiple branches: pmat> identify 0x72a7140 ARRAY(457025) at 0x72a7140 is: └─(via RV) value {error} of HASH(3) at 0x490ea40, which is: └─(via RV) value {events} of HASH(8)=Mojo::Redis2 at 0x490e0b0, which is: └─(via RV) value {ws_redis_master} of HASH(4) at 0x3ebef40, which is: ├─(via RV) the lexical $instances at depth 1 of CODE(PP) at 0x4264c38, which is: │ └─the symbol '&Binary::WebSocketAPI::v3::Wrapper::Streamer::shared_redis' ├─(via RV) the lexical $instances at depth 1 of CODE(PP) at 0x42504a0, which is: │ └─the symbol '&Binary::WebSocketAPI::v3::Instance::Redis::instances' ├─(via RV) the lexical $instances at depth 1 of CODE(PP) at 0x4257500, which is: │ └─the symbol '&Binary::WebSocketAPI::v3::Instance::Redis::redis_pricer' ├─(via RV) the lexical $instances at depth 1 of CODE(PP) at 0x4264920, which is: │ └─the symbol '&Binary::WebSocketAPI::Plugins::Helpers::ws_redis_slave' └─(via RV) the lexical $instances at depth 1 of CODE(PP) at 0x4263eb8, which is: └─the symbol '&Binary::WebSocketAPI::Plugins::Helpers::ws_redis_master' Here, the named symbols count as well-known roots for the purpose of identifying SVs. The SV in question has been identified as reachable via a chain of keys, coming from a hash stored in a lexical variable named C<$instances> captured by of five different functions. Sometimes, the path from a given SV to the known roots is somehow self-referential, and needs to refer back to itself. This is done with lettered markers. pmat> identify 0x55d00c107218 REF() at 0x55d00c107218 is: └─element [0] of ARRAY(1) at 0x55d00c106f90, which is (*A): └─(via RV) value {cycle} of HASH(1) at 0x55d00c1240c8, which is: ├─(via RV) element [0] of ARRAY(1) at 0x55d00c106f90, which is: │ └─already found as *A └─(via RV) the lexical $loop at depth 1 of CODE() at 0x55d00c107230=main_cv, which is: └─the main code In each case, the output should at least help work out what any given SV is by noting what references it, recursively, up to the roots of the interpreter. =head1 AUTHOR Paul Evans =cut �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share��������������������������������������������������������������������������������000755��001750��001750�� 0�14550507443� 12750� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons��������������������������������������������������������������������������000755��001750��001750�� 0�14550507443� 14063� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-internal.svg���������������������������������������������������000444��001750��001750�� 11011�14550507443� 20473� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-lexical.svg����������������������������������������������������000444��001750��001750�� 10303�14550507443� 20303� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml L �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-none.svg�������������������������������������������������������000444��001750��001750�� 7350�14550507443� 17611� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-padlist.svg����������������������������������������������������000444��001750��001750�� 10274�14550507443� 20331� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml P ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-symtab.svg�����������������������������������������������������000444��001750��001750�� 10277�14550507443� 20173� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml S ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-user.svg�������������������������������������������������������000444��001750��001750�� 10277�14550507443� 17652� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml U ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/reachable-yes.svg��������������������������������������������������������000444��001750��001750�� 7430�14550507443� 17451� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/refs-All.svg�������������������������������������������������������������000444��001750��001750�� 40703�14550507443� 16432� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �������������������������������������������������������������Devel-MAT-0.52/share/icons/refs-Direct.svg����������������������������������������������������������000444��001750��001750�� 37761�14550507443� 17146� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ���������������Devel-MAT-0.52/share/icons/refs-Strong.svg����������������������������������������������������������000444��001750��001750�� 36765�14550507443� 17213� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������Devel-MAT-0.52/share/icons/size-Owned.svg�����������������������������������������������������������000444��001750��001750�� 42104�14550507443� 17006� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/size-SV.svg��������������������������������������������������������������000444��001750��001750�� 35443�14550507443� 16272� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/size-Structure.svg�������������������������������������������������������000444��001750��001750�� 36102�14550507443� 17733� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/strength-indirect.svg����������������������������������������������������000444��001750��001750�� 14542�14550507443� 20424� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ��������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/strength-inferred.svg����������������������������������������������������000444��001750��001750�� 12605�14550507443� 20417� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ���������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/strength-strong.svg������������������������������������������������������000444��001750��001750�� 13105�14550507443� 20131� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/strength-weak.svg��������������������������������������������������������000444��001750��001750�� 14127�14550507443� 17551� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-ARRAY.svg�����������������������������������������������������������000444��001750��001750�� 22213�14550507443� 16616� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-BOOL.svg������������������������������������������������������������000444��001750��001750�� 10362�14550507443� 16475� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-CODE.svg������������������������������������������������������������000444��001750��001750�� 10246�14550507443� 16455� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-C_STRUCT.svg��������������������������������������������������������000444��001750��001750�� 22727�14550507443� 17240� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������Devel-MAT-0.52/share/icons/type-FORMAT.svg����������������������������������������������������������000444��001750��001750�� 16453�14550507443� 16741� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-GLOB.svg������������������������������������������������������������000444��001750��001750�� 21066�14550507443� 16470� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-HASH.svg������������������������������������������������������������000444��001750��001750�� 27414�14550507443� 16473� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-INVLIST.svg���������������������������������������������������������000444��001750��001750�� 33633�14550507443� 17100� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-IO.svg��������������������������������������������������������������000444��001750��001750�� 13013�14550507443� 16245� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-LVALUE.svg����������������������������������������������������������000444��001750��001750�� 14000�14550507443� 16723� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml Devel-MAT-0.52/share/icons/type-PAD.svg�������������������������������������������������������������000444��001750��001750�� 20052�14550507443� 16343� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-PADLIST.svg���������������������������������������������������������000444��001750��001750�� 22221�14550507443� 17037� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-PADNAMES.svg��������������������������������������������������������000444��001750��001750�� 27420�14550507443� 17135� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-REF.svg�������������������������������������������������������������000444��001750��001750�� 11716�14550507443� 16362� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ��������������������������������������������������Devel-MAT-0.52/share/icons/type-REGEXP.svg����������������������������������������������������������000444��001750��001750�� 7266�14550507443� 16725� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-SCALAR.svg����������������������������������������������������������000444��001750��001750�� 7223�14550507443� 16671� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-STASH.svg�����������������������������������������������������������000444��001750��001750�� 13653�14550507443� 16632� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �������������������������������������������������������������������������������������Devel-MAT-0.52/share/icons/type-UNDEF.svg�����������������������������������������������������������000444��001750��001750�� 6433�14550507443� 16567� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������� image/svg+xml �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t������������������������������������������������������������������������������������000755��001750��001750�� 0�14550507443� 12111� 5����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/00use.t����������������������������������������������������������������������������000444��001750��001750�� 1446�14550507443� 13374� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use_ok( 'Devel::MAT::Context' ); use_ok( 'Devel::MAT::Dumpfile' ); use_ok( 'Devel::MAT::Graph' ); use_ok( 'Devel::MAT::SV' ); use_ok( 'Devel::MAT::Tool' ); use_ok( 'Devel::MAT' ); use_ok( 'Devel::MAT::InternalTools' ); use_ok( 'Devel::MAT::Tool::Callers' ); use_ok( 'Devel::MAT::Tool::Count' ); use_ok( 'Devel::MAT::Tool::Find' ); use_ok( 'Devel::MAT::Tool::Identify' ); use_ok( 'Devel::MAT::Tool::Inrefs' ); use_ok( 'Devel::MAT::Tool::ListDanglingPtrs' ); use_ok( 'Devel::MAT::Tool::Outrefs' ); use_ok( 'Devel::MAT::Tool::Reachability' ); use_ok( 'Devel::MAT::Tool::Show' ); use_ok( 'Devel::MAT::Tool::Sizes' ); use_ok( 'Devel::MAT::Tool::Stack' ); use_ok( 'Devel::MAT::Tool::Summary' ); use_ok( 'Devel::MAT::Tool::Symbols' ); done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/01self.t���������������������������������������������������������������������������000444��001750��001750�� 15700�14550507443� 13550� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Identity; use Scalar::Util qw( weaken ); use Devel::MAT::Dumper; use Devel::MAT; my $ADDR = qr/0x[0-9a-f]+/; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); my $df = $pmat->dumpfile; ok( my $defstash = $df->defstash, '$df has default stash' ); BEGIN { our $PACKAGE_SCALAR = "some value" } { ok( my $gv = $defstash->value( "PACKAGE_SCALAR" ), 'default stash has PACKAGE_SCALAR GV' ); ok( my $sv = $gv->scalar, 'PACKAGE_SCALAR GV has SCALAR' ); is( $sv->symname, '$main::PACKAGE_SCALAR', 'PACKAGE_SCALAR SV has a name' ); is( $sv->basetype, 'SV', 'SV base type' ); identical( $pmat->find_symbol( '$PACKAGE_SCALAR' ), $sv, '$pmat->find_symbol $PACKAGE_SCALAR' ); identical( $pmat->find_symbol( '$::PACKAGE_SCALAR' ), $sv, '$pmat->find_symbol $::PACKAGE_SCALAR' ); identical( $pmat->find_symbol( '$main::PACKAGE_SCALAR' ), $sv, '$pmat->find_symbol $main::PACKAGE_SCALAR' ); is( $sv->pv, "some value", 'PACKAGE_SCALAR SV has PV' ); } BEGIN { our @PACKAGE_ARRAY = qw( A B C ) } { ok( my $gv = $defstash->value( "PACKAGE_ARRAY" ), 'default stash hash PACKAGE_ARRAY GV' ); ok( my $av = $gv->array, 'PACKAGE_ARRAY GV has ARRAY' ); is( $av->symname, '@main::PACKAGE_ARRAY', 'PACKAGE_ARRAY AV has a name' ); is( $av->basetype, 'AV', 'AV base type' ); identical( $pmat->find_symbol( '@PACKAGE_ARRAY' ), $av, '$pmat->find_symbol @PACKAGE_ARRAY' ); is( $av->elem(1)->pv, "B", 'PACKAGE_ARRAY AV has elements' ); } BEGIN { our %PACKAGE_HASH = ( one => 1, two => 2 ) } { ok( my $gv = $defstash->value( "PACKAGE_HASH" ), 'default stash hash PACKAGE_HASH GV' ); ok( my $hv = $gv->hash, 'PACKAGE_HASH GV has HASH' ); is( $gv->basetype, 'GV', 'GV base type' ); is( $hv->symname, '%main::PACKAGE_HASH', 'PACKAGE_HASH hv has a name' ); is( $hv->basetype, 'HV', 'HV base type' ); identical( $pmat->find_symbol( '%PACKAGE_HASH' ), $hv, '$pmat->find_symbol %PACKAGE_HASH' ); is( $hv->value("one")->uv, 1, 'PACKAGE_HASH HV has elements' ); } { ok( my $backrefs = $defstash->backrefs, 'Default stash HV has backrefs' ); ok( $backrefs->is_backrefs, 'Backrefs AV knows it is a backrefs list' ); } sub PACKAGE_CODE { my $lexvar = "An unlikely scalar value"; } { ok( my $cv = $defstash->value_code( "PACKAGE_CODE" ), 'default stash has PACKAGE_CODE CV' ); is( $cv->symname, '&main::PACKAGE_CODE', 'PACKAGE_CODE CV has a name' ); is( $cv->basetype, 'CV', 'CV base type' ); is( $cv->depth, 0, 'PACKAGE_CODE CV currently has depth 0' ); identical( $pmat->find_symbol( '&PACKAGE_CODE' ), $cv, '$pmat->find_symbol &PACKAGE_CODE' ); is( $cv->padname( 1 )->name, '$lexvar', 'PACKAGE_CODE CV has padname(1)' ); is( $cv->padix_from_padname( '$lexvar' ), 1, 'PACKAGE_CODE CV can find padix from padname' ); cmp_ok( $cv->max_padix, '>=', 1, 'PACKAGE_CODE CV has at least 1 pad entry' ); my @constants = $cv->constants; ok( @constants, 'CV has constants' ); is( $constants[0]->pv, "An unlikely scalar value", 'CV constants' ); # PADNAMES stopped being a real thing after 5.20 if( $df->{perlver} <= ( ( 5 << 24 ) | ( 20 << 16 ) | 0xffff ) ) { is( $cv->padnames_av->type, "PADNAMES", 'CV has padnames' ); } my $pad0 = $cv->pad(1); is( $pad0->type, "PAD", 'CV has pad(1)' ); is( $pad0->padcv, $cv, 'PAD at 1 has padcv' ); is( $pad0->lexvar( '$lexvar' ), $cv->lexvar( '$lexvar', 1 ), 'CV has lexvar' ); } BEGIN { our @AofA = ( [] ); } { my $av = $pmat->find_symbol( '@AofA' ); ok( my $rv = $av->elem(0), 'AofA AV has elem[0]' ); ok( my $av2 = $rv->rv, 'RV has rv' ); my @outrefs_direct = $av->outrefs_direct; is( scalar @outrefs_direct, 1, '$av->outrefs_direct is 1' ); is( $outrefs_direct[0]->sv, $rv, 'AV outref[0] SV is $rv' ); is( $outrefs_direct[0]->strength, "strong", 'AV outref[0] strength is strong' ); is( $outrefs_direct[0]->name, "element [0]", 'AV outref[0] name' ); my @outrefs_indirect = $av->outrefs_indirect; is( scalar @outrefs_indirect, 1, '$av->outrefs_indirect is 1' ); is( $outrefs_indirect[0]->sv, $av2, 'AV outref[0] SV is $av2' ); is( $outrefs_indirect[0]->strength, "indirect", 'AV outref[0] strength is indirect' ); is( $outrefs_indirect[0]->name, "element [0] via RV", 'AV outref[0] name' ); is( $av->outref_named( "element [0]" )->name, "element [0]", 'AV ->outref_named' ); ok( !defined $av->maybe_outref_named( "element [1]" ), 'AV has no outref named "element [1]"' ); } BEGIN { our $LVREF = \substr our $TMPPV = "abc", 1, 2 } { my $sv = $pmat->find_symbol( '$LVREF' ); ok( my $rv = $sv->rv, 'LVREF SV has RV' ); is( $rv->lvtype, "x", '$rv->lvtype is x' ); } BEGIN { our $strongref = []; weaken( our $weakref = $strongref ) } { my $rv_strong = $pmat->find_symbol( '$strongref' ); my $rv_weak = $pmat->find_symbol( '$weakref' ); identical( $rv_strong->rv, $rv_weak->rv, '$strongref and $weakref have same referrant' ); ok( !$rv_strong->is_weak, '$strongref is not weak' ); ok( $rv_weak->is_weak, '$weakref is weak' ); # and longcat is long my $target = $rv_weak->rv; ok( my $backrefs = $target->backrefs, 'Weakref target has backrefs' ); } # Code hidden in a BEGIN block wouldn't be seen sub make_closure { my $env; sub { $env }; } BEGIN { our $CLOSURE = make_closure(); } { my $closure = $pmat->find_symbol( '$CLOSURE' )->rv; ok( $closure->is_cloned, '$closure is cloned' ); my $protosub = $closure->protosub; ok( defined $protosub, '$closure has a protosub' ); ok( $protosub->is_clone, '$protosub is a clone' ); } BEGIN { our @QUOTING = ( "1\\2", "don't", "do\0this", "at\x9fhome", "LONG"x100 ); } { my $av = $pmat->find_symbol( '@QUOTING' ); is_deeply( [ map { $_->qq_pv( 20 ) } $av->elems ], [ "'1\\\\2'", "'don\\'t'", '"do\\x00this"', '"at\\x9fhome"', "'LONGLONGLONGLONGLONG'..." ], '$sv->qq_pv quotes correctly' ); } BEGIN { our $BYTESTRING = do { no utf8; "\xa0bytes are here" }; our $UTF8STRING = do { use utf8; "\x{2588}UTF-8 bytes are here" }; } { { no utf8; my $bytesv = $pmat->find_symbol( '$BYTESTRING' ); ok( !$bytesv->pv_is_utf8, '$BYTESTRING lacks SvUTF8' ); ok( $bytesv->pv =~ m/\xa0/, '$BYTESTRING contains \xa0 byte' ); } { use utf8; my $utf8sv = $pmat->find_symbol( '$UTF8STRING' ); ok( $utf8sv->pv_is_utf8, '$UTF8STRING has SvUTF8' ); ok( $utf8sv->pv =~ m/\x{2588}/, '$UTF8STRING contains U+2588' ); } } { my $stderr = $pmat->find_glob( 'STDERR' )->io; is( $stderr->ofileno, 2, '$stderr has ofileno 2' ); } { package Inner; sub method {} } { my $innerstash = $pmat->find_stash( "Inner" ); is( $innerstash->stashname, "Inner", 'Inner stashname' ); ok( $innerstash->value( "method" ), 'Inner stash has method' ); } done_testing; ����������������������������������������������������������������Devel-MAT-0.52/t/02contexts.t�����������������������������������������������������������������������000444��001750��001750�� 4212�14550507443� 14443� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Devel::MAT::Dumper; use Devel::MAT; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; my $inner_l0 = __LINE__+1; sub inner { Devel::MAT::Dumper::dump( $DUMPFILE ) # l0 + 1 } my $outer_l0 = __LINE__+1; sub outer { eval { # l0 + 1 inner( "C", "D" ) # l0 + 2 }; } my $anon_l0 = __LINE__+1; my $cv = sub { map { eval 'outer( "A", "B" );'; } "one"; # l0 + 1 }; $cv->(); # l0 + 3 END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); my $df = $pmat->dumpfile; my @ctxts = $df->contexts; ok( scalar @ctxts, 'Found some call contexts' ); my ( $cinner, $ctry, $couter, $ceval, $canon ) = @ctxts; { is( $cinner->type, "SUB", '$cinner type' ); is( $cinner->file, __FILE__, '$cinner file' ); is( $cinner->line, $outer_l0 + 2, '$cinner line' ); is( $cinner->cv->symname, '&main::inner', '$cinner CV name' ); is( $cinner->depth, 1, '$cinner depth' ); is( $cinner->olddepth, 0, '$cinner olddepth' ); is_deeply( [ map { $_->pv } $cinner->args->elems ], [qw( C D )], '$cinner args' ); } { is( $ctry->type, "TRY", '$ctry type' ); is( $ctry->file, __FILE__, '$ctry file' ); is( $ctry->line, $outer_l0 + 1, '$ctry line' ); } { is( $couter->type, "SUB", '$couter type' ); like( $couter->file, qr/^\(eval \d+\)/, '$couter file' ); is( $couter->line, 1, '$couter line' ); is( $couter->cv->symname, '&main::outer', '$couter CV name' ); is_deeply( [ map { $_->pv } $couter->args->elems ], [qw( A B )], '$couter args' ); } { is( $ceval->type, "EVAL", '$ceval type' ); is( $ceval->file, __FILE__, '$ceval file' ); is( $ceval->line, $anon_l0 + 1, '$ceval line' ); like( $ceval->code->pv, qr/^outer\( "A", "B" \);/, '$ceval code PV' ); } { is( $canon->type, "SUB", '$canon type' ); is( $canon->file, __FILE__, '$canon file' ); is( $canon->line, $anon_l0 + 3, '$canon line' ); is( $canon->cv->symname, "&main::__ANON__", '$canon CV name' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/03local.t��������������������������������������������������������������������������000444��001750��001750�� 4740�14550507443� 13675� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Devel::MAT::Dumper; $Devel::MAT::Dumper::VERSION >= 0.38 or plan skip_all => "Devel::MAT::Dumper too old to capture 'local' saves"; $] >= 5.018 or plan skip_all => "Devel::MAT::Dumper can't capture 'local' saves from this version of perl"; use Devel::MAT; our $SVAR = "old value"; local $SVAR = "new value"; # SV our @AVAR = ( 1, 2, 3 ); local @AVAR = ( 4, 5 ); # AV our %HVAR = ( old => "value" ); local %HVAR = ( new => "value" ); # HV sub GVAR { 1 } my $codeline = __LINE__; no warnings 'redefine'; local *GVAR = sub { 2 }; my @ARRAY = (qw( a b c )); local $ARRAY[1] = "d"; # AELEM my %HASH = ( key => "oldval" ); local $HASH{key} = "newval"; # HELEM my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE if defined $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); my $df = $pmat->dumpfile; # SVAR { my $gv = $pmat->find_glob( "SVAR" ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $gv->outrefs; is( $savedref->name, "saved value of SCALAR slot", '$savedref->name' ); is( $savedref->sv->pv, "old value", '$savedref->sv->pv' ); } # AVAR { my $gv = $pmat->find_glob( "AVAR" ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $gv->outrefs; is( $savedref->name, "saved value of ARRAY slot", '$savedref->name' ); is( $savedref->sv->elems, 3, '$savedref->sv->elems' ); } # HVAR { my $gv = $pmat->find_glob( "HVAR" ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $gv->outrefs; is( $savedref->name, "saved value of HASH slot", '$savedref->name' ); ok( $savedref->sv->value( "old" ), '$savedref->sv has "old" key' ); } # GVAR { my $gv = $pmat->find_glob( "GVAR" ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $gv->outrefs; is( $savedref->name, "saved value of CODE slot", '$savedref->name' ); is( $savedref->sv->line, $codeline, '$savedref->sv->line' ); } # AELEM { my $av = $pmat->dumpfile->main_cv->lexvar( '@ARRAY' ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $av->outrefs; is( $savedref->name, "saved value of element [1]", '$savedref->name' ); is( $savedref->sv->pv, "b", '$savedref->sv->pv' ); } # HELEM { my $hv = $pmat->dumpfile->main_cv->lexvar( '%HASH' ); my ( $savedref ) = grep { $_->name =~ m/^saved / } $hv->outrefs; is( $savedref->name, "saved value of value {key}", '$savedref->name' ); is( $savedref->sv->pv, "oldval", '$savedref->sv->pv' ); } done_testing; ��������������������������������Devel-MAT-0.52/t/04objects.t������������������������������������������������������������������������000444��001750��001750�� 2675�14550507443� 14242� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; BEGIN { require feature; no warnings 'once'; defined $feature::feature{class} or plan skip_all => "feature 'class' is not available"; } use experimental 'class'; class AClass { field $x = "the scalar field"; field @y = ( "the array field" ); field %z = ( name => "the hash field" ); } my $obj = AClass->new; use Devel::MAT::Dumper; use Devel::MAT; my $ADDR = qr/0x[0-9a-f]+/; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); my $df = $pmat->dumpfile; { ok( my $obj = $df->sv_at( 0+$obj ), '$df has obj SV' ); is( $obj->basetype, "OBJ", 'Object base type' ); is( $obj->desc, "OBJ()", 'Object ->desc' ); my $cls = $obj->blessed; is( $cls->basetype, "HV", 'Class base type' ); is( $cls->type, "CLASS", 'Class type' ); is( $cls->desc, "STASH(2)", 'Class ->desc' ); is( scalar( my @fields = $cls->fields ), 3, 'Class has 3 fields' ); is( $fields[0]->fieldix, 0, 'Fields[0] fieldix' ); is( $fields[0]->name, '$x', 'Fields[0] name' ); my $xfield = $obj->field( '$x' ); is( $xfield->desc, "SCALAR(PV)", 'Description of $x field' ); my $yfield = $obj->field( '@y' ); is( $yfield->desc, "ARRAY(1)", 'Description of @y field' ); my $zfield = $obj->field( '%z' ); is( $zfield->desc, "HASH(1)", 'Description of %z field' ); } done_testing; �������������������������������������������������������������������Devel-MAT-0.52/t/10tool-identify.t������������������������������������������������������������������000444��001750��001750�� 4200�14550507443� 15356� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use utf8; use Test::More; use Devel::MAT::Dumper; use Devel::MAT; use Scalar::Util qw( refaddr ); my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; our %HASH = ( array => [ my $SCALAR = \"foobar" ], ); Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); ok ( scalar( grep { $_ eq "Identify" } $pmat->available_tools ), 'Identify tool is available' ); $pmat->load_tool( "Identify" ); my $graph = $pmat->inref_graph( $pmat->dumpfile->sv_at( refaddr $SCALAR ), strong => 1, direct => 1, elide => 1, ); my $got = ""; no warnings 'once'; local *Devel::MAT::Cmd::printf = sub { shift; my ( $fmt, @args ) = @_; $got .= sprintf $fmt, @args; }; Devel::MAT::Tool::Identify->walk_graph( $graph, "" ); # Due to ordering within walk_graph this string should be relatively stable # Different output on thready vs. non-thready perls my $want_thready = <<'EOR'; ├─(via RV) element [0] of ARRAY(1) at _ADDR_, which is: │ └─(via RV) value {array} of HASH(1) at _ADDR_, which is: │ └─the symbol '%main::HASH' ├─(via RV) pad temporary _NUM_ at depth 1 of CODE() at _ADDR_=main_cv, which is: │ └─the main code └─(via RV) the lexical $SCALAR at depth 1 of CODE() at _ADDR_=main_cv, which is: └─the main code EOR my $want_nonthready = <<'EOR'; ├─(via RV) a constant of CODE() at _ADDR_=main_cv, which is: │ └─the main code ├─(via RV) element [0] of ARRAY(1) at _ADDR_, which is: │ └─(via RV) value {array} of HASH(1) at _ADDR_, which is: │ └─the symbol '%main::HASH' └─(via RV) the lexical $SCALAR at depth 1 of CODE() at _ADDR_=main_cv, which is: └─the main code EOR my $want = $pmat->dumpfile->ithreads ? $want_thready : $want_nonthready; chomp $want; $want = quotemeta $want; $want =~ s/_ADDR_/0x[0-9a-f]+/g; $want =~ s/_NUM_/\\d+/g; # Various versions of perl internals might sometimes end up leaving one of # these in PL_tmpsv. In order not to upset the exact match of this test, just # trim them out $got =~ s/=tmpsv//g; like( $got, qr/^$want$/, 'string from walk_graph' ); done_testing; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/10tool-inrefs.t��������������������������������������������������������������������000444��001750��001750�� 4440�14550507443� 15037� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Test::Identity; use List::Util qw( pairgrep ); use Devel::MAT::Dumper; use Devel::MAT; my $ADDR = qr/0x[0-9a-f]+/; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); my $df = $pmat->dumpfile; $pmat->available_tools; $pmat->load_tool( "Inrefs" ); BEGIN { our @AofA = ( [] ); } { my $av = $pmat->find_symbol( '@AofA' ); my $rv = $av->elem(0); my $av2 = $rv->rv; my @inrefs_direct = $av2->inrefs_direct; is( scalar @inrefs_direct, 1, '$av2->inrefs_direct is 1' ); is( $inrefs_direct[0]->sv, $rv, 'AV inref[0] SV is $rv' ); is( $inrefs_direct[0]->strength, "strong", 'AV inref[0] strength is strong' ); is( $inrefs_direct[0]->name, "the referrant", 'AV inref[0] name' ); my @av2_inrefs = $av2->inrefs; is( ( grep { $_->name eq "element [0] via RV" } @av2_inrefs )[0]->sv, $av, '$av2 is referred to as element[0] via RV of $av' ); is_deeply( [ map { $_->sv } $av2->inrefs_indirect ], [ $av ], '$av2->inrefs_indirect' ); } { my @pvs = grep { $_->desc =~ m/^SCALAR/ and defined $_->pv and $_->pv eq $DUMPFILE } $df->heap; # There's likely only one item in this list: # 1 value of the $DUMPFILE lexical itself my ( $lexical ) = grep { grep { $_->name eq 'the lexical $DUMPFILE' } $_->inrefs } @pvs; ok( $lexical, 'Found the $DUMPFILE lexical' ); } BEGIN { our $PACKAGE_SCALAR = "some value" } { my $sv = $pmat->find_symbol( '$PACKAGE_SCALAR' ); my $svnode = $pmat->inref_graph( $sv, depth => 4 ); ok( defined $svnode, '->inref_graph $sv defined' ); my ( undef, $gvnode ) = pairgrep { $a->name eq "the scalar" } $svnode->edges_in; ok( $gvnode, '$svnode has "the scalar" edge in' ); is( $gvnode->sv->type, "GLOB", 'gvnode is a GLOB' ); my ( undef, $stashnode ) = pairgrep { $a->name eq "value {PACKAGE_SCALAR}" } $gvnode->edges_in; ok( $stashnode, '$gvnode has value {PACKAGE_SCALAR}' ); is( $stashnode->sv->type, "STASH", 'svnode stash is a STASH' ); ok( scalar( grep { $_->name eq "the default stash" } $stashnode->roots ), 'stashnode has default stash as a root' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/10tool-reachability.t��������������������������������������������������������������000444��001750��001750�� 2773�14550507443� 16220� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use List::Util qw( pairgrep ); use Scalar::Util qw( weaken ); use Devel::MAT::Dumper; use Devel::MAT; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; # Set up a reference cycle with an easy-to-find PV in it # Run this from an anonymous sub so we know the lexical is dropped do { my $av = [ undef, "This is" ]; $av->[0] = $av; $av->[1] .= " a cycle"; undef $av; }; # It might still be in the temp SV; try to overwrite it my $tmp = []; $tmp->[0] = 0; undef $tmp; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); ok( scalar( grep { $_ eq "Reachability" } $pmat->available_tools ), 'Reachability tool is available' ); $pmat->load_tool( "Reachability" ); my $df = $pmat->dumpfile; { my $defstash = $df->defstash; ok( $defstash->reachable, 'Default stash is reachable' ); my $dump = $pmat->find_symbol( "&Devel::MAT::Dumper::dump" ); ok( $dump->reachable, '&Devel::MAT::Dumper::dump is reachable' ); } SKIP: { my @pvs = grep { $_->desc eq "SCALAR(P)" and $_->pv eq join " ", qw( This is a cycle ) } $df->heap; skip "Could not find SCALAR(P) containing 'This is a cycle'", 1 unless @pvs; skip "Could not uniquely identify the PV in the cyclic leak AV", 1 unless @pvs == 1; my ( $pv ) = @pvs; ok( !$pv->reachable, "'This is a cycle' PV is not reachable" ); if( $pv->reachable ) { diag( "PV is:" ); diag( $_ ) for $pmat->identify( $pv ); } } done_testing; �����Devel-MAT-0.52/t/10tool-sizes.t���������������������������������������������������������������������000444��001750��001750�� 2060�14550507443� 14702� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Devel::MAT::Dumper; use Devel::MAT; my $DUMPFILE = __FILE__ =~ s/\.t/\.pmat/r; our $EMPTY_SVIV = 123; our @EMPTY_AV = (); our @ARRAY = ( 123, 45, [ 6, 7 ] ); Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } my $pmat = Devel::MAT->load( $DUMPFILE ); ok ( scalar( grep { $_ eq "Sizes" } $pmat->available_tools ), 'Sizes tool is available' ); $pmat->load_tool( "Sizes" ); my $sviv_size = $pmat->find_symbol( '$EMPTY_SVIV' )->size; my $av_size = $pmat->find_symbol( '@EMPTY_AV' )->size; my $av = $pmat->find_symbol( '@ARRAY' ); my $av2 = $av->elem(2)->rv; # Structure { is( scalar $av->structure_set, 4, '$av->structure_set' ); cmp_ok( $av->size, '>', $av_size, '$av->size > $av_size' ); is( $av->structure_size, $av->size + 3*$sviv_size, '$av->structure_size' ); } # Owned { is( scalar $av->owned_set, 7, '$av->owned_set' ); is( $av->owned_size, $av->size + 3*$sviv_size + $av2->size + 2*$sviv_size, '$av->owned_size' ); } done_testing; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������Devel-MAT-0.52/t/50cmd-print-table.t����������������������������������������������������������������000444��001750��001750�� 2761�14550507443� 15570� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; use Test::More; use Devel::MAT; sub lines_from(&) { my ( $code ) = @_; my @lines; no warnings 'once'; local *Devel::MAT::Cmd::printf = sub { shift; my ( $format, @args ) = @_; push @lines, sprintf $format, @args; }; $code->(); return join "", @lines; } # Basic table { is( lines_from { Devel::MAT::Cmd->print_table( [ [ "A", "B", "C" ] ] ) }, "A B C\n", 'Single row' ); is( lines_from { Devel::MAT::Cmd->print_table( [ [ "A", "B", "C" ], [ "De", "Fgh", "Ijkl" ] ] ) }, "A B C\n" . "De Fgh Ijkl\n", 'Rows are aligned' ); } # Separator { is( lines_from { Devel::MAT::Cmd->print_table( [ [ "A", "B", "C" ] ], sep => "," ) }, "A,B,C\n", 'Single row with separator' ); } # Right alignment { is( lines_from { Devel::MAT::Cmd->print_table( [ [ "A", 12, "C" ], [ "De", 3456, "Ijkl" ] ], align => [ undef, "right" ] ); }, "A 12 C\n" . "De 3456 Ijkl\n", 'Rows are aligned' ); } # Headings { no warnings 'once'; local *Devel::MAT::Cmd::format_heading = sub { return "*$_[1]*" }; is( lines_from { Devel::MAT::Cmd->print_table( [ [ "1", "2" ] ], headings => [ "A", "B" ] ) }, "*A* *B*\n" . "1 2\n", 'Row with headings' ); } # Indent { is( lines_from { Devel::MAT::Cmd->print_table( [ [ "x", "y", "z" ] ], indent => 3 ) }, " x y z\n", 'Row with indent' ); } done_testing; ���������������Devel-MAT-0.52/t/99pod.t����������������������������������������������������������������������������000444��001750��001750�� 256�14550507443� 13362� 0����������������������������������������������������������������������������������������������������ustar�00leo�����������������������������leo�����������������������������000000��000000�������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!/usr/bin/perl use v5.14; use warnings; 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(); ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������