view release on metacpan or  search on metacpan

lib/Devel/MAT/Dumpfile.pm  view on Meta::CPAN

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2013-2024 -- leonerd@leonerd.org.uk

package Devel::MAT::Dumpfile 0.54;

use v5.14;
use warnings;

use Carp;
use IO::Handle;   # ->read
use IO::Seekable; # ->tell

use List::Util qw( pairmap );

use Devel::MAT::SV;
use Devel::MAT::Context;

use Struct::Dumb 0.07 qw( readonly_struct );
readonly_struct StructType => [qw( name fields )];
readonly_struct StructField => [qw( name type )];

use constant {
   PMAT_SVxMAGIC => 0x80,
};

=head1 NAME

C<Devel::MAT::Dumpfile> - load and analyse a heap dump file

=head1 SYNOPSIS

   use Devel::MAT::Dumpfile;

   my $df = Devel::MAT::Dumpfile->load( "path/to/the/file.pmat" );

=head1 DESCRIPTION

This module provides a class that loads a heap dump file previously written by
L<Devel::MAT::Dumper>. It provides accessor methods to obtain various
well-known root starting addresses, or to find arbitrary SVs by address. Each
SV is represented by an instance of L<Devel::MAT::SV>.

=cut

my @ROOTS;
my %ROOTDESC;
foreach (
   [ sv_undef        => "+the undef SV" ],
   [ sv_yes          => "+the true SV" ],
   [ sv_no           => "+the false SV" ],
   [ main_cv         => "+the main code" ],
   [ defstash        => "+the default stash" ],
   [ mainstack       => "+the main stack AV" ],
   [ beginav         => "+the BEGIN list" ],
   [ checkav         => "+the CHECK list" ],
   [ unitcheckav     => "+the UNITCHECK list" ],
   [ initav          => "+the INIT list" ],
   [ endav           => "+the END list" ],
   [ strtab          => "+the shared string table HV" ],
   [ envgv           => "-the ENV GV" ],
   [ incgv           => "+the INC GV" ],
   [ statgv          => "+the stat GV" ],
   [ statname        => "+the statname SV" ],
   [ tmpsv           => "-the temporary SV" ],
   [ defgv           => "+the default GV" ],
   [ argvgv          => "-the ARGV GV" ],
   [ argvoutgv       => "+the argvout GV" ],
   [ argvout_stack   => "+the argvout stack AV" ],
   [ errgv           => "+the *@ GV" ],
   [ fdpidav         => "+the FD-to-PID mapping AV" ],
   [ preambleav      => "+the compiler preamble AV" ],
   [ modglobalhv     => "+the module data globals HV" ],
   [ regex_padav     => "+the REGEXP pad AV" ],
   [ sortstash       => "+the sort stash" ],
   [ firstgv         => "-the *a GV" ],
   [ secondgv        => "-the *b GV" ],
   [ debstash        => "-the debugger stash" ],
   [ stashcache      => "+the stash cache" ],
   [ isarev          => "+the reverse map of \@ISA dependencies" ],
   [ registered_mros => "+the registered MROs HV" ],
   [ rs              => "+the IRS" ],
   [ last_in_gv      => "+the last input GV" ],
   [ ofsgv           => "+the OFS GV" ],
   [ defoutgv        => "+the default output GV" ],
   [ hintgv          => "-the hints (%^H) GV" ],
   [ patchlevel      => "+the patch level" ],
   [ apiversion      => "+the API version" ],
   [ e_script        => "+the '-e' script" ],
   [ mess_sv         => "+the message SV" ],
   [ ors_sv          => "+the ORS SV" ],
   [ encoding        => "+the encoding" ],
   [ blockhooks      => "+the block hooks" ],
   [ custom_ops      => "+the custom ops HV" ],
   [ custom_op_names => "+the custom op names HV" ],
   [ custom_op_descs => "+the custom op descriptions HV" ],
   map { [ $_ => "+the $_" ] } qw(
      Latin1 UpperLatin1 AboveLatin1 NonL1NonFinalFold HasMultiCharFold
      utf8_mark utf8_X_regular_begin utf8_X_extend utf8_toupper utf8_totitle
      utf8_tolower utf8_tofold utf8_charname_begin utf8_charname_continue
      utf8_idstart utf8_idcont utf8_xidstart utf8_perl_idstart utf8_perl_idcont
      utf8_xidcont utf8_foldclosures utf8_foldable ),
) {
   my ( $name, $desc ) = @$_;
   push @ROOTS, $name;
   $ROOTDESC{$name} = $desc;

   # Autogenerate the accessors
   my $code = sub {
      my $self = shift;
      $self->{roots}{$name} ? $self->sv_at( $self->{roots}{$name}[0] ) : undef;
   };
   no strict 'refs';
   *$name = $code;
}

*ROOTS = sub { @ROOTS };