File Coverage

blib/lib/Proc/ProcessTable.pm
Criterion Covered Total %
statement 48 79 60.7
branch 9 30 30.0
condition 6 15 40.0
subroutine 12 14 85.7
pod 1 2 50.0
total 76 140 54.2


line stmt bran cond sub pod time code
1             package Proc::ProcessTable;
2              
3 6     6   432931 use 5.006;
  6         73  
4              
5 6     6   36 use strict;
  6         11  
  6         126  
6 6     6   39 use warnings;
  6         12  
  6         190  
7 6     6   33 use Carp;
  6         11  
  6         384  
8 6     6   43 use Config;
  6         20  
  6         330  
9 6     6   49 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
  6         12  
  6         1954  
10              
11             require Exporter;
12             require DynaLoader;
13              
14             @ISA = qw(Exporter DynaLoader);
15             # Items to export into callers namespace by default. Note: do not export
16             # names by default without a very good reason. Use EXPORT_OK instead.
17             # Do not simply export all your public functions/methods/constants.
18             @EXPORT = qw(
19            
20             );
21             $VERSION = '0.635';
22              
23             sub AUTOLOAD {
24             # This AUTOLOAD is used to 'autoload' constants from the constant()
25             # XS function. If a constant is not found then control is passed
26             # to the AUTOLOAD in AutoLoader.
27              
28 0     0   0 my $constname;
29 0         0 ($constname = $AUTOLOAD) =~ s/.*:://;
30 0 0       0 my $val = constant($constname, @_ ? $_[0] : 0);
31 0 0       0 if ($! != 0) {
32 0 0       0 if ($! =~ /Invalid/) {
33 0         0 $AutoLoader::AUTOLOAD = $AUTOLOAD;
34 0         0 goto &AutoLoader::AUTOLOAD;
35             }
36             else {
37 0         0 croak "Your vendor has not defined Proc::ProcessTable macro $constname";
38             }
39             }
40 0         0 eval "sub $AUTOLOAD { $val }";
41 0         0 goto &$AUTOLOAD;
42             }
43              
44             bootstrap Proc::ProcessTable $VERSION;
45              
46             # Preloaded methods go here.
47 6     6   2677 use Proc::ProcessTable::Process;
  6         15  
  6         278  
48 6     6   39 use File::Find;
  6         12  
  6         4350  
49              
50             my %TTYDEVS;
51              
52             our $TTYDEVSFILE = "/tmp/TTYDEVS_" . $Config{byteorder}; # Where we store the TTYDEVS hash
53              
54             sub new
55             {
56 3     3 1 4019707 my ($this, %args) = @_;
57 3   33     228 my $class = ref($this) || $this;
58 3         71 my $self = {};
59 3         46 bless $self, $class;
60              
61 3         119 mutex_new(1);
62 3 50 33     78 if ( exists $args{cache_ttys} && $args{cache_ttys} == 1 )
63             {
64 0         0 $self->{cache_ttys} = 1
65             }
66              
67 3 50 33     129 if ( exists $args{enable_ttys} && (! $args{enable_ttys}))
68             {
69 0         0 $self->{enable_ttys} = 0;
70 0 0       0 if ($self->{'cache_ttys'}) {
71 0         0 carp("cache_ttys specified with enable_ttys, cache_ttys a no-op");
72             }
73             }
74             else
75             {
76 3         193 $self->{enable_ttys} = 1;
77             }
78              
79 3         82 my $status = $self->initialize;
80 3         27 mutex_new(0);
81 3 50       19 if($status)
82             {
83 3         27 return $self;
84             }
85             else
86             {
87 0         0 return undef;
88             }
89             }
90              
91             sub initialize
92             {
93 3     3 0 16 my ($self) = @_;
94              
95 3 50       28 if ($self->{enable_ttys})
96             {
97              
98             # Get the mapping of TTYs to device nums
99             # reading/writing the cache if we are caching
100 3 50       92 if( $self->{cache_ttys} )
101             {
102              
103 0         0 require Storable;
104              
105 0 0       0 if( -r $TTYDEVSFILE )
106             {
107 0         0 $_ = Storable::retrieve($TTYDEVSFILE);
108 0         0 %Proc::ProcessTable::TTYDEVS = %$_;
109             }
110             else
111             {
112 0         0 $self->_get_tty_list;
113              
114 0         0 require File::Temp;
115 0         0 require File::Basename;
116              
117 0         0 my($ttydevs_fh, $ttydevs_tmpfile) = File::Temp::tempfile('ProcessTable_XXXXXXXX', DIR => File::Basename::dirname($TTYDEVSFILE));
118 0         0 chmod 0644, $ttydevs_tmpfile;
119 0         0 Storable::store_fd( \%Proc::ProcessTable::TTYDEVS, $ttydevs_fh );
120 0         0 close $ttydevs_fh;
121              
122 0 0       0 if( !rename $ttydevs_tmpfile, $TTYDEVSFILE )
123             {
124 0         0 my $err = $!;
125 0         0 unlink $ttydevs_tmpfile;
126 0 0       0 if( !-r $TTYDEVSFILE)
127             {
128 0         0 die "Renaming $ttydevs_tmpfile to $TTYDEVSFILE failed: $err";
129             }
130             # else somebody else obviously created the file in the meantime
131             }
132             }
133             }
134             else
135             {
136 3         60 $self->_get_tty_list;
137             }
138             }
139              
140             # Call the os-specific initialization
141 3         1100 $self->_initialize_os;
142              
143 3         31 return 1;
144             }
145              
146             ###############################################
147             # Generate a hash mapping TTY numbers to paths.
148             # This might be faster in Table.xs,
149             # but it's a lot more portable here
150             ###############################################
151             sub _get_tty_list
152             {
153 3     3   22 my ($self) = @_;
154 3         18 undef %Proc::ProcessTable::TTYDEVS;
155 3 50       181 return unless -d "/dev";
156             find({ wanted =>
157             sub{
158 51 50 33 51   1345 $File::Find::prune = 1 if -d $_ && ( ! -x $_ || $_ eq "/dev/.lxc" || $_ eq "/dev/.lxd-mounts");
      66        
159 51         706 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
160             $atime,$mtime,$ctime,$blksize,$blocks) = stat($File::Find::name);
161 51 100       3104 $Proc::ProcessTable::TTYDEVS{$rdev} = $File::Find::name
162             if(-c $File::Find::name);
163 3         1406 }, no_chdir => 1},
164             "/dev"
165             );
166             }
167              
168             # Apparently needed for mod_perl
169       0     sub DESTROY {}
170              
171             1;
172             __END__