22

✏️ Editing: ProcessTable.pm

package Proc::ProcessTable;

use 5.006;

use strict;
use warnings;
use Carp;
use Config;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);

require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
    
);
$VERSION = '0.59';

sub AUTOLOAD {
    # This AUTOLOAD is used to 'autoload' constants from the constant()
    # XS function.  If a constant is not found then control is passed
    # to the AUTOLOAD in AutoLoader.

my $constname;
    ($constname = $AUTOLOAD) =~ s/.*:://;
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {
    if ($! =~ /Invalid/) {
        $AutoLoader::AUTOLOAD = $AUTOLOAD;
        goto &AutoLoader::AUTOLOAD;
    }
    else {
        croak "Your vendor has not defined Proc::ProcessTable macro $constname";
    }
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}

bootstrap Proc::ProcessTable $VERSION;

# Preloaded methods go here.
use Proc::ProcessTable::Process;
use File::Find;

my %TTYDEVS;

our $TTYDEVSFILE = "/tmp/TTYDEVS_" . $Config{byteorder}; # Where we store the TTYDEVS hash

sub new 
{
  my ($this, %args) = @_;
  my $class = ref($this) || $this;
  my $self = {};
  bless $self, $class;

mutex_new(1);
  if ( exists $args{cache_ttys} && $args{cache_ttys} == 1 )
  { 
    $self->{cache_ttys} = 1 
  }

if ( exists $args{enable_ttys} && (! $args{enable_ttys}))
  {
    $self->{enable_ttys} = 0;
    if ($self->{'cache_ttys'}) {
      carp("cache_ttys specified with enable_ttys, cache_ttys a no-op");
    }
  }
  else
  {
    $self->{enable_ttys} = 1;
  }

my $status = $self->initialize;
  mutex_new(0);
  if($status)
  {
    return $self; 
  }
  else
  {
    return undef;
  }
}

sub initialize 
{
  my ($self) = @_;

if ($self->{enable_ttys})
  {

# Get the mapping of TTYs to device nums
    # reading/writing the cache if we are caching
    if( $self->{cache_ttys} )
    {

require Storable;

if( -r $TTYDEVSFILE )
      {
        $_ = Storable::retrieve($TTYDEVSFILE);
        %Proc::ProcessTable::TTYDEVS = %$_;
      }
      else
      {
        $self->_get_tty_list;

require File::Temp;
        require File::Basename;

my($ttydevs_fh, $ttydevs_tmpfile) = File::Temp::tempfile('ProcessTable_XXXXXXXX', DIR => File::Basename::dirname($TTYDEVSFILE));
        chmod 0644, $ttydevs_tmpfile;
        Storable::store_fd( \%Proc::ProcessTable::TTYDEVS, $ttydevs_fh );
        close $ttydevs_fh;

if( !rename $ttydevs_tmpfile, $TTYDEVSFILE )
        {
          my $err = $!;
          unlink $ttydevs_tmpfile;
          if( !-r $TTYDEVSFILE)
          {
            die "Renaming $ttydevs_tmpfile to $TTYDEVSFILE failed: $err";
          }
          # else somebody else obviously created the file in the meantime
        }
      }
    }
    else
    {
      $self->_get_tty_list;
    }
  }

# Call the os-specific initialization
  $self->_initialize_os;

return 1; 
}

###############################################
# Generate a hash mapping TTY numbers to paths.
# This might be faster in Table.xs,
# but it's a lot more portable here
###############################################
sub _get_tty_list 
{
  my ($self) = @_;
  undef %Proc::ProcessTable::TTYDEVS;
  find({ wanted => 
       sub{
     $File::Find::prune = 1 if -d $_ && ! -x $_;
     my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
        $atime,$mtime,$ctime,$blksize,$blocks) = stat($File::Find::name);
     $Proc::ProcessTable::TTYDEVS{$rdev} = $File::Find::name
       if(-c $File::Find::name);
       }, no_chdir => 1},
       "/dev" 
      );
}

# Apparently needed for mod_perl
sub DESTROY {}

1;
__END__

=head1 NAME

Proc::ProcessTable - Perl extension to access the unix process table

=head1 SYNOPSIS

use Proc::ProcessTable;

my $p = Proc::ProcessTable->new( 'cache_ttys' => 1 ); 
  my @fields = $p->fields;
  my $ref = $p->table;

=head1 DESCRIPTION

Perl interface to the unix process table.

=head1 METHODS

=over 4

=item new

Creates a new ProcessTable object. The constructor can take the following
flags:

enable_ttys -- causes the constructor to use the tty determination code,
which is the default behavior.  Setting this to 0 disables this code,
thus preventing the module from traversing the device tree, which on some
systems, can be quite large and/or contain invalid device paths (for example,
Solaris does not clean up invalid device entries when disks are swapped).  If
this is specified with cache_ttys, a warning is generated and the cache_ttys
is overridden to be false.

cache_ttys -- causes the constructor to look for and use a file that
caches a mapping of tty names to device numbers, and to create the
file if it doesn't exist. This feature requires the Storable module.
By default, the cache file name consists of a prefix F</tmp/TTYDEVS_> and a
byte order tag. The file name can be accessed (and changed) via
C<$Proc::ProcessTable::TTYDEVSFILE>.

=item fields

Returns a list of the field names supported by the module on the
current architecture.

=item table

Reads the process table and returns a reference to an array of
Proc::ProcessTable::Process objects. Attributes of a process object
are returned by accessors named for the attribute; for example, to get
the uid of a process just do:

$process->uid

The priority and pgrp methods also allow values to be set, since these
are supported directly by internal perl functions.

=back

=head1 EXAMPLES

# A cheap and sleazy version of ps
 use Proc::ProcessTable;

my $FORMAT = "%-6s %-10s %-8s %-24s %s\n";
 my $t = Proc::ProcessTable->new;
 printf($FORMAT, "PID", "TTY", "STAT", "START", "COMMAND"); 
 foreach my $p ( @{$t->table} ){
   printf($FORMAT, 
          $p->pid, 
          $p->ttydev, 
          $p->state, 
          scalar(localtime($p->start)), 
          $p->cmndline);
 }

# Dump all the information in the current process table
 use Proc::ProcessTable;

my $t = Proc::ProcessTable->new;

foreach my $p (@{$t->table}) {
  print "--------------------------------\n";
  foreach my $f ($t->fields){
    print $f, ":  ", $p->{$f}, "\n";
  }
 }

=head1 CAVEATS

Please see the file README in the distribution for a list of supported
operating systems. Please see the file PORTING for information on how
to help make this work on your OS.

=head1 AUTHOR

D. Urist, durist@frii.com

=head1 SEE ALSO

L<Proc::ProcessTable::Process>, L<perl(1)>.

=cut

MR SKB