File Coverage

blib/lib/App/Devel/MAT/Explorer/GTK/SVDetail.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
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 -- leonerd@leonerd.org.uk
5              
6             package App::Devel::MAT::Explorer::GTK::SVDetail;
7              
8 1     1   1200 use strict;
  1         1  
  1         24  
9 1     1   3 use warnings;
  1         1  
  1         22  
10 1     1   3 use feature qw( switch );
  1         1  
  1         73  
11 1     1   494 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  1         8  
  1         3  
12              
13             our $VERSION = '0.03';
14              
15 1     1   430 use Devel::MAT 0.23; # ->ifileno, ->ofileno on IO SVs
  1         33009  
  1         32  
16              
17 1     1   49 use App::Devel::MAT::Explorer::GTK::Resources qw( get_icon );
  0            
  0            
18             use App::Devel::MAT::Explorer::GTK::Widgets qw( label textarea );
19             use App::Devel::MAT::Explorer::GTK::Utils qw( bytes2size );
20              
21             use Struct::Dumb qw( -named_constructors );
22             use List::UtilsBy qw( nsort_by );
23              
24             struct SVDetail => [qw( order type title render expand )];
25              
26             my @MORE_DETAILS;
27              
28             sub table_add
29             {
30             my ( $table, $label, $widget, $yoptions, $right ) = @_;
31              
32             my $xoptions = [ "expand", "fill" ];
33             $yoptions //= [ "fill" ];
34             $right //= 3;
35              
36             my ( $next_row ) = $table->get_size;
37              
38             $table->attach( label( $label ), 0, 1, $next_row, $next_row + 1, $xoptions, $yoptions, 0, 3 );
39             $table->attach( $widget, 1, $right, $next_row, $next_row + 1, $xoptions, $yoptions, 0, 3 );
40             }
41              
42             sub display_sv_in_table
43             {
44             my ( $sv, $table ) = @_;
45              
46             # Common things for all widget types;
47             my $type = $sv->type;
48             table_add( $table, "Type" => textarea( $type ), undef, 2 );
49              
50             table_add( $table, "Address" => textarea( sprintf "%#x", $sv->addr ), undef, 2 );
51              
52             table_add( $table, "SvREFCNT" => textarea( $sv->refcnt ), undef, 2 );
53              
54             my $sizestr = $sv->size;
55             if( $sv->size > 1024 ) {
56             $sizestr = bytes2size( $sv->size ) . " ($sizestr)";
57             }
58             table_add( $table, "Size" => textarea( $sizestr ), undef, 2 );
59              
60             table_add( $table, "Description" => textarea( $sv->desc ) );
61              
62             $table->attach(
63             Gtk2::Image->new_from_pixbuf( get_icon( "type-$type", w => 40, h => 40 ) ),
64             2, 3, 1, 5, [], [], 5, 5,
65             );
66              
67             if( my $stash = $sv->blessed ) {
68             table_add( $table, "Blessed", textarea( $stash->stashname ) );
69             }
70              
71             given( $type ) {
72             when([ "GLOB", "CODE", "STASH" ]) {
73             table_add( $table, "Stashname", textarea( $sv->stashname ) ) if defined $sv->stashname;
74             }
75             }
76              
77             given( $type ) {
78             when( "CODE" ) {
79             table_add( $table, "Flags", textarea( join( " ",
80             ( $sv->is_clone ? "CLONE" : () ),
81             ( $sv->is_cloned ? "CLONED" : () ),
82             ( $sv->is_xsub ? "XSUB" : () ),
83             ( $sv->is_weakoutside ? "WEAKOUTSIDE" : () ),
84             ( $sv->is_cvgv_rc ? "CVGV_RC" : () ),
85             ( $sv->is_lexical ? "LEXICAL" : () ) ) ) );
86             table_add( $table, "Oproot", textarea( sprintf "%x (%d)", $sv->oproot, $sv->oproot ) ) if $sv->oproot;
87              
88             # depth only makes sense of PP subs
89             if( $sv->oproot and ( my $depth = $sv->depth ) > -1 ) {
90             table_add( $table, "Depth", textarea( $depth ) );
91             }
92             }
93             when( "SCALAR" ) {
94             table_add( $table, "UV", textarea( $sv->uv ) ) if defined $sv->uv;
95             table_add( $table, "IV", textarea( $sv->iv ) ) if defined $sv->iv;
96             table_add( $table, "NV", textarea( $sv->nv ) ) if defined $sv->nv;
97             if( defined $sv->pv ) {
98             table_add( $table, "PV len", textarea( $sv->pvlen ) );
99             table_add( $table, "PV", my $pvtext = textarea( $sv->qq_pv( 32 ) ) );
100             $pvtext->set_tooltip_text( $sv->qq_pv( 1024 ) );
101             }
102             }
103             when( "REF" ) {
104             table_add( $table, "RV", textarea( $sv->rv->desc . ( $sv->is_weak ? " weakly" : " strongly" ) ) )
105             if defined $sv->rv;
106             }
107             when( "IO" ) {
108             table_add( $table, "Input fileno", textarea( $sv->ifileno ) ) if $sv->ifileno != -1;
109             table_add( $table, "Output fileno", textarea( $sv->ofileno ) ) if $sv->ofileno != -1;
110             }
111             }
112              
113             given( $type ) {
114             when([ "SCALAR", "REF", "ARRAY", "HASH", "STASH", "CODE" ]) {
115             table_add( $table, "Name", textarea( $sv->name ) ) if defined $sv->name;
116             }
117             }
118              
119             given( $type ) {
120             when([ "GLOB", "CODE" ]) {
121             table_add( $table, "Location", textarea( $sv->location ) );
122             }
123             when([ "PAD", "PADNAMES", "PADLIST" ]) {
124             table_add( $table, "CV location", textarea( $sv->padcv->location ) );
125             }
126             }
127              
128             foreach my $extra ( nsort_by { $_->order } @MORE_DETAILS ) {
129             my $data = $extra->render->( $sv );
130             defined $data or next;
131              
132             my $widget;
133             given( $extra->type ) {
134             when( "widget" ) { $widget = $data }
135             when( "text" ) { $widget = textarea( $data ) }
136             when( "icon" ) { $widget = Gtk2::Image->new_from_pixbuf( get_icon( $data ) ) }
137             default { die "Unable to handle SV detail type " . $extra->type }
138             }
139              
140             table_add( $table, $extra->title => $widget, $extra->expand ? [ "expand", "fill" ] : undef )
141             }
142             }
143              
144             my $next_sv_detail_order = 0;
145             sub Devel::MAT::UI::provides_sv_detail
146             {
147             shift;
148             my %args = @_;
149              
150             push @MORE_DETAILS, SVDetail(
151             order => $args{order} // $next_sv_detail_order++,
152             type => $args{type},
153             title => $args{title},
154             render => $args{render},
155             expand => $args{expand},
156             );
157             }
158              
159             0x55AA;