exmap.pl

内存管理工具Exmap。该工具比 ps 或 top 更精确

#!/usr/bin/perl -w
#
# (c) John Berthels 2005 <[e-mail]>. 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 NAME

exmap.pl - a perl/GTK GUI to the Exmap memory analysis functionality

=cut

sub 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 Progress

Progress indicator. Currently writes to stdout.

=cut

package 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 View

Abstract base class for all View elements. These are thin perl object
wrappers around Gtk Widgets, accessed via the C<window> method.

The view has these virtual methods:

=over

=item _init_windows

This method should set up the gtk widgets, and set C<window> to the
top-level widget.

=item set_data

This is passed object-specific data, which is intended to be of use
when updating the view. Expensive calculation is to be avoided.

=item update_view

This is called to paint the widgets. It is generally called
immediately after set_data, but may be delayed if a widget isn't in
view.

=back

Any args passed to ->new get passed to C<set_data>.

=cut

package 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 ListView

Abstract base class for all View elements consisting of a list of
items which have 'sizes'. Each row may start with zero or more 'first
columns' and is then followed by the 'sizes' for that row.

An update_view method is provided to display these, and provides the
functionality of selecting which size columns to display for a given
view, depending on the configuration.

The derived class lists its 'first columns' (by overriding the
C<_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 which
returns a string, the list object will be wrapped in a frame with that
label.

The top level widget is the scrolledlist, the underlying
Gtk::SimpleList is accessible via the C<list_window> method.


Derived classes must implement a C<set_data> method. This should not be
an expensive call - calculation should be deferred to the update_view
stage.

After C<set_data> has been called either _rows must be set to a list of Row
objects. These will be called from C<update_view> in order to provide
the row first_cols and sizes, allowing the size calculations to be
deferred until that time.

=cut

package 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 Row

This is a single listview Row. It can seperately return the initial
columns and sizes, to avoid the expense of calculating the sizes.

=cut

package 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 sizes
sub sizes
{
    my $s = shift;
    my $closure = $s->{_size_closure};
    return $closure ? $closure->() : undef;
}


# ------------------------------------------------------------

=head2 ProcList

This is a ListView showing a list of processes.

=cut

package 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 FileList

This is a ListView showing a list of files.

=cut

package 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 FilesPerProcList

This is a ListView showing a list of files within a given process.

=cut

package 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"] )];