bin/pmat-explore-gtk - metacpan.org

#!/usr/bin/perl

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

use Carp;

use Glib qw( TRUE FALSE );
use Gtk2 -init;
use Gtk2::SimpleList;

use Devel::MAT;

use File::ShareDir qw( module_file );
use List::Util qw( pairs );
use List::UtilsBy qw( sort_by );

my $pmat;
my $df;

my %ICONS;        # {$name} = $pixbuf
my %TYPES_LARGE;  # {$type} = $pixbuf

foreach (qw( SCALAR REF ARRAY HASH CODE GLOB STASH LVALUE REGEXP IO FORMAT PADLIST PADNAMES PAD )) {
   Devel::MAT::UI->register_icon( name => "type-$_", svg => "icons/type-$_.svg" );

   $TYPES_LARGE{$_} = Gtk2::Gdk::Pixbuf->new_from_file_at_size(
      module_file( "Devel::MAT::UI", "icons/type-$_.svg" ), 40, 40
   );
}

my $win = Gtk2::Window->new( "toplevel" );
$win->signal_connect( destroy => sub { Gtk2->main_quit } );
$win->resize( 1000, 600 );
my $winbox = Gtk2::VBox->new( 0, 0 );
$win->add( $winbox );

my $menu = Gtk2::MenuBar->new;
$winbox->pack_start( $menu, FALSE, TRUE, 0 );

my $filemenu = add_submenu( $menu, "File" );
add_menuitem( $filemenu, "Quit" => sub { Gtk2->main_quit } );

my $navmenu = add_submenu( $menu, "Navigate" );

my $toolbar = Gtk2::Toolbar->new;
$toolbar->set_style( 'both' );
$winbox->pack_start( $toolbar, FALSE, TRUE, 0 );

my $backbtn = $toolbar->append_item( "Back", "Go back to the previous SV", "",
   Gtk2::Image->new_from_stock("gtk-go-back", "small-toolbar"), \&history_back );
my $forwardbtn = $toolbar->append_item( "Forward", "Go forward to the next SV", "",
   Gtk2::Image->new_from_stock("gtk-go-forward", "small-toolbar"), \&history_forward );

my $svs_loaded;

my $outrefs_mth = "outrefs";
my $inrefs_mth = "inrefs";
{
   my %mode_buttons;

   my %mode_tooltip = (
      All    => "Display and count every kind of inref and outref",
      Direct => "Display and count only direct inrefs and outrefs",
      Strong => "Display and count only strong direct inrefs and outrefs",
   );

   Devel::MAT::UI->provides_radiobutton_set(
      map {
         my $filter = $_ eq "All" ? "" : "_\L$_";

         Devel::MAT::UI->register_icon(
            name => "refs-$_",
            svg => "icons/refs-$_.svg"
         );

         {
            text    => $_,
            icon    => "refs-$_",
            tooltip => $mode_tooltip{$_},
            code    => sub {
               $outrefs_mth = "outrefs$filter";
               $inrefs_mth  = "inrefs$filter";

               reset_svlist_refs() if $svs_loaded;
               redisplay_sv();
            },
         }
      } qw( All Direct Strong )
   );
}

### History management
{
   my @back_sv;
   my @forward_sv;
   my $current_sv;

   $backbtn->set_sensitive( FALSE );
   $forwardbtn->set_sensitive( FALSE );

   sub history_back
   {
      return unless @back_sv;

      unshift @forward_sv, $current_sv if $current_sv;
      $current_sv = pop @back_sv;

      $backbtn->set_sensitive( scalar @back_sv );
      $forwardbtn->set_sensitive( scalar @forward_sv );

      display_sv( $current_sv );
   }

   sub history_forward
   {
      return unless @forward_sv;

      push @back_sv, $current_sv if $current_sv;
      $current_sv = shift @forward_sv;

      $backbtn->set_sensitive( scalar @back_sv );
      $forwardbtn->set_sensitive( scalar @forward_sv );

      display_sv( $current_sv );
   }

   sub history_nav
   {
      my ( $sv ) = @_;

      push @back_sv, $current_sv if $current_sv;
      $current_sv = $sv;

      if( @forward_sv and $sv == $forward_sv[0] ) {
         shift @forward_sv;
      }
      else {
         @forward_sv = ();
      }

      $backbtn->set_sensitive( scalar @back_sv );
      $forwardbtn->set_sensitive( scalar @forward_sv );

      display_sv( $current_sv );
   }

   sub redisplay_sv
   {
      display_sv( $current_sv ) if $current_sv;
   }
}

add_menuitem( $navmenu, "Back" => \&history_back );
add_menuitem( $navmenu, "Forward" => \&history_forward );

add_menuitem( $navmenu, "To SV..." => sub {
   my $d = Gtk2::Dialog->new(
      'Enter SV address',
      $win,
      [ qw( modal destroy-with-parent )],
      'gtk-cancel' => 'reject',
      'gtk-ok'     => 'accept',
   );

   my $entry = Gtk2::Entry->new();
   $d->signal_connect(
      response => sub {
         my $win = shift;
         my $ev = shift;
         if( $ev eq 'accept' ) {
            my $sv = $df->sv_at( hex $entry->get_text );
            history_nav( $sv ) if $sv;
            $win->destroy;
         }
         elsif( $ev eq 'reject' ) {
            $win->destroy;
         }
      }
   );

   my $vbox = $d->vbox;
   $vbox->pack_start($entry, 0, 0, 4);
   $vbox->show_all;
   $d->show;
});

my $rootmenu = add_submenu( $menu, "Roots" );

my $toolmenu;
foreach my $tool ( sort Devel::MAT->available_tools ) {
   my $tool_class = "Devel::MAT::Tool::$tool";
   next unless $tool_class->can( "FOR_UI" ) and $tool_class->FOR_UI;

   $toolmenu ||= add_submenu( $menu, "Tools" );
   add_menuitem( $toolmenu, $tool, sub {
      my ( $mi ) = @_;

      $mi->set_sensitive( FALSE );

      my $tool = $pmat->load_tool( $tool, progress => \&progress );
      $tool->init_ui( "Devel::MAT::UI" );
      progress( "Done" );
   });
}

my $pane = Gtk2::HPaned->new;
$winbox->add( $pane );

my $statusbar = Gtk2::Statusbar->new;
$winbox->pack_end( $statusbar, FALSE, TRUE, 0 );

$statusbar->pack_start( framed( my $perlver_label = Gtk2::Label->new( "" ) ), FALSE, FALSE, 0 );
$statusbar->pack_start( framed( my $svcount_label = Gtk2::Label->new( "" ) ), FALSE, FALSE, 0 );
$statusbar->pack_start( framed( my $bytetotal_label = Gtk2::Label->new( "" ) ), FALSE, FALSE, 0 );

$win->show_all;

{
   my $id;
   sub progress
   {
      $statusbar->pop( $id ) if $id;
      $id = $statusbar->push( $statusbar->get_context_id("progress"), "Progress: $_[0]" );
      Gtk2->main_iteration_do( FALSE ) while Gtk2->events_pending;
   }
}

my $filename = $ARGV[0] or die "Need dumpfile\n";

$win->set_title( "$filename - pmat-explore-gtk" );

$pmat = Devel::MAT->load( $filename, progress => \&progress );
$df = $pmat->dumpfile;

$perlver_label->set_text( join " ", "Perl",
   $df->perlversion,
   ( $df->ithreads ? "thread" : () ),
   ( $df->ptr_len * 8 ) . "bit",
);
$svcount_label->set_text( scalar($df->heap) . " SVs" );

# We're going to be using Inrefs
$pmat->load_tool( "Inrefs", progress => \&progress );

foreach ( pairs $df->roots ) {
   my ( $desc, $sv ) = @$_;
   add_menuitem( $rootmenu, $desc, sub { history_nav( $sv ) } ) if $sv;
}

my $svlist_model = Gtk2::ListStore->new(
   "Glib::String",
   "Glib::Int",
   "Glib::String",
   "Glib::Int",
   "Glib::String",
   "Glib::Int",
   "Glib::Int",
);

# UI column constants
sub Devel::MAT::UI::COLUMN_TYPE   () { 0 }
sub Devel::MAT::UI::COLUMN_ADDR   () { 1 }
sub Devel::MAT::UI::COLUMN_DESC   () { 2 }
sub Devel::MAT::UI::COLUMN_SIZE   () { 3 }
sub Devel::MAT::UI::COLUMN_BLESSED() { 4 }
sub Devel::MAT::UI::COLUMN_OUTREFS() { 5 }
sub Devel::MAT::UI::COLUMN_INREFS () { 6 }

my $svlist_view = Gtk2::TreeView->new;
$svlist_view->set_model( $svlist_model );

sub add_svlist_column
{
   my %args = @_;

   my $column = Gtk2::TreeViewColumn->new_with_attributes(
      $args{title}, Gtk2::CellRendererText->new, text => $args{idx},
   );
   $column->set_sort_column_id( $args{idx} );

   $svlist_view->append_column( $column );
}

sub bytes2size
{
   my ( $bytes ) = @_;

   if( $bytes < 1024 ) {
      return $bytes
   }
   if( $bytes < 1024**2 ) {
      return sprintf "%.1f Ki", $bytes / 1024;
   }
   if( $bytes < 1024**3 ) {
      return sprintf "%.1f Mi", $bytes / 1024**2;
   }
   if( $bytes < 1024**4 ) {
      return sprintf "%.1f Gi", $bytes / 1024**3;
   }
   return sprintf "%.1f Ti", $bytes / 1024**4;
}

# First two columns are special
$svlist_view->insert_column_with_data_func( -1, " ",
   Gtk2::CellRendererPixbuf->new, sub {
      my ( $column, $renderer, $model, $iter ) = @_;
      my $type = $model->get( $iter, Devel::MAT::UI->COLUMN_TYPE );
      my $icon = $ICONS{"type-$type"} or warn "No icon for type $type";

      $renderer->set( pixbuf => $icon ) if $icon;
   }, undef
);
$svlist_view->insert_column_with_data_func( -1, "Address",
   Gtk2::CellRendererText->new, sub {
      my ( $column, $renderer, $model, $iter ) = @_;
      my $addr = $model->get( $iter, Devel::MAT::UI->COLUMN_ADDR );
      $renderer->set( text => sprintf "%#x", $addr );
   }, undef
);

add_svlist_column title => "Description", idx => 2;

$svlist_view->insert_column_with_data_func( -1, "Size",
   Gtk2::CellRendererText->new, sub {
      my ( $column, $renderer, $model, $iter ) = @_;
      my $bytes = $model->get( $iter, Devel::MAT::UI->COLUMN_SIZE );
      $renderer->set( text => bytes2size $bytes );
   }, undef
);

add_svlist_column title => "Blessed",     idx => 4;
add_svlist_column title => "Outrefs",     idx => 5;
add_svlist_column title => "Inrefs",      idx => 6;

$svlist_view->get_column( $_ )->set_sort_column_id( $_ ) for 0, 1, 3;

$pane->add1( vscrollable( $svlist_view ) );

my $total = scalar $df->heap;
my $count = 0;
my $bytes = 0;
foreach my $sv ( $df->heap ) {
   my $iter = $svlist_model->append;
   $svlist_model->set( $iter,
      0 => $sv->type,
      1 => $sv->addr,
      2 => $sv->desc,
      3 => $sv->size,
      4 => ( $sv->blessed ? $sv->blessed->stashname : "" ),
      5 => scalar $sv->$outrefs_mth,
      6 => scalar $sv->$inrefs_mth,
   );
   $count++;
   progress( sprintf "Loading GTK TreeView %d of %d (%.2f%%)",
      $count, $total, $count*100 / $total ) if ($count % 1000) == 0;
   $bytes += $sv->size;
}

$svs_loaded = 1;

sub reset_svlist_refs
{
   my $count = 0;
   for ( my $iter = $svlist_model->get_iter_first; $iter; $iter = $svlist_model->iter_next( $iter ) ) {
      my $addr = $svlist_model->get( $iter, 1 );
      my $sv = $df->sv_at( $addr );

      $svlist_model->set( $iter,
         5 => scalar $sv->$outrefs_mth,
         6 => scalar $sv->$inrefs_mth,
      );

      $count++;
      progress( sprintf "Loading GTK TreeView %d of %d (%.2f%%)",
         $count, $total, $count*100 / $total ) if ($count % 1000) == 0;
   }

   progress( "Done" );
}

$bytetotal_label->set_text( $bytes . " bytes" );

my $table = Gtk2::Table->new( 1, 3 );
$pane->add2( $table );

$svlist_view->signal_connect( row_activated => sub {
   my( $self, $path, $column ) = @_;
   my $iter = $svlist_model->get_iter( $path );
   my $addr = $svlist_model->get( $iter, 1 );

   my $sv = $df->sv_at( $addr );
   history_nav( $sv );
});

progress( "Done" );

$win->show_all;
Gtk2->main;

sub table_add
{
   my ( $label, $widget, $yoptions, $right ) = @_;

   my $xoptions = [ "expand", "fill" ];
   $yoptions  //= [ "fill" ];
   $right     //= 3;

   my ( $next_row ) = $table->get_size;

   $table->attach( label( $label ), 0, 1,      $next_row, $next_row + 1, $xoptions, $yoptions, 0, 3 );
   $table->attach( $widget,         1, $right, $next_row, $next_row + 1, $xoptions, $yoptions, 0, 3 );
}

my @more_details; # [] = { type, title, render }

sub display_sv
{
   my ( $sv ) = @_;

   $table->remove( $_ ) foreach $table->get_children;
   $table->resize( 1, 1 );

   # Common things for all widget types;
   my $type = $sv->type;
   table_add( "Type" => label( $type ), undef, 2 );

   table_add( "Address" => label( sprintf "%#x", $sv->addr ), undef, 2 );

   table_add( "SvREFCNT" => label( $sv->refcnt ), undef, 2 );

   my $sizestr = $sv->size;
   if( $sv->size > 1024 ) {
      $sizestr = bytes2size( $sv->size ) . " ($sizestr)";
   }
   table_add( "Size" => label( $sizestr ), undef, 2 );

   table_add( "Description" => label( $sv->desc ) );

   $table->attach(
      Gtk2::Image->new_from_pixbuf( $TYPES_LARGE{$type} ), 2, 3, 1, 5, [], [], 5, 5,
   );

   if( my $stash = $sv->blessed ) {
      table_add( "Blessed", label( $stash->stashname ) );
   }

   given( $type ) {
      when([ "GLOB", "CODE", "STASH" ]) {
         table_add( "Stashname", label( $sv->stashname ) ) if defined $sv->stashname;
      }
   }

   given( $type ) {
      when( "CODE" ) {
         table_add( "Flags", label( join( " ",
                  ( $sv->is_clone       ? "CLONE"       : () ),
                  ( $sv->is_cloned      ? "CLONED"      : () ),
                  ( $sv->is_xsub        ? "XSUB"        : () ),
                  ( $sv->is_weakoutside ? "WEAKOUTSIDE" : () ),
                  ( $sv->is_cvgv_rc     ? "CVGV_RC"     : () ) ) ) );
         table_add( "Oproot", label( sprintf "%x (%d)", $sv->oproot, $sv->oproot ) ) if $sv->oproot;
      }
      when( "SCALAR" ) {
         table_add( "UV", label( $sv->uv ) ) if defined $sv->uv;
         table_add( "IV", label( $sv->iv ) ) if defined $sv->iv;
         table_add( "NV", label( $sv->nv ) ) if defined $sv->nv;
         if( defined $sv->pv ) {
            table_add( "PV len", label( $sv->pvlen ) );
            table_add( "PV",     label( $sv->qq_pv( 32 ) ) );
         }
      }
      when( "REF" ) {
         table_add( "RV", label( $sv->rv->desc . ( $sv->is_weak ? " weakly" : " strongly" ) ) )
            if defined $sv->rv;
      }
   }

   given( $type ) {
      when([ "SCALAR", "REF", "ARRAY", "HASH", "STASH", "CODE" ]) {
         table_add( "Name", label( $sv->name ) ) if defined $sv->name;
      }
   }

   given( $type ) {
      when([ "GLOB", "CODE" ]) {
         table_add( "Location", label( $sv->location ) );
      }
      when([ "PAD", "PADNAMES", "PADLIST" ]) {
         table_add( "CV location", label( $sv->padcv->location ) );
      }
   }

   foreach my $extra ( @more_details ) {
      my $data = $extra->{render}->( $sv );
      defined $data or next;

      my $widget;
      given( $extra->{type} ) {
         when( "text" ) { $widget = label( $data ) }
         when( "icon" ) { $widget = Gtk2::Image->new_from_pixbuf( $ICONS{$data} ) }
         default        { die "Unable to handle SV detail type $extra->{type}" }
      }

      table_add( $extra->{title} => $widget )
   }

   my $outrefs = Gtk2::SimpleList->new(
      "Ref"  => "text",
      "Addr" => "text",
      "Desc" => "text",
   );
   foreach ( sort_by { $_->[0] } pairs $sv->$outrefs_mth ) {
      my ( $name, $ref ) = @$_;
      push @{ $outrefs->{data} }, [ $name, sprintf( "%#x", $ref->addr ), $ref->desc ];
   }
   $outrefs->signal_connect( row_activated => sub {
      my( $self, $path, $column ) = @_;
      my $data = $self->get_row_data_from_path( $path );

      my $addr = hex $data->[1];
      my $sv = $df->sv_at( $addr );
      history_nav( $sv );
   });
   table_add( "Outrefs" => vscrollable( $outrefs ), [ "expand", "fill" ] );

   my $inrefs = Gtk2::SimpleList->new(
      "Ref"  => "text",
      "Addr" => "text",
      "Desc" => "text",
   );
   foreach ( sort_by { $_->[0] } pairs $sv->$inrefs_mth ) {
      my ( $name, $ref ) = @$_;
      if( $ref ) {
         push @{ $inrefs->{data} }, [ $name, sprintf( "%#x", $ref->addr ), $ref->desc ];
      }
      else {
         push @{ $inrefs->{data} }, [ $name, "-", "ROOT" ];
      }
   }
   $inrefs->signal_connect( row_activated => sub {
      my( $self, $path, $column ) = @_;
      my $data = $self->get_row_data_from_path( $path );

      my $addr = hex $data->[1];
      my $sv = $df->sv_at( $addr );
      history_nav( $sv ) if $sv;
   });
   table_add( "Inrefs" => vscrollable( $inrefs ), [ "expand", "fill" ] );

   $table->show_all;

   for( my $iter = $svlist_model->get_iter_first; $iter; $iter = $svlist_model->iter_next( $iter ) ) {
      my $addr = $svlist_model->get_value( $iter, 1 );

      if( $sv->addr == $addr ) {
         my $path = $svlist_model->get_path( $iter );
         $svlist_view->scroll_to_cell( $path, $svlist_view->get_column( 0 ), '' );
         $svlist_view->get_selection->select_path( $path );
         last;
      }
   }
}

sub vscrollable
{
   my ( $widget ) = @_;

   my $win = Gtk2::ScrolledWindow->new;
   $win->set_policy( 'never', 'always' );
   $win->add( $widget );

   return $win;
}

sub framed
{
   my ( $widget ) = @_;
   my $frame = Gtk2::Frame->new;
   $frame->set_shadow_type( "in" );
   $frame->add( $widget );
   return $frame;
}

sub label
{
   my ( $text ) = @_;
   my $l = Gtk2::Label->new( $text );
   $l->set_alignment( 0, 0 );
   return $l;
}

sub add_submenu
{
   my ( $menu, $name ) = @_;

   my $mi = Gtk2::MenuItem->new( $name );
   my $submenu = Gtk2::Menu->new;
   $mi->set_submenu( $submenu );

   $menu->append( $mi );

   return $submenu;
}

sub add_menuitem
{
   my ( $menu, $name, $code ) = @_;

   my $mi = Gtk2::MenuItem->new( $name );
   $mi->signal_connect( activate => $code );

   $menu->append( $mi );
}

## Tool plugin hooks

sub Devel::MAT::UI::register_icon
{
   shift;
   my %args = @_;
   my $name = delete $args{name};

   my $path = delete $args{svg} or die "Cannot register an icon - need an SVG path";

   $ICONS{$name} = Gtk2::Gdk::Pixbuf->new_from_file( module_file( "Devel::MAT::UI", $path ) );
}

sub Devel::MAT::UI::provides_radiobutton_set
{
   shift;

   $toolbar->append_space;

   my $group;
   foreach my $button ( @_ ) {
      my $code = $button->{code};

      my $button = $toolbar->append_element(
         "radiobutton", undef, $button->{text}, $button->{tooltip}, "",
         $button->{icon} ? Gtk2::Image->new_from_pixbuf( $ICONS{$button->{icon}} // die "No icon $button->{icon}" ) : undef,
         sub {
            my ( $button ) = @_;
            return unless $button->get_active;

            goto &$code;
         },
      );

      $button->set_group( $group ) if $group;
      $group //= $button->get_group;
   }
}

my %COLTYPES; BEGIN { %COLTYPES = (
   int  => { store_type => "Glib::Int",    renderer => "Gtk2::CellRendererText",   attr => "text"   },
   text => { store_type => "Glib::String", renderer => "Gtk2::CellRendererText",   attr => "text"   },
   icon => { store_type => "Glib::String", renderer => "Gtk2::CellRendererPixbuf", func => sub {
      my ( $column, $cell, $model, $iter, $idx ) = @_;
      my $name = $model->get( $iter, $idx ) or return;
      $cell->set( pixbuf => $ICONS{$name} );
   } },
); }
sub Devel::MAT::UI::provides_svlist_column
{
   shift;
   my %args = @_;

   my $type = $COLTYPES{$args{type}} or
      croak "Unrecognised column type $args{type}";

   my $idx = $svlist_model->get_n_columns;

   # Cannot add a new column to a model, we'll have to make a new bigger model,
   # copy the data, set it
   my $new_model = Gtk2::ListStore->new(
      ( map { $svlist_model->get_column_type($_) } 0 .. $idx-1 ),
      $type->{store_type},
   );

   for ( my $src_iter = $svlist_model->get_iter_first; $src_iter; $src_iter = $svlist_model->iter_next( $src_iter ) ) {
      my $dest_iter = $new_model->append;
      my @values = $svlist_model->get( $src_iter ), undef;
      $new_model->set( $dest_iter, map { $_ => $values[$_] } 0 .. $#values );
   }

   $svlist_view->set_model( $svlist_model = $new_model );

   my $column = Gtk2::TreeViewColumn->new_with_attributes(
      $args{title},
      my $renderer = $type->{renderer}->new,
   );

   if( $type->{attr} ) {
      $column->set_attributes( $renderer, $type->{attr} => $idx );
   }
   elsif( $type->{func} ) {
      $column->set_cell_data_func( $renderer, $type->{func}, $idx );
   }
   $svlist_view->append_column( $column );
   $column->set_sort_column_id( $idx );

   return $idx;
}

sub Devel::MAT::UI::set_svlist_column_values
{
   shift;
   my %args = @_;

   my $idx = $args{column};
   my $from = $args{from};
   ref $from eq "CODE" or croak "Expected 'from' as a CODE reference";

   my $total = scalar $df->heap;
   my $count = 0;
   for ( my $iter = $svlist_model->get_iter_first; $iter; $iter = $svlist_model->iter_next( $iter ) ) {
      my $addr = $svlist_model->get( $iter, 1 );
      my $data = $from->( $df->sv_at( $addr ) );

      $svlist_model->set( $iter, $idx, $data );

      $count++;
      progress( sprintf "Loading GTK TreeView %d of %d (%.2f%%)",
         $count, $total, $count*100 / $total ) if ($count % 1000) == 0;
   }

   progress( "Done" );
}

sub Devel::MAT::UI::provides_sv_detail
{
   shift;
   my %args = @_;

   push @more_details, {
      type   => $args{type},
      title  => $args{title},
      render => $args{render},
   };
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)