Devel-MAT-Dumper-0.47000755001750001750 014406345310 13075 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/Build.PL000444001750001750 113014406345310 14521 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'Devel::MAT::Dumper', requires => { 'File::Spec' => 0, 'perl' => '5.010', # various XS failures on 5.8 }, test_requires => { 'Test::More' => '0.88', # done_testing }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, 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-Dumper-0.47/Changes000444001750001750 665514406345310 14541 0ustar00leoleo000000000000Revision history for Devel-MAT-Dumper 0.47 2023-03-21 [CHANGES] * Also dump the mortals list to the dumpfile * Use mro_get_linear_isa() to perform the package helper walk on objects rather than reïmplementing our own bad DFS * Delete the now-unused legacy helper API support (RT147233, RT147085, RT145110) 0.46 2022-09-12 [CHANGES] * Bugfixes to SYNOPSIS example for latest v0.44 API shape * Make sure to run package helpers for superclasses too * No longer follow legacy %HELPER_PER_{PACKAGE,MAGIC} hashes; warn at dump time if they are nonempty * Defined experimental new v0.5 dumpfile version for `feature-class` perl branch. This remains experimental while the branch is. [BUGFIXES] * Fix for module load order problems, by not overwriting entries in PL_modglobal if already present 0.45 2022-04-02 [CHANGES] * Added `DMD_ADD_ROOT()` * Additionally dump the `->mg_virtual` field of MAGIC structures 0.44 2022-03-16 [CHANGES] * Defined a whole new mechanism for dumping information about C-level structs that are not Perl-visible SVs * Defined a better API for creating helper functions. New API is opt-in by defining a `WANT_DMD_API_044` macro * Also ignore SAVEt_STRLEN_SMALL and SAVEt_SAVESWITCHSTACK on the savestack 0.43 2022-02-26 [CHANGES] * Ignore SAVEt_FREEPV on the savestack * Add support for perl 5.35's boolean types, as indicated by SvIsBOOL() 0.42 2020-04-24 [CHANGES] * Support a -dump_at_WARN flag * Add a new CODEx type to handle nonzero PadnameFLAGS() (RT132414) [BUGFIXES] * Ensure perls before 5.18 still write context information 0.41 2019-08-14 23:25:22 [CHANGES] * Define another thirdparty XS extension for setting dumper helpers per blessed package * Attach SIGABRT using an unsafe signal handler so it can see the inner workings of C or XS code * Ignore some unimportant savestack entry types 0.40 2019-02-02 17:14:49 [CHANGES] * Define an SV extension to notate extra SV information when perl is compiled with -DDEBUG_LEAKING_SCALARS [BUGFIXES] * Perl 5.29.7 removed two UTF-8-related root SVs * Don't dump the mortal UV+PVs that are generated as a side-effect of calling dump_optree() on custom ops (related to RT128222) 0.39 2019-01-16 14:20:35 [BUGFIXES] * Handle the incorrect value of AvFILL(PL_curstack) * Avoid some (harmless) compiler warnings 0.38 2019-01-14 17:44:15 [CHANGES] * Capture saved values of 'local' variables and aggregate slots on perl 5.18+ (RT125918) * Add an entire new (experimental) mechanism for thirdparty XS modules to provide additional annotations for SV to SV references * Define PMAT format 0.4, which adds a table of SV extension sizes 0.37 2018-07-24 17:55:09 [CHANGES] * Define PMAT format 0.3, which represents undef SCALARs more efficiently [BUGFIXES] * Don't skip SVt_NULL SVs as they are valid undefs (RT125915) 0.36 2018-07-16 20:21:41 [CHANGES] * Split from Devel-MAT distribution Devel-MAT-Dumper-0.47/LICENSE000444001750001750 4375514406345310 14275 0ustar00leoleo000000000000This software is copyright (c) 2023 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) 2023 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) 2023 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-Dumper-0.47/MANIFEST000444001750001750 34414406345310 14344 0ustar00leoleo000000000000Build.PL Changes doc/format-v0.5.txt doc/format.txt lib/Devel/MAT/Dumper.pm lib/Devel/MAT/Dumper.xs lib/Devel/MAT/Dumper/Helper.pm LICENSE MANIFEST This list of files META.json META.yml README t/00use.t t/01header.t t/99pod.t Devel-MAT-Dumper-0.47/META.json000444001750001750 243014406345310 14652 0ustar00leoleo000000000000{ "abstract" : "write a heap dump file for later analysis", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4231", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Devel-MAT-Dumper", "prereqs" : { "build" : { "requires" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "requires" : { "File::Spec" : "0", "perl" : "5.010" } }, "test" : { "requires" : { "Test::More" : "0.88" } } }, "provides" : { "Devel::MAT::Dumper" : { "file" : "lib/Devel/MAT/Dumper.pm", "version" : "0.47" }, "Devel::MAT::Dumper::Helper" : { "file" : "lib/Devel/MAT/Dumper/Helper.pm", "version" : "0.47" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.47", "x_serialization_backend" : "JSON::PP version 4.07" } Devel-MAT-Dumper-0.47/META.yml000444001750001750 143314406345310 14504 0ustar00leoleo000000000000--- abstract: 'write a heap dump file for later analysis' author: - 'Paul Evans ' build_requires: ExtUtils::CBuilder: '0' Test::More: '0.88' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4231, 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-Dumper provides: Devel::MAT::Dumper: file: lib/Devel/MAT/Dumper.pm version: '0.47' Devel::MAT::Dumper::Helper: file: lib/Devel/MAT/Dumper/Helper.pm version: '0.47' requires: File::Spec: '0' perl: '5.010' resources: license: http://dev.perl.org/licenses/ version: '0.47' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Devel-MAT-Dumper-0.47/README000444001750001750 1134614406345310 14137 0ustar00leoleo000000000000NAME Devel::MAT::Dumper - write a heap dump file for later analysis SYNOPSIS use Devel::MAT::Dumper; Devel::MAT::Dumper::dump( "path/to/the/file.pmat" ); DESCRIPTION This module provides the memory-dumping function that creates a heap dump file which can later be read by Devel::MAT::Dumpfile. It provides a single function which is not exported, which writes a file to the given path. The dump file will contain a representation of every SV in Perl's arena, providing information about pointers between them, as well as other information about the state of the process at the time it was created. It contains a snapshot of the process at that moment in time, which can later be loaded and analysed by various tools using Devel::MAT::Dumpfile. This module used to be part of the main Devel::MAT distribution but is now in its own one so that it can be installed independently on servers or other locations where perl processes need to inspected but analysis tools can be run elsewhere. IMPORT OPTIONS The following import options control the behaviour of the module. They may primarily be useful when used in the -M perl option: -dump_at_DIE Installs a handler for the special __DIE__ signal to write a dump file when die() is about to cause a fatal signal. This is more reliable at catching the callstack and memory state than using an END block. $ perl -MDevel::MAT::Dumper=-dump_at_DIE ... -dump_at_WARN Installs a handler for the special __WARN__ signal to write a dump file when perl prints a warning. $ perl -MDevel::MAT::Dumper=-dump_at_WARN ... It is likely useful to combine this with the NNN numbering feature of the -file argument, to ensure that later warnings don't overwrite a particular file. -dump_at_END Installs an END block which writes a dump file at END time, just before the interpreter exits. $ perl -MDevel::MAT::Dumper=-dump_at_END ... -dump_at_SIGQUIT Installs a handler for SIGQUIT to write a dump file if the signal is received. The signal handler will remain in place and can be used several times. $ perl -MDevel::MAT::Dumper=-dump_at_SIGQUIT ... Take care if you are using the key combination on a terminal to send this signal to a foreground process, because if it has fork()ed any background workers or similar, the signal will also be delivered to those as well. -dump_at_SIGNAME Installs a handler for the named signal (e.g. SIGABRT, SIGINT) to write a dump file if the signal is received. After dumping the file, the signal handler is removed and the signal re-raised. $ perl -MDevel::MAT::Dumper=-dump_at_SIGABRT ... Note that SIGABRT uses an "unsafe" signal handler (i.e. not deferred until the next perl op), so it can capture the full context of any ongoing XS or C library operations. -file $PATH Sets the name of the file which is automatically dumped; defaults to basename $0.pmat if not supplied. $ perl -MDevel::MAT::Dumper=-file,foo.pmat ... In the special case that $0 is exactly the string -e or -E, the filename will be prefixed with perl so as not to create files whose names begin with a leading hyphen, as this confuses some commandline parsers. $ perl -MDevel::MAT::Dumper=-dump_at_END -E 'say "hello"' hello Dumping to perl-e.pmat because of END If the pattern contains NNN, this will be replaced by a unique serial number per written file, starting from 0. This may be helpful in the case of DIE, WARN or SIGQUIT handlers, which could be invoked multiple times. The file name is converted to an absolute path immediately, so if the running program later calls chdir(), it will still be generated in the directory the program started from rather than the one it happens to be in at the time. -max_string Sets the maximum length of string buffer to dump from PVs; defaults to 256 if not supplied. Use a negative size to dump the entire buffer of every PV regardless of size. -eager_open Opens the dump file immediately at import time, instead of waiting until the time it actually writes the heap dump. This may be useful if the process changes user ID, or to debug problems involving too many open filehandles. FUNCTIONS These functions are not exported, they must be called fully-qualified. dump dump( $path ) Writes a heap dump to the named file dumpfh dumpfh( $fh ) Writes a heap dump to the given filehandle (which must be a plain OS-level filehandle, though does not need to be a regular file, or seekable). AUTHOR Paul Evans Devel-MAT-Dumper-0.47/doc000755001750001750 014406345310 13642 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/doc/format-v0.5.txt000444001750001750 1703514406345310 16544 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 5 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: PADNAME_FIELD UINT PADIX UINT FIELDIX PTR FIELDSTASH 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: OBJ Header(1+I): UINT COUNT = $n PTRs(0) STRs(0) Body: {PTR FIELD}*$n type: CLASS [extends fields of a stash] PTRs(1) ADJUST_BLOCKS 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-Dumper-0.47/doc/format.txt000444001750001750 1647614406345310 16066 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 Mortals: UINT COUNT = $n {PTR ELEM}*$n UINT FLOOR Devel-MAT-Dumper-0.47/lib000755001750001750 014406345310 13643 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/lib/Devel000755001750001750 014406345310 14702 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/lib/Devel/MAT000755001750001750 014406345310 15323 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/lib/Devel/MAT/Dumper.pm000444001750001750 2015514406345310 17275 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-2018 -- leonerd@leonerd.org.uk package Devel::MAT::Dumper; use strict; use warnings; our $VERSION = '0.47'; use File::Basename qw( basename ); use File::Spec; use POSIX; require XSLoader; XSLoader::load( __PACKAGE__, $VERSION ); =head1 NAME C - write a heap dump file for later analysis =head1 SYNOPSIS use Devel::MAT::Dumper; Devel::MAT::Dumper::dump( "path/to/the/file.pmat" ); =head1 DESCRIPTION This module provides the memory-dumping function that creates a heap dump file which can later be read by L. It provides a single function which is not exported, which writes a file to the given path. The dump file will contain a representation of every SV in Perl's arena, providing information about pointers between them, as well as other information about the state of the process at the time it was created. It contains a snapshot of the process at that moment in time, which can later be loaded and analysed by various tools using C. This module used to be part of the main L distribution but is now in its own one so that it can be installed independently on servers or other locations where perl processes need to inspected but analysis tools can be run elsewhere. =cut =head1 IMPORT OPTIONS The following C options control the behaviour of the module. They may primarily be useful when used in the C<-M> perl option: =head2 -dump_at_DIE Installs a handler for the special C<__DIE__> signal to write a dump file when C is about to cause a fatal signal. This is more reliable at catching the callstack and memory state than using an C block. $ perl -MDevel::MAT::Dumper=-dump_at_DIE ... =head2 -dump_at_WARN Installs a handler for the special C<__WARN__> signal to write a dump file when perl prints a warning. $ perl -MDevel::MAT::Dumper=-dump_at_WARN ... It is likely useful to combine this with the C numbering feature of the C<-file> argument, to ensure that later warnings don't overwrite a particular file. =head2 -dump_at_END Installs an C block which writes a dump file at C time, just before the interpreter exits. $ perl -MDevel::MAT::Dumper=-dump_at_END ... =head2 -dump_at_SIGQUIT Installs a handler for C to write a dump file if the signal is received. The signal handler will remain in place and can be used several times. $ perl -MDevel::MAT::Dumper=-dump_at_SIGQUIT ... Take care if you are using the C<< >> key combination on a terminal to send this signal to a foreground process, because if it has Ced any background workers or similar, the signal will also be delivered to those as well. =head2 -dump_at_SIGI Installs a handler for the named signal (e.g. C, C) to write a dump file if the signal is received. After dumping the file, the signal handler is removed and the signal re-raised. $ perl -MDevel::MAT::Dumper=-dump_at_SIGABRT ... Note that C uses an "unsafe" signal handler (i.e. not deferred until the next perl op), so it can capture the full context of any ongoing XS or C library operations. =head2 -file $PATH Sets the name of the file which is automatically dumped; defaults to basename F<$0.pmat> if not supplied. $ perl -MDevel::MAT::Dumper=-file,foo.pmat ... In the special case that C<$0> is exactly the string C<-e> or C<-E>, the filename will be prefixed with C so as not to create files whose names begin with a leading hyphen, as this confuses some commandline parsers. $ perl -MDevel::MAT::Dumper=-dump_at_END -E 'say "hello"' hello Dumping to perl-e.pmat because of END If the pattern contains C, this will be replaced by a unique serial number per written file, starting from 0. This may be helpful in the case of C, C or C handlers, which could be invoked multiple times. The file name is converted to an absolute path immediately, so if the running program later calls C, it will still be generated in the directory the program started from rather than the one it happens to be in at the time. =head2 -max_string Sets the maximum length of string buffer to dump from PVs; defaults to 256 if not supplied. Use a negative size to dump the entire buffer of every PV regardless of size. =head2 -eager_open Opens the dump file immediately at C time, instead of waiting until the time it actually writes the heap dump. This may be useful if the process changes user ID, or to debug problems involving too many open filehandles. =cut our $MAX_STRING = 256; # used by XS code my $basename = basename( $0 ); $basename = "perl$basename" if $basename =~ m/^-e$/i; # RT119164 my $dumpfile_name = File::Spec->rel2abs( "$basename.pmat" ); my $dumpfh; my $next_serial = 0; my $dump_at_END; END { return unless $dump_at_END; if( $dumpfh ) { Devel::MAT::Dumper::dumpfh( $dumpfh ); } else { ( my $file = $dumpfile_name ) =~ s/NNN/$next_serial++/e; print STDERR "Dumping to $file because of END\n"; Devel::MAT::Dumper::dump( $file ); } } sub import { my $pkg = shift; my $eager_open; while( @_ ) { my $sym = shift; if( $sym eq "-dump_at_DIE" ) { my $old_DIE = $SIG{__DIE__}; $SIG{__DIE__} = sub { local $SIG{__DIE__} = $old_DIE if defined $old_DIE; return if $^S or !defined $^S; # only catch real process-fatal errors ( my $file = $dumpfile_name ) =~ s/NNN/$next_serial++/e; print STDERR "Dumping to $file because of DIE\n"; Devel::MAT::Dumper::dump( $file ); die @_; }; } elsif( $sym eq "-dump_at_WARN" ) { my $old_WARN = $SIG{__WARN__}; $SIG{__WARN__} = sub { local $SIG{__WARN__} = $old_WARN if defined $old_WARN; ( my $file = $dumpfile_name ) =~ s/NNN/$next_serial++/e; print STDERR "Dumping to $file because of WARN\n"; Devel::MAT::Dumper::dump( $file ); warn @_; }; } elsif( $sym eq "-dump_at_END" ) { $dump_at_END++; } elsif( $sym eq "-dump_at_SIGQUIT" ) { $SIG{QUIT} = sub { ( my $file = $dumpfile_name ) =~ s/NNN/$next_serial++/e; print STDERR "Dumping to $file because of SIGQUIT\n"; Devel::MAT::Dumper::dump( $file ); }; } elsif( $sym =~ m/^-dump_at_SIG(\S+)$/ ) { my $signal = $1; exists $SIG{$signal} or die "Unrecognised signal name SIG$signal\n"; my $handler = sub { ( my $file = $dumpfile_name ) =~ s/NNN/$next_serial++/e; print STDERR "Dumping to $file because of SIG$signal\n"; Devel::MAT::Dumper::dump( $file ); undef $SIG{$signal}; kill $signal => $$; }; if( $signal eq "ABRT" ) { # Install SIGABRT handler using unsafe signal so it can see # inner workings of C code properly my $sigaction = POSIX::SigAction->new( $handler ); $sigaction->safe(0); POSIX::sigaction( POSIX::SIGABRT, $sigaction ); } else { $SIG{$signal} = $handler; } } elsif( $sym eq "-file" ) { $dumpfile_name = File::Spec->rel2abs( shift ); } elsif( $sym eq "-max_string" ) { $MAX_STRING = shift; } elsif( $sym eq "-eager_open" ) { $eager_open++; } else { die "Unrecognised $pkg import symbol $sym\n"; } } if( $eager_open ) { open $dumpfh, ">", $dumpfile_name or die "Cannot open $dumpfile_name for writing - $!\n"; } } =head1 FUNCTIONS These functions are not exported, they must be called fully-qualified. =head2 dump dump( $path ) Writes a heap dump to the named file =head2 dumpfh dumpfh( $fh ) Writes a heap dump to the given filehandle (which must be a plain OS-level filehandle, though does not need to be a regular file, or seekable). =cut =head1 AUTHOR Paul Evans =cut 0x55AA; Devel-MAT-Dumper-0.47/lib/Devel/MAT/Dumper.xs000444001750001750 12317514406345310 17341 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 */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include #include #include #include #define FORMAT_VERSION_MAJOR 0 #define FORMAT_VERSION_MINOR 4 /* Actually 5 if HAVE_FEATURE_CLASS */ #ifndef SvOOK_offset # define SvOOK_offset(sv, len) STMT_START { len = SvIVX(sv); } STMT_END #endif #ifndef CxHASARGS # define CxHASARGS(cx) ((cx)->blk_sub.hasargs) #endif #ifndef OpSIBLING # define OpSIBLING(o) ((o)->op_sibling) #endif #ifndef HvNAMELEN # define HvNAMELEN(hv) (strlen(HvNAME(hv))) #endif /* This technically applies all the way back to 5.6 if we need it... */ #if (PERL_REVISION == 5) && (PERL_VERSION == 10) && (PERL_SUBVERSION == 0) # define CxOLD_OP_TYPE(cx) ((cx)->blk_eval.old_op_type) #endif #ifdef ObjectFIELDS # define HAVE_FEATURE_CLASS #endif static int max_string; #if NVSIZE == 8 # define PMAT_NVSIZE 8 #else # define PMAT_NVSIZE 10 #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 26) # define SAVEt_ARG0_MAX SAVEt_REGCONTEXT # define SAVEt_ARG1_MAX SAVEt_FREEPADNAME # define SAVEt_ARG2_MAX SAVEt_APTR # define SAVEt_MAX SAVEt_DELETE /* older perls already defined SAVEt_ARG_MAX */ #elif (PERL_REVISION == 5) && (PERL_VERSION >= 22) # define SAVEt_MAX SAVEt_DELETE #elif (PERL_REVISION == 5) && (PERL_VERSION >= 20) # define SAVEt_MAX SAVEt_AELEM #elif (PERL_REVISION == 5) && (PERL_VERSION >= 18) # define SAVEt_MAX SAVEt_GVSLOT #endif static SV *tmpsv; /* A temporary SV for internal purposes. Will not get dumped */ static SV *make_tmp_iv(IV iv) { if(!tmpsv) tmpsv = newSV(0); sv_setiv(tmpsv, iv); return tmpsv; } static uint8_t sv_sizes[] = { /* Header PTRs, STRs */ 4 + PTRSIZE + UVSIZE, 1, 0, /* common SV */ UVSIZE, 8, 2, /* GLOB */ 1 + 2*UVSIZE + PMAT_NVSIZE, 1, 1, /* SCALAR */ 1, 2, 0, /* REF */ 1 + UVSIZE, 0, 0, /* ARRAY + has body */ UVSIZE, 1, 0, /* HASH + has body */ UVSIZE + 0, 1 + 4, 0 + 1, /* STASH = extends HASH */ 5 + UVSIZE + PTRSIZE, 5, 2, /* CODE + has body */ 2*UVSIZE, 3, 0, /* IO */ 1 + 2*UVSIZE, 1, 0, /* LVALUE */ 0, 0, 0, /* REGEXP */ 0, 0, 0, /* FORMAT */ 0, 0, 0, /* INVLIST */ 0, 0, 0, /* UNDEF */ 0, 0, 0, /* YES */ 0, 0, 0, /* NO */ #ifdef HAVE_FEATURE_CLASS UVSIZE, 0, 0, /* OBJECT */ UVSIZE + 0, 1+4+1, 0+1, /* CLASS = extends STASH */ #endif }; static uint8_t svx_sizes[] = { /* Header PTRs STRs */ 2, 3, 0, /* magic */ 0, 1, 0, /* saved SV */ 0, 1, 0, /* saved AV */ 0, 1, 0, /* saved HV */ UVSIZE, 1, 0, /* saved AELEM */ 0, 2, 0, /* saved HELEM */ 0, 1, 0, /* saved CV */ 0, 1, 1, /* SV->SV annotation */ 2*UVSIZE, 0, 1, /* SV leak report */ }; static uint8_t ctx_sizes[] = { /* Header PTRs STRs */ 1 + UVSIZE, 0, 1, /* common CTX */ 4, 2, 0, /* SUB */ 0, 0, 0, /* TRY */ 0, 1, 0, /* EVAL */ }; // These do NOT agree with perl's SVt_* constants! enum PMAT_SVt { PMAT_SVtGLOB = 1, PMAT_SVtSCALAR, PMAT_SVtREF, PMAT_SVtARRAY, PMAT_SVtHASH, PMAT_SVtSTASH, PMAT_SVtCODE, PMAT_SVtIO, PMAT_SVtLVALUE, PMAT_SVtREGEXP, PMAT_SVtFORMAT, PMAT_SVtINVLIST, PMAT_SVtUNDEF, PMAT_SVtYES, PMAT_SVtNO, PMAT_SVtOBJ, PMAT_SVtCLASS, PMAT_SVtSTRUCT = 0x7F, /* fields as described by corresponding META_STRUCT */ /* TODO: emit these in DMD_helper.h */ PMAT_SVxMAGIC = 0x80, PMAT_SVxSAVED_SV, PMAT_SVxSAVED_AV, PMAT_SVxSAVED_HV, PMAT_SVxSAVED_AELEM, PMAT_SVxSAVED_HELEM, PMAT_SVxSAVED_CV, PMAT_SVxSVSVnote, PMAT_SVxDEBUGREPORT, PMAT_SVtMETA_STRUCT = 0xF0, }; enum PMAT_CODEx { PMAT_CODEx_CONSTSV = 1, PMAT_CODEx_CONSTIX, PMAT_CODEx_GVSV, PMAT_CODEx_GVIX, PMAT_CODEx_PADNAME, /* PMAT_CODEx_PADSV was 6 */ PMAT_CODEx_PADNAMES = 7, PMAT_CODEx_PAD, PMAT_CODEx_PADNAME_FLAGS, PMAT_CODEx_PADNAME_FIELD, }; enum PMAT_CLASSx { PMAT_CLASSx_FIELD = 1, }; enum PMAT_CTXt { PMAT_CTXtSUB = 1, PMAT_CTXtTRY, PMAT_CTXtEVAL, }; /* API v0.44 */ typedef struct { FILE *fh; int next_structid; HV *structdefs; } DMDContext; typedef int DMD_Helper(pTHX_ DMDContext *ctx, SV const *sv); static HV *helper_per_package; typedef int DMD_MagicHelper(pTHX_ DMDContext *ctx, SV const *sv, MAGIC *mg); static HV *helper_per_magic; static void write_u8(FILE *fh, uint8_t v) { fwrite(&v, 1, 1, fh); } /* We just write multi-byte integers in native endian, because we've declared * in the file flags what the platform byte direction is anyway */ static void write_u32(FILE *fh, uint32_t v) { fwrite(&v, 4, 1, fh); } static void write_u64(FILE *fh, uint64_t v) { fwrite(&v, 8, 1, fh); } static void write_uint(FILE *fh, UV v) { #if UVSIZE == 8 write_u64(fh, v); #elif UVSIZE == 4 write_u32(fh, v); #else # error "Expected UVSIZE to be either 4 or 8" #endif } static void write_ptr(FILE *fh, const void *ptr) { fwrite(&ptr, sizeof ptr, 1, fh); } static void write_svptr(FILE *fh, const SV *ptr) { fwrite(&ptr, sizeof ptr, 1, fh); } static void write_nv(FILE *fh, NV v) { #if NVSIZE == 8 fwrite(&v, sizeof(NV), 1, fh); #else // long double is 10 bytes but sizeof() may be 16. fwrite(&v, 10, 1, fh); #endif } static void write_strn(FILE *fh, const char *s, size_t len) { write_uint(fh, len); fwrite(s, len, 1, fh); } static void write_str(FILE *fh, const char *s) { if(s) write_strn(fh, s, strlen(s)); else write_uint(fh, -1); } #define PMOP_pmreplroot(o) o->op_pmreplrootu.op_pmreplroot #if (PERL_REVISION == 5) && (PERL_VERSION < 14) # define OP_CLASS(o) (PL_opargs[o->op_type] & OA_CLASS_MASK) #endif static void dump_optree(FILE *fh, const CV *cv, OP *o); static void dump_optree(FILE *fh, const CV *cv, OP *o) { OP *kid; switch(o->op_type) { case OP_CONST: case OP_METHOD_NAMED: #ifdef USE_ITHREADS if(o->op_targ) { write_u8(fh, PMAT_CODEx_CONSTIX); write_uint(fh, o->op_targ); } #else write_u8(fh, PMAT_CODEx_CONSTSV); write_svptr(fh, cSVOPx(o)->op_sv); #endif break; case OP_AELEMFAST: case OP_GVSV: case OP_GV: #ifdef USE_ITHREADS write_u8(fh, PMAT_CODEx_GVIX); write_uint(fh, o->op_targ ? o->op_targ : cPADOPx(o)->op_padix); #else write_u8(fh, PMAT_CODEx_GVSV); write_svptr(fh, cSVOPx(o)->op_sv); #endif break; } if(o->op_flags & OPf_KIDS) { for (kid = ((UNOP*)o)->op_first; kid; kid = OpSIBLING(kid)) { dump_optree(fh, cv, kid); } } if(OP_CLASS(o) == OA_PMOP && #if (PERL_REVISION == 5) && ((PERL_VERSION > 25) || ((PERL_VERSION == 25) && (PERL_SUBVERSION >= 6))) /* The OP_PUSHRE behaviour was moved to OP_SPLIT in 5.25.6 */ o->op_type != OP_SPLIT && #else o->op_type != OP_PUSHRE && #endif (kid = PMOP_pmreplroot(cPMOPx(o)))) dump_optree(fh, cv, kid); } static void write_common_sv(FILE *fh, const SV *sv, size_t size) { // Header write_svptr(fh, sv); write_u32(fh, SvREFCNT(sv)); write_uint(fh, sizeof(SV) + size); // PTRs write_svptr(fh, SvOBJECT(sv) ? (SV*)SvSTASH(sv) : NULL); } static void write_private_gv(FILE *fh, const GV *gv) { write_common_sv(fh, (const SV *)gv, sizeof(XPVGV) + (isGV_with_GP(gv) ? sizeof(struct gp) : 0)); if(isGV_with_GP(gv)) { // Header write_uint(fh, GvLINE(gv)); // PTRs write_svptr(fh, (SV*)GvSTASH(gv)); write_svptr(fh, GvSV(gv)); write_svptr(fh, (SV*)GvAV(gv)); write_svptr(fh, (SV*)GvHV(gv)); write_svptr(fh, (SV*)GvCV(gv)); write_svptr(fh, (SV*)GvEGV(gv)); write_svptr(fh, (SV*)GvIO(gv)); write_svptr(fh, (SV*)GvFORM(gv)); // STRs write_str(fh, GvNAME(gv)); write_str(fh, GvFILE(gv)); } else { // Header write_uint(fh, 0); // PTRs write_svptr(fh, (SV*)GvSTASH(gv)); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); // STRs write_str(fh, NULL); write_str(fh, NULL); } } static void write_private_sv(FILE *fh, const SV *sv) { size_t size = 0; switch(SvTYPE(sv)) { case SVt_IV: break; case SVt_NV: size += sizeof(NV); break; case SVt_PV: size += sizeof(XPV) - STRUCT_OFFSET(XPV, xpv_cur); break; case SVt_PVIV: size += sizeof(XPVIV) - STRUCT_OFFSET(XPV, xpv_cur); break; case SVt_PVNV: size += sizeof(XPVNV) - STRUCT_OFFSET(XPV, xpv_cur); break; case SVt_PVMG: size += sizeof(XPVMG); break; } if(SvPOK(sv)) size += SvLEN(sv); if(SvOOK(sv)) { STRLEN offset; SvOOK_offset(sv, offset); size += offset; } write_common_sv(fh, sv, size); // Header write_u8(fh, (SvIOK(sv) ? 0x01 : 0) | (SvUOK(sv) ? 0x02 : 0) | (SvNOK(sv) ? 0x04 : 0) | (SvPOK(sv) ? 0x08 : 0) | (SvUTF8(sv) ? 0x10 : 0)); write_uint(fh, SvIOK(sv) ? SvUVX(sv) : 0); write_nv(fh, SvNOK(sv) ? SvNVX(sv) : 0.0); write_uint(fh, SvPOK(sv) ? SvCUR(sv) : 0); // PTRs #if (PERL_REVISION == 5) && (PERL_VERSION <= 20) write_svptr(fh, (SV *)SvOURSTASH(sv)); #else write_svptr(fh, NULL); #endif // STRs if(SvPOK(sv)) { STRLEN len = SvCUR(sv); if(max_string > -1 && len > max_string) len = max_string; write_strn(fh, SvPVX((SV *)sv), len); } else write_str(fh, NULL); } static void write_private_rv(FILE *fh, const SV *rv) { write_common_sv(fh, rv, 0); // Header write_u8(fh, (SvWEAKREF(rv) ? 0x01 : 0)); // PTRs write_svptr(fh, SvRV((SV *)rv)); #if (PERL_REVISION == 5) && (PERL_VERSION <= 20) write_svptr(fh, (SV *)SvOURSTASH(rv)); #else write_svptr(fh, NULL); #endif } static void write_private_av(FILE *fh, const AV *av) { /* Perl doesn't bother to keep AvFILL(PL_curstack) updated for efficiency * reasons, so if we're looking at PL_curstack we'll use a different method * to calculate this */ int len = (av == PL_curstack) ? (PL_stack_sp - PL_stack_base + 1) : AvFILLp(av) + 1; write_common_sv(fh, (const SV *)av, sizeof(XPVAV) + sizeof(SV *) * (AvMAX(av) + 1)); // Header write_uint(fh, len); write_u8(fh, (!AvREAL(av) ? 0x01 : 0)); // Body int i; for(i = 0; i < len; i++) write_svptr(fh, AvARRAY(av)[i]); } static int write_hv_header(FILE *fh, const HV *hv, size_t size) { size += sizeof(XPVHV); int nkeys = 0; if(HvARRAY(hv)) { int bucket; for(bucket = 0; bucket <= HvMAX(hv); bucket++) { HE *he; size += sizeof(HE *); for(he = HvARRAY(hv)[bucket]; he; he = he->hent_next) { size += sizeof(HE); nkeys++; if(!HvSHAREKEYS(hv)) size += sizeof(HEK) + he->hent_hek->hek_len + 2; } } } write_common_sv(fh, (const SV *)hv, size); return nkeys; } static void write_hv_body_elems(FILE *fh, const HV *hv) { // The shared string table (PL_strtab) has shared strings as keys but its // values are not SV pointers; they are refcounts. Pretend these values are // NULL. bool is_strtab = (hv == PL_strtab); int bucket; for(bucket = 0; bucket <= HvMAX(hv); bucket++) { HE *he; for(he = HvARRAY(hv)[bucket]; he; he = he->hent_next) { STRLEN len; char *key = HePV(he, len); write_strn(fh, key, len); write_svptr(fh, is_strtab ? NULL : HeVAL(he)); } } } static void write_private_hv(FILE *fh, const HV *hv) { int nkeys = write_hv_header(fh, hv, 0); // Header write_uint(fh, nkeys); // PTRs if(SvOOK(hv) && HvAUX(hv)) write_svptr(fh, (SV*)HvAUX(hv)->xhv_backreferences); else write_svptr(fh, NULL); // Body if(HvARRAY(hv) && nkeys) write_hv_body_elems(fh, hv); } static void write_stash_ptrs(FILE *fh, const HV *stash) { struct mro_meta *mro_meta = HvAUX(stash)->xhv_mro_meta; if(SvOOK(stash) && HvAUX(stash)) write_svptr(fh, (SV*)HvAUX(stash)->xhv_backreferences); else write_svptr(fh, NULL); if(mro_meta) { #if (PERL_REVISION == 5) && (PERL_VERSION >= 12) write_svptr(fh, (SV*)mro_meta->mro_linear_all); write_svptr(fh, mro_meta->mro_linear_current); #else write_svptr(fh, NULL); write_svptr(fh, NULL); #endif write_svptr(fh, (SV*)mro_meta->mro_nextmethod); #if (PERL_REVISION == 5) && ((PERL_VERSION > 10) || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)) write_svptr(fh, (SV*)mro_meta->isa); #else write_svptr(fh, NULL); #endif } else { write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); write_svptr(fh, NULL); } } static void write_private_stash(FILE *fh, const HV *stash) { struct mro_meta *mro_meta = HvAUX(stash)->xhv_mro_meta; int nkeys = write_hv_header(fh, stash, sizeof(struct xpvhv_aux) + (mro_meta ? sizeof(struct mro_meta) : 0)); // Header // HASH write_uint(fh, nkeys); // PTRs write_stash_ptrs(fh, stash); // STRs write_str(fh, HvNAME(stash)); // Body if(HvARRAY(stash)) write_hv_body_elems(fh, stash); } static void write_private_cv(FILE *fh, const CV *cv) { bool is_xsub = CvISXSUB(cv); PADLIST *pl = (is_xsub ? NULL : CvPADLIST(cv)); /* If the optree contains custom ops, the OP_CLASS() macro will allocate * a mortal SV. We'll need to FREETMPS it to ensure we don't dump it * accidentally */ SAVETMPS; // TODO: accurate size information on CVs write_common_sv(fh, (const SV *)cv, sizeof(XPVCV)); // Header int line = 0; OP *start; if(!CvISXSUB(cv) && !CvCONST(cv) && (start = CvSTART(cv))) { if(start->op_type == OP_NEXTSTATE) line = CopLINE((COP*)start); } write_uint(fh, line); write_u8(fh, (CvCLONE(cv) ? 0x01 : 0) | (CvCLONED(cv) ? 0x02 : 0) | (is_xsub ? 0x04 : 0) | (CvWEAKOUTSIDE(cv) ? 0x08 : 0) | #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) (CvCVGV_RC(cv) ? 0x10 : 0) | #else /* Prior to 5.14, CvANON() was used to indicate this */ (CvANON(cv) ? 0x10 : 0) | #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 22) (CvLEXICAL(cv) ? 0x20 : 0) | #endif 0); if(!is_xsub && !CvCONST(cv)) write_ptr(fh, CvROOT(cv)); else write_ptr(fh, NULL); write_u32(fh, CvDEPTH(cv)); // PTRs write_svptr(fh, (SV*)CvSTASH(cv)); #if (PERL_REVISION == 5) && (PERL_VERSION >= 18) if(CvNAMED(cv)) write_svptr(fh, NULL); else #endif write_svptr(fh, (SV*)CvGV(cv)); write_svptr(fh, (SV*)CvOUTSIDE(cv)); #if (PERL_REVISION == 5) && (PERL_VERSION >= 20) /* Padlists are no longer heap-allocated on 5.20+ */ write_svptr(fh, NULL); #else write_svptr(fh, (SV*)(pl)); #endif if(CvCONST(cv)) write_svptr(fh, (SV*)CvXSUBANY(cv).any_ptr); else write_svptr(fh, NULL); // STRs if(CvFILE(cv)) write_str(fh, CvFILE(cv)); else write_str(fh, ""); #if (PERL_REVISION == 5) && (PERL_VERSION >= 18) if(CvNAMED(cv)) write_str(fh, HEK_KEY(CvNAME_HEK((CV*)cv))); else #endif write_str(fh, NULL); // Body if(cv == PL_main_cv && PL_main_root) /* The PL_main_cv does not have a CvROOT(); instead that is found in * PL_main_root */ dump_optree(fh, cv, PL_main_root); else if(!is_xsub && !CvCONST(cv) && CvROOT(cv)) dump_optree(fh, cv, CvROOT(cv)); #if (PERL_REVISION == 5) && (PERL_VERSION >= 18) if(pl) { PADNAME **names = PadlistNAMESARRAY(pl); PAD **pads = PadlistARRAY(pl); int depth, i; write_u8(fh, PMAT_CODEx_PADNAMES); # if (PERL_VERSION > 20) write_svptr(fh, NULL); { PADNAME **padnames = PadnamelistARRAY(PadlistNAMES(pl)); int padix_max = PadnamelistMAX(PadlistNAMES(pl)); int padix; for(padix = 1; padix <= padix_max; padix++) { PADNAME *pn = padnames[padix]; if(!pn) continue; write_u8(fh, PMAT_CODEx_PADNAME); write_uint(fh, padix); write_str(fh, PadnamePV(pn)); write_svptr(fh, (SV*)PadnameOURSTASH(pn)); if(PadnameFLAGS(pn)) { uint8_t flags = 0; if(PadnameOUTER(pn)) flags |= 0x01; if(PadnameIsSTATE(pn)) flags |= 0x02; if(PadnameLVALUE(pn)) flags |= 0x04; if(PadnameFLAGS(pn) & PADNAMEt_TYPED) flags |= 0x08; if(PadnameFLAGS(pn) & PADNAMEt_OUR) flags |= 0x10; if(flags) { write_u8(fh, PMAT_CODEx_PADNAME_FLAGS); write_uint(fh, padix); write_u8(fh, flags); } #ifdef HAVE_FEATURE_CLASS if(PadnameIsFIELD(pn)) { write_u8(fh, PMAT_CODEx_PADNAME_FIELD); write_uint(fh, padix); write_uint(fh, PadnameFIELDINFO(pn)->fieldix); write_svptr(fh, (SV *)PadnameFIELDINFO(pn)->fieldstash); } #endif } } } # else write_svptr(fh, (SV*)PadlistNAMES(pl)); # endif for(depth = 1; depth <= PadlistMAX(pl); depth++) { PAD *pad = pads[depth]; write_u8(fh, PMAT_CODEx_PAD); write_uint(fh, depth); write_svptr(fh, (SV*)pad); } } #endif write_u8(fh, 0); FREETMPS; } static void write_private_io(FILE *fh, const IO *io) { write_common_sv(fh, (const SV *)io, sizeof(XPVIO)); write_uint(fh, PerlIO_fileno(IoIFP(io))); write_uint(fh, PerlIO_fileno(IoOFP(io))); // PTRs write_svptr(fh, (SV*)IoTOP_GV(io)); write_svptr(fh, (SV*)IoFMT_GV(io)); write_svptr(fh, (SV*)IoBOTTOM_GV(io)); } static void write_private_lv(FILE *fh, const SV *sv) { write_common_sv(fh, sv, sizeof(XPVLV)); // Header write_u8(fh, LvTYPE(sv)); write_uint(fh, LvTARGOFF(sv)); write_uint(fh, LvTARGLEN(sv)); // PTRs write_svptr(fh, LvTARG(sv)); } #ifdef HAVE_FEATURE_CLASS static void write_private_obj(FILE *fh, const SV *obj) { int nfields = ObjectMAXFIELD(obj) + 1; write_common_sv(fh, obj, sizeof(XPVOBJ)); // Header write_uint(fh, nfields); SV **fields = ObjectFIELDS(obj); int i; for(i = 0; i < nfields; i++) write_svptr(fh, fields[i]); } static void write_private_class(FILE *fh, const HV *cls) { struct mro_meta *mro_meta = HvAUX(cls)->xhv_mro_meta; int nkeys = write_hv_header(fh, cls, sizeof(struct xpvhv_aux) + (mro_meta ? sizeof(struct mro_meta) : 0)); // Header // HASH write_uint(fh, nkeys); // PTRs write_stash_ptrs(fh, cls); write_ptr(fh, HvAUX(cls)->xhv_class_adjust_blocks); // STRs write_str(fh, HvNAME(cls)); // Body if(HvARRAY(cls)) write_hv_body_elems(fh, cls); { PADNAMELIST *fields = HvAUX(cls)->xhv_class_fields; int nfields = PadnamelistMAX(fields)+1; for(int i = 0; i < nfields; i++) { PADNAME *pn = PadnamelistARRAY(fields)[i]; write_u8(fh, PMAT_CLASSx_FIELD); write_uint(fh, PadnameFIELDINFO(pn)->fieldix); write_str(fh, PadnamePV(pn)); } } write_u8(fh, 0); } #endif static void write_annotations_from_stack(FILE *fh, int n) { dSP; SV **p = SP - n + 1; while(p <= SP) { unsigned char type = SvIV(p[0]); switch(type) { case PMAT_SVxSVSVnote: write_u8(fh, type); write_svptr(fh, p[1]); /* target */ write_svptr(fh, p[2]); /* value */ write_strn(fh, SvPV_nolen(p[3]), SvCUR(p[3])); /* annotation */ p += 4; break; default: fprintf(stderr, "ARG: Unsure how to handle PMAT_SVn annotation type %02x\n", type); p = SP + 1; } } } static void run_package_helpers(DMDContext *ctx, const SV *sv, SV *classname) { FILE *fh = ctx->fh; HE *he; DMD_Helper *helper = NULL; if((he = hv_fetch_ent(helper_per_package, classname, 0, 0))) helper = (DMD_Helper *)SvUV(HeVAL(he)); if(helper) { ENTER; SAVETMPS; int ret = (*helper)(aTHX_ ctx, sv); if(ret > 0) write_annotations_from_stack(fh, ret); FREETMPS; LEAVE; } } static void write_sv(DMDContext *ctx, const SV *sv) { FILE *fh = ctx->fh; unsigned char type = -1; switch(SvTYPE(sv)) { case SVt_NULL: type = PMAT_SVtUNDEF; break; case SVt_IV: case SVt_NV: case SVt_PV: case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: type = SvROK(sv) ? PMAT_SVtREF : PMAT_SVtSCALAR; break; #if (PERL_REVISION == 5) && (PERL_VERSION < 12) case SVt_RV: type = PMAT_SVtREF; break; #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 19) case SVt_INVLIST: type = PMAT_SVtINVLIST; break; #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 12) case SVt_REGEXP: type = PMAT_SVtREGEXP; break; #endif case SVt_PVGV: type = PMAT_SVtGLOB; break; case SVt_PVLV: type = PMAT_SVtLVALUE; break; case SVt_PVAV: type = PMAT_SVtARRAY; break; // HVs with names we call STASHes case SVt_PVHV: #ifdef HAVE_FEATURE_CLASS if(HvNAME(sv) && HvSTASH_IS_CLASS(sv)) type = PMAT_SVtCLASS; else #endif if(HvNAME(sv)) type = PMAT_SVtSTASH; else type = PMAT_SVtHASH; break; case SVt_PVCV: type = PMAT_SVtCODE; break; case SVt_PVFM: type = PMAT_SVtFORMAT; break; case SVt_PVIO: type = PMAT_SVtIO; break; #ifdef HAVE_FEATURE_CLASS case SVt_PVOBJ: type = PMAT_SVtOBJ; break; #endif default: fprintf(stderr, "dumpsv %p has unknown SvTYPE %d\n", sv, SvTYPE(sv)); break; } if(type == PMAT_SVtSCALAR && !SvOK(sv)) type = PMAT_SVtUNDEF; #if (PERL_REVISION == 5) && (PERL_VERSION >= 35) if(type == PMAT_SVtSCALAR && SvIsBOOL(sv)) /* SvTRUE() et al. might mutate; but it's OK we know this is one of the bools */ type = (SvIVX(sv)) ? PMAT_SVtYES : PMAT_SVtNO; #endif write_u8(fh, type); switch(type) { case PMAT_SVtGLOB: write_private_gv (fh, (GV*)sv); break; case PMAT_SVtSCALAR: write_private_sv (fh, sv); break; case PMAT_SVtREF: write_private_rv (fh, sv); break; case PMAT_SVtARRAY: write_private_av (fh, (AV*)sv); break; case PMAT_SVtHASH: write_private_hv (fh, (HV*)sv); break; case PMAT_SVtSTASH: write_private_stash(fh, (HV*)sv); break; case PMAT_SVtCODE: write_private_cv (fh, (CV*)sv); break; case PMAT_SVtIO: write_private_io (fh, (IO*)sv); break; case PMAT_SVtLVALUE: write_private_lv (fh, sv); break; #ifdef HAVE_FEATURE_CLASS case PMAT_SVtOBJ: write_private_obj(fh, sv); break; case PMAT_SVtCLASS: write_private_class(fh, (HV*)sv); break; #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 12) case PMAT_SVtREGEXP: write_common_sv(fh, sv, sizeof(regexp)); break; #endif case PMAT_SVtFORMAT: write_common_sv(fh, sv, sizeof(XPVFM)); break; case PMAT_SVtINVLIST: write_common_sv(fh, sv, sizeof(XPV) + SvLEN(sv)); break; case PMAT_SVtUNDEF: write_common_sv(fh, sv, 0); break; case PMAT_SVtYES: write_common_sv(fh, sv, 0); break; case PMAT_SVtNO: write_common_sv(fh, sv, 0); break; } if(SvMAGICAL(sv)) { MAGIC *mg; for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { write_u8(fh, PMAT_SVxMAGIC); write_svptr(fh, sv); write_u8(fh, mg->mg_type); write_u8(fh, (mg->mg_flags & MGf_REFCOUNTED ? 0x01 : 0)); write_svptr(fh, mg->mg_obj); if(mg->mg_len == HEf_SVKEY) write_svptr(fh, (SV*)mg->mg_ptr); else write_svptr(fh, NULL); write_svptr(fh, (SV *)mg->mg_virtual); /* Not really an SV */ if(mg->mg_type == PERL_MAGIC_ext && mg->mg_ptr && mg->mg_len != HEf_SVKEY) { SV *key = make_tmp_iv((IV)mg->mg_virtual); HE *he; DMD_MagicHelper *helper = NULL; he = hv_fetch_ent(helper_per_magic, key, 0, 0); if(he) helper = (DMD_MagicHelper *)SvUV(HeVAL(he)); if(helper) { ENTER; SAVETMPS; int ret = (helper)(aTHX_ ctx, sv, mg); if(ret > 0) write_annotations_from_stack(fh, ret); FREETMPS; LEAVE; } } } } if(SvOBJECT(sv)) { AV *linearized_mro = mro_get_linear_isa(SvSTASH(sv)); for(SSize_t i = 0; i <= AvFILL(linearized_mro); i++) run_package_helpers(ctx, sv, AvARRAY(linearized_mro)[i]); } #ifdef DEBUG_LEAKING_SCALARS { write_u8(fh, PMAT_SVxDEBUGREPORT); write_svptr(fh, sv); write_uint(fh, sv->sv_debug_serial); write_uint(fh, sv->sv_debug_line); /* TODO: this is going to make the file a lot larger, due to nonshared * strings. Consider if there's a way we can share these somehow */ write_str(fh, sv->sv_debug_file); } #endif } typedef struct { const char *name; enum { DMD_FIELD_PTR, DMD_FIELD_BOOL, DMD_FIELD_U8, DMD_FIELD_U32, DMD_FIELD_UINT, } type; struct { void *ptr; bool b; long n; }; } DMDNamedField; typedef struct { const char *name; const char *str; size_t len; } DMDNamedString; static void writestruct(pTHX_ DMDContext *ctx, const char *name, void *addr, size_t size, size_t nfields, const DMDNamedField fields[]) { FILE *fh = ctx->fh; if(!ctx->structdefs) ctx->structdefs = newHV(); SV *idsv = *hv_fetch(ctx->structdefs, name, strlen(name), 1); if(!SvOK(idsv)) { int structid = ctx->next_structid; ctx->next_structid++; sv_setiv(idsv, structid); write_u8(fh, PMAT_SVtMETA_STRUCT); write_uint(fh, structid); write_uint(fh, nfields); write_str(fh, name); for(size_t i = 0; i < nfields; i++) { write_str(fh, fields[i].name); write_u8(fh, fields[i].type); } } write_u8(fh, PMAT_SVtSTRUCT); /* Almost the same layout as write_common_sv() */ // Header for common write_svptr(fh, addr); write_u32(fh, -1); write_uint(fh, size); // PTRs for common write_svptr(fh, NUM2PTR(SV *, SvIV(idsv))); /* abuse the stash pointer to store the descriptor ID */ // Body for(size_t i = 0; i < nfields; i++) switch(fields[i].type) { case DMD_FIELD_PTR: write_ptr(fh, fields[i].ptr); break; case DMD_FIELD_BOOL: write_u8(fh, fields[i].b); break; case DMD_FIELD_U8: write_u8(fh, fields[i].n); break; case DMD_FIELD_U32: write_u32(fh, fields[i].n); break; case DMD_FIELD_UINT: write_uint(fh, fields[i].n); break; } } #if (PERL_REVISION == 5) && (PERL_VERSION < 14) /* * This won't be very good, but good enough for our needs */ static I32 dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { dVAR; I32 i; for(i = startingblock; i >= 0; i--) { const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: return i; default: continue; } } return i; } static const PERL_CONTEXT *caller_cx(int count, void *ignore) { I32 cxix = dopoptosub_at(cxstack, cxstack_ix); const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; while(1) { while(cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = dopoptosub_at(ccstack, top_si->si_cxix); } if(cxix < 0) return NULL; if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if(!count--) break; cxix = dopoptosub_at(ccstack, cxix - 1); } const PERL_CONTEXT *cx = &ccstack[cxix]; if(CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1); if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } return cx; } #endif static void dumpfh(FILE *fh) { max_string = SvIV(get_sv("Devel::MAT::Dumper::MAX_STRING", GV_ADD)); DMDContext ctx = { .fh = fh, .next_structid = 0, }; // Header fwrite("PMAT", 4, 1, fh); int flags = 0; #if (BYTEORDER == 0x1234) || (BYTEORDER == 0x12345678) // little-endian #elif (BYTEORDER == 0x4321) || (BYTEORDER == 0x87654321) flags |= 0x01; // big-endian #else # error "Expected BYTEORDER to be big- or little-endian" #endif #if UVSIZE == 8 flags |= 0x02; // 64-bit integers #elif UVSIZE == 4 #else # error "Expected UVSIZE to be either 4 or 8" #endif #if PTRSIZE == 8 flags |= 0x04; // 64-bit pointers #elif PTRSIZE == 4 #else # error "Expected PTRSIZE to be either 4 or 8" #endif #if NVSIZE > 8 flags |= 0x08; // long-double #endif #ifdef USE_ITHREADS flags |= 0x10; // ithreads #endif write_u8(fh, flags); write_u8(fh, 0); write_u8(fh, FORMAT_VERSION_MAJOR); #ifdef HAVE_FEATURE_CLASS write_u8(fh, 5); #else write_u8(fh, FORMAT_VERSION_MINOR); #endif write_u32(fh, PERL_REVISION<<24 | PERL_VERSION<<16 | PERL_SUBVERSION); write_u8(fh, sizeof(sv_sizes)/3); fwrite(sv_sizes, sizeof(sv_sizes), 1, fh); write_u8(fh, sizeof(svx_sizes)/3); fwrite(svx_sizes, sizeof(svx_sizes), 1, fh); write_u8(fh, sizeof(ctx_sizes)/3); fwrite(ctx_sizes, sizeof(ctx_sizes), 1, fh); // Roots write_svptr(fh, &PL_sv_undef); write_svptr(fh, &PL_sv_yes); write_svptr(fh, &PL_sv_no); struct root { char *name; SV *ptr; } roots[] = { { "main_cv", (SV*)PL_main_cv }, { "defstash", (SV*)PL_defstash }, { "mainstack", (SV*)PL_mainstack }, { "beginav", (SV*)PL_beginav }, { "checkav", (SV*)PL_checkav }, { "unitcheckav", (SV*)PL_unitcheckav }, { "initav", (SV*)PL_initav }, { "endav", (SV*)PL_endav }, { "strtab", (SV*)PL_strtab }, { "envgv", (SV*)PL_envgv }, { "incgv", (SV*)PL_incgv }, { "statgv", (SV*)PL_statgv }, { "statname", (SV*)PL_statname }, { "tmpsv", (SV*)PL_Sv }, // renamed { "defgv", (SV*)PL_defgv }, { "argvgv", (SV*)PL_argvgv }, { "argvoutgv", (SV*)PL_argvoutgv }, { "argvout_stack", (SV*)PL_argvout_stack }, { "errgv", (SV*)PL_errgv }, { "fdpid", (SV*)PL_fdpid }, { "preambleav", (SV*)PL_preambleav }, { "modglobalhv", (SV*)PL_modglobal }, #ifdef USE_ITHREADS { "regex_padav", (SV*)PL_regex_padav }, #endif { "sortstash", (SV*)PL_sortstash }, { "firstgv", (SV*)PL_firstgv }, { "secondgv", (SV*)PL_secondgv }, { "debstash", (SV*)PL_debstash }, { "stashcache", (SV*)PL_stashcache }, { "isarev", (SV*)PL_isarev }, #if (PERL_REVISION == 5) && ((PERL_VERSION > 10) || (PERL_VERSION == 10 && PERL_SUBVERSION > 0)) { "registered_mros", (SV*)PL_registered_mros }, #endif { "rs", (SV*)PL_rs }, { "last_in_gv", (SV*)PL_last_in_gv }, { "defoutgv", (SV*)PL_defoutgv }, { "hintgv", (SV*)PL_hintgv }, { "patchlevel", (SV*)PL_patchlevel }, { "e_script", (SV*)PL_e_script }, { "mess_sv", (SV*)PL_mess_sv }, { "ors_sv", (SV*)PL_ors_sv }, { "encoding", (SV*)PL_encoding }, #if (PERL_REVISION == 5) && (PERL_VERSION >= 12) { "ofsgv", (SV*)PL_ofsgv }, #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) && (PERL_VERSION <= 20) { "apiversion", (SV*)PL_apiversion }, #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) { "blockhooks", (SV*)PL_blockhooks }, #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 16) { "custom_ops", (SV*)PL_custom_ops }, { "custom_op_names", (SV*)PL_custom_op_names }, { "custom_op_descs", (SV*)PL_custom_op_descs }, #endif // Unicode etc... { "utf8_mark", (SV*)PL_utf8_mark }, { "utf8_toupper", (SV*)PL_utf8_toupper }, { "utf8_totitle", (SV*)PL_utf8_totitle }, { "utf8_tolower", (SV*)PL_utf8_tolower }, { "utf8_tofold", (SV*)PL_utf8_tofold }, { "utf8_idstart", (SV*)PL_utf8_idstart }, { "utf8_idcont", (SV*)PL_utf8_idcont }, #if (PERL_REVISION == 5) && (PERL_VERSION >= 12) && (PERL_VERSION <= 20) { "utf8_X_extend", (SV*)PL_utf8_X_extend }, #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 14) { "utf8_xidstart", (SV*)PL_utf8_xidstart }, { "utf8_xidcont", (SV*)PL_utf8_xidcont }, { "utf8_foldclosures", (SV*)PL_utf8_foldclosures }, #if (PERL_REVISION == 5) && ((PERL_VERSION < 29) || (PERL_VERSION == 29 && PERL_SUBVERSION < 7)) { "utf8_foldable", (SV*)PL_utf8_foldable }, #endif #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 16) { "Latin1", (SV*)PL_Latin1 }, { "AboveLatin1", (SV*)PL_AboveLatin1 }, { "utf8_perl_idstart", (SV*)PL_utf8_perl_idstart }, #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 18) #if (PERL_REVISION == 5) && ((PERL_VERSION < 29) || (PERL_VERSION == 29 && PERL_SUBVERSION < 7)) { "NonL1NonFinalFold", (SV*)PL_NonL1NonFinalFold }, #endif { "HasMultiCharFold", (SV*)PL_HasMultiCharFold }, # if (PERL_VERSION <= 20) { "utf8_X_regular_begin", (SV*)PL_utf8_X_regular_begin }, # endif { "utf8_charname_begin", (SV*)PL_utf8_charname_begin }, { "utf8_charname_continue", (SV*)PL_utf8_charname_continue }, { "utf8_perl_idcont", (SV*)PL_utf8_perl_idcont }, #endif #if (PERL_REVISION == 5) && ((PERL_VERSION > 19) || (PERL_VERSION == 19 && PERL_SUBVERSION >= 4)) { "UpperLatin1", (SV*)PL_UpperLatin1 }, #endif }; AV *moreroots = get_av("Devel::MAT::Dumper::MORE_ROOTS", 0); int nroots = sizeof(roots) / sizeof(roots[0]); if(moreroots) nroots += (AvFILL(moreroots)+1) / 2; write_u32(fh, nroots); int i; for(i = 0; i < sizeof(roots) / sizeof(roots[0]); i++) { write_str(fh, roots[i].name); write_svptr(fh, roots[i].ptr); } if(moreroots) { SV **svp = AvARRAY(moreroots); int max = AvFILL(moreroots); for(i = 0; i < max; i += 2) { write_str(fh, SvPV_nolen(svp[i])); write_svptr(fh, svp[i+1]); } } // Stack write_uint(fh, PL_stack_sp - PL_stack_base + 1); SV **sp; for(sp = PL_stack_base; sp <= PL_stack_sp; sp++) write_svptr(fh, *sp); bool seen_defstash = false; // Heap SV *arena; for(arena = PL_sv_arenaroot; arena; arena = (SV *)SvANY(arena)) { const SV *arenaend = &arena[SvREFCNT(arena)]; SV *sv; for(sv = arena + 1; sv < arenaend; sv++) { if(sv == tmpsv) continue; switch(SvTYPE(sv)) { case 0xff: continue; } write_sv(&ctx, sv); if(sv == (const SV *)PL_defstash) seen_defstash = true; } } // and a few other things that don't actually appear in the arena if(!seen_defstash) write_sv(&ctx, (const SV *)PL_defstash); // Savestack #if (PERL_REVISION == 5) && (PERL_VERSION >= 18) /* The savestack only had a vaguely nicely predicable layout from perl 5.18 onwards * On earlier perls we'll just not bother. Sorry * No `local` detection for you */ int saveix = PL_savestack_ix; while(saveix) { UV uv = PL_savestack[saveix-1].any_uv; U8 type = (U8)uv & SAVE_MASK; /* TODO: this seems fragile - does core perl not export a nice way to * do it? */ char count; if(type <= SAVEt_ARG0_MAX) count = 0; else if(type <= SAVEt_ARG1_MAX) count = 1; else if(type <= SAVEt_ARG2_MAX) count = 2; else if(type <= SAVEt_MAX) count = 3; else /* Unrecognised type; just abort here */ break; saveix -= (count + 1); ANY *a0 = count > 0 ? &PL_savestack[saveix ] : NULL, *a1 = count > 1 ? &PL_savestack[saveix+1] : NULL, *a2 = count > 2 ? &PL_savestack[saveix+2] : NULL; switch(type) { /* Most savestack entries aren't very interesting to Devel::MAT, but * there's a few we find useful. A lot of them don't add any linkages * between SVs, so we can ignore the majority of them */ case SAVEt_CLEARSV: case SAVEt_CLEARPADRANGE: #if (PERL_REVISION == 5) && (PERL_VERSION >= 24) case SAVEt_TMPSFLOOR: #endif case SAVEt_BOOL: case SAVEt_COMPPAD: case SAVEt_FREEOP: case SAVEt_FREEPV: case SAVEt_FREESV: case SAVEt_I16: case SAVEt_I32_SMALL: case SAVEt_I8: case SAVEt_INT_SMALL: case SAVEt_MORTALIZESV: case SAVEt_OP: case SAVEt_PARSER: case SAVEt_SHARED_PVREF: case SAVEt_SPTR: case SAVEt_DESTRUCTOR: case SAVEt_DESTRUCTOR_X: case SAVEt_GP: case SAVEt_I32: case SAVEt_INT: case SAVEt_IV: case SAVEt_LONG: #if (PERL_REVISION == 5) && (PERL_VERSION >= 20) case SAVEt_STRLEN: #endif #if (PERL_REVISION == 5) && (PERL_VERSION >= 34) case SAVEt_STRLEN_SMALL: #endif case SAVEt_SAVESWITCHSTACK: case SAVEt_VPTR: case SAVEt_ADELETE: case SAVEt_DELETE: /* ignore */ break; case SAVEt_AV: /* a local'ised @var */ write_u8(fh, PMAT_SVxSAVED_AV); write_svptr(fh, a0->any_ptr); // GV write_svptr(fh, a1->any_ptr); // AV break; case SAVEt_HV: /* a local'ised %var */ write_u8(fh, PMAT_SVxSAVED_HV); write_svptr(fh, a0->any_ptr); // GV write_svptr(fh, a1->any_ptr); // HV break; case SAVEt_SV: /* a local'ised $var */ write_u8(fh, PMAT_SVxSAVED_SV); write_svptr(fh, a0->any_ptr); // GV write_svptr(fh, a1->any_ptr); // SV break; case SAVEt_HELEM: /* a local'ised $hash{key} */ write_u8(fh, PMAT_SVxSAVED_HELEM); write_svptr(fh, a0->any_ptr); // HV write_svptr(fh, a1->any_ptr); // key SV write_svptr(fh, a2->any_ptr); // value SV break; case SAVEt_AELEM: /* a local'ised $array[idx] */ write_u8(fh, PMAT_SVxSAVED_AELEM); write_svptr(fh, a0->any_ptr); // AV write_uint(fh, a1->any_iv); // index write_svptr(fh, a2->any_ptr); // value SV break; case SAVEt_GVSLOT: /* a local'ised glob slot * a0 points at the GV itself, a1 points at one of the slots within * the GP part * In practice this would only ever be the CODE slot, because other * slots have other localisation mechanisms */ if(a1->any_ptr != (SV **) &(GvGP((GV *)a0->any_ptr)->gp_cv)) { fprintf(stderr, "TODO: SAVEt_GVSLOT of slot other than ->gp_cv\n"); break; } write_u8(fh, PMAT_SVxSAVED_CV); write_svptr(fh, a0->any_ptr); write_svptr(fh, a2->any_ptr); break; case SAVEt_GENERIC_SVREF: /* Core perl uses this in a number of places, a few of which we can * identify */ if(a0->any_ptr == &GvSV(PL_defgv)) { /* local $_ = ... */ write_u8(fh, PMAT_SVxSAVED_SV); write_svptr(fh, (SV *)PL_defgv); write_svptr(fh, a1->any_ptr); } else fprintf(stderr, "TODO: SAVEt_GENERIC_SVREF *a0=%p a1=%p\n", *((void **)a0->any_ptr), a1->any_ptr); break; default: fprintf(stderr, "TODO: savestack type=%d\n", type); break; } } #endif write_u8(fh, 0); // Caller context int cxix; for(cxix = 0; ; cxix++) { const PERL_CONTEXT *cx = caller_cx(cxix, NULL); if(!cx) break; switch(CxTYPE(cx)) { case CXt_SUB: { COP *oldcop = cx->blk_oldcop; write_u8(fh, PMAT_CTXtSUB); write_u8(fh, cx->blk_gimme); write_uint(fh, CopLINE(oldcop)); write_str(fh, CopFILE(oldcop)); write_u32(fh, cx->blk_sub.olddepth); write_svptr(fh, (SV*)cx->blk_sub.cv); #if (PERL_REVISION == 5) && ((PERL_VERSION > 23) || (PERL_VERSION == 23 && PERL_SUBVERSION >= 8)) write_svptr(fh, NULL); #else write_svptr(fh, CxHASARGS(cx) ? (SV*)cx->blk_sub.argarray : NULL); #endif break; } case CXt_EVAL: { COP *oldcop = cx->blk_oldcop; if(CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { /* eval() */ write_u8(fh, PMAT_CTXtEVAL); write_u8(fh, cx->blk_gimme); write_uint(fh, CopLINE(oldcop)); write_str(fh, CopFILE(oldcop)); write_svptr(fh, cx->blk_eval.cur_text); } else if(cx->blk_eval.old_namesv) // require ; else { /* eval BLOCK == TRY */ write_u8(fh, PMAT_CTXtTRY); write_u8(fh, cx->blk_gimme); write_uint(fh, CopLINE(oldcop)); write_str(fh, CopFILE(oldcop)); } break; } } } write_u8(fh, 0); // Mortals stack { // Mortal stack is a pre-inc stack write_uint(fh, PL_tmps_ix + 1); for(SSize_t i = 0; i <= PL_tmps_ix; i++) { write_ptr(fh, PL_tmps_stack[i]); } write_uint(fh, PL_tmps_floor); } if(ctx.structdefs) SvREFCNT_dec((SV *)ctx.structdefs); } MODULE = Devel::MAT::Dumper PACKAGE = Devel::MAT::Dumper void dump(char *file) CODE: { FILE *fh = fopen(file, "wb+"); if(!fh) croak("Cannot open %s for writing - %s", file, strerror(errno)); dumpfh(fh); fclose(fh); } void dumpfh(FILE *fh) BOOT: SV *sv, **svp; if((svp = hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/%helper_per_package", 0))) sv = *svp; else hv_stores(PL_modglobal, "Devel::MAT::Dumper/%helper_per_package", sv = newRV_noinc((SV *)(newHV()))); helper_per_package = (HV *)SvRV(sv); if((svp = hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/%helper_per_magic", 0))) sv = *svp; else hv_stores(PL_modglobal, "Devel::MAT::Dumper/%helper_per_magic", sv = newRV_noinc((SV *)(newHV()))); helper_per_magic = (HV *)SvRV(sv); sv_setiv(*hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/writestruct()", 1), PTR2UV(&writestruct)); Devel-MAT-Dumper-0.47/lib/Devel/MAT/Dumper000755001750001750 014406345310 16557 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/lib/Devel/MAT/Dumper/Helper.pm000444001750001750 4167514406345310 20526 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, 2019 -- leonerd@leonerd.org.uk package Devel::MAT::Dumper::Helper; use strict; use warnings; our $VERSION = '0.47'; =head1 NAME C - give XS modules extensions for memory dumping =head1 SYNOPSIS In F if( eval { require Devel::MAT::Dumper::Helper } ) { Devel::MAT::Dumper::Helper->extend_module_build( $build ); } In your module's XS source: #ifdef HAVE_DMD_HELPER # define WANT_DMD_API_044 # include "DMD_helper.h" #endif ... #ifdef HAVE_DMD_HELPER static int dumpstruct(pTHX_ DMDContext *ctx, const SV *sv) { int ret = 0; ret += DMD_ANNOTATE_SV(sv, another_sv, "the description of this field"); ... return ret; } static int dumpmagic(pTHX_ DMDContext *ctx, const SV *sv, MAGIC *mg) { int ret = 0; ret += DMD_ANNOTATE_SV(sv, another_sv, "the description of this field"); ... return ret; } #endif ... BOOT: #ifdef HAVE_DMD_HELPER DMD_SET_PACKAGE_HELPER("My::Package", dumpstruct); DMD_SET_MAGIC_HELPER(&vtbl, dumpmagic); #endif =head1 DESCRIPTION This module provides a build-time helper to assist in writing XS modules that can provide extra information to a L heap dump file when dumping data structures relating to that module. Following the example in the L section above, the C function is called whenever L finds an SV blessed into the given package, and the C function is called whenever L finds an SV with extension magic matching the given magic virtual table pointer. These functions may then inspect the module's state from the SV or MAGIC pointers, and invoke the C macro to provide extra annotations into the heap dump file about how this SV is related to another one. The C macro is required before C<#include>ing the file, so as to enable the API structure described here. Without that, an earlier version of the module is provided instead, which will eventually be removed in some later version. Under this code structure, a module will cleanly build, install and run just fine if L is not available at build time, so it is not necessary to list that as a C or C requirement. Additionally, the way the inserted code is structured does not cause the XS module to load C itself, so there is no runtime dependency either, even if the support was made available. The newly inserted code is only invoked if both C and this XS module are actually loaded. Note that this entire mechanism is currently experimental. =cut my $DMD_helper_h = do { local $/; readline DATA; }; =head1 FUNCTIONS =cut =head2 write_DMD_helper_h Devel::MAT::Dumper::Helper->write_DMD_helper_h Writes the L file to the current working directory. To cause the compiler to actually find this file, see L. =cut sub write_DMD_helper_h { shift; open my $out, ">", "DMD_helper.h" or die "Cannot open DMD_helper.h for writing - $!\n"; $out->print( $DMD_helper_h ); } =head2 extra_compiler_flags @flags = Devel::MAT::Dumper::Helper->extra_compiler_flags Returns a list of extra flags that the build scripts should add to the compiler invocation. This enables the C compiler to find the F file, and also defines a symbol C which the XS code can then use in C<#ifdef> guards: #ifdef HAVE_DMD_HELPER ... #endif =cut sub extra_compiler_flags { shift; return "-DHAVE_DMD_HELPER", "-I."; } =head2 extend_module_build Devel::MAT::Dumper::Helper->extend_module_build( $build ) A convenient shortcut for performing all the tasks necessary to make a L-based distribution use the helper. =cut sub extend_module_build { my $self = shift; my ( $build ) = @_; eval { $self->write_DMD_helper_h } or do { warn $@; return; }; # preserve existing flags my @flags = @{ $build->extra_compiler_flags }; push @flags, $self->extra_compiler_flags; $build->extra_compiler_flags( @flags ); } =head1 XS MACROS The header file provides the following macros, which may be used by the XS module. =head2 DMD_SET_PACKAGE_HELPER typedef int DMD_Helper(pTHX_ DMDContext *ctx, const SV *sv); DMD_SET_PACKAGE_HELPER(char *packagename, DMD_Helper *helper); This macro should be called from the C section of the XS module to associate a helper function with a named package. Whenever an instance of an object blessed into that package is encountered by the dumper, the helper function will be called to provide extra information about it. When invoked, the helper function is passed a pointer to the blessed SV directly - remember this will be the underlying object storage and not the C that the Perl code uses to refer to it. It should return an integer that is the sum total of the return values of all the calls to C that it made, or 0 if it did not make any. The I pointer to the helper function points at an opaque structure internal to the C module. Helper functions are not expected to interact with it, except to pass it on any C calls it may make. =head2 DMD_SET_MAGIC_HELPER typedef int DMD_MagicHelper(pTHX_ DMDContext *ctx, const SV *sv, MAGIC *mg); DMD_SET_MAGIC_HELPER(MGVTBL *vtbl, DMD_MagicHelper *helper); This macro should be called from the C section of the XS module to associate a helper function with a given magic virtual method table. Whenever an SV with that kind of magic is encountered by the dumper, the helper function will be called to provide extra information about it. When invoked, the helper function is passed a pointer to the magical SV as well as the specific C instance responsible for this call. It should return an integer that is the sum total of the return values of all the calls to C that it made, or 0 if it did not make any. The I pointer to the helper function points at an opaque structure internal to the C module. Helper functions are not expected to interact with it, except to pass it on any C calls it may make. =head2 DMD_ADD_ROOT DMD_ADD_ROOT(SV *sv, const char *name); This macro should be called from the C section of the XS module to add another root SV pointer to be added to the root SVs table. This is useful for annotating static SV pointers or other storage that can refer to SVs or memory structures within the module, but which would not be discovered by a normal heap walk. The I argument is also used as the description string within the C UI. It should begin with either a C<+> or C<-> character to annotate that the root contains a strong or weak reference, respectively. =head2 DMD_ANNOTATE_SV DMD_ANNOTATE_SV(const SV *referrer, const SV *referrant, const char *label); This macro should be called by a helper function, in order to provide extra information about the SV it has encountered. The macro notes that a pointer exists from the SV given by I, pointing at the SV given by I, described by the given string label. Each call to this macro returns an integer, which the helper function must accumulate the total of, and return that number to the caller. Not that it is not necessary that either the referrer nor the referrant actually are the SV that the helper function encountered. Arbitrary annotations between SVs are permitted. Additionally, it is permitted that the SV addresses do not in fact point at Perl SVs, but instead point to arbitarary data structures, which should be written about using C. =head2 DMD_DUMP_STRUCT typedef struct { const char *name; enum { DMD_FIELD_PTR, DMD_FIELD_BOOL, DMD_FIELD_U8, DMD_FIELD_U32, DMD_FIELD_UINT, } type; void *ptr; /* for type=PTR */ bool b; /* for type=BOOL */ long n; /* for the remaining numerical types */ } DMDNamedField; DMD_DUMP_STRUCT(DMDContext *ctx, const char *name, void *addr, size_t size, size_t nfields, const DMDNamedField fields[]); This macro should be called by a helper function, in order to provide extra information about a memory structure that is not a Perl SV. By using this macro, the module can write information into the dumpfile about the memory structure types and values that it operates on, allowing the C tooling to operate on it - such as by following pointers and finding or identifying the contents. The code invoked by this macro at runtime actually does B separate tasks, which are closely related. The first time a call is made for any particular string value in I, the function will write metadata information into the dumpfile which gives the name and type of each of the fields. Every call, including this first one, will write the values of the fields associated with a single instance of the structure, by reusing the information provided to the first call. The I argument must be the value given to the helper function. I gives the pointer address of the structure itself. I should give its total size in bytes (often C is sufficient here). The I, I, and I parameters between them are used both by the initial metadata call, and for every structure instance. I gives a unique name to this type of structure - it should be composed of the base name of the XS module, and a local name within the module, separated by C. I gives the number of individual field instances given in the I array, which itself provides a label name, a type, and an actual value. The first two fields of the C structure give its name and type, and one subsequent field should be set to give the value for it. Which field to use depends on the type. Note that it is very important, once a structure name has been seen the first time, that every subsequent call for the same must have exactly the same count of fields, and the types of each of them. The values of the fields, as well as the size of the structure overall, are recorded for every call, but the typing information is stored only once on that first call. It is best to ensure that the module source contains only a single instance of this macro for a given structure name, thus ensuring the type information will always be consistent. =head1 HANDLING C-LEVEL STRUCTURES For example, given a C struct definition such as: struct MyData { SV *buf; int state; AV *more_stuff; }; A call to provide this to the dumpfile could look like: struct MyData *dat = ...; DMD_DUMP_STRUCT(ctx, "Module::Name/MyData", dat, sizeof(struct MyData), 3, ((const DMDNamedField []){ {"the buf SV", DMD_FIELD_PTR, .ptr = dat->buf}, {"the state", DMD_FIELD_UINT, .n = dat->state}, {"the more_stuff AV", DMD_FIELD_PTR, .ptr = dat->more_stuff}, }) ); Conventionally, names of unique fields all begin C<"the ...">. Fields that point to other Perl SVs should explain what kind of SV they point to, so any discrepencies can be observed in the tooling later on. A call to this macro alone is likely not enough to fully link the information in the dumpfile, however. It is unlikely that any pointer value that the dumper itself will encounter would point to this data structure - if so, Perl would not know how to deal with it. It's likely that the module would use some technique such as storing a pointer in the UV field of a blessed SCALAR SV, as a way to retain it. In that typical example, a helper function should be attached to the package name that SV would be blessed into. When the dumper encounters that blessed SV it will invoke the helper function, which can then call C and also use C to provide a linkage between the blessed SV containing the UV value, and this structure. static int dumppackage_mydata(pTHX_ DMDContext *ctx, const SV *sv) { int ret = 0; struct MyData *dat = NUM2PTR(struct MyData *, SvUV((SV *)sv)); DMD_DUMP_STRUCT(...); ret += DMD_ANNOTATE_SV(sv, (SV *)dat, "the MyData structure"); return ret; } BOOT: There is no ordering requirement between these two - the annotation linking the pointers can be made before, or after, the structure itself has been written. In fact, there are no ordering constraints at all; feel free to write the data structures and annotations in whatever order is most natural to the dumper code, =cut =head1 AUTHOR Paul Evans =cut 0x55AA; __DATA__ #ifndef __DEVEL_MAT_DUMPER_HELPER_H__ #define __DEVEL_MAT_DUMPER_HELPER_H__ #define DMD_ANNOTATE_SV(targ, val, name) S_DMD_AnnotateSv(aTHX_ targ, val, name) static int S_DMD_AnnotateSv(pTHX_ const SV *targ, const SV *val, const char *name) { dSP; if(!targ || !val) return 0; mXPUSHi(0x87); /* TODO PMAT_SVxSVSVnote */ XPUSHs((SV *)targ); XPUSHs((SV *)val); mXPUSHp(name, strlen(name)); PUTBACK; return 4; } #ifdef WANT_DMD_API_044 typedef struct DMDContext DMDContext; typedef int DMD_Helper(pTHX_ DMDContext *ctx, const SV *sv); #define DMD_SET_PACKAGE_HELPER(package, helper) S_DMD_SetPackageHelper(aTHX_ package, helper) static void S_DMD_SetPackageHelper(pTHX_ char *package, DMD_Helper *helper) { HV *helper_per_package; SV **svp; if((svp = hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/%helper_per_package", 0))) helper_per_package = (HV *)SvRV(*svp); else { helper_per_package = newHV(); hv_stores(PL_modglobal, "Devel::MAT::Dumper/%helper_per_package", newRV_noinc((SV *)helper_per_package)); } hv_store(helper_per_package, package, strlen(package), newSVuv(PTR2UV(helper)), 0); } typedef int DMD_MagicHelper(pTHX_ DMDContext *ctx, const SV *sv, MAGIC *mg); #define DMD_SET_MAGIC_HELPER(vtbl, helper) S_DMD_SetMagicHelper(aTHX_ vtbl, helper) static void S_DMD_SetMagicHelper(pTHX_ MGVTBL *vtbl, DMD_MagicHelper *helper) { HV *helper_per_magic; SV **svp; if((svp = hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/%helper_per_magic", 0))) helper_per_magic = (HV *)SvRV(*svp); else { helper_per_magic = newHV(); hv_stores(PL_modglobal, "Devel::MAT::Dumper/%helper_per_magic", newRV_noinc((SV *)helper_per_magic)); } SV *keysv = newSViv((IV)vtbl); hv_store_ent(helper_per_magic, keysv, newSVuv(PTR2UV(helper)), 0); SvREFCNT_dec(keysv); } typedef struct { const char *name; enum { DMD_FIELD_PTR, DMD_FIELD_BOOL, DMD_FIELD_U8, DMD_FIELD_U32, DMD_FIELD_UINT, } type; struct { void *ptr; bool b; long n; }; } DMDNamedField; #define DMD_DUMP_STRUCT(ctx, name, addr, size, nfields, fields) \ S_DMD_DumpStruct(aTHX_ ctx, name, addr, size, nfields, fields) static void S_DMD_DumpStruct(pTHX_ DMDContext *ctx, const char *name, void *addr, size_t size, size_t nfields, const DMDNamedField fields[]) { static void (*func)(pTHX_ DMDContext *ctx, const char *, void *, size_t, size_t, const DMDNamedField []); if(!func) { SV **svp = hv_fetchs(PL_modglobal, "Devel::MAT::Dumper/writestruct()", 0); if(svp) func = INT2PTR(void (*)(pTHX_ DMDContext *ctx, const char *, void *, size_t, size_t, const DMDNamedField[]), SvUV(*svp)); else func = (void *)(-1); } if(func != (void *)(-1)) (*func)(aTHX_ ctx, name, addr, size, nfields, fields); } #else typedef int DMD_Helper(pTHX_ const SV *sv); #define DMD_SET_PACKAGE_HELPER(package, helper) S_DMD_SetPackageHelper(aTHX_ package, helper) static void S_DMD_SetPackageHelper(pTHX_ char *package, DMD_Helper *helper) { HV *helper_per_package = get_hv("Devel::MAT::Dumper::HELPER_PER_PACKAGE", GV_ADD); hv_store(helper_per_package, package, strlen(package), newSVuv(PTR2UV(helper)), 0); } typedef int DMD_MagicHelper(pTHX_ const SV *sv, MAGIC *mg); #define DMD_SET_MAGIC_HELPER(vtbl, helper) S_DMD_SetMagicHelper(aTHX_ vtbl, helper) static void S_DMD_SetMagicHelper(pTHX_ MGVTBL *vtbl, DMD_MagicHelper *helper) { HV *helper_per_magic = get_hv("Devel::MAT::Dumper::HELPER_PER_MAGIC", GV_ADD); SV *keysv = newSViv((IV)vtbl); hv_store_ent(helper_per_magic, keysv, newSVuv(PTR2UV(helper)), 0); SvREFCNT_dec(keysv); } #endif #define DMD_IS_ACTIVE() S_DMD_is_active(aTHX) static bool S_DMD_is_active(pTHX) { #ifdef MULTIPLICITY return !!get_cv("Devel::MAT::Dumper::dump", 0); #else static bool active; static bool cached = FALSE; if(!cached) { active = !!get_cv("Devel::MAT::Dumper::dump", 0); cached = TRUE; } return active; #endif } #define DMD_ADD_ROOT(sv, name) S_DMD_add_root(aTHX_ sv, name) static void S_DMD_add_root(pTHX_ SV *sv, const char *name) { AV *moreroots = get_av("Devel::MAT::Dumper::MORE_ROOTS", GV_ADD); av_push(moreroots, newSVpvn(name, strlen(name))); av_push(moreroots, sv); } #endif Devel-MAT-Dumper-0.47/t000755001750001750 014406345310 13340 5ustar00leoleo000000000000Devel-MAT-Dumper-0.47/t/00use.t000444001750001750 22414406345310 14574 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use_ok( 'Devel::MAT::Dumper' ); use_ok( 'Devel::MAT::Dumper::Helper' ); done_testing; Devel-MAT-Dumper-0.47/t/01header.t000444001750001750 207114406345310 15253 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Config; use Devel::MAT::Dumper; my $DUMPFILE = "test.pmat"; Devel::MAT::Dumper::dump( $DUMPFILE ); END { unlink $DUMPFILE; } pass "Write dumpfile"; open my $fh, "<", $DUMPFILE or die "Cannot open $DUMPFILE for reading - $!"; read $fh, my $buf, 12; my ( $sig, $flags, $zero, $major, $minor, $perlver ) = unpack "A4 C C C C I", $buf; is( $sig, "PMAT", 'File magic signature' ); is( $flags, ( $Config{byteorder} =~ m/4321$/ ? 0x01 : 0x00 ) | ( $Config{uvsize} == 8 ? 0x02 : 0x00 ) | ( $Config{ptrsize} == 8 ? 0x04 : 0x00 ) | ( $Config{nvsize} > 8 ? 0x08 : 0x00 ) | ( $Config{useithreads} ? 0x10 : 0x00 ), 'Flags' ); is( $zero, 0, 'Zero' ); is( $major, 0, 'Major' ); require feature; no warnings 'once'; if( $feature::feature{class} ) { is( $minor, 5, 'Minor' ); } else { is( $minor, 4, 'Minor' ); } my ( $rev, $sub ) = $] =~ m/^5\.(...)(...)$/; is( $perlver, ( 5 << 24 ) | ( $rev << 16 ) | ( $sub + 0 ), 'Perlver' ); done_testing; Devel-MAT-Dumper-0.47/t/99pod.t000444001750001750 25714406345310 14612 0ustar00leoleo000000000000#!/usr/bin/perl use strict; 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();