File Coverage

blib/lib/Devel/MAT/Tool/Show.pm

Criterion	Covered	Total	%
statement	62	256	24.2
branch	0	134	0.0
condition	0	19	0.0
subroutine	21	43	48.8
pod	0	18	0.0
total	83	470	17.6

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

package Devel::MAT::Tool::Show 0.49;

use v5.14;
use warnings;
use base qw( Devel::MAT::Tool );

use List::Util qw( max );

use constant CMD => "show";
use constant CMD_DESC => "Show information about a given SV";

use constant CMD_OPTS => (
   full_pv => { help => "show the full captured PV",
                alias => "F" },
   pad => { help => "show the first PAD of a CODE",
            alias => "P" },
);

=head1 NAME

C - show information about a given SV

=head1 DESCRIPTION

This C tool provides a command that prints interesting information
from within an SV. Its exact output will depend on the type of SV it is
applied to.

=cut

=head1 COMMANDS

=cut

=head2 show

   pmat> show 0x1bbf598
   IO() at 0x1bbf598 with refcount 2
     blessed as IO::File
     ifileno=2
     ofileno=2

Prints information about the given SV.

=cut

use constant CMD_ARGS_SV => 1;

my @SHOW_EXTRA;
sub register_extra
{
   shift;
   my ( $code ) = @_;
   push @SHOW_EXTRA, $code;
}

sub run
{
   my $self = shift;
   my %opts = %{ +shift };
   my ( $sv ) = @_;

   Devel::MAT::Cmd->printf( "%s with refcount %d\n",
      Devel::MAT::Cmd->format_sv( $sv ),
      $sv->refcnt,
   );

   my $size = $sv->size;
   if( $size < 1024 ) {
      Devel::MAT::Cmd->printf( "  size %d bytes\n",
         $size,
      );
   }
   else {
      Devel::MAT::Cmd->printf( "  size %s (%d bytes)\n",
         Devel::MAT::Cmd->format_bytes( $size ),
         $size,
      );
   }

   if( my $stash = $sv->blessed ) {
      Devel::MAT::Cmd->printf( "  blessed as %s\n", $stash->stashname );
   }

   if( my $symname = $sv->symname ) {
      Devel::MAT::Cmd->printf( "  named as %s\n",
         Devel::MAT::Cmd->format_symbol( $symname )
      );
   }

   foreach my $magic ( $sv->magic ) {
      my $type = $magic->type;
      $type = "^" . chr( 0x40 + ord $type ) if ord $type < 0x20;

      Devel::MAT::Cmd->printf( "  has %s magic",
         Devel::MAT::Cmd->format_note( $type, 1 ),
      );

      Devel::MAT::Cmd->printf( " with object at %s",
         Devel::MAT::Cmd->format_sv( $magic->obj )
      ) if $magic->obj;

      Devel::MAT::Cmd->printf( " with pointer at %s",
         Devel::MAT::Cmd->format_sv( $magic->ptr )
      ) if $magic->ptr;

      Devel::MAT::Cmd->printf( "\n     with virtual table at 0x%x",
         $magic->vtbl
      ) if $magic->vtbl;

      Devel::MAT::Cmd->printf( "\n" );
   }

   if( defined( my $serial = $sv->debug_serial ) ) {
      Devel::MAT::Cmd->printf( "  debug serial %d\n", $serial );

      my $file = $sv->debug_file;
      Devel::MAT::Cmd->printf( "  created at %s:%d\n", $file, $sv->debug_line )
         if defined $file;
   }

   foreach my $extra ( @SHOW_EXTRA ) {
      $extra->( $sv ); # TODO: consider opts?
   }

   my $type = $sv->type;
   my $method = "show_$type";
   $self->$method( $sv, \%opts );
}

sub say_with_sv
{
   my ( $str, @args ) = @_;
   my $sv = pop @args;

   Devel::MAT::Cmd->printf( $str . "%s\n",
      @args,
      Devel::MAT::Cmd->format_sv( $sv ),
   );
}

sub show_GLOB
{
   my $self = shift;
   my ( $gv ) = @_;

   Devel::MAT::Cmd->printf( "  name=%s\n", $gv->name ) if $gv->name;

   say_with_sv '  stash=', $gv->stash if $gv->stash;

   say_with_sv '  SCALAR=', $gv->scalar if $gv->scalar;
   say_with_sv '  ARRAY=',  $gv->array  if $gv->array;
   say_with_sv '  HASH=',   $gv->hash   if $gv->hash;
   say_with_sv '  CODE=',   $gv->code   if $gv->code;
   say_with_sv '  EGV=',    $gv->egv    if $gv->egv;
   say_with_sv '  IO=',     $gv->io     if $gv->io;
   say_with_sv '  FORM=',   $gv->form   if $gv->form;
}

sub show_SCALAR
{
   my $self = shift;
   my ( $sv, $opts ) = @_;

   Devel::MAT::Cmd->printf( "  UV=%s\n",
      Devel::MAT::Cmd->format_value( $sv->uv, nv => 1 ),
   ) if defined $sv->uv;
   Devel::MAT::Cmd->printf( "  IV=%s\n",
      Devel::MAT::Cmd->format_value( $sv->iv, nv => 1 ),
   ) if defined $sv->iv;
   Devel::MAT::Cmd->printf( "  NV=%s\n",
      Devel::MAT::Cmd->format_value( $sv->nv, nv => 1 ),
   ) if defined $sv->nv;

   if( defined( my $pv = $sv->pv ) ) {
      Devel::MAT::Cmd->printf( "  PV=%s\n",
         Devel::MAT::Cmd->format_value( $pv, pv => 1,
             ( $opts->{full_pv} ? ( maxlen => 0 ) : () ),
         ),
      );
      Devel::MAT::Cmd->printf( "  PVLEN %d\n", $sv->pvlen );
   }
}

sub show_BOOL
{
   my $self = shift;
   my ( $sv, $opts ) = @_;

   Devel::MAT::Cmd->printf( "  BOOL=%s\n",
      Devel::MAT::Cmd->format_value( $sv->uv ? "true" : "false" )
   );
}

sub show_REF
{
   my $self = shift;
   my ( $sv ) = @_;

   say_with_sv '  RV=', $sv->rv if $sv->rv;
}

sub show_ARRAY
{
   my $self = shift;
   my ( $av ) = @_;

   Devel::MAT::Cmd->printf( "  %d elements (use 'elems' command to show)\n",
      $av->n_elems,
   );
}

sub show_STASH
{
   my $self = shift;
   my ( $hv ) = @_;

   Devel::MAT::Cmd->printf( "  stashname=%s\n", $hv->stashname );
   $self->show_HASH( $hv );
}

sub show_HASH
{
   my $self = shift;
   my ( $hv ) = @_;

   Devel::MAT::Cmd->printf( "  %d values (use 'values' command to show)\n",
      $hv->n_values,
   );
}

sub show_CODE
{
   my $self = shift;
   my ( $cv, $opts ) = @_;

   $cv->hekname  ? Devel::MAT::Cmd->printf( "  hekname=%s\n", $cv->hekname )
                 : Devel::MAT::Cmd->printf( "  no hekname\n" );

   $cv->stash    ? say_with_sv( "  stash=", $cv->stash )
                 : Devel::MAT::Cmd->printf( "  no stash\n" );

   $cv->glob     ? say_with_sv( "  glob=", $cv->glob )
                 : Devel::MAT::Cmd->printf( "  no glob\n" );

   $cv->location ? Devel::MAT::Cmd->printf( "  location=%s\n", $cv->location )
                 : Devel::MAT::Cmd->printf( "  no location\n" );

   $cv->scope    ? say_with_sv( "  scope=", $cv->scope )
                 : Devel::MAT::Cmd->printf( "  no scope\n" );

   $cv->padlist  ? say_with_sv( "  padlist=", $cv->padlist )
                 : ();

   $cv->padnames_av ? say_with_sv( "  padnames_av=", $cv->padnames_av )
                    : ();

   $cv->protosub ? say_with_sv( "  protosub=", $cv->protosub )
                 : ();

   my @pads = $cv->pads;
   foreach my $depth ( 0 .. $#pads ) {
      next unless $pads[$depth];
      say_with_sv( "  pad[$depth]=", $pads[$depth] );
   }

   if( $opts->{pad} and my $pad0 = ( $cv->pads )[0] ) {
      Devel::MAT::Cmd->printf( "PAD[0]:\n" );
      $self->show_PAD_contents( $pad0 );
   }

   if( my @globs = $cv->globrefs ) {
      Devel::MAT::Cmd->printf( "Referenced globs:\n  " );
      Devel::MAT::Cmd->printf( "%s, ", Devel::MAT::Cmd->format_sv( $_ ) ) for @globs;
      Devel::MAT::Cmd->printf( "\n" );
   }
}

sub show_PAD
{
   my $self = shift;
   my ( $pad ) = @_;

   my $padcv = $pad->padcv;
   $padcv ? say_with_sv( "  padcv=", $padcv )
          : Devel::MAT::Cmd->printf( "  no padcv\n" );

   $self->show_PAD_contents( $pad );
}

sub _join
{
   # Like CORE::join but respects string concat operator
   my ( $sep, @elems ) = @_;
   my $ret = shift @elems;
   $ret = $ret . $sep . $_ for @elems;
   return $ret;
}

sub show_PAD_contents
{
   my $self = shift;
   my ( $pad ) = @_;

   my $padcv = $pad->padcv;

   my @elems = $pad->elems;
   my @padnames = map {
      my $padname = $padcv->padname( $_ );
      # is_outer is always set for is_our; it's only interesting without is_our
      my $is_just_outer = $padname && $padname->is_outer && !$padname->is_our;

      $padname ? _join( " ",
         ( $padname->is_state ? Devel::MAT::Cmd->format_note( "state" ) : () ),
         ( $padname->is_our   ? Devel::MAT::Cmd->format_note( "our" )   : () ),
         ( $padname->is_field ? Devel::MAT::Cmd->format_note( "field" ) : () ),
         Devel::MAT::Cmd->format_note( $padname->name, 1 ),
         ( $is_just_outer     ? Devel::MAT::Cmd->format_note( "*OUTER", 2 ) : () ),
         # is_typed and is_lvalue not indicated
      ) : undef
   } 0 .. $#elems;
   my $idxlen  = length $#elems;
   my $namelen = max map { defined $_ ? length $_ : 0 } @padnames;

   my %padtype;
   if( my $gvix = $padcv->{gvix} ) {
      $padtype{$_} = "GLOB" for @$gvix;
   }
   if( my $constix = $padcv->{constix} ) {
      $padtype{$_} = "CONST" for @$constix;
   }

   Devel::MAT::Cmd->printf( "  [%*d/%-*s]=%s\n",
      $idxlen, 0,
      $namelen, Devel::MAT::Cmd->format_note( '@_', 1 ),
      ( $elems[0] ? Devel::MAT::Cmd->format_sv_with_value( $elems[0] ) : "NULL" ),
   );

   foreach my $padix ( 1 .. $#elems ) {
      my $sv = $elems[$padix];
      if( $padnames[$padix] ) {
         Devel::MAT::Cmd->printf( "  [%*d/%-*s]=%s\n",
            $idxlen, $padix,
            $namelen, $padnames[$padix],
            ( $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL" ),
         );
      }
      else {
         Devel::MAT::Cmd->printf( "  [%*d %-*s]=%s\n",
            $idxlen, $padix,
            $namelen, $padtype{$padix} // "",
            ( $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL" ),
         );
      }
   }
}

# TODO: PADLIST

sub show_PADNAMES
{
   my $self = shift;
   my ( $padnames ) = @_;

   $padnames->padcv ? say_with_sv( "  padcv=", $padnames->padcv )
                    : Devel::MAT::Cmd->printf( "  no padcv\n" );

   my @elems = $padnames->elems;
   # Every PADNAMES element is either NULL or a SCALAR(PV)
   # PADIX 0 is always @_
   foreach my $padix ( 1 .. $#elems ) {
      my $slot = $elems[$padix];
      if( $slot and $slot->type eq "SCALAR" ) {
         Devel::MAT::Cmd->printf( "  [%d] is %s\n", $padix, Devel::MAT::Cmd->format_note( $slot->pv, 1 ) );
      }
   }
}

sub show_IO
{
   my $self = shift;
   my ( $io ) = @_;

   Devel::MAT::Cmd->printf( "  ifileno=%d\n", $io->ifileno ) if defined $io->ifileno;
   Devel::MAT::Cmd->printf( "  ofileno=%d\n", $io->ofileno ) if defined $io->ofileno;
}

sub show_OBJECT
{
   my $self = shift;
   my ( $obj ) = @_;

   my @fields = $obj->fields;

   foreach my $field ( $obj->blessed->fields ) {
      my $val = $obj->field( $field->fieldix );

      Devel::MAT::Cmd->printf( "  %s=%s\n",
         Devel::MAT::Cmd->format_note( $field->name, 1 ),
         Devel::MAT::Cmd->format_sv_with_value( $val )
      );
   }
}

sub show_CLASS
{
   my $self = shift;
   my ( $cls ) = @_;

   Devel::MAT::Cmd->printf( "  is CLASS\n" );

   $cls->adjust_blocks ? say_with_sv( "  adjust_blocks=", $cls->adjust_blocks )
                       : ();

   $self->show_STASH( $cls );
}

sub show_C_STRUCT
{
   my $self = shift;
   my ( $struct ) = @_;

   my @fields = $struct->fields;

   while( @fields ) {
      my $field = shift @fields;
      my $val   = shift @fields;

      next unless defined $val;

      if( $field->type == 0x00 ) { # PTR
         Devel::MAT::Cmd->printf( "  %s=%s\n",
            $field->name,
            Devel::MAT::Cmd->format_sv_with_value( $val )
         );
      }
      elsif( $field->type == 0x01 ) { # BOOL
         Devel::MAT::Cmd->printf( "  %s=%s\n",
            $field->name,
            Devel::MAT::Cmd->format_value( $val ? "true" : "false" )
         );
      }
      else { # various number types
         Devel::MAT::Cmd->printf( "  %s=%s\n",
            $field->name,
            Devel::MAT::Cmd->format_value( $val ),
         );
      }
   }
}

package # hide
   Devel::MAT::Tool::Show::_elems;
use base qw( Devel::MAT::Tool );

use List::Util qw( min );

use constant CMD => "elems";
use constant CMD_DESC => "List the elements of an ARRAY SV";

=head2 elems

   pmat> elems endav
     [0] CODE(PP) at 0x562e93222dc8

Prints elements of an ARRAY SV.

Takes the following named options:

=over 4

=item --count, -c MAX

Show at most this number of elements (default 50).

=back

Takes the following positional arguments:

=over 4

=item *

Optional start index (default 0).

=back

=cut

use constant CMD_OPTS => (
   count => { help => "maximum count of elements to print",
              type => "i",
              alias => "c",
              default => 50 },
);

use constant CMD_ARGS_SV => 1;
use constant CMD_ARGS => (
   { name => "startidx", help => "starting index" },
);

sub run
{
   my $self = shift;
   my %opts = %{ +shift };
   my ( $av, $startidx ) = @_;

   my $type = $av->type;
   if( $type eq "HASH" or $type eq "STASH" ) {
      die "Cannot 'elems' of a $type - maybe you wanted 'values'?\n";
   }
   elsif( $type ne "ARRAY" ) {
      die "Cannot 'elems' of a non-ARRAY\n";
   }

   $startidx //= 0;
   my $stopidx = min( $startidx + $opts{count}, $av->n_elems );

   my @rows;
   foreach my $idx ( $startidx .. $stopidx-1 ) {
      my $sv = $av->elem( $idx );
      push @rows, [
         Devel::MAT::Cmd->format_value( $idx, index => 1 ),
         $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL",
      ];
   }

   Devel::MAT::Cmd->print_table( \@rows, indent => 2 );

   my $morecount = $av->n_elems - $stopidx;
   Devel::MAT::Cmd->printf( "  ... (%d more)\n", $morecount ) if $morecount;
}

package # hide
   Devel::MAT::Tool::Show::_values;
use base qw( Devel::MAT::Tool );

use constant CMD => "values";
use constant CMD_DESC => "List the values of a HASH-like SV";

=head2 values

   pmat> values defstash
     {"\b"}                GLOB($%*) at 0x562e93114eb8
     {"\017"}              GLOB($*) at 0x562e9315a428
     ...

Prints values of a HASH or STASH SV.

Takes the following named options:

=over 4

=item --count, -c MAX

Show at most this number of values (default 50).

=back

Takes the following positional arguments:

=over 4

=item *

Optional skip count (default 0). If present, will skip over this number of
keys initially to show more of them.

=back

=cut

use constant CMD_OPTS => (
   count => { help => "maximum count of values to print",
              type => "i",
              alias => "c",
              default => 50 },
);

use constant CMD_ARGS_SV => 1;
use constant CMD_ARGS => (
   { name => "skipcount", help => "skip over this many keys initially" },
);

sub run
{
   my $self = shift;
   my %opts = %{ +shift };
   my ( $hv, $skipcount ) = @_;

   my $type = $hv->type;
   if( $type eq "ARRAY" ) {
      die "Cannot 'values' of a $type - maybe you wanted 'elems'?\n";
   }
   elsif( $type ne "HASH" and $type ne "STASH" ) {
      die "Cannot 'elems' of a non-HASHlike\n";
   }

   # TODO: control of sorting, start at, filtering
   my @keys = sort $hv->keys;
   splice @keys, 0, $skipcount if $skipcount;

   Devel::MAT::Tool::more->paginate( { pagesize => $opts{count} }, sub {
      my ( $count ) = @_;
      my @rows;
      foreach my $key ( splice @keys, 0, $count ) {
         my $sv = $hv->value( $key );
         push @rows, [
            Devel::MAT::Cmd->format_value( $key, key => 1,
               stash => ( $type eq "STASH" ) ),
            $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL",
         ];
      }

      Devel::MAT::Cmd->print_table( \@rows, indent => 2 );

      my $morecount = @keys;
      Devel::MAT::Cmd->printf( "  ... (%d more)\n", $morecount ) if $morecount;
      return $morecount;
   } );
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;