File Coverage

blib/lib/Linux/Smaps.pm

Criterion	Covered	Total	%
statement	207	283	73.1
branch	61	102	59.8
condition	48	113	42.4
subroutine	31	37	83.7
pod	9	9	100.0
total	356	544	65.4

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.13';

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( $.==0 ) {                 # nothing read
    $!||=EACCES;                # some kernels just report it as an empty file
    $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;
__END__