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

package Devel::MAT::SV;

use strict;
use warnings;
use feature qw( switch );
no if $] >= 5.017011, warnings => 'experimental::smartmatch';

our $VERSION = '0.23';

use Carp;
use Scalar::Util qw( weaken );
use List::Util qw( pairgrep pairmap pairs );

# Load XS code
require Devel::MAT;

use constant immortal => 0;

use Struct::Dumb 0.07 qw( readonly_struct );
readonly_struct Reference => [qw( name strength sv )];

=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

# Lexical subs, so all inline subclasses can see it
my $direct_or_rv = sub {
   my ( $name, $sv ) = @_;
   if( defined $sv and $sv->type eq "REF" and !$sv->{magic} ) {
      return ( "+$name" => $sv,
               ";$name via RV" => $sv->rv );
   }
   else {
      return ( "+$name" => $sv );
   }
};

my $indirect_or_rv = sub {
   my ( $name, $sv ) = @_;
   if( defined $sv and $sv->type eq "REF" and !$sv->{magic} ) {
      return ( ";$name" => $sv,
               ";$name via RV" => $sv->rv );
   }
   else {
      return ( ";$name" => $sv );
   }
};

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<Devel::MAT::SV::> prefix.

=cut

=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<desc> 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<SvREFCNT> 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<SvREFCNT> 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<undef>.

=cut

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

=head2 size

   $size = $sv->size

Returns the (approximate) size in bytes of the SV

=cut

# XS accessor

=head2 magic

   ( $type, $sv, $type, $sv, ... ) = $sv->magic

Returns a pair list of magic applied to the SV; each giving the type and
target SV.

=cut

# TODO: This interface needs fixing
sub magic
{
   my $self = shift;
   return unless my $magic = $self->{magic};

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

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

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

=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<Devel::MAT> 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<strong> references contribute to
the C<refcount> of the referrant, others do not. C<strong> and C<weak>
references are SV addresses found directly within the referring SV structure;
C<indirect> and C<inferred> references are extra return values added here for
convenience by examining the surrounding structure.

=item sv => SV

The referrant SV itself.

=back

=cut

# Each outref name starts with one of four characters to indicate its type
my %STRENGTH_FROM_PREFIX = (
   "+" => "strong", # direct strong
   "-" => "weak",   # direct weak
   ";" => "indirect",
   "." => "inferred",
);

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

   my @outrefs = pairgrep { defined $b } $self->_outrefs;

   push @outrefs, "-the bless package", $self->blessed if $self->blessed;

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

      if( my $obj = $self->df->sv_at( $obj_at ) ) {
         my $reftype = ( $flags & 0x01 ) ? "+" : "-";
         push @outrefs, "$reftype'$type' magic object" => $obj;
      }
      if( my $ptr = $self->df->sv_at( $ptr_at ) ) {
         push @outrefs, "+'$type' magic pointer" => $ptr;
      }
   }

   @outrefs = pairgrep { $a =~ m/^$match/ } @outrefs if $match;

   return @outrefs / 2 if !wantarray;

   return pairmap {
      my $prefix = substr( $a, 0, 1, "" );
      Reference( $a, $STRENGTH_FROM_PREFIX{$prefix}, $b )
   } @outrefs;
}

sub outrefs { shift->_outrefs_matching( undef ) }

=head2 outrefs_strong

   @refs = $sv->outrefs_strong

Returns the subset of C<outrefs> that are direct strong references.

=head2 outrefs_weak

   @refs = $sv->outrefs_weak

Returns the subset of C<outrefs> that are direct weak references.

=head2 outrefs_direct

   @refs = $sv->outrefs_direct

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

=head2 outrefs_indirect

   @refs = $sv->outrefs_indirect

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

=head2 outrefs_inferred

   @refs = $sv->outrefs_inferred

Returns the subset of C<outrefs> that are not directly stored in the SV
structure, but instead inferred by C<Devel::MAT> itself.

=cut

sub outrefs_strong   { shift->_outrefs_matching( qr/\+/   ) }
sub outrefs_weak     { shift->_outrefs_matching( qr/-/    ) }
sub outrefs_direct   { shift->_outrefs_matching( qr/[+-]/ ) }
sub outrefs_indirect { shift->_outrefs_matching( qr/;/    ) }
sub outrefs_inferred { shift->_outrefs_matching( qr/\./   ) }

=head1 IMMORTAL SVs

Three special SV objects exist outside of the heap, to represent C<undef> 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;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
use constant immortal => 1;
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;
use base qw( Devel::MAT::SV::Immortal );
our $VERSION = '0.23';
sub desc { "UNDEF" }
sub type { "UNDEF" }

package Devel::MAT::SV::YES;
use base qw( Devel::MAT::SV::Immortal );
our $VERSION = '0.23';
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 { '' }
sub name {}

package Devel::MAT::SV::NO;
use base qw( Devel::MAT::SV::Immortal );
our $VERSION = '0.23';
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 { '' }
sub name {}

package Devel::MAT::SV::Unknown;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 0xff );

sub desc { "UNKNOWN" }

sub _outrefs {}

package Devel::MAT::SV::GLOB;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 1 );

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

Represents a glob; an SV of type C<SVt_PVGV>.

=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<FILE line LINE>)
that the GV first appears at.

=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;


   return (
      "+the scalar" => $self->scalar,
      "+the array"  => $self->array,
      "+the hash"   => $self->hash,
      "+the code"   => $self->code,
      "+the io"     => $self->io,
      "+the form"   => $self->form,

      # the egv is weakref if if it points back to itself
      ( $self->egv and $self->egv == $self ) ? "-the egv" : "+the egv" =>
         $self->egv,
   );
}

package Devel::MAT::SV::SCALAR;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 2 );

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

Represents a non-referential scalar value; an SV of any of the types up to and
including C<SVt_PVMV> (that is, C<IV>, C<NV>, C<PV>, C<PVIV>, C<PVNV> or
C<PVMG>). 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<undef>.

=head2 iv

   $iv = $sv->iv

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

=head2 nv

   $nv = $sv->nv

Returns the floating numeric portion, if valid, or C<undef>.

=head2 pv

   $pv = $sv->pv

Returns the string portion, if valid, or C<undef>.

=head2 pvlen

   $pvlen = $sv->pvlen

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

=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<our>' variable.

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

=cut

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

sub name
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return '$' . $self->df->sv_at( $glob_at )->stashname;
}

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;

   return (
      "+the our stash" => $self->ourstash,
   );
}

package Devel::MAT::SV::REF;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 3 );

=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" : "";
}

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

sub _outrefs
{
   my $self = shift;
   return (
      ( $self->is_weak ? "-" : "+" ) . "the referrant" => $self->rv,
      "+the our stash" => $self->ourstash,
   );
}

package Devel::MAT::SV::ARRAY;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 4 );

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

Represents an array; an SV of type C<SVt_PVAV>.

=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) : () ] );
}

=head2 is_unreal

   $unreal = $av->is_unreal

Returns true if the C<AvREAL()> flag is not set on the array - i.e. that its
SV pointers do not contribute to the C<SvREFCNT> 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 name
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return '@' . $self->df->sv_at( $glob_at )->stashname;
}

=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 =
      scalar($self->elems);

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

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

sub _outrefs
{
   my $self = shift;
   my $df = $self->df;

   my $n = $self->n_elems;

   if( $self->is_unreal ) {
      return map {
         +"-element [$_]" => $df->sv_at( $self->elem_at( $_ ) ),
      } 0 .. $n-1;
   }

   return map {
      $direct_or_rv->( "element [$_]" => $df->sv_at( $self->elem_at( $_ ) ) ),
   } 0 .. $n-1;
}

package Devel::MAT::SV::PADLIST;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
our $VERSION = '0.23';
use constant type => "PADLIST";

=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
sub _outrefs
{
   my $self = shift;
   my $df = $self->df;

   my $n = $self->n_elems;

   return (
      "+the padnames" => $df->sv_at( $self->elem_at( 0 ) ),

      map { +"+pad at depth $_" => $df->sv_at( $self->elem_at( $_ ) ) }
         1 .. $n-1
   );
}

package Devel::MAT::SV::PADNAMES;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
our $VERSION = '0.23';
use constant type => "PADNAMES";

=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<undef>

=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<undef>

=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
sub _outrefs
{
   my $self = shift;
   my $df = $self->df;

   my $n = $self->n_elems;

   return (
      # [0] is always UNDEF

      map { +"+padname [$_]" => $df->sv_at( $self->elem_at( $_ ) ) }
         1 .. $n-1
   );
}

package Devel::MAT::SV::PAD;
# Synthetic type
use base qw( Devel::MAT::SV::ARRAY );
our $VERSION = '0.23';
use constant type => "PAD";

use List::Util qw( pairmap );

=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 lexvars

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

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

=cut

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

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;
}

# Totally different outrefs format
sub _outrefs
{
   my $self = shift;
   my $padcv = $self->padcv;

   my @svs = $self->elems;

   return (
      '+the @_ av' => $svs[0],
      map {
         my $sv = $svs[$_];
         my $padname = $padcv->padname( $_ );
         my $name = $padname ? $padname->name : undef;
         $name ? ( $direct_or_rv->( "the lexical $name" => $sv ) )
               : ( $direct_or_rv->( "elem [$_]" => $sv ) )
      } 1 .. $#svs,
   );
}

package Devel::MAT::SV::HASH;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 5 );

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

Represents a hash; an SV of type C<SVt_PVHV>. The C<Devel::MAT::SV::STASH>
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 name
{
   my $self = shift;
   return unless my $glob_at = $self->glob_at;
   return '%' . $self->df->sv_at( $glob_at )->stashname;
}

# 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<keys>).

=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 $df = $self->df;

   my @keys = $self->keys;

   return (
      # backrefs are optimised so if there's only one backref, it is stored
      # in the backrefs slot directly
      ( $self->backrefs && $self->backrefs->type eq "ARRAY" ) ?
         ( "+the backrefs list" => $self->backrefs,
           map { +";a backref" => $_ } $self->backrefs->elems ) :
         ( "-a backref" => $self->backrefs ),

      map {
         $direct_or_rv->( "value {$_}" => $df->sv_at( $self->value_at( $_ ) ) )
      } @keys
   );
}

package Devel::MAT::SV::STASH;
use base qw( Devel::MAT::SV::HASH );
our $VERSION = '0.23';
__PACKAGE__->register_type( 6 );

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

Represents a hash used as a stash; an SV of type C<SVt_PVHV> whose C<HvNAME()>
is non-NULL. This is a subclass of C<Devel::MAT::SV::HASH>.

=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<undef> 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;
   return $self->SUPER::_outrefs,
      "+the mro linear all HV"  => $self->mro_linearall,
      "+the mro linear current" => $self->mro_linearcurrent,
      "+the mro next::method"   => $self->mro_nextmethod,
      "+the mro ISA cache"      => $self->mro_isa,
}

package Devel::MAT::SV::CODE;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 7 );

use Carp;

use List::Util 1.44 qw( uniq );

use Struct::Dumb 0.07 qw( readonly_struct );
readonly_struct Padname => [qw( name ourstash )];

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

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

=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 ) {
      given( $type ) {
         when( 1 ) { push @{ $self->{consts_at} }, $df->_read_ptr }
         when( 2 ) { push @{ $self->{constix} }, $df->_read_uint }
         when( 3 ) { push @{ $self->{gvs_at} }, $df->_read_ptr }
         when( 4 ) { push @{ $self->{gvix} }, $df->_read_uint }
         when( 5 ) { my $padix = $df->_read_uint;
                     $self->{padnames}[$padix] = _load_padname( $df ); }
         when( 6 ) { # ignore - used to be padsvs_at
                     $df->_read_uint; $df->_read_uint; $df->_read_ptr; }
         when( 7 ) { $self->_set_padnames_at( $df->_read_ptr ); }
         when( 8 ) { my $depth = $df->_read_uint;
                     $self->{pads_at}[$depth] = $df->_read_ptr; }
         default   { die "TODO: unhandled CODEx type $type"; }
      }
   }
}

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

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

sub _fixup
{
   my $self = shift;
   return unless $self->padlist_at;

   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;

      @pads = map { $df->sv_at( $_ ) } @{ $self->{pads_at} };
      shift @pads; # always zero
   }
   else {
      # 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 );
      }
   }

   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 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;

         # Clear the obviously unused elements of lexnames and padlists
         foreach my $ix ( @$idxes ) {
            $padnames->_clear_elem( $ix ) if $padnames;
            $_ and $_->_clear_elem( $ix ) for @pads;
         }
      }
   }
}

=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<FILE line LINE> if the line is defined, or C<FILE> 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<CvCLONE()>, C<CvCLONED()>, C<CvISXSUB()>, C<CvWEAKOUTSIDE()>,
C<CvCVGV_RC()> and C<CvLEXICAL()> 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 name
{
   my $self = shift;

   # CvLEXICALs or CVs with non-reified CvGVs may still have a hekname
   if( defined( my $hekname = $self->hekname ) ) {
      return '&' . $self->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<undef> if it doesn't
have a name.

The returned padname is a structure of the following fields:

 $name = $padname->name

=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<undef> if one does not exist.

=cut

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

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

   foreach my $padix ( 1 .. $#$padnames ) {
      return $padix if defined $padnames->[$padix] and
                       $padnames->[$padix]->name eq $padname;
   }

   return undef;
}

=head2 padnames

   $padnames = $cv->padnames

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<undef>. The individual pad names themselves can still be found via the
C<padname> method.

=cut

sub padnames
{
   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;
}

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, "C" if $self->is_cloned; # C for Closure
   push @flags, "P" if $self->is_clone;  # P for Protosub

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

sub _outrefs
{
   my $self = shift;
   my $pads = $self->{pads};

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

   my $padlist = $self->padlist;

   # If we have a PADLIST then its contents are indirect; if not then they are direct strong
   my $padnames_desc = $padlist ? ";the padnames"
                                : "+the padnames";
   my $pad_descf     = $padlist ? ";pad at depth %d"
                                : "+pad at depth %d";

   return (
      ( $self->is_weakoutside ? "-the scope" : "+the scope" ) =>
         $self->scope,

      "-the stash" => $self->stash,

      ( $self->is_cvgv_rc ? "+the glob" : "-the glob" ) =>
         $self->glob,

      "+the constant value" => $self->constval,
      ".the protosub" => $self->protosub,

      ( map { +"+a constant" => $_ } $self->constants ),
      ( map { +"+a referenced glob" => $_ } $self->globrefs ),

      "+the padlist" => $padlist,
      $padnames_desc => $self->padnames,

      ( map {
            my $depth = $_;
            sprintf( $pad_descf, $depth ) => $pads->[$depth-1],
         } 1 .. $maxdepth ),
   );
}

package Devel::MAT::SV::IO;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 8 );

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

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

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;
   return (
      "+the top GV" => $self->topgv,
      "+the format GV" => $self->formatgv,
      "+the bottom GV" => $self->bottomgv,
   );
}

package Devel::MAT::SV::LVALUE;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 9 );

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;
   return (
      "+the target" => $self->target,
   );
}

package Devel::MAT::SV::REGEXP;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 10 );

sub load {}

sub desc { "REGEXP()" }

sub _outrefs { () }

package Devel::MAT::SV::FORMAT;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 11 );

sub load {}

sub desc { "FORMAT()" }

sub _outrefs { () }

package Devel::MAT::SV::INVLIST;
use base qw( Devel::MAT::SV );
our $VERSION = '0.23';
__PACKAGE__->register_type( 12 );

sub load {}

sub desc { "INVLIST()" }

sub _outrefs { () }

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;
