#!/usr/bin/perl -w## (c) John Berthels 2005 <jjberthels@gmail.com>. See COPYING for license.#use strict;use Exmap;use Gtk2;use Gtk2::SimpleList;use Glib; # For KeyFile# There must be a better way to arrange windows?use constant WIDTH => 800;use constant HEIGHT => 600;my $CFG;main(@ARGV);exit 0;=head1 NAMEexmap.pl - a perl/GTK GUI to the Exmap memory analysis functionality=cutsub main{    my $doquit = shift;    $CFG = Config->new;    $CFG->load; # It's OK if this fails - cfg file might not exist.        my $exmap = Exmap->new;    die("Can't initialise exmap data") unless $exmap;    my $progress = Progress->new;    $exmap->load($progress)	or die("Can't load exmap process information");    print "Calculating...\n";    Gtk2->init;    my $mw = Gtk2::Window->new("toplevel");    # Why is this necessary?    $mw->set_default_size(WIDTH, HEIGHT);    $mw->signal_connect(destroy => sub { Gtk2->main_quit; });    my $tabwin = Gtk2::Notebook->new;    my $symlist = ElfSymbolList->new;    my @tabs;    my $proctab = ProcTab->new($exmap, $symlist);    $tabwin->append_page($proctab->window, "Processes");    push @tabs, $proctab;    my $filetab = FileTab->new($exmap, $symlist);    push @tabs, $filetab;    $tabwin->append_page($filetab->window, "Files");    $tabwin->signal_connect(switch_page => sub {				my $nb = shift;				my $page = shift;				my $pagenum = shift;				# Gotta love closures				my $tab = $tabs[$pagenum];				$tab->show_tab;				});    my $bottombar = make_bottombar($exmap);    my $hpane = Gtk2::HPaned->new;    $hpane->pack1($tabwin, 1, 1);    $hpane->pack2($symlist->window, 1, 1);    my $vbox = Gtk2::VBox->new;    $vbox->add($hpane);    $vbox->pack_end($bottombar, 0, 0, 0);    $mw->add($vbox);    $mw->show_all;	    print "Running\n";    Gtk2->main unless $doquit;    $CFG->check_save;}sub make_bottombar{    my $exmap = shift;    my $bottombar = Gtk2::HBox->new;    my @procs = $exmap->procs;    my $totals = Exmap::Sizes->new;    $totals->scale_mbytes;    foreach my $proc (@procs) {	my $sizes = $proc->sizes;	$totals->add($sizes);    }    my $text = sprintf ("Number of Procs: %d Number of Files: %d\n",			scalar @procs,			scalar($exmap->files));    $text .= join( "|", map {	$totals->key_name($_) . " " . $totals->sval($_);    } $totals->keys);    $bottombar->pack_start(Gtk2::Label->new($text), 0, 0, 0);    my $quit_button = Gtk2::Button->new("Quit");    $quit_button->signal_connect(clicked => sub { Gtk2::main_quit; });    $bottombar->pack_end($quit_button, 0, 0, 0);    return $bottombar;}# ------------------------------------------------------------=head2 ProgressProgress indicator. Currently writes to stdout.=cutpackage Progress;use base qw/Exmap::Progress/;sub number_of_ticks{    my $s = shift;    $s->{_total_ticks} = shift;    $s->{_this_tick} = 0;    print "Number of procs: $s->{_total_ticks}\n";    return 1;}sub tick{    my $s = shift;    my $text = shift;    my $digits = length $s->{_total_ticks};    my $tick = sprintf("%0${digits}d", ++$s->{_this_tick});    print "$tick/$s->{_total_ticks}: Loaded: $text\n";    return 1;}sub finished{    my $s = shift;    print "Finished loading\n";    return 1;}# ------------------------------------------------------------=head2 ViewAbstract base class for all View elements. These are thin perl objectwrappers around Gtk Widgets, accessed via the C<window> method.The view has these virtual methods:=over=item _init_windowsThis method should set up the gtk widgets, and set C<window> to thetop-level widget.=item set_dataThis is passed object-specific data, which is intended to be of usewhen updating the view. Expensive calculation is to be avoided.=item update_viewThis is called to paint the widgets. It is generally calledimmediately after set_data, but may be delayed if a widget isn't inview.=backAny args passed to ->new get passed to C<set_data>.=cutpackage View;sub new{    my $c = shift;    $c = ref $c if ref $c;    my $s = {};    bless $s, $c;    $s->_init_windows;    $s->set_data(@_);    return $s;}sub window{    my $s = shift;    my $win = shift;    if ($win) {	$s->{_window} = $win;    }    return $s->{_window};}sub _init_windows { die "_init_windows called in abstract base class"; }sub update_view { die "_init_windows called in abstract base class"; }sub set_data { die "set_data called in abstract base class"; }# ------------------------------------------------------------=head2 ListViewAbstract base class for all View elements consisting of a list ofitems which have 'sizes'. Each row may start with zero or more 'firstcolumns' and is then followed by the 'sizes' for that row.An update_view method is provided to display these, and provides thefunctionality of selecting which size columns to display for a givenview, depending on the configuration.The derived class lists its 'first columns' (by overriding theC<_first_columns> method).The initial list view sort column is set to the first size column.It tweaks the underlying list model (ensures all columns sortable,resizeable) and adds dynamic horizontal and vertical scrollbars.If a derived class overrides C<_frame_name> with a method whichreturns a string, the list object will be wrapped in a frame with thatlabel.The top level widget is the scrolledlist, the underlyingGtk::SimpleList is accessible via the C<list_window> method.Derived classes must implement a C<set_data> method. This should not bean expensive call - calculation should be deferred to the update_viewstage.After C<set_data> has been called either _rows must be set to a list of Rowobjects. These will be called from C<update_view> in order to providethe row first_cols and sizes, allowing the size calculations to bedeferred until that time.=cutpackage ListView;use base qw/View/;sub _init_windows{    my $s = shift;    my @cols = $s->_first_columns;    my $start_sort_col = (scalar @cols) / 2;    my $sizes = Exmap::Sizes->new;    $sizes->scale_kbytes;    push @cols,	map { $sizes->key_name($_) => 'text' } $CFG->cols_for_listview($s);	    my $listwin = Gtk2::SimpleList->new(@cols);    $s->list_window($listwin);    $s->_make_all_sortable;    my $model = $s->list_window->get_model;    $model->set_sort_column_id($start_sort_col, 'descending');    $s->_make_all_resizable;    $s->_set_all_col_sortfunc;    my $scr_list = Gtk2::ScrolledWindow->new;    $scr_list->set_policy('automatic', 'automatic');    $scr_list->add($listwin);    $s->window($scr_list);    my $frame_text = $s->_frame_name;    if ($frame_text) {	my $frame = Gtk2::Frame->new($frame_text);	$frame->add($s->window);	$s->window($frame);    }    return 1;}sub _frame_name{    return undef;}sub _first_columns { die "_first_columns called in listview" };sub list_window{    my $s = shift;    my $win = shift;    if ($win) {	$s->{_list_window} = $win;    }    return $s->{_list_window};}sub _make_all_sortable{    my $s = shift;    return $s->_foreach_column( sub {        my $s = shift;	my $colid = shift;	my $col = shift;	$s->list_window->get_column($colid)->set_sort_column_id($colid);    });}sub _make_all_resizable{    my $s = shift;    return $s->_foreach_column( sub {        my $s = shift;	my $colid = shift;	my $col = shift;	$s->list_window->get_column($colid)->set_resizable(1);    });}sub _set_all_col_sortfunc{    my $s = shift;    # Do a numeric sort on all numeric strings, and string sort on others    my $sort_func = sub {	my $model = shift;       my $a = shift;       my $b = shift;       my $colid = shift;       $a = lc $model->get_value($a, $colid);       $b = lc $model->get_value($b, $colid);              return 0 if (!defined $a) && (!defined $b);       return +1 if not defined $a;       return -1 if not defined $b;              # Allow various numeric seperators, to be more locale friendly       my $number_re = qr/^[\s\d\.,_]+$/;       if ($a =~ $number_re && $b =~ $number_re) {           $a <=> $b;       }       else {           $a cmp $b;       }   };        return $s->_foreach_column( sub {				    my $s = shift;	my $colid = shift;	my $col = shift;	$s->list_window->get_model->set_sort_func($colid, $sort_func, $colid);    });}sub _foreach_column{    my $s = shift;    my $subref = shift;        my $win = $s->list_window;    my @cols = $win->get_columns;    my $colid = 0;    foreach my $col (@cols) {	$subref->($s, $colid, $col);	++$colid;    }    return;}sub update_view{    my $s = shift;    my $lw = $s->list_window;    # Do nothing unless we have an update    return 1 unless $s->{_rows};    # Assign data to the Gtk widget in one go, rather than push each    # row into the tied array.    my @rows;    my @cols = $CFG->cols_for_listview($s);    foreach my $row (@{$s->{_rows}}) {	my @row = $row->first_cols;	my $sizes = $row->sizes;	if ($sizes) {	    $sizes->scale_kbytes;	    push @row, $sizes->multi_svals(@cols);	}	push @rows, [@row];    }    # Calling this appears to call Gtk2::ListStore::set, which has    # performance problems.    #    @{$lw->{data}} = @rows;    @{$lw->{data}} = ();    my $model = $lw->get_model;    my $insert_at = 1 + scalar @rows;    foreach my $row (@rows) {	my $colnum = 0;	my @values = map { ($colnum++, $_) } @$row;	$model->insert_with_values($insert_at, @values);    }    # Flag that we have consumed these rows    $s->{_rows} = undef;    return 1;}# ------------------------------------------------------------=head2 RowThis is a single listview Row. It can seperately return the initialcolumns and sizes, to avoid the expense of calculating the sizes.=cutpackage Row;sub new{    my $c = shift;    $c = ref $c if ref $c;    my $s = {};    $s->{_first_cols} = shift;    $s->{_size_closure} = shift;    bless $s, $c;    return $s;}sub first_cols { return @{$_[0]->{_first_cols}}; }# Invoke the closure to find the sizessub sizes{    my $s = shift;    my $closure = $s->{_size_closure};    return $closure ? $closure->() : undef;}# ------------------------------------------------------------=head2 ProcListThis is a ListView showing a list of processes.=cutpackage ProcList;use base qw/ListView/;sub _first_columns{    return (PID => 'int',	    Cmdline => 'text');}sub set_data{    my $s = shift;    my @rows = map {	my $proc = $_;	Row->new( [ $proc->pid,		    $proc->cmdline ],		  sub { return $proc->sizes; } );    } @_;    $s->{_rows} = \@rows;    return 1;}# ------------------------------------------------------------=head2 FileListThis is a ListView showing a list of files.=cutpackage FileList;use base qw/ListView/;sub _first_columns{    return ('File Name' => 'text',	    'Num Procs' => 'int');}sub set_data{    my $s = shift;    my @rows = map {	my $file = $_;	Row->new( [ $file->name,		    scalar($file->procs)],		  sub { return $file->sizes; } );    } @_;    $s->{_rows} = \@rows;    return 1;}# ------------------------------------------------------------=head2 FilesPerProcListThis is a ListView showing a list of files within a given process.=cutpackage FilesPerProcList;use base qw/ListView/;sub _frame_name{    return "Files mapped by process";}sub _first_columns{    return ('File Name' => 'text');}sub set_data{    my $s = shift;    my $proc = shift;    $s->{_rows} = [];    if ($proc) {	my @rows = map {	    my $file = $_;	    Row->new([$file->name],		     sub { $proc->sizes($file) });	} $proc->files;	$s->{_rows} = [@rows];    }    else {	$s->{_rows} = [Row->new( ["No process selected"] )];