t.pl

#!/usr/bin/perl

# Copyright Ben Maurer 
# you can distribute this under the MIT/X11 License

my $pid=shift @ARGV;
unless ($pid) {
    print "./smem.pl <pid>\n";
    exit 1;
}
my $map=Linux::Smaps->new($pid);
my @VMAs = $map->vmas;

format STDOUT =
VMSIZE:  @######## kb
$map->size
RSS:     @######## kb total
$map->rss
         @######## kb shared
$map->shared_clean + $map->shared_dirty
         @######## kb private clean
$map->private_clean
         @######## kb private dirty
$map->private_dirty
.

write;

printPrivateMappings ();
printSharedMappings ();

sub sharedMappings () {
    return grep { ($_->shared_clean  + $_->shared_dirty) > 0 } @VMAs;
}

sub privateMappings () {
    return grep { ($_->private_clean  + $_->private_dirty) > 0 } @VMAs;
}

sub printPrivateMappings ()
{
    $TYPE = "PRIVATE MAPPINGS";
    $^ = 'SECTION_HEADER';
    $~ = 'SECTION_ITEM';
    $- = 0;
    $= = 100000000;
    foreach  $vma (sort {-($a->private_dirty <=> $b->private_dirty)} privateMappings ()) {
    $size  = $vma->size;
    $dirty = $vma->private_dirty;
    $clean = $vma->private_clean;
    $file  = $vma->file_name;
    write;
    }
}

sub printSharedMappings ()
{
    $TYPE = "SHARED MAPPINGS";
    $^ = 'SECTION_HEADER';
    $~ = 'SECTION_ITEM';
    $- = 0;
    $= = 100000000;
    
    foreach  $vma (sort {-(($a->shared_clean + $a->shared_dirty)
    <=>
    ($b->shared_clean + $b->shared_dirty))} 
    sharedMappings ()) {
    
    $size  = $vma->size;
    $dirty = $vma->shared_dirty;
    $clean = $vma->shared_clean;
    $file  = $vma->file_name;
    write;
    
    
    }
}

format SECTION_HEADER =
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$TYPE
@>>>>>>>>>> @>>>>>>>>>>  @>>>>>>>>>   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
"vmsize",     "rss clean", "rss dirty", "file"
.

format SECTION_ITEM =
@####### kb @####### kb @####### kb   @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$size,             $clean,         $dirty,             $file
.


package Linux::Smaps;

use 5.008;
use strict;
use warnings FATAL=>'all';
no warnings qw(uninitialized portable);
use Errno qw/EACCES/;

my $min_vma_off;

BEGIN {
  package Linux::Smaps::VMA;

  use strict;
  BEGIN {
    our @attributes=qw(vma_start vma_end r w x mayshare file_off
               dev_major dev_minor inode file_name is_deleted _line);
    # it seems a bit faster (~4%) if _line is placed at the end of
    # @attributes.
    my $line_idx=$#attributes;
    our %attributes;
    for( my $i=0; $i<@attributes; $i++ ) {
      no strict 'refs';
      my $n=$i;
      *{__PACKAGE__.'::'.$attributes[$n]}=
    $attributes{$attributes[$n]}=
      sub : lvalue {
        my $I=$_[0];
        if( @_>1 ) {
          $I->[$n]=$_[1];
        } elsif( defined($I->[$n]) || !defined($I->[$line_idx]) ) {
          $I->[$n];
        } else {
          $I->_parse if defined $I->[$line_idx];
          $I->[$n];
        }
      };
      my $const=sub () {$n};
      *{__PACKAGE__.'::V_'.$attributes[$n]}=$const;
      *{'Linux::Smaps::V_'.$attributes[$n]}=$const;
      $Linux::Smaps::VMA::attr_idx{$attributes[$n]}=$n;
    }
    $min_vma_off=@attributes;

    our %special=
      (
       vmflags=>sub {my @l=split /\s+/, $_[0]; shift @l; \@l},
      );
    our @special;
  }

  sub new {bless [@_[1..$#_]]=>(ref $_[0] ? ref $_[0] : $_[0])}

  sub _parse {
    my ($I)=@_;
    @{$I}[V_vma_start..V_is_deleted]=(hex($1), hex($2), ($3 eq 'r'),
                      ($4 eq 'w'), ($5 eq 'x'), ($6 eq 's'),
                      hex($7), hex($8), hex($9), $10, $11,
                      defined($12))
      if $I->[V__line]=~/^
             ([\da-f]+)-([\da-f]+)\s      # range
             ([r\-])([w\-])([x\-])([sp])\s        # access mode
             ([\da-f]+)\s                         # page offset in file
             ([\da-f]+):([\da-f]+)\s      # device
             (\d+)\s*                     # inode
             (.*?)                                # file name
             (\s\(deleted\))?             # is deleted?
             $
            /xi;
    undef $I->[V__line]; # eval it only once
    return;
  }
}

BEGIN {
  our @attributes=qw{pid lasterror filename procdir _elem};
  our %attributes;
  for( my $i=0; $i<@attributes; $i++ ) {
    my $n=$i;
    die "Internal Error"        # should not happen
      if exists $Linux::Smaps::VMA::attributes{$attributes[$n]};
    no strict 'refs';
    *{__PACKAGE__.'::'.$attributes[$n]}=
      $attributes{$attributes[$n]}=
    sub : lvalue {@_>1 ? $_[0]->[$n]=$_[1] : $_[0]->[$n]};
    *{__PACKAGE__.'::M_'.$attributes[$n]}=sub () {$n};
  }
}

our $VERSION = '0.11';
sub new {
  my $class=shift;
  $class=ref($class) if( ref($class) );
  my $I=bless []=>$class;
  my %h;

  $I->[M_procdir]='/proc';
  $I->[M_pid]='self';

  if( @_==1 ) {
    $I->[M_pid]=shift;
  } else {
    our @attributes;
    our %attributes;
    %h=@_;
    foreach my $k (@attributes) {
      $attributes{$k}->($I, $h{$k}) if exists $h{$k};
    }
  }

  return $I if( $h{uninitialized} );

  my $rc=$I->update;
  die __PACKAGE__.": ".$I->[M_lasterror]."\n" unless( $rc );

  return $rc;
}

sub clear_refs {
  my ($I)=@_;

  my $name=$I->[M_procdir].'/'.$I->[M_pid].'/clear_refs';

  open my $f, '>', $name or do {
    $I->[M_lasterror]="Cannot open $name: $!";
    return;
  };
  print $f "1\n";
  close $f;

  return $I;
}

my ($cnt1, $fmt1)=(0);

sub update {
  my ($I)=@_;

  my $name;

  # this way one can use one object to loop through a list of processes like:
  # foreach (@pids) {
  #   $smaps->pid=$_; $smaps->update;
  #   process($smaps);
  # }
  if( defined $I->[M_filename] ) {
    $name=$I->[M_filename];
  } else {
    $name=$I->[M_procdir].'/'.$I->[M_pid].'/smaps';
  }

  # Normally, access permissions for a file are checked when it is opened.
  # /proc/PID/smaps is different. Here permissions are checked by the read
  # syscall.
  open my $f, '<', $name or do {
    $I->[M_lasterror]="Cannot open $name: $!";
    return;
  };

  my $current;
  $I->[M__elem]=[];
  my %cache;
  my ($l, $tmp, $m);
  my $current_off=@Linux::Smaps::VMA::attributes;

  $!=0;
  while( defined($l=<$f>) ) {
    if( $current_off<@Linux::Smaps::VMA::attributes ) {
      if( $tmp=$Linux::Smaps::VMA::special[$current_off] ) {
        $current->[$current_off++]=$tmp->($l);
      } else {
        no warnings qw(numeric);
        $current->[$current_off++]=0+(unpack $fmt1, $l)[0];
      }
    } elsif( $l=~/^(\w+):\s*(\d+) kB$/ ) {
      $m=lc $1;

      if( exists $Linux::Smaps::VMA::attributes{$m} ) {
    $I->[M_lasterror]="Linux::Smaps::VMA::$m method is already defined";
    return;
      }
      if( exists $Linux::Smaps::attributes{$m} ) {
    $I->[M_lasterror]="Linux::Smaps::$m method is already defined";
    return;
      }

      $current->[$current_off++]=0+$2;

      push @Linux::Smaps::VMA::attributes, $m;
      {
    no strict 'refs';
    my $n=$#Linux::Smaps::VMA::attributes;
    *{'Linux::Smaps::VMA::'.$m}=
      $Linux::Smaps::VMA::attributes{$m}=
        sub : lvalue {@_>1 ? $_[0]->[$n]=$_[1] : $_[0]->[$n]};
    $Linux::Smaps::VMA::attr_idx{$m}=$n;
      }

      {
    no strict 'refs';
    my $attr_nr=$#Linux::Smaps::VMA::attributes;
    *{__PACKAGE__."::$m"}=$Linux::Smaps::attributes{$m}=sub {
      my ($I, $n)=@_;
      my $rc=0;
      foreach my $el (length $n
              ? grep(
                 {
                  $_->_parse if(!defined($_->[V_file_name]) and
                        defined($_->[V__line]));
                  $_->[V_file_name] eq $n;
                 } @{$I->[M__elem]}
                )
              : @{$I->[M__elem]}) {
        $rc+=$el->[$attr_nr];
      }
      return $rc;
    };
      }

      if( length($m)>$cnt1 ) {
    $cnt1=length($m);
    $fmt1="x".($cnt1+1)."A*";
      }
    } elsif( $l=~/^(\w+):.+$/ and $tmp=$Linux::Smaps::VMA::special{$m=lc $1} ) {
      if( exists $Linux::Smaps::VMA::attributes{$m} ) {
    $I->[M_lasterror]="Linux::Smaps::VMA::$m method is already defined";
    return;
      }

      $Linux::Smaps::VMA::special[$current_off]=$tmp;
      $current->[$current_off++]=$tmp->($l);

      push @Linux::Smaps::VMA::attributes, $m;
      {
    no strict 'refs';
    my $n=$#Linux::Smaps::VMA::attributes;
    *{'Linux::Smaps::VMA::'.$m}=
      $Linux::Smaps::VMA::attributes{$m}=
        sub : lvalue {@_>1 ? $_[0]->[$n]=$_[1] : $_[0]->[$n]};
    $Linux::Smaps::VMA::attr_idx{$m}=$n;
      }
    } elsif( $l=~/^([\da-f]+-[\da-f]+)\s/i ) {
      # the rest of the line is lazily parsed
      @{$current=bless [], 'Linux::Smaps::VMA'}[V__line]=$l;

      # use %cache to work around a bug in some implementations,
      # VMAs may be reported twice.
      push @{$I->[M__elem]}, $current unless $cache{$1}++;
      $current_off=$min_vma_off;
    } else {
      $I->[M_lasterror]="$name($.): not parsed: $l";
      return;
    }
  }

  if( $!==EACCES and !defined $current ) {
    $I->[M_lasterror]="$name: read failed: $!";
    close $f;
    return;
  }

  close $f;

  return $I;
}
BEGIN {
  foreach my $n (qw{heap stack vdso vsyscall}) {
    no strict 'refs';
    my $name=$n;
    my $s="[$n]";
    *{__PACKAGE__.'::'.$name}=sub {
      foreach my $el (@{$_[0]->[M__elem]}) {
    $el->_parse if !defined($el->[V_file_name]) and defined($el->[V__line]);
    return $el if $s eq $el->[V_file_name];
      }
    };
  }
}

sub unnamed {
  my $I=shift;
  if( wantarray ) {
    return grep {
      $_->_parse if !defined($_->[V_file_name]) and defined($_->[V__line]);
      !length $_->[V_file_name];
    } @{$I->[M__elem]};
  } else {
    my @idx=@Linux::Smaps::VMA::attr_idx{qw/size rss shared_clean shared_dirty
                        private_clean private_dirty/};
    my $sum=Linux::Smaps::VMA->new((0)x@Linux::Smaps::VMA::attributes);
    foreach my $el (@{$I->[M__elem]}) {
      $el->_parse if !defined($el->[V_file_name]) and defined($el->[V__line]);
      next if( length $el->[V_file_name] );
      foreach my $idx (@idx) {$sum->[$idx]+=$el->[$idx]}
    }
    return $sum;
  }
}

sub named {
  my $I=shift;
  if( wantarray ) {
    return grep {
      $_->_parse if !defined($_->[V_file_name]) and defined($_->[V__line]);
      length $_->[V_file_name];
    } @{$I->[M__elem]};
  } else {
    my @idx=@Linux::Smaps::VMA::attr_idx{qw/size rss shared_clean shared_dirty
                        private_clean private_dirty/};
    my $sum=Linux::Smaps::VMA->new((0)x@Linux::Smaps::VMA::attributes);
    foreach my $el (@{$I->[M__elem]}) {
      $el->_parse if !defined($el->[V_file_name]) and defined($el->[V__line]);
      next if( !length $el->[V_file_name] );
      foreach my $idx (@idx) {$sum->[$idx]+=$el->[$idx]}
    }
    return $sum;
  }
}

sub all {
  my $I=shift;
  if( wantarray ) {
    return @{$I->[M__elem]};
  } else {
    my @idx=@Linux::Smaps::VMA::attr_idx{qw/size rss shared_clean shared_dirty
                        private_clean private_dirty/};
    my $sum=Linux::Smaps::VMA->new((0)x@Linux::Smaps::VMA::attributes);
    foreach my $el (@{$I->[M__elem]}) {
      foreach my $idx (@idx) {$sum->[$idx]+=$el->[$idx]}
    }
    return $sum;
  }
}

sub names {
  my $I=shift;
  local $_;
  my %h;
  undef @h{map {
    $_->_parse if !defined($_->[V_file_name]) and defined($_->[V__line]);
    $_->[V_file_name];
  } @{$I->[M__elem]}};
  delete @h{'',qw/[heap] [stack] [vdso] [vsyscall]/};
  return keys %h;
}

sub diff {
  my $I=shift;
  my @my_special;
  my @my=map {
    $_->_parse if !defined($_->[V_file_name]) and defined($_->[V__line]);
    if( $_->[V_file_name]=~/\[\w+\]/ ) {
      push @my_special, $_;
      ();
    } else {
      $_;
    }
  } @{$I->[M__elem]};
  my %other_special;
  my %other=map {
    $_->_parse if !defined($_->[V_file_name]) and defined($_->[V__line]);
    if( $_->[V_file_name]=~/^(\[\w+\])$/ ) {
      $other_special{$1}=$_;
      ();
    } else {
      ($_->[V_vma_start]=>$_);
    }
  } @{shift->[M__elem]};

  my @new;
  my @diff;
  my @old;

  foreach my $vma (@my_special) {
    if( exists $other_special{$vma->[V_file_name]} ) {
      my $x=delete $other_special{$vma->[V_file_name]};
      push @diff, [$vma, $x]
    if( $vma->[V_vma_start] != $x->[V_vma_start] or
        $vma->[V_vma_end] != $x->[V_vma_end] or
        $vma->shared_clean != $x->shared_clean or
        $vma->shared_dirty != $x->shared_dirty or
        $vma->private_clean != $x->private_clean or
        $vma->private_dirty != $x->private_dirty or
        $vma->[V_dev_major] != $x->[V_dev_major] or
        $vma->[V_dev_minor] != $x->[V_dev_minor] or
        $vma->[V_r] != $x->[V_r] or
        $vma->[V_w] != $x->[V_w] or
        $vma->[V_x] != $x->[V_x] or
        $vma->[V_file_off] != $x->[V_file_off] or
        $vma->[V_inode] != $x->[V_inode] or
        $vma->[V_mayshare] != $x->[V_mayshare] );
    } else {
      push @new, $vma;
    }
  }
  @old=values %other_special;

  foreach my $vma (@my) {
    if( exists $other{$vma->[V_vma_start]} ) {
      my $x=delete $other{$vma->[V_vma_start]};
      push @diff, [$vma, $x]
    if( $vma->[V_vma_end] != $x->[V_vma_end] or
        $vma->shared_clean != $x->shared_clean or
        $vma->shared_dirty != $x->shared_dirty or
        $vma->private_clean != $x->private_clean or
        $vma->private_dirty != $x->private_dirty or
        $vma->[V_dev_major] != $x->[V_dev_major] or
        $vma->[V_dev_minor] != $x->[V_dev_minor] or
        $vma->[V_r] != $x->[V_r] or
        $vma->[V_w] != $x->[V_w] or
        $vma->[V_x] != $x->[V_x] or
        $vma->[V_file_off] != $x->[V_file_off] or
        $vma->[V_inode] != $x->[V_inode] or
        $vma->[V_mayshare] != $x->[V_mayshare] or
        $vma->[V_file_name] ne $x->[V_file_name] );
    } else {
      push @new, $vma;
    }
  }
  push @old, sort {$a->[V_vma_start] <=> $b->[V_vma_start]} values %other;

  return \@new, \@diff, \@old;
}

sub vmas {return @{$_[0]->_elem};}

{
  my $once;
  sub import {
    my $class=shift;
    unless( $once ) {
      $once=1;
      eval {$class->new(@_)};
    }
  }
}

1;