view release on metacpan or  search on metacpan

lib/Devel/MAT/SV.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::SV 0.54;

use v5.14;
use warnings;

use Carp;
use Scalar::Util qw( weaken );

use Syntax::Keyword::Match;

# Load XS code
require Devel::MAT;

use constant immortal => 0;

use List::Util qw( first );

use Struct::Dumb 0.07 qw( readonly_struct );
readonly_struct Reference => [qw( name strength sv )];
readonly_struct Magic     => [qw( type obj ptr vtbl )];

=head1 NAME

C<Devel::MAT::SV> - represent a single SV from a heap dump

=head1 DESCRIPTION

Objects in this class represent individual SV variables found in the arena
during a heap dump. Actual types of SV are represented by subclasses, which
are documented below.

=cut

my $CONSTANTS;
BEGIN {
   $CONSTANTS = {
      STRENGTH_STRONG   => (1 << 0),
      STRENGTH_WEAK     => (1 << 1),
      STRENGTH_INDIRECT => (1 << 2),
      STRENGTH_INFERRED => (1 << 3),
   };
   $CONSTANTS->{STRENGTH_DIRECT} = $CONSTANTS->{STRENGTH_STRONG}|$CONSTANTS->{STRENGTH_WEAK};
   $CONSTANTS->{STRENGTH_ALL}    = $CONSTANTS->{STRENGTH_STRONG}|$CONSTANTS->{STRENGTH_WEAK}|$CONSTANTS->{STRENGTH_INDIRECT}|$CONSTANTS->{STRENGTH_INFERRED};
}
use constant $CONSTANTS;

my %types;
sub register_type
{
   $types{$_[1]} = $_[0];
   # generate the ->type constant method
   ( my $typename = $_[0] ) =~ s/^Devel::MAT::SV:://;
   no strict 'refs';
   *{"$_[0]::type"} = sub () { $typename } unless defined *{"$_[0]::type"}{CODE};
}

sub new
{
   shift;
   my ( $type, $df, $header, $ptrs, $strs ) = @_;

   my $class = $types{$type} or croak "Cannot load unknown SV type $type";

   my $self = bless {}, $class;

   $self->_set_core_fields(
      $type, $df,

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

sub _outrefs
{
   my $self = shift;
   my ( $match, $no_desc ) = @_;

   my @outrefs;

   if( $match & STRENGTH_STRONG and my $ourstash = $self->ourstash ) {
      push @outrefs, $no_desc ? ( strong => $ourstash ) :
         Devel::MAT::SV::Reference( "the our stash", strong => $ourstash );
   }

   return @outrefs;
}

package Devel::MAT::SV::REF 0.54;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 3 );
use constant $CONSTANTS;
use constant basetype => "SV";

=head1 Devel::MAT::SV::REF

Represents a referential scalar; any SCALAR-type SV with the C<SvROK> flag
set.

=cut

sub load
{
   my $self = shift;
   my ( $header, $ptrs, $strs ) = @_;

   ( my $flags ) =
      unpack "C", $header;

   $self->_set_ref_fields(
      @{$ptrs}[0,1], # RV, OURSTASH
      $flags & 0x01, # RV_IS_WEAK
   );

   $flags &= ~0x01;
   $flags and die sprintf "Unrecognised REF flags %02x\n", $flags;
}

=head2 rv

   $svrv = $sv->rv;

Returns the SV referred to by the reference.

=cut

sub rv { my $self = shift; return $self->df->sv_at( $self->rv_at ) }

=head2 is_weak

   $weak = $sv->is_weak;

Returns true if the SV is a weakened RV reference.

=cut

# XS accessor

=head2 ourstash

   $stash = $sv->ourstash;

Returns the stash of the SCALAR, if it is an 'C<our>' variable.

=cut

sub ourstash { my $self = shift; return $self->df->sv_at( $self->ourstash_at ) }

sub desc
{
   my $self = shift;

   return sprintf "REF(%s)", $self->is_weak ? "W" : "";
}

*symname = \&Devel::MAT::SV::SCALAR::symname;

sub _outrefs
{
   my $self = shift;
   my ( $match, $no_desc ) = @_;

   my @outrefs;

   my $is_weak = $self->is_weak;
   if( $match & ( $is_weak ? STRENGTH_WEAK : STRENGTH_STRONG ) and my $rv = $self->rv ) {
      my $strength = $is_weak ? "weak" : "strong";
      push @outrefs, $no_desc ? ( $strength => $rv ) :
         Devel::MAT::SV::Reference( "the referrant", $strength => $rv );
   }

   if( $match & STRENGTH_STRONG and my $ourstash = $self->ourstash ) {
      push @outrefs, $no_desc ? ( strong => $ourstash ) :
         Devel::MAT::SV::Reference( "the our stash", strong => $ourstash );
   }

   return @outrefs;
}

package Devel::MAT::SV::BOOL 0.54;
use base qw( Devel::MAT::SV::SCALAR );

sub type { return "BOOL" }

sub desc
{
   my $self = shift;
   return "BOOL(YES)" if $self->uv;
   return "BOOL(NO)";
}

package Devel::MAT::SV::ARRAY 0.54;
use base qw( Devel::MAT::SV );