1#  You may distribute under the terms of either the GNU General Public License
2#  or the Artistic License (the same terms as Perl itself)
3#
4#  (C) Paul Evans, 2016-2020 -- leonerd@leonerd.org.uk
5
6package Devel::MAT::Tool::Show 0.44;
7
8use v5.14;
9use warnings;
10use base qw( Devel::MAT::Tool );
11
12use List::Util qw( max );
13
14use constant CMD => "show";
15use constant CMD_DESC => "Show information about a given SV";
16
17use constant CMD_OPTS => (
18   full_pv => { help => "show the full captured PV",
19                alias => "F" },
20   pad => { help => "show the first PAD of a CODE",
21            alias => "P" },
22);
23
24=head1 NAME
25
26C<Devel::MAT::Tool::Show> - show information about a given SV
27
28=head1 DESCRIPTION
29
30This C<Devel::MAT> tool provides a command that prints interesting information
31from within an SV. Its exact output will depend on the type of SV it is
32applied to.
33
34=cut
35
36=head1 COMMANDS
37
38=cut
39
40=head2 show
41
42   pmat> show 0x1bbf598
43   IO() at 0x1bbf598 with refcount 2
44     blessed as IO::File
45     ifileno=2
46     ofileno=2
47
48Prints information about the given SV.
49
50=cut
51
52use constant CMD_ARGS_SV => 1;
53
54sub run
55{
56   my $self = shift;
57   my %opts = %{ +shift };
58   my ( $sv ) = @_;
59
60   Devel::MAT::Cmd->printf( "%s with refcount %d\n",
61      Devel::MAT::Cmd->format_sv( $sv ),
62      $sv->refcnt,
63   );
64
65   my $size = $sv->size;
66   if( $size < 1024 ) {
67      Devel::MAT::Cmd->printf( "  size %d bytes\n",
68         $size,
69      );
70   }
71   else {
72      Devel::MAT::Cmd->printf( "  size %s (%d bytes)\n",
73         Devel::MAT::Cmd->format_bytes( $size ),
74         $size,
75      );
76   }
77
78   if( my $stash = $sv->blessed ) {
79      Devel::MAT::Cmd->printf( "  blessed as %s\n", $stash->stashname );
80   }
81
82   if( my $symname = $sv->symname ) {
83      Devel::MAT::Cmd->printf( "  named as %s\n",
84         Devel::MAT::Cmd->format_symbol( $symname )
85      );
86   }
87
88   foreach my $magic ( $sv->magic ) {
89      my $type = $magic->type;
90      $type = "^" . chr( 0x40 + ord $type ) if ord $type < 0x20;
91
92      Devel::MAT::Cmd->printf( "  has %s magic",
93         Devel::MAT::Cmd->format_note( $type, 1 ),
94      );
95
96      Devel::MAT::Cmd->printf( " with object at %s",
97         Devel::MAT::Cmd->format_sv( $magic->obj )
98      ) if $magic->obj;
99
100      Devel::MAT::Cmd->printf( " with pointer at %s",
101         Devel::MAT::Cmd->format_sv( $magic->ptr )
102      ) if $magic->ptr;
103
104      Devel::MAT::Cmd->printf( "\n" );
105   }
106
107   if( defined( my $serial = $sv->debug_serial ) ) {
108      Devel::MAT::Cmd->printf( "  debug serial %d\n", $serial );
109
110      my $file = $sv->debug_file;
111      Devel::MAT::Cmd->printf( "  created at %s:%d\n", $file, $sv->debug_line )
112         if defined $file;
113   }
114
115   my $type = ref $sv; $type =~ s/^Devel::MAT::SV:://;
116   my $method = "show_$type";
117   $self->$method( $sv, \%opts );
118}
119
120sub say_with_sv
121{
122   my ( $str, @args ) = @_;
123   my $sv = pop @args;
124
125   Devel::MAT::Cmd->printf( $str . "%s\n",
126      @args,
127      Devel::MAT::Cmd->format_sv( $sv ),
128   );
129}
130
131sub show_GLOB
132{
133   my $self = shift;
134   my ( $gv ) = @_;
135
136   Devel::MAT::Cmd->printf( "  name=%s\n", $gv->name ) if $gv->name;
137
138   say_with_sv '  stash=', $gv->stash if $gv->stash;
139
140   say_with_sv '  SCALAR=', $gv->scalar if $gv->scalar;
141   say_with_sv '  ARRAY=',  $gv->array  if $gv->array;
142   say_with_sv '  HASH=',   $gv->hash   if $gv->hash;
143   say_with_sv '  CODE=',   $gv->code   if $gv->code;
144   say_with_sv '  EGV=',    $gv->egv    if $gv->egv;
145   say_with_sv '  IO=',     $gv->io     if $gv->io;
146   say_with_sv '  FORM=',   $gv->form   if $gv->form;
147}
148
149sub show_SCALAR
150{
151   my $self = shift;
152   my ( $sv, $opts ) = @_;
153
154   Devel::MAT::Cmd->printf( "  UV=%s\n",
155      Devel::MAT::Cmd->format_value( $sv->uv, nv => 1 ),
156   ) if defined $sv->uv;
157   Devel::MAT::Cmd->printf( "  IV=%s\n",
158      Devel::MAT::Cmd->format_value( $sv->iv, nv => 1 ),
159   ) if defined $sv->iv;
160   Devel::MAT::Cmd->printf( "  NV=%s\n",
161      Devel::MAT::Cmd->format_value( $sv->nv, nv => 1 ),
162   ) if defined $sv->nv;
163
164   if( defined( my $pv = $sv->pv ) ) {
165      Devel::MAT::Cmd->printf( "  PV=%s\n",
166         Devel::MAT::Cmd->format_value( $pv, pv => 1,
167             ( $opts->{full_pv} ? ( maxlen => 0 ) : () ),
168         ),
169      );
170      Devel::MAT::Cmd->printf( "  PVLEN %d\n", $sv->pvlen );
171   }
172}
173
174sub show_REF
175{
176   my $self = shift;
177   my ( $sv ) = @_;
178
179   say_with_sv '  RV=', $sv->rv if $sv->rv;
180}
181
182sub show_ARRAY
183{
184   my $self = shift;
185   my ( $av ) = @_;
186
187   Devel::MAT::Cmd->printf( "  %d elements (use 'elems' command to show)\n",
188      $av->n_elems,
189   );
190}
191
192sub show_STASH
193{
194   my $self = shift;
195   my ( $hv ) = @_;
196
197   Devel::MAT::Cmd->printf( "  stashname=%s\n", $hv->stashname );
198   $self->show_HASH( $hv );
199}
200
201sub show_HASH
202{
203   my $self = shift;
204   my ( $hv ) = @_;
205
206   Devel::MAT::Cmd->printf( "  %d values (use 'values' command to show)\n",
207      $hv->n_values,
208   );
209}
210
211sub show_CODE
212{
213   my $self = shift;
214   my ( $cv, $opts ) = @_;
215
216   $cv->hekname  ? Devel::MAT::Cmd->printf( "  hekname=%s\n", $cv->hekname )
217                 : Devel::MAT::Cmd->printf( "  no hekname\n" );
218
219   $cv->stash    ? say_with_sv( "  stash=", $cv->stash )
220                 : Devel::MAT::Cmd->printf( "  no stash\n" );
221
222   $cv->glob     ? say_with_sv( "  glob=", $cv->glob )
223                 : Devel::MAT::Cmd->printf( "  no glob\n" );
224
225   $cv->location ? Devel::MAT::Cmd->printf( "  location=%s\n", $cv->location )
226                 : Devel::MAT::Cmd->printf( "  no location\n" );
227
228   $cv->scope    ? say_with_sv( "  scope=", $cv->scope )
229                 : Devel::MAT::Cmd->printf( "  no scope\n" );
230
231   $cv->padlist  ? say_with_sv( "  padlist=", $cv->padlist )
232                 : ();
233
234   $cv->padnames_av ? say_with_sv( "  padnames_av=", $cv->padnames_av )
235                    : ();
236
237   $cv->protosub ? say_with_sv( "  protosub=", $cv->protosub )
238                 : ();
239
240   my @pads = $cv->pads;
241   foreach my $depth ( 0 .. $#pads ) {
242      next unless $pads[$depth];
243      say_with_sv( "  pad[$depth]=", $pads[$depth] );
244   }
245
246   if( $opts->{pad} and my $pad0 = ( $cv->pads )[0] ) {
247      Devel::MAT::Cmd->printf( "PAD[0]:\n" );
248      $self->show_PAD_contents( $pad0 );
249   }
250
251   if( my @globs = $cv->globrefs ) {
252      Devel::MAT::Cmd->printf( "Referenced globs:\n  " );
253      Devel::MAT::Cmd->printf( "%s, ", Devel::MAT::Cmd->format_sv( $_ ) ) for @globs;
254      Devel::MAT::Cmd->printf( "\n" );
255   }
256}
257
258sub show_PAD
259{
260   my $self = shift;
261   my ( $pad ) = @_;
262
263   my $padcv = $pad->padcv;
264   $padcv ? say_with_sv( "  padcv=", $padcv )
265          : Devel::MAT::Cmd->printf( "  no padcv\n" );
266
267   $self->show_PAD_contents( $pad );
268}
269
270sub _join
271{
272   # Like CORE::join but respects string concat operator
273   my ( $sep, @elems ) = @_;
274   my $ret = shift @elems;
275   $ret = $ret . $sep . $_ for @elems;
276   return $ret;
277}
278
279sub show_PAD_contents
280{
281   my $self = shift;
282   my ( $pad ) = @_;
283
284   my $padcv = $pad->padcv;
285
286   my @elems = $pad->elems;
287   my @padnames = map {
288      my $padname = $padcv->padname( $_ );
289      # is_outer is always set for is_our; it's only interesting without is_our
290      my $is_just_outer = $padname && $padname->is_outer && !$padname->is_our;
291
292      $padname ? _join( " ",
293         ( $padname->is_state ? Devel::MAT::Cmd->format_note( "state" ) : () ),
294         ( $padname->is_our   ? Devel::MAT::Cmd->format_note( "our" )   : () ),
295         Devel::MAT::Cmd->format_note( $padname->name, 1 ),
296         ( $is_just_outer     ? Devel::MAT::Cmd->format_note( "*OUTER", 2 ) : () ),
297         # is_typed and is_lvalue not indicated
298      ) : undef
299   } 0 .. $#elems;
300   my $idxlen  = length $#elems;
301   my $namelen = max map { defined $_ ? length $_ : 0 } @padnames;
302
303   my %padtype;
304   if( my $gvix = $padcv->{gvix} ) {
305      $padtype{$_} = "GLOB" for @$gvix;
306   }
307   if( my $constix = $padcv->{constix} ) {
308      $padtype{$_} = "CONST" for @$constix;
309   }
310
311   Devel::MAT::Cmd->printf( "  [%*d/%-*s]=%s\n",
312      $idxlen, 0,
313      $namelen, Devel::MAT::Cmd->format_note( '@_', 1 ),
314      ( $elems[0] ? Devel::MAT::Cmd->format_sv_with_value( $elems[0] ) : "NULL" ),
315   );
316
317   foreach my $padix ( 1 .. $#elems ) {
318      my $sv = $elems[$padix];
319      if( $padnames[$padix] ) {
320         Devel::MAT::Cmd->printf( "  [%*d/%-*s]=%s\n",
321            $idxlen, $padix,
322            $namelen, $padnames[$padix],
323            ( $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL" ),
324         );
325      }
326      else {
327         Devel::MAT::Cmd->printf( "  [%*d %-*s]=%s\n",
328            $idxlen, $padix,
329            $namelen, $padtype{$padix} // "",
330            ( $sv ? Devel::MAT::Cmd->format_sv( $sv ) : "NULL" ),
331         );
332      }
333   }
334}
335
336# TODO: PADLIST
337
338sub show_PADNAMES
339{
340   my $self = shift;
341   my ( $padnames ) = @_;
342
343   $padnames->padcv ? say_with_sv( "  padcv=", $padnames->padcv )
344                    : Devel::MAT::Cmd->printf( "  no padcv\n" );
345
346   my @elems = $padnames->elems;
347   # Every PADNAMES element is either NULL or a SCALAR(PV)
348   # PADIX 0 is always @_
349   foreach my $padix ( 1 .. $#elems ) {
350      my $slot = $elems[$padix];
351      if( $slot and $slot->type eq "SCALAR" ) {
352         Devel::MAT::Cmd->printf( "  [%d] is %s\n", $padix, Devel::MAT::Cmd->format_note( $slot->pv, 1 ) );
353      }
354   }
355}
356
357sub show_IO
358{
359   my $self = shift;
360   my ( $io ) = @_;
361
362   Devel::MAT::Cmd->printf( "  ifileno=%d\n", $io->ifileno ) if defined $io->ifileno;
363   Devel::MAT::Cmd->printf( "  ofileno=%d\n", $io->ofileno ) if defined $io->ofileno;
364}
365
366package # hide
367   Devel::MAT::Tool::Show::_elems;
368use base qw( Devel::MAT::Tool );
369
370use List::Util qw( min );
371
372use constant CMD => "elems";
373use constant CMD_DESC => "List the elements of an ARRAY SV";
374
375=head2 elems
376
377   pmat> elems endav
378     [0] CODE(PP) at 0x562e93222dc8
379
380Prints elements of an ARRAY SV.
381
382Takes the following named options:
383
384=over 4
385
386=item --count, -c MAX
387
388Show at most this number of elements (default 50).
389
390=back
391
392Takes the following positional arguments:
393
394=over 4
395
396=item *
397
398Optional start index (default 0).
399
400=back
401
402=cut
403
404use constant CMD_OPTS => (
405   count => { help => "maximum count of elements to print",
406              type => "i",
407              alias => "c",
408              default => 50 },
409);
410
411use constant CMD_ARGS_SV => 1;
412use constant CMD_ARGS => (
413   { name => "startidx", help => "starting index" },
414);
415
416sub run
417{
418   my $self = shift;
419   my %opts = %{ +shift };
420   my ( $av, $startidx ) = @_;
421
422   my $type = $av->type;
423   if( $type eq "HASH" or $type eq "STASH" ) {
424      die "Cannot 'elems' of a $type - maybe you wanted 'values'?\n";
425   }
426   elsif( $type ne "ARRAY" ) {
427      die "Cannot 'elems' of a non-ARRAY\n";
428   }
429
430   $startidx //= 0;
431   my $stopidx = min( $startidx + $opts{count}, $av->n_elems );
432
433   my @rows;
434   foreach my $idx ( $startidx .. $stopidx-1 ) {
435      my $sv = $av->elem( $idx );
436      push @rows, [
437         Devel::MAT::Cmd->format_value( $idx, index => 1 ),
438         $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL",
439      ];
440   }
441
442   Devel::MAT::Cmd->print_table( \@rows, indent => 2 );
443
444   my $morecount = $av->n_elems - $stopidx;
445   Devel::MAT::Cmd->printf( "  ... (%d more)\n", $morecount ) if $morecount;
446}
447
448package # hide
449   Devel::MAT::Tool::Show::_values;
450use base qw( Devel::MAT::Tool );
451
452use constant CMD => "values";
453use constant CMD_DESC => "List the values of a HASH-like SV";
454
455=head2 values
456
457   pmat> values defstash
458     {"\b"}                GLOB($%*) at 0x562e93114eb8
459     {"\017"}              GLOB($*) at 0x562e9315a428
460     ...
461
462Prints values of a HASH or STASH SV.
463
464Takes the following named options:
465
466=over 4
467
468=item --count, -c MAX
469
470Show at most this number of values (default 50).
471
472=back
473
474Takes the following positional arguments:
475
476=over 4
477
478=item *
479
480Optional skip count (default 0). If present, will skip over this number of
481keys initially to show more of them.
482
483=back
484
485=cut
486
487use constant CMD_OPTS => (
488   count => { help => "maximum count of values to print",
489              type => "i",
490              alias => "c",
491              default => 50 },
492);
493
494use constant CMD_ARGS_SV => 1;
495use constant CMD_ARGS => (
496   { name => "skipcount", help => "skip over this many keys initially" },
497);
498
499sub run
500{
501   my $self = shift;
502   my %opts = %{ +shift };
503   my ( $hv, $skipcount ) = @_;
504
505   my $type = $hv->type;
506   if( $type eq "ARRAY" ) {
507      die "Cannot 'values' of a $type - maybe you wanted 'elems'?\n";
508   }
509   elsif( $type ne "HASH" and $type ne "STASH" ) {
510      die "Cannot 'elems' of a non-HASHlike\n";
511   }
512
513   # TODO: control of sorting, start at, filtering
514   my @keys = sort $hv->keys;
515   splice @keys, 0, $skipcount if $skipcount;
516
517   Devel::MAT::Tool::more->paginate( { pagesize => $opts{count} }, sub {
518      my ( $count ) = @_;
519      my @rows;
520      foreach my $key ( splice @keys, 0, $count ) {
521         my $sv = $hv->value( $key );
522         push @rows, [
523            Devel::MAT::Cmd->format_value( $key, key => 1,
524               stash => ( $type eq "STASH" ) ),
525            $sv ? Devel::MAT::Cmd->format_sv_with_value( $sv ) : "NULL",
526         ];
527      }
528
529      Devel::MAT::Cmd->print_table( \@rows, indent => 2 );
530
531      my $morecount = @keys;
532      Devel::MAT::Cmd->printf( "  ... (%d more)\n", $morecount ) if $morecount;
533      return $morecount;
534   } );
535}
536
537=head1 AUTHOR
538
539Paul Evans <leonerd@leonerd.org.uk>
540
541=cut
542
5430x55AA;
544