File: ProcessTable.pm

package info (click to toggle)
libproc-processtable-perl 0.45-6
  • links: PTS, VCS
  • area: main
  • in suites: wheezy
  • size: 620 kB
  • sloc: ansic: 4,025; perl: 361; makefile: 14
file content (264 lines) | stat: -rw-r--r-- 6,058 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
package Proc::ProcessTable;

use 5.006;

use strict;
use Carp;
use Fcntl;
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.45';

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"; # 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;
        my $old_umask = umask;
        umask 022;

        sysopen( my $ttydevs_fh, $TTYDEVSFILE, O_WRONLY | O_EXCL | O_CREAT )
            or die "$TTYDEVSFILE was created by other process";
        Storable::store_fd( \%Proc::ProcessTable::TTYDEVS, $ttydevs_fh );
        close $ttydevs_fh;
        umask $old_umask;
      }
    }
    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;

  $p = new Proc::ProcessTable( 'cache_ttys' => 1 ); 
  @fields = $p->fields;
  $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 diables 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 file is /tmp/TTYDEVS by default). This
feature requires the Storable module.

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

 $FORMAT = "%-6s %-10s %-8s %-24s %s\n";
 $t = new Proc::ProcessTable;
 printf($FORMAT, "PID", "TTY", "STAT", "START", "COMMAND"); 
 foreach $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;

 $t = new Proc::ProcessTable;

 foreach $p (@{$t->table}) {
  print "--------------------------------\n";
  foreach $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

Proc::ProcessTable::Process.pm, perl(1).

=cut