File Coverage

blib/lib/Devel/MAT/SV.pm

Criterion	Covered	Total	%
statement	790	1099	71.8
branch	282	482	58.5
condition	72	146	49.3
subroutine	192	276	69.5
pod	17	23	73.9
total	1353	2026	66.7

#  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 -- [e-mail]

package Devel::MAT::SV 0.50;

use v5.14;
use warnings;

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

use Syntax::Keyword::Match;

# Load XS code
require Devel::MAT;

use constant immortal => 0;

use List::Util qw( first );

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

=head1 NAME

C - represent a single SV from a heap dump

=head1 DESCRIPTION

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

=cut

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

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

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

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

   my $self = bless {}, $class;

   $self->_set_core_fields(
      $type, $df,
      ( unpack "$df->{ptr_fmt} $df->{u32_fmt} $df->{uint_fmt}", $header ),
      $ptrs->[0],
   );

   return $self;
}

=head1 COMMON METHODS

=cut

=head2 type

   $type = $sv->type

Returns the major type of the SV. This is the class name minus the
C prefix.

=cut

=head2 basetype

   $type = $sv->basetype

Returns the inner perl API type of the SV. This is one of

   SV AV HV CV GV LV PVIO PVFM REGEXP INVLIST OBJ

=head2 desc

   $desc = $sv->desc

Returns a string describing the type of the SV and giving a short detail of
its contents. The exact details depends on the SV type.

=cut

=head2 desc_addr

   $desc = $sv->desc_addr

Returns a string describing the SV as with C and giving its address in
hex. A useful way to uniquely identify the SV when printing.

=cut

sub desc_addr
{
   my $self = shift;
   return sprintf "%s at %#x", $self->desc, $self->addr;
}

=head2 addr

   $addr = $sv->addr

Returns the address of the SV

=cut

# XS accessor

=head2 refcnt

   $count = $sv->refcnt

Returns the C reference count of the SV

=head2 refcount_adjusted

   $count = $sv->refcount_adjusted

Returns the reference count of the SV, adjusted to take account of the fact
that the C value of the backrefs list of a hash or weakly-referenced
object is artificially high.

=cut

# XS accessor

sub refcount_adjusted { shift->refcnt }

=head2 blessed

   $stash = $sv->blessed

If the SV represents a blessed object, returns the stash SV. Otherwise returns
C.

=cut

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

=head2 symname

   $name = $sv->symname

Called on an SV which is a member of the symbol table, this method returns the
perl representation of the full symbol name, including sigil. Otherwise,
returns C.

A leading C prefix is removed for symbols in packages other than
C.

=cut

my $mksymname = sub {
   my ( $sigil, $glob ) = @_;

   my $stashname = $glob->stashname;
   $stashname =~ s/^main::// if $stashname =~ m/^main::.+::/;
   return $sigil . $stashname;
};

sub symname {}

=head2 size

   $size = $sv->size

Returns the (approximate) size in bytes of the SV

=cut

# XS accessor

=head2 magic

   @magics = $sv->magic

Returns a list of magic applied to the SV; each giving the type and target SVs
as struct fields:

   $type = $magic->type
   $sv = $magic->obj
   $sv = $magic->ptr
   $ptr = $magic->vtbl

=cut

sub magic
{
   my $self = shift;
   return unless my $magic = $self->{magic};

   my $df = $self->df;
   return map {
      my ( $type, undef, $obj_at, $ptr_at, $vtbl_ptr ) = @$_;
      Magic( $type, $df->sv_at( $obj_at ), $df->sv_at( $ptr_at ), $vtbl_ptr );
   } @$magic;
}

=head2 magic_svs

   @svs = $sv->magic_svs

A more efficient way to retrieve just the SVs associated with the applied
magic.

=cut

sub magic_svs
{
   my $self = shift;
   return unless my $magic = $self->{magic};

   my $df = $self->df;
   return map {
      my ( undef, undef, $obj_at, $ptr_at ) = @$_;
      ( $obj_at ? ( $df->sv_at( $obj_at ) ) : () ),
      ( $ptr_at ? ( $df->sv_at( $ptr_at ) ) : () )
   } @$magic;
}

=head2 backrefs

   $av_or_rv = $sv->backrefs

Returns backrefs SV, which may be an AV containing the back references, or
if there is only one, the REF SV itself referring to this.

=cut

sub backrefs
{
   my $self = shift;

   return undef unless my $magic = $self->{magic};

   foreach my $mg ( @$magic ) {
      my ( $type, undef, $obj_at ) = @$mg;
      # backrefs list uses "<" magic type
      return $self->df->sv_at( $obj_at ) if $type eq "<";
   }

   return undef;
}

=head2 rootname

   $rootname = $sv->rootname

If the SV is a well-known root, this method returns its name. Otherwise
returns C.

=cut

sub rootname
{
   my $self = shift;
   return $self->{rootname};
}

# internal
sub more_magic
{
   my $self = shift;
   my ( $type, $flags, $obj_at, $ptr_at, $vtbl_ptr ) = @_;

   push @{ $self->{magic} }, [ $type => $flags, $obj_at, $ptr_at, $vtbl_ptr ];
}

sub _more_annotations
{
   my $self = shift;
   my ( $val_at, $name ) = @_;

   push @{ $self->{annotations} }, [ $val_at, $name ];
}

# DEBUG_LEAKING_SCALARS
sub _debugdata
{
   my $self = shift;
   my ( $serial, $line, $file ) = @_;
   $self->{debugdata} = [ $serial, $line, $file ];
}

sub debug_serial
{
   my $self = shift;
   return $self->{debugdata} && $self->{debugdata}[0];
}

sub debug_line
{
   my $self = shift;
   return $self->{debugdata} && $self->{debugdata}[1];
}

sub debug_file
{
   my $self = shift;
   return $self->{debugdata} && $self->{debugdata}[2];
}

=head2 outrefs

   @refs = $sv->outrefs

Returns a list of Reference objects for each of the SVs that this one refers
to, either directly by strong or weak reference, indirectly via RV, or
inferred by C itself.

Each object is a structure of three fields:

=over 4

=item name => STRING

A human-readable string for identification purposes.

=item strength => "strong"|"weak"|"indirect"|"inferred"

Identifies what kind of reference it is. C references contribute to
the C of the referrant, others do not. C and C
references are SV addresses found directly within the referring SV structure;
C and C references are extra return values added here for
convenience by examining the surrounding structure.

=item sv => SV

The referrant SV itself.

=back

=cut

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

   # In scalar context we're just counting so we might as well count just SVs
   $no_desc ||= !wantarray;

   my @outrefs = $self->_outrefs( $match, $no_desc );

   if( $match & STRENGTH_WEAK and my $blessed = $self->blessed ) {
      push @outrefs, $no_desc ? ( weak => $blessed ) :
         Reference( "the bless package", weak => $blessed );
   }

   foreach my $mg ( @{ $self->{magic} || [] } ) {
      my ( $type, $flags, $obj_at, $ptr_at ) = @$mg;

      if( my $obj = $self->df->sv_at( $obj_at ) ) {
         my $is_strong = ( $flags & 0x01 );
         if( $match & ( $is_strong ? STRENGTH_STRONG : STRENGTH_WEAK ) ) {
            my $strength = $is_strong ? "strong" : "weak";
            push @outrefs, $no_desc ? ( $strength => $obj ) :
               Reference( "'$type' magic object", $strength => $obj );
         }
      }

      if( $match & STRENGTH_STRONG and my $ptr = $self->df->sv_at( $ptr_at ) ) {
         push @outrefs, $no_desc ? ( strong => $ptr ) :
            Reference( "'$type' magic pointer", strong => $ptr );
      }
   }

   foreach my $ann ( @{ $self->{annotations} || [] } ) {
      my ( $val_at, $name ) = @$ann;
      my $val = $self->df->sv_at( $val_at ) or next;

      push @outrefs, $no_desc ? ( strong => $val ) :
         Reference( $name, strong => $val );
   }

   return @outrefs / 2 if !wantarray;
   return @outrefs;
}

sub outrefs { $_[0]->_outrefs_matching( STRENGTH_ALL, $_[1] ) }

=head2 outrefs_strong

   @refs = $sv->outrefs_strong

Returns the subset of C that are direct strong references.

=head2 outrefs_weak

   @refs = $sv->outrefs_weak

Returns the subset of C that are direct weak references.

=head2 outrefs_direct

   @refs = $sv->outrefs_direct

Returns the subset of C that are direct strong or weak references.

=head2 outrefs_indirect

   @refs = $sv->outrefs_indirect

Returns the subset of C that are indirect references via RVs.

=head2 outrefs_inferred

   @refs = $sv->outrefs_inferred

Returns the subset of C that are not directly stored in the SV
structure, but instead inferred by C itself.

=cut

sub outrefs_strong   { $_[0]->_outrefs_matching( STRENGTH_STRONG,   $_[1] ) }
sub outrefs_weak     { $_[0]->_outrefs_matching( STRENGTH_WEAK,     $_[1] ) }
sub outrefs_direct   { $_[0]->_outrefs_matching( STRENGTH_DIRECT,   $_[1] ) }
sub outrefs_indirect { $_[0]->_outrefs_matching( STRENGTH_INDIRECT, $_[1] ) }
sub outrefs_inferred { $_[0]->_outrefs_matching( STRENGTH_INFERRED, $_[1] ) }

=head2 outref_named

   $ref = $sv->outref_named( $name )

I

Looks for a reference whose name is exactly that given, and returns it if so.

Throws an exception if the SV has no such outref of that name.

=head2 maybe_outref_named

   $ref = $sv->maybe_outref_named( $name )

I

As L but returns C if there is no such reference.

=cut

sub maybe_outref_named
{
   my $self = shift;
   my ( $name ) = @_;

   return first { $_->name eq $name } $self->outrefs;
}

sub outref_named
{
   my $self = shift;
   my ( $name ) = @_;

   return $self->maybe_outref_named( $name ) // croak "No outref named $name";
}

=head2 is_mortal

   $mortal = $sv->is_mortal

Returns true if this SV is referenced by the temps stack.

=cut

sub _set_is_mortal
{
   my $self = shift;
   $self->{is_mortal} = 1;
}

sub is_mortal
{
   my $self = shift;
   return $self->{is_mortal};
}

=head1 IMMORTAL SVs

Three special SV objects exist outside of the heap, to represent C and
boolean true and false. They are

=over 4

=item * Devel::MAT::SV::UNDEF

=item * Devel::MAT::SV::YES

=item * Devel::MAT::SV::NO

=back

=cut

package Devel::MAT::SV::Immortal 0.50;
use base qw( Devel::MAT::SV );
use constant immortal => 1;
use constant basetype => "SV";
sub new {
   my $class = shift;
   my ( $df, $addr ) = @_;
   my $self = bless {}, $class;
   $self->_set_core_fields( 0, $df, $addr, 0, 0, 0 );
   return $self;
}
sub _outrefs { () }

package Devel::MAT::SV::UNDEF 0.50;
use base qw( Devel::MAT::SV::Immortal );
sub desc { "UNDEF" }
sub type { "UNDEF" }

package Devel::MAT::SV::YES 0.50;
use base qw( Devel::MAT::SV::Immortal );
sub desc { "YES" }
sub type { "SCALAR" }

# Pretend to be 1 / "1"
sub uv { 1 }
sub iv { 1 }
sub nv { 1.0 }
sub pv { "1" }
sub rv { undef }
sub is_weak { '' }

package Devel::MAT::SV::NO 0.50;
use base qw( Devel::MAT::SV::Immortal );
sub desc { "NO" }
sub type { "SCALAR" }

# Pretend to be 0 / ""
sub uv { 0 }
sub iv { 0 }
sub nv { 0.0 }
sub pv { "0" }
sub rv { undef }
sub is_weak { '' }

package Devel::MAT::SV::Unknown 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 0xff );

sub desc { "UNKNOWN" }

sub _outrefs {}

package Devel::MAT::SV::GLOB 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 1 );
use constant $CONSTANTS;
use constant basetype => "GV";

=head1 Devel::MAT::SV::GLOB

Represents a glob; an SV of type C.

=cut

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

   my ( $line ) =
      unpack "$df->{uint_fmt}", $header;

   $self->_set_glob_fields(
      @{$ptrs}[0..7],
      $line, $strs->[1],
      $strs->[0],
   );
}

sub _fixup
{
   my $self = shift;

   $_ and $_->_set_glob_at( $self->addr ) for $self->scalar, $self->array, $self->hash, $self->code;
}

=head2 file

=head2 line

=head2 location

   $file = $gv->file

   $line = $gv->line

   $location = $gv->location

Returns the filename, line number, or combined location (C)
that the GV first appears at.

=head2 name

   $name = $gv->name

Returns the value of the C field, for named globs.

=cut

# XS accessors

sub location
{
   my $self = shift;
   my $file = $self->file;
   my $line = $self->line;
   defined $file ? "$file line $line" : undef
}

=head2 stash

   $stash = $gv->stash

Returns the stash to which the GV belongs.

=cut

sub stash  { my $self = shift; $self->df->sv_at( $self->stash_at  ) }

=head2 scalar

=head2 array

=head2 hash

=head2 code

=head2 egv

=head2 io

=head2 form

   $sv = $gv->scalar

   $av = $gv->array

   $hv = $gv->hash

   $cv = $gv->code

   $gv = $gv->egv

   $io = $gv->io

   $form = $gv->form

Return the SV in the various glob slots.

=cut

sub scalar { my $self = shift; $self->df->sv_at( $self->scalar_at ) }
sub array  { my $self = shift; $self->df->sv_at( $self->array_at  ) }
sub hash   { my $self = shift; $self->df->sv_at( $self->hash_at   ) }
sub code   { my $self = shift; $self->df->sv_at( $self->code_at   ) }
sub egv    { my $self = shift; $self->df->sv_at( $self->egv_at    ) }
sub io     { my $self = shift; $self->df->sv_at( $self->io_at     ) }
sub form   { my $self = shift; $self->df->sv_at( $self->form_at   ) }

sub stashname
{
   my $self = shift;
   my $name = $self->name;
   $name =~ s(^([\x00-\x1f])){"^" . chr(64 + ord $1)}e;
   return $self->stash->stashname . "::" . $name;
}

sub desc
{
   my $self = shift;
   my $sigils = "";
   $sigils .= '$' if $self->scalar;
   $sigils .= '@' if $self->array;
   $sigils .= '%' if $self->hash;
   $sigils .= '&' if $self->code;
   $sigils .= '*' if $self->egv;
   $sigils .= 'I' if $self->io;
   $sigils .= 'F' if $self->form;

   return "GLOB($sigils)";
}

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

   my @outrefs;

   if( $match & STRENGTH_STRONG ) {
      foreach my $slot (qw( scalar array hash code io form )) {
         my $sv = $self->$slot or next;
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the $slot", strong => $sv );
      }
   }

   if( my $egv = $self->egv ) {
      # the egv is weakref if if it points back to itself
      my $egv_is_self = $egv == $self;

      if( $match & ( $egv_is_self ? STRENGTH_WEAK : STRENGTH_STRONG ) ) {
         my $strength = $egv_is_self ? "weak" : "strong";
         push @outrefs, $no_desc ? ( $strength => $egv ) :
            Devel::MAT::SV::Reference( "the egv", $strength => $egv );
      }
   }

   foreach my $saved ( @{ $self->{saved} } ) {
      my $sv = $self->df->sv_at( $saved->[1] );

      push @outrefs, $no_desc ? ( inferred => $sv ) :
         Devel::MAT::SV::Reference( "saved value of " . Devel::MAT::Cmd->format_note( $saved->[0] ) . " slot",
            "inferred", $sv );
   }

   return @outrefs;
}

sub _more_saved
{
   my $self = shift;
   my ( $slot, $addr ) = @_;

   push @{ $self->{saved} }, [ $slot => $addr ];
}

package Devel::MAT::SV::SCALAR 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 2 );
use constant $CONSTANTS;
use constant basetype => "SV";

=head1 Devel::MAT::SV::SCALAR

Represents a non-referential scalar value; an SV of any of the types up to and
including C (that is, C, C, C, C, C or
C). This includes all numbers, integers and floats, strings, and dualvars
containing multiple parts.

=cut

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

   my ( $flags, $uv, $nvbytes, $pvlen ) =
      unpack "C $df->{uint_fmt} A$df->{nv_len} $df->{uint_fmt}", $header;
   my $nv = unpack "$df->{nv_fmt}", $nvbytes;

   # $strs->[0] will be swiped

   $self->_set_scalar_fields( $flags, $uv, $nv,
      $strs->[0], $pvlen,
      $ptrs->[0], # OURSTASH
   );

   # $strs->[0] is now undef

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

=head2 uv

   $uv = $sv->uv

Returns the integer numeric portion as an unsigned value, if valid, or C.

=head2 iv

   $iv = $sv->iv

Returns the integer numeric portion as a signed value, if valid, or C.

=head2 nv

   $nv = $sv->nv

Returns the floating numeric portion, if valid, or C.

=head2 pv

   $pv = $sv->pv

Returns the string portion, if valid, or C.

=head2 pvlen

   $pvlen = $sv->pvlen

Returns the length of the string portion, if valid, or C.

=cut

# XS accessors

=head2 qq_pv

   $str = $sv->qq_pv( $maxlen )

Returns the PV string, if defined, suitably quoted. If C<$maxlen> is defined
and the PV is longer than this, it is truncated and C<...> is appended after
the containing quote marks.

=cut

sub qq_pv
{
   my $self = shift;
   my ( $maxlen ) = @_;

   defined( my $pv = $self->pv ) or return undef;
   $pv = substr( $pv, 0, $maxlen ) if defined $maxlen and $maxlen < length $pv;

   my $truncated = $self->pvlen > length $pv;

   if( $pv =~ m/^[\x20-\x7e]*$/ ) {
      $pv =~ s/(['\\])/\\$1/g;
      $pv = qq('$pv');
   }
   else {
      $pv =~ s{(\")     | (\r)     | (\n)     | ([\x00-\x1f\x80-\xff])}
              {$1?'\\"' : $2?"\\r" : $3?"\\n" : sprintf "\\x%02x", ord $4}egx;
      $pv = qq("$pv");
   }
   $pv .= "..." if $truncated;

   return $pv;
}

=head2 ourstash

   $stash = $sv->ourstash

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

After perl 5.20 this is no longer used, and will return C.

=cut

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

sub symname
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return $mksymname->( '$', $self->df->sv_at( $glob_at ) );
}

sub type
{
   my $self = shift;
   return "SCALAR" if defined $self->uv or defined $self->iv or defined $self->nv or defined $self->pv;
   return "UNDEF";
}

sub desc
{
   my $self = shift;

   my @flags;
   push @flags, "UV" if defined $self->uv;
   push @flags, "IV" if defined $self->iv;
   push @flags, "NV" if defined $self->nv;
   push @flags, "PV" if defined $self->pv;
   local $" = ",";
   return "UNDEF()" unless @flags;
   return "SCALAR(@flags)";
}

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

   my @outrefs;

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

   return @outrefs;
}

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

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

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

=cut

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

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

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

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

=head2 rv

   $svrv = $sv->rv

Returns the SV referred to by the reference.

=cut

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

=head2 is_weak

   $weak = $sv->is_weak

Returns true if the SV is a weakened RV reference.

=cut

# XS accessor

=head2 ourstash

   $stash = $sv->ourstash

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

=cut

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

sub desc
{
   my $self = shift;

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

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

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

   my @outrefs;

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

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

   return @outrefs;
}

package Devel::MAT::SV::BOOL 0.50;
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.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 4 );
use constant $CONSTANTS;
use constant basetype => "AV";

=head1 Devel::MAT::SV::ARRAY

Represents an array; an SV of type C.

=cut

sub refcount_adjusted
{
   my $self = shift;
   # AVs that are backrefs lists have an SvREFCNT artificially high
   return $self->refcnt - ( $self->is_backrefs ? 1 : 0 );
}

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

   my ( $n, $flags ) =
      unpack "$df->{uint_fmt} C", $header;

   $self->_set_array_fields( $flags || 0, [ $n ? $df->_read_ptrs($n) : () ] );
}

sub _more_saved
{
   my $self = shift;
   my ( $index, $addr ) = @_;

   push @{ $self->{saved} }, [ $index => $addr ];
}

=head2 is_unreal

   $unreal = $av->is_unreal

Returns true if the C flag is not set on the array - i.e. that its
SV pointers do not contribute to the C of the SVs it points at.

=head2 is_backrefs

   $backrefs = $av->is_backrefs

Returns true if the array contains the backrefs list of a hash or
weakly-referenced object.

=cut

# XS accessors

sub symname
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return $mksymname->( '@', $self->df->sv_at( $glob_at ) );
}

=head2 elems

   @svs = $av->elems

Returns all of the element SVs in a list

=cut

sub elems
{
   my $self = shift;

   my $n = $self->n_elems;
   return $n unless wantarray;

   my $df = $self->df;
   return map { $df->sv_at( $self->elem_at( $_ ) ) } 0 .. $n-1;
}

=head2 elem

   $sv = $av->elem( $index )

Returns the SV at the given index

=cut

sub elem
{
   my $self = shift;
   return $self->df->sv_at( $self->elem_at( $_[0] ) );
}

sub desc
{
   my $self = shift;

   my @flags = $self->n_elems;

   push @flags, "!REAL" if $self->is_unreal;

   $" = ",";
   return "ARRAY(@flags)";
}

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

   my $n = $self->n_elems;

   my @outrefs;

   if( $self->is_unreal ) {
      if( $match & STRENGTH_WEAK ) {
         foreach my $idx ( 0 .. $n-1 ) {
            my $sv = $self->elem( $idx ) or next;

            push @outrefs, $no_desc ? ( weak => $sv ) :
               Devel::MAT::SV::Reference( "element " . Devel::MAT::Cmd->format_value( $idx, index => 1 ), weak => $sv );
         }
      }
   }
   else {
      foreach my $idx ( 0 .. $n-1 ) {
         my $sv = $self->elem( $idx ) or next;

         my $name = $no_desc ? undef :
            "element " . Devel::MAT::Cmd->format_value( $idx, index => 1 );
         if( $match & STRENGTH_STRONG ) {
            push @outrefs, $no_desc ? ( strong => $sv ) :
               Devel::MAT::SV::Reference( $name, strong => $sv );
         }
         if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) {
            push @outrefs, $no_desc ? ( indirect => $rv ) :
               Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv );
         }
      }
   }

   foreach my $saved ( @{ $self->{saved} } ) {
      my $sv = $self->df->sv_at( $saved->[1] );

      push @outrefs, $no_desc ? ( inferred => $sv ) :
         Devel::MAT::SV::Reference( "saved value of element " . Devel::MAT::Cmd->format_value( $saved->[0], index => 1 ),
            inferred => $sv );
   }

   return @outrefs;
}

package Devel::MAT::SV::PADLIST 0.50;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
use constant type => "PADLIST";
use constant $CONSTANTS;

=head1 Devel::MAT::SV::PADLIST

A subclass of ARRAY, this is used to represent the PADLIST of a CODE SV.

=cut

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

sub desc
{
   my $self = shift;
   return "PADLIST(" . $self->n_elems . ")";
}

# Totally different outrefs format than ARRAY
sub _outrefs
{
   my $self = shift;
   my ( $match, $no_desc ) = @_;

   my @outrefs;

   if( $match & STRENGTH_STRONG ) {
      my $df = $self->df;
      my $n = $self->n_elems;

      if( my $padnames = $df->sv_at( $self->elem_at( 0 ) ) ) {
         push @outrefs, $no_desc ? ( strong => $padnames ) :
            Devel::MAT::SV::Reference( "the padnames", strong => $padnames );
      }

      foreach my $idx ( 1 .. $n-1 ) {
         my $pad = $df->sv_at( $self->elem_at( $idx ) ) or next;

         push @outrefs, $no_desc ? ( strong => $pad ) :
            Devel::MAT::SV::Reference( "pad at depth $idx", strong => $pad );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::PADNAMES 0.50;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
use constant type => "PADNAMES";
use constant $CONSTANTS;

=head1 Devel::MAT::SV::PADNAMES

A subclass of ARRAY, this is used to represent the PADNAMES of a CODE SV.

=cut

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

=head2 padname

   $padname = $padnames->padname( $padix )

Returns the name of the lexical at the given index, or C

=cut

sub padname
{
   my $self = shift;
   my ( $padix ) = @_;
   my $namepv = $self->elem( $padix ) or return undef;
   $namepv->type eq "SCALAR" or return undef;
   return $namepv->pv;
}

=head2 padix_from_padname

   $padix = $padnames->padix_from_padname( $padname )

Returns the index of the lexical with the given name, or C

=cut

sub padix_from_padname
{
   my $self = shift;
   my ( $padname ) = @_;

   foreach my $padix ( 1 .. scalar( $self->elems ) - 1 ) {
      my $namepv;
      return $padix if $namepv = $self->elem( $padix ) and
                       $namepv->type eq "SCALAR" and
                       $namepv->pv eq $padname;
   }

   return undef;
}

sub desc
{
   my $self = shift;
   return "PADNAMES(" . scalar($self->elems) . ")";
}

# Totally different outrefs format than ARRAY
sub _outrefs
{
   my $self = shift;
   my ( $match, $no_desc ) = @_;

   my @outrefs;

   if( $match & STRENGTH_STRONG ) {
      my $df = $self->df;
      my $n = $self->n_elems;

      foreach my $idx ( 1 .. $n-1 ) {
         my $padname = $df->sv_at( $self->elem_at( $idx ) ) or next;

         push @outrefs, $no_desc ? ( strong => $padname ) :
            Devel::MAT::SV::Reference( "padname " . Devel::MAT::Cmd->format_value( $idx, index => 1 ), strong => $padname );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::PAD 0.50;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
use constant type => "PAD";
use constant $CONSTANTS;

=head1 Devel::MAT::SV::PAD

A subclass of ARRAY, this is used to represent a PAD of a CODE SV.

=cut

sub desc
{
   my $self = shift;
   return "PAD(" . scalar($self->elems) . ")";
}

=head2 padcv

   $cv = $pad->padcv

Returns the C SV for which this is a pad.

=cut

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

=head2 lexvars

   ( $name, $sv, $name, $sv, ... ) = $pad->lexvars

Returns a name/value list of the lexical variables in the pad.

=cut

sub lexvars
{
   my $self = shift;
   my $padcv = $self->padcv;

   my @svs = $self->elems;
   return map {
      my $padname = $padcv->padname( $_ );
      $padname ? ( $padname->name => $svs[$_] ) : ()
   } 1 .. $#svs;
}

=head2 maybe_lexvar

   $sv = $pad->maybe_lexvar( $padname )

I

Returns the SV associated with the given padname if one exists, or C if
not.

Used to be named C.

=cut

sub maybe_lexvar
{
   my $self = shift;
   my ( $padname ) = @_;

   my $padix = $self->padcv->padix_from_padname( $padname ) or return undef;
   return $self->elem( $padix );
}

*lexvar = \&maybe_lexvar;

# Totally different outrefs format than ARRAY
sub _outrefs
{
   my $self = shift;
   my ( $match, $no_desc ) = @_;

   my $padcv = $self->padcv;

   my @svs = $self->elems;

   my @outrefs;

   if( $match & STRENGTH_STRONG and my $argsav = $svs[0] ) {
      push @outrefs, $no_desc ? ( strong => $argsav ) :
         Devel::MAT::SV::Reference( "the " . Devel::MAT::Cmd->format_note( '@_', 1 ) . " av", strong => $argsav );
   }

   foreach my $idx ( 1 .. $#svs ) {
      my $sv = $svs[$idx] or next;

      my $name;
      if( !$no_desc ) {
         my $padname = $padcv->padname( $idx );
         $name = $padname ? $padname->name : undef;
         if( $name ) {
            $name = "the lexical " . Devel::MAT::Cmd->format_note( $name, 1 );
         }
         else {
            $name = "pad temporary $idx";
         }
      }

      if( $match & STRENGTH_STRONG ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( $name, strong => $sv );
      }
      if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) {
         push @outrefs, $no_desc ? ( indirect => $rv ) :
            Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::HASH 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 5 );
use constant $CONSTANTS;
use constant basetype => "HV";

=head1 Devel::MAT::SV::HASH

Represents a hash; an SV of type C. The C
subclass is used to represent hashes that are used as stashes.

=cut

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

   ( my $n ) =
      unpack "$df->{uint_fmt} a*", $header;

   my %values_at;
   foreach ( 1 .. $n ) {
      my $key = $df->_read_str;
      $values_at{$key} = $df->_read_ptr;
   }

   $self->_set_hash_fields(
      $ptrs->[0], # BACKREFS
      \%values_at,
   );

}

# Back-compat. for loading old .pmat files that didn't store AvREAL
sub _fixup
{
   my $self = shift;

   if( my $backrefs = $self->backrefs ) {
      $backrefs->_set_backrefs( 1 ) if $backrefs->type eq "ARRAY";
   }
}

sub _more_saved
{
   my $self = shift;
   my ( $keyaddr, $valaddr ) = @_;

   push @{ $self->{saved} }, [ $keyaddr, $valaddr ];
}

sub symname
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return $mksymname->( '%', $self->df->sv_at( $glob_at ) );
}

# HVs have a backrefs field directly, rather than using magic
sub backrefs
{
   my $self = shift;
   return $self->df->sv_at( $self->backrefs_at );
}

=head2 keys

   @keys = $hv->keys

Returns the set of keys present in the hash, as plain perl strings, in no
particular order.

=cut

# XS accessor

=head2 value

   $sv = $hv->value( $key )

Returns the SV associated with the given key

=cut

sub value
{
   my $self = shift;
   my ( $key ) = @_;
   return $self->df->sv_at( $self->value_at( $key ) );
}

=head2 values

   @svs = $hv->values

Returns all of the SVs stored as values, in no particular order (though, in an
order corresponding to the order returned by C).

=cut

sub values
{
   my $self = shift;
   return $self->n_values if !wantarray;

   my $df = $self->df;
   return map { $df->sv_at( $_ ) } $self->values_at;
}

sub desc
{
   my $self = shift;
   my $named = $self->{name} ? " named $self->{name}" : "";
   return "HASH(" . $self->n_values . ")";
}

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

   my $df = $self->df;

   my @outrefs;

   if( my $backrefs = $self->backrefs ) {
      # backrefs are optimised so if there's only one backref, it is stored
      # in the backrefs slot directly
      if( $backrefs->type eq "ARRAY" ) {
         if( $match & STRENGTH_STRONG ) {
            push @outrefs, $no_desc ? ( strong => $backrefs ) :
               Devel::MAT::SV::Reference( "the backrefs list", strong => $backrefs );
         }

         if( $match & STRENGTH_INDIRECT ) {
            foreach my $sv ( $self->backrefs->elems ) {
               push @outrefs, $no_desc ? ( indirect => $sv ) :
                  Devel::MAT::SV::Reference( "a backref", indirect => $sv );
            }
         }
      }
      else {
         if( $match & STRENGTH_WEAK ) {
            push @outrefs, $no_desc ? ( weak => $backrefs ) :
               Devel::MAT::SV::Reference( "a backref", weak => $backrefs );
         }
      }
   }

   foreach my $key ( $self->keys ) {
      my $sv = $df->sv_at( $self->value_at( $key ) ) or next;
      my $name = $no_desc ? undef :
         "value " . Devel::MAT::Cmd->format_value( $key, key => 1 );

      if( $match & STRENGTH_STRONG ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( $name, strong => $sv );
      }
      if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) {
         push @outrefs, $no_desc ? ( indirect => $sv ) :
            Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv );
      }
   }

   foreach my $saved ( @{ $self->{saved} } ) {
      my $keysv = $self->df->sv_at( $saved->[0] );
      my $valsv = $self->df->sv_at( $saved->[1] );

      push @outrefs, $no_desc ? ( inferred => $keysv ) :
         Devel::MAT::SV::Reference( "a key for saved value",
            inferred => $keysv );
      push @outrefs, $no_desc ? ( inferred => $valsv ) :
         Devel::MAT::SV::Reference( "saved value of value " . Devel::MAT::Cmd->format_value( $keysv->pv, key => 1 ),
            inferred => $valsv );
   }

   return @outrefs;
}

package Devel::MAT::SV::STASH 0.50;
use base qw( Devel::MAT::SV::HASH );
__PACKAGE__->register_type( 6 );
use constant $CONSTANTS;

=head1 Devel::MAT::SV::STASH

Represents a hash used as a stash; an SV of type C whose C
is non-NULL. This is a subclass of C.

=cut

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

   my ( $hash_bytes, $hash_ptrs, $hash_strs ) = @{ $df->{sv_sizes}[5] };

   $self->SUPER::load(
      substr( $header, 0, $hash_bytes, "" ),
      [ splice @$ptrs, 0, $hash_ptrs ],
      [ splice @$strs, 0, $hash_strs ],
   );

   @{$self}{qw( mro_linearall_at mro_linearcurrent_at mro_nextmethod_at mro_isa_at )} =
      @$ptrs;

   ( $self->{name} ) =
      @$strs;
}

=head2 mro_linear_all

=head2 mro_linearcurrent

=head2 mro_nextmethod

=head2 mro_isa

   $hv = $stash->mro_linear_all

   $sv = $stash->mro_linearcurrent

   $sv = $stash->mro_nextmethod

   $av = $stash->mro_isa

Returns the fields from the MRO structure

=cut

sub mro_linearall     { my $self = shift; return $self->df->sv_at( $self->{mro_linearall_at} ) }
sub mro_linearcurrent { my $self = shift; return $self->df->sv_at( $self->{mro_linearcurrent_at} ) }
sub mro_nextmethod    { my $self = shift; return $self->df->sv_at( $self->{mro_nextmethod_at} ) }
sub mro_isa           { my $self = shift; return $self->df->sv_at( $self->{mro_isa_at} ) }

=head2 value_code

   $cv = $stash->value_code( $key )

Returns the CODE associated with the given symbol name, if it exists, or
C if not. This is roughly equivalent to

   $cv = $stash->value( $key )->code

Except that it is aware of the direct reference to CVs that perl 5.22 will
optimise for. This method should be used in preference to the above construct.

=cut

sub value_code
{
   my $self = shift;
   my ( $key ) = @_;

   my $sv = $self->value( $key ) or return undef;
   if( $sv->type eq "GLOB" ) {
      return $sv->code;
   }
   elsif( $sv->type eq "REF" ) {
      return $sv->rv;
   }

   die "TODO: value_code on non-GLOB, non-REF ${\ $sv->desc }";
}

=head2 stashname

   $name = $stash->stashname

Returns the name of the stash

=cut

sub stashname
{
   my $self = shift;
   return $self->{name};
}

sub desc
{
   my $self = shift;
   my $desc = $self->SUPER::desc;
   $desc =~ s/^HASH/STASH/;
   return $desc;
}

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

   my @outrefs = $self->SUPER::_outrefs( @_ );

   if( $match & STRENGTH_STRONG ) {
      if( my $sv = $self->mro_linearall ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the mro linear all HV",  strong => $sv );
      }
      if( my $sv = $self->mro_linearcurrent ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the mro linear current", strong => $sv );
      }
      if( my $sv = $self->mro_nextmethod ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the mro next::method",   strong => $sv );
      }
      if( my $sv = $self->mro_isa ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the mro ISA cache",      strong => $sv );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::CODE 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 7 );
use constant $CONSTANTS;
use constant basetype => "CV";

use Carp;

use List::Util 1.44 qw( uniq );

use Struct::Dumb 0.07 qw( struct );
struct Padname => [qw( name ourstash flags fieldix fieldstash_at )];
{
   no strict 'refs';
   *{__PACKAGE__."::Padname::is_outer"}  = sub { shift->flags & 0x01 };
   *{__PACKAGE__."::Padname::is_state"}  = sub { shift->flags & 0x02 };
   *{__PACKAGE__."::Padname::is_lvalue"} = sub { shift->flags & 0x04 };
   *{__PACKAGE__."::Padname::is_typed"}  = sub { shift->flags & 0x08 };
   *{__PACKAGE__."::Padname::is_our"}    = sub { shift->flags & 0x10 };

   # Internal flags, not appearing in the file itself
   *{__PACKAGE__."::Padname::is_field"}  = sub { shift->flags & 0x100 };
}

=head1 Devel::MAT::SV::CODE

Represents a function or closure; an SV of type C.

=cut

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

   my ( $line, $flags, $oproot, $depth ) =
      unpack "$df->{uint_fmt} C $df->{ptr_fmt} $df->{u32_fmt}", $header;

   defined $depth or $depth = -1;

   $self->_set_code_fields( $line, $flags, $oproot, $depth,
      @{$ptrs}[0, 2..4], # STASH, OUTSIDE, PADLIST, CONSTVAL
      @{$strs}[0, 1],    # FILE, NAME
   );
   $self->_set_glob_at( $ptrs->[1] );

   # After perl 5.20 individual padname structs are no longer arena-allocated
   $self->{padnames} = [] if $df->{perlver} > ( ( 5 << 24 ) | ( 20 << 16 ) | 0xffff );

   while( my $type = $df->_read_u8 ) {
      match( $type : == ) {
         case( 1 ) { push @{ $self->{consts_at} }, $df->_read_ptr }
         case( 2 ) { push @{ $self->{constix} }, $df->_read_uint }
         case( 3 ) { push @{ $self->{gvs_at} }, $df->_read_ptr }
         case( 4 ) { push @{ $self->{gvix} }, $df->_read_uint }
         case( 5 ) { my $padix = $df->_read_uint;
                     $self->{padnames}[$padix] = _load_padname( $df ); }
         case( 6 ) { # ignore - used to be padsvs_at
                     $df->_read_uint; $df->_read_uint; $df->_read_ptr; }
         case( 7 ) { $self->_set_padnames_at( $df->_read_ptr ); }
         case( 8 ) { my $depth = $df->_read_uint;
                     $self->{pads_at}[$depth] = $df->_read_ptr; }
         case( 9 )  { my $padname = $self->{padnames}[ $df->_read_uint ];
                      $padname->flags = $df->_read_u8; }
         case( 10 ) { my $padname = $self->{padnames}[ $df->_read_uint ];
                      $padname->flags |= 0x100;
                      $padname->fieldix = $df->_read_uint;
                      $padname->fieldstash_at = $df->_read_ptr; }
         default {
            die "TODO: unhandled CODEx type $type";
         }
      }
   }
}

sub _load_padname
{
   my ( $df ) = @_;

   return Padname( $df->_read_str, $df->_read_ptr, 0, 0, 0 );
}

sub _fixup
{
   my $self = shift;

   my $df = $self->df;

   my $padlist = $self->padlist;
   if( $padlist ) {
      bless $padlist, "Devel::MAT::SV::PADLIST";
      $padlist->_set_padcv_at( $self->addr );
   }

   my $padnames;
   my @pads;

   # 5.18.0 onwards has a totally different padlist arrangement
   if( $df->{perlver} >= ( ( 5 << 24 ) | ( 18 << 16 ) ) ) {
      $padnames = $self->padnames_av;

      @pads = map { $df->sv_at( $_ ) } @{ $self->{pads_at} };
      shift @pads; # always zero
   }
   elsif( $padlist ) {
      # PADLIST[0] stores the names of the lexicals
      # The rest stores the actual pads
      ( $padnames, @pads ) = $padlist->elems;
      $self->_set_padnames_at( $padnames->addr );
   }

   if( $padnames ) {
      bless $padnames, "Devel::MAT::SV::PADNAMES";
      $padnames->_set_padcv_at( $self->addr );

      $self->{padnames} = \my @padnames;

      foreach my $padix ( 1 .. $padnames->elems - 1 ) {
         my $padnamesv = $padnames->elem( $padix ) or next;
         $padnamesv->immortal and next; # UNDEF

         $padnames[$padix] = Padname( $padnamesv->pv, $padnamesv->ourstash, 0, 0, 0 );
      }
   }

   foreach my $pad ( @pads ) {
      next unless $pad;

      bless $pad, "Devel::MAT::SV::PAD";
      $pad->_set_padcv_at( $self->addr );
   }

   $self->{pads} = \@pads;

   # Under ithreads, constants and captured GVs are actually stored in the first padlist
   if( $df->ithreads ) {
      my $pad0 = $pads[0];

      foreach my $type (qw( const gv )) {
         my $idxes  = $self->{"${type}ix"} or next;
         my $svs_at = $self->{"${type}s_at"} ||= [];

         @$svs_at = map { my $e = $pad0->elem($_);
                          $e ? $e->addr : undef } uniq @$idxes;
      }
   }

   if( $self->is_cloned and my $oproot = $self->oproot ) {
      if( my $protosub = $df->{protosubs_by_oproot}{$oproot} ) {
         $self->_set_protosub_at( $protosub->addr );
      }
   }
}

=head2 stash

=head2 glob

=head2 file

=head2 line

=head2 scope

=head2 padlist

=head2 constval

=head2 oproot

=head2 depth

   $stash = $cv->stash

   $gv = $cv->glob

   $filename = $cv->file

   $line = $cv->line

   $scope_cv = $cv->scope

   $av = $cv->padlist

   $sv = $cv->constval

   $addr = $cv->oproot

   $depth = $cv->depth

Returns the stash, glob, filename, line number, scope, padlist, constant value,
oproot or depth of the code.

=cut

sub stash    { my $self = shift; return $self->df->sv_at( $self->stash_at ) }
sub glob     { my $self = shift; return $self->df->sv_at( $self->glob_at ) }
# XS accessors: file, line
sub scope    { my $self = shift; return $self->df->sv_at( $self->outside_at ) }
sub padlist  { my $self = shift; return $self->df->sv_at( $self->padlist_at ) }
sub constval { my $self = shift; return $self->df->sv_at( $self->constval_at ) }
# XS accessors: oproot, depth

=head2 location

   $location = $cv->location

Returns C if the line is defined, or C if not.

=cut

sub location
{
   my $self = shift;
   my $line = $self->line;
   my $file = $self->file;
   # line 0 is invalid
   return $line ? "$file line $line" : $file;
}

=head2 is_clone

=head2 is_cloned

=head2 is_xsub

=head2 is_weakoutside

=head2 is_cvgv_rc

=head2 is_lexical

   $clone = $cv->is_clone

   $cloned = $cv->is_cloned

   $xsub = $cv->is_xsub

   $weak = $cv->is_weakoutside

   $rc = $cv->is_cvgv_rc

   $lexical = $cv->is_lexical

Returns the C, C, C, C,
C and C flags.

=cut

# XS accessors

=head2 protosub

   $protosub = $cv->protosub

Returns the protosub CV, if known, for a closure CV.

=cut

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

=head2 constants

   @svs = $cv->constants

Returns a list of the SVs used as constants or method names in the code. On
ithreads perl the constants are part of the padlist structure so this list is
constructed from parts of the padlist at loading time.

=cut

sub constants
{
   my $self = shift;
   my $df = $self->df;
   return map { $df->sv_at($_) } @{ $self->{consts_at} || [] };
}

=head2 globrefs

   @svs = $cv->globrefs

Returns a list of the SVs used as GLOB references in the code. On ithreads
perl the constants are part of the padlist structure so this list is
constructed from parts of the padlist at loading time.

=cut

sub globrefs
{
   my $self = shift;
   my $df = $self->df;
   return map { $df->sv_at($_) } @{ $self->{gvs_at} };
}

sub stashname { my $self = shift; return $self->stash ? $self->stash->stashname : undef }

sub symname
{
   my $self = shift;

   # CvLEXICALs or CVs with non-reified CvGVs may still have a hekname
   if( defined( my $hekname = $self->hekname ) ) {
      my $stashname = $self->stashname;
      $stashname =~ s/^main:://;
      return '&' . $stashname . "::" . $hekname;
   }
   elsif( my $glob = $self->glob ) {
      return '&' . $glob->stashname;
   }

   return undef;
}

=head2 padname

   $padname = $cv->padname( $padix )

Returns the name of the $padix'th lexical variable, or C if it doesn't
have a name.

The returned padname is a structure of the following fields:

 $name = $padname->name

 $bool = $padname->is_outer
 $bool = $padname->is_state
 $bool = $padname->is_lvalue
 $bool = $padname->is_typed
 $bool = $padname->is_our
 $bool = $padname->is_field

=cut

sub padname
{
   my $self = shift;
   my ( $padix ) = @_;

   return $self->{padnames}[$padix];
}

=head2 padix_from_padname

   $padix = $cv->padix_from_padname( $padname )

Returns the index of the first lexical variable with the given pad name, or
C if one does not exist.

=cut

sub padix_from_padname
{
   my $self = shift;
   my ( $padname ) = @_;

   my $padnames = $self->{padnames};

   foreach my $padix ( 1 .. $#$padnames ) {
      my $thisname;

      return $padix if defined $padnames->[$padix] and
                       defined( $thisname = $padnames->[$padix]->name ) and
                       $thisname eq $padname;
   }

   return undef;
}

=head2 max_padix

   $max_padix = $cv->max_padix

Returns the maximum valid pad index.

This is typically used to create a list of potential pad indexes, such as

   0 .. $cv->max_padix

Note that since pad slots may contain things other than lexical variables, not
every pad slot between 0 and this index will necessarily contain a lexical
variable or have a pad name.

=cut

sub max_padix
{
   my $self = shift;
   return $#{ $self->{padnames} };
}

=head2 padnames_av

   $padnames_av = $cv->padnames_av

Returns the AV reference directly which stores the pad names.

After perl version 5.20, this is no longer used directly and will return
C. The individual pad names themselves can still be found via the
C method.

=cut

sub padnames_av
{
   my $self = shift;

   return $self->df->sv_at( $self->padnames_at or return undef )
      // croak "${\ $self->desc } PADNAMES is not accessible";
}

=head2 pads

   @pads = $cv->pads

Returns a list of the actual pad AVs.

=cut

sub pads
{
   my $self = shift;
   return $self->{pads} ? @{ $self->{pads} } : ();
}

=head2 pad

   $pad = $cv->pad( $depth )

Returns the PAD at the given depth (given by 1-based index).

=cut

sub pad
{
   my $self = shift;
   my ( $depth ) = @_;
   return $self->{pads} ? $self->{pads}[$depth-1] : undef;
}

=head2 maybe_lexvar

   $sv = $cv->maybe_lexvar( $padname, $depth )

I

Returns the SV on the PAD associated with the given padname, at the
optionally-given depth (1-based index). If I<$depth> is not provided, the
topmost live PAD will be used. If no variable exists of the given name returns
C.

Used to be called C.

=cut

sub maybe_lexvar
{
   my $self = shift;
   my ( $padname, $depth ) = @_;

   $depth //= $self->depth;
   $depth or croak "Cannot fetch current pad of a non-live CODE";

   return $self->pad( $depth )->maybe_lexvar( $padname );
}

*lexvar = \&maybe_lexvar;

sub desc
{
   my $self = shift;

   my @flags;
   push @flags, "PP"    if $self->oproot;
   push @flags, "CONST" if $self->constval;
   push @flags, "XS"    if $self->is_xsub;

   push @flags, "closure" if $self->is_cloned;
   push @flags, "proto"   if $self->is_clone;

   local $" = ",";
   return "CODE(@flags)";
}

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

   my $pads = $self->{pads};

   my $maxdepth = $pads ? scalar @$pads : 0;

   my $have_padlist = defined $self->padlist;

   my @outrefs;

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

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

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

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

   if( $match & STRENGTH_INFERRED and my $protosub = $self->protosub ) {
      push @outrefs, $no_desc ? ( inferred => $protosub ) :
         Devel::MAT::SV::Reference( "the protosub", inferred => $protosub );
   }

   # Under ithreads, constants and captured GVs are actually stored in the
   # first padlist, so they're only here.
   my $ithreads = $self->df->ithreads;

   if( $match & ( $ithreads ? STRENGTH_INDIRECT : STRENGTH_STRONG ) ) {
      my $strength = $ithreads ? "indirect" : "strong";

      foreach my $sv ( $self->constants ) {
         $sv or next;
         push @outrefs, $no_desc ? ( $strength => $sv ) :
            Devel::MAT::SV::Reference( "a constant", $strength => $sv );
      }
      foreach my $sv ( $self->globrefs ) {
         $sv or next;
         push @outrefs, $no_desc ? ( $strength => $sv ) :
            Devel::MAT::SV::Reference( "a referenced glob", $strength => $sv );
      }
   }

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

   # If we have a PADLIST then its contents are indirect; if not then they
   #   are direct strong
   if( $match & ( $have_padlist ? STRENGTH_INDIRECT : STRENGTH_STRONG ) ) {
      my $strength = $have_padlist ? "indirect" : "strong";

      if( my $padnames_av = $self->padnames_av ) {
         push @outrefs, $no_desc ? ( $strength => $padnames_av ) :
            Devel::MAT::SV::Reference( "the padnames", $strength => $padnames_av );
      }

      foreach my $depth ( 1 .. $maxdepth ) {
         my $pad = $pads->[$depth-1] or next;

         push @outrefs, $no_desc ? ( $strength => $pad ) :
            Devel::MAT::SV::Reference( "pad at depth $depth", $strength => $pad );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::IO 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 8 );
use constant $CONSTANTS;
use constant basetype => "IO";

=head1 Devel::MAT::SV::IO

Represents an IO handle; an SV type of C.

=cut

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

   @{$self}{qw( ifileno ofileno )} =
      unpack "$df->{uint_fmt}2", $header;

   defined $_ and $_ == $df->{minus_1} and
      $_ = -1 for @{$self}{qw( ifileno ofileno )};

   @{$self}{qw( topgv_at formatgv_at bottomgv_at )} =
      @$ptrs;
}

=head2 ifileno

=head2 ofileno

   $ifileno = $io->ifileno

   $ofileno = $io->ofileno

Returns the input or output file numbers.

=cut

sub ifileno { my $self = shift; return $self->{ifileno} }
sub ofileno { my $self = shift; return $self->{ofileno} }

sub topgv    { my $self = shift; $self->df->sv_at( $self->{topgv_at}    ) }
sub formatgv { my $self = shift; $self->df->sv_at( $self->{formatgv_at} ) }
sub bottomgv { my $self = shift; $self->df->sv_at( $self->{bottomgv_at} ) }

sub desc { "IO()" }

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

   my @outrefs;

   if( $match & STRENGTH_STRONG ) {
      if( my $gv = $self->topgv ) {
         push @outrefs, $no_desc ? ( strong => $gv ) :
            Devel::MAT::SV::Reference( "the top GV",    strong => $gv );
      }
      if( my $gv = $self->formatgv ) {
         push @outrefs, $no_desc ? ( strong => $gv ) :
            Devel::MAT::SV::Reference( "the format GV", strong => $gv );
      }
      if( my $gv = $self->bottomgv ) {
         push @outrefs, $no_desc ? ( strong => $gv ) :
            Devel::MAT::SV::Reference( "the bottom GV", strong => $gv );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::LVALUE 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 9 );
use constant $CONSTANTS;
use constant basetype => "LV";

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

   ( $self->{type}, $self->{off}, $self->{len} ) =
      unpack "a1 $df->{uint_fmt}2", $header;

   ( $self->{targ_at} ) =
      @$ptrs;
}

sub lvtype { my $self = shift; return $self->{type} }
sub off    { my $self = shift; return $self->{off} }
sub len    { my $self = shift; return $self->{len} }
sub target { my $self = shift; return $self->df->sv_at( $self->{targ_at} ) }

sub desc { "LVALUE()" }

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

   my @outrefs;

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

   return @outrefs;
}

package Devel::MAT::SV::REGEXP 0.50;
use base qw( Devel::MAT::SV );
use constant basetype => "REGEXP";
__PACKAGE__->register_type( 10 );

sub load {}

sub desc { "REGEXP()" }

sub _outrefs { () }

package Devel::MAT::SV::FORMAT 0.50;
use base qw( Devel::MAT::SV );
use constant basetype => "PVFM";
__PACKAGE__->register_type( 11 );

sub load {}

sub desc { "FORMAT()" }

sub _outrefs { () }

package Devel::MAT::SV::INVLIST 0.50;
use base qw( Devel::MAT::SV );
use constant basetype => "INVLIST";
__PACKAGE__->register_type( 12 );

sub load {}

sub desc { "INVLIST()" }

sub _outrefs { () }

# A hack to compress files
package Devel::MAT::SV::_UNDEFSV 0.50;
use base qw( Devel::MAT::SV::SCALAR );
__PACKAGE__->register_type( 13 );

sub load
{
   my $self = shift;

   bless $self, "Devel::MAT::SV::SCALAR";

   $self->_set_scalar_fields( 0, 0, 0,
      "", 0,
      0,
   );
}

package Devel::MAT::SV::_YESSV 0.50;
use base qw( Devel::MAT::SV::BOOL );
__PACKAGE__->register_type( 14 );

sub load
{
   my $self = shift;

   bless $self, "Devel::MAT::SV::BOOL";

   $self->_set_scalar_fields( 0x01, 1, 1.0,
      "1", 1,
      0,
   );
}

package Devel::MAT::SV::_NOSV 0.50;
use base qw( Devel::MAT::SV::BOOL );
__PACKAGE__->register_type( 15 );

sub load
{
   my $self = shift;

   bless $self, "Devel::MAT::SV::BOOL";

   $self->_set_scalar_fields( 0x01, 0, 0,
      "", 0,
      0,
   );
}

package Devel::MAT::SV::OBJECT 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 16 );
use constant $CONSTANTS;
use constant basetype => "OBJ";

=head1 Devel::MAT::SV::OBJECT

Represents an object instance; an SV of type C. These are only
present in files from perls with C.

=cut

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

   my ( $n ) =
      unpack "$df->{uint_fmt} a*", $header;

   my @fields_at = $n ? $df->_read_ptrs( $n ) : ();
   $self->_set_object_fields( \@fields_at );
}

=head2 fields

   @svs = $obj->fields

Returns all the values of all the fields in a list.

Note that to find the names of the fields you'll have to enquire with the
class

=cut

sub fields
{
   my $self = shift;

   my $n = $self->n_fields;
   return $n unless wantarray;

   my $df = $self->df;
   return map { $df->sv_at( $self->field_at( $_ ) ) } 0 .. $n-1;
}

=head2 field

   $sv = $obj->field( $name_or_fieldix )

Returns the value of the given field; which may be specified by name or
index directly.

=cut

sub field
{
   my $self = shift;
   my ( $name_or_fieldix ) = @_;

   my $fieldix;
   if( $name_or_fieldix =~ m/^\d+$/ ) {
      $fieldix = $name_or_fieldix;
   }
   else {
      $fieldix = $self->blessed->field( $name_or_fieldix )->fieldix;
   }

   return $self->df->sv_at( $self->field_at( $fieldix ) );
}

sub desc
{
   my $self = shift;

   return "OBJ()";
}

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

   my $n = $self->n_fields;

   my @outrefs;

   foreach my $field ( $self->blessed->fields ) {
      my $sv = $self->field( $field->fieldix ) or next;

      my $name = $no_desc ? undef :
         "the " . Devel::MAT::Cmd->format_note( $field->name, 1 ) . " field";
      if( $match & STRENGTH_STRONG ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( $name, strong => $sv );
      }
      if( $match & STRENGTH_INDIRECT and $sv->type eq "REF" and !$sv->{magic} and my $rv = $sv->rv ) {
         push @outrefs, $no_desc ? ( indirect => $rv ) :
            Devel::MAT::SV::Reference( $name . " via RV", indirect => $rv );
      }
   }

   return @outrefs;
}

package Devel::MAT::SV::CLASS 0.50;
use base qw( Devel::MAT::SV::STASH );
__PACKAGE__->register_type( 17 );
use constant $CONSTANTS;

use Carp;

use Struct::Dumb 0.07 qw( readonly_struct );
readonly_struct Field => [qw( fieldix name )];

use List::Util qw( first );

=head1 Devel::MAT::SV::CLASS

Represents a class; a sub-type of stash for implementing object classes. These
are only present in files from perls with C.

=cut

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

   my ( $stash_bytes, $stash_ptrs, $stash_strs ) = @{ $df->{sv_sizes}[6] };

   $self->SUPER::load(
      substr( $header, 0, $stash_bytes, "" ),
      [ splice @$ptrs, 0, $stash_ptrs ],
      [ splice @$strs, 0, $stash_strs ],
   );

   @{$self}{qw( adjust_blocks_at )} =
      @$ptrs;

   while( my $type = $df->_read_u8 ) {
      match( $type : == ) {
         case( 1 ) { push @{ $self->{fields} }, [ $df->_read_uint, $df->_read_str ] }
         default {
            die "TODO: unhandled CLASSx type $type";
         }
      }
   }
}

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

=head2 fields

   @fields = $class->fields

Returns a list of the field definitions of the class, in declaration order.
Each is a structure whose form is given below.

=cut

sub fields
{
   my $self = shift;
   return map { Field( @$_ ) } @{ $self->{fields} };
}

=head2 field

   $field = $class->field( $name_or_fieldix )

Returns the field definition of the given field; which may be specified by
name or index directly. Throws an exception if none such exists.

The returned field is a structure of the following fields:

   $fieldix = $field->fieldix
   $name    = $field->name

=head2 maybe_field

   $field = $class->maybe_field( $name_or_fieldix )

I

Similar to L but returns undef if none such exists.

=cut

sub maybe_field
{
   my $self = shift;
   my ( $name_or_fieldix ) = @_;

   if( $name_or_fieldix =~ m/^\d+$/ ) {
      return first { $_->fieldix == $name_or_fieldix } $self->fields;
   }
   else {
      return first { $_->name eq $name_or_fieldix } $self->fields
   }
}

sub field
{
   my $self = shift;
   return $self->maybe_field( @_ ) // do {
      my ( $name_or_fieldix ) = @_;
      croak "No field at index $name_or_fieldix" if $name_or_fieldix =~ m/^\d+$/;
      croak "No field named '$name_or_fieldix'";
   };
}

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

   my @outrefs = $self->SUPER::_outrefs( @_ );

   if( $match & STRENGTH_STRONG ) {
      if( my $sv = $self->adjust_blocks ) {
         push @outrefs, $no_desc ? ( strong => $sv ) :
            Devel::MAT::SV::Reference( "the ADJUST blocks AV", strong => $sv );
      }
   }

   return @outrefs;
}

# A "SV" type that isn't really an SV, but has many of the same methods. These
# aren't created by core perl, but are used by XS extensions
package Devel::MAT::SV::C_STRUCT 0.50;
use base qw( Devel::MAT::SV );
__PACKAGE__->register_type( 0x7F );
use constant $CONSTANTS;
use constant {
   FIELD_PTR  => 0x00,
   FIELD_BOOL => 0x01,
   FIELD_U8   => 0x02,
   FIELD_U32  => 0x03,
   FIELD_UINT => 0x04,
};
use Carp;
use List::Util qw( first );

=head1 Devel::MAT::SV::C_STRUCT

Represents a C-level c type.

=cut

sub desc
{
   my $self = shift;
   my $typename = $self->structtype->name;

   "C_STRUCT($typename)";
}

sub load
{
   my $self = shift;
   my ( $fields ) = @_;

   my $df = $self->df;

   my @vals;

   foreach my $field ( @$fields ) {
      push @vals, my $type = $field->type;

      if( $type == FIELD_PTR ) {
         push @vals, $df->_read_ptr;
      }
      elsif( $type == FIELD_BOOL or $type == FIELD_U8 ) {
         push @vals, $df->_read_u8;
      }
      elsif( $type == FIELD_U32 ) {
         push @vals, $df->_read_u32;
      }
      elsif( $type == FIELD_UINT ) {
         push @vals, $df->_read_uint;
      }
      else {
         croak "TODO: load struct field type = $type\n";
      }
   }

   $self->_set_struct_fields( @vals );
}

=head2 fields

   @kvlist = $struct->fields

Returns an even-sized name/value list of all the field values stored by the
struct; each preceeded by its field type structure.

=cut

sub fields
{
   my $self = shift;

   my $df = $self->df;

   my $fields = $self->structtype->fields;

   return map {
      my $field = $fields->[$_];

      if( $field->type == FIELD_PTR ) {
         $field => $df->sv_at( $self->field( $_ ) )
      }
      else {
         $field => $self->field( $_ );
      }
   } 0 .. $#$fields;
}

=head2 field_named

   $val = $struct->field_named( $name )

Looks for a field whose name is exactly that given, and returns its value.

Throws an exception if the struct has no such field of that name.

=head2 maybe_field_named

   $val = $struct->maybe_field_named( $name )

I

As L but returns C if there is no such field.

=cut

sub maybe_field_named
{
   my $self = shift;
   my ( $name ) = @_;

   my $fields = $self->structtype->fields;

   defined( my $idx = first { $fields->[$_]->name eq $name } 0 .. $#$fields )
      or return undef;

   my $field = $fields->[$idx];

   if( $field->type == FIELD_PTR ) {
      return $self->df->sv_at( $self->field( $idx ) );
   }
   else {
      return $self->field( $idx );
   }
}

sub field_named
{
   my $self = shift;
   my ( $name ) = @_;

   return $self->maybe_field_named( $name ) // croak "No field named $name";
}

=head2 structtype

   $structtype = $struct->structtype

Returns a metadata structure describing the type of the struct itself.

Has the following named accessors

=over 4

=item name => STRING

The name of the struct type, as given by the dumpfile.

=item fields => ARRAY[ Field ]

An ARRAY reference containing the definitions of each field in turn

=back

=cut

sub structtype
{
   my $self = shift;
   return $self->df->structtype( $self->structid );
}

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

   return unless $match & STRENGTH_STRONG;

   my $df = $self->df;

   my @outrefs;

   my $fields = $self->structtype->fields;
   foreach my $idx ( 0 .. $#$fields ) {
      my $field = $fields->[$idx];
      $field->type == FIELD_PTR or next; # Is PTR

      my $sv = $df->sv_at( $self->field( $idx ) ) or next;

      push @outrefs, $no_desc ? ( strong => $sv ) :
         Devel::MAT::SV::Reference( $field->name, strong => $sv );
   }

   return @outrefs;
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;