view release on metacpan or  search on metacpan

lib/Linux/Smaps.pm  view on Meta::CPAN

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};
  }
}

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