File Coverage

blib/lib/Net/Connection/lsof.pm
Criterion Covered Total %
statement 14 115 12.1
branch 0 42 0.0
condition 0 9 0.0
subroutine 5 6 83.3
pod 1 1 100.0
total 20 173 11.5


line stmt bran cond sub pod time code
1              
2             package Net::Connection::lsof;
3              
4 2     2   130785 use 5.006;
  2         16  
5 2     2   13 use strict;
  2         3  
  2         43  
6 2     2   12 use warnings;
  2         4  
  2         75  
7 2     2   988 use Net::Connection;
  2         192676  
  2         152  
8 2     2   970 use Proc::ProcessTable;
  2         11362  
  2         2551  
9             require Exporter;
10              
11             our @ISA = qw(Exporter);
12             our @EXPORT=qw(lsof_to_nc_objects);
13              
14             =head1 NAME
15              
16             Net::Connection::lsof - This uses lsof to generate a array of Net::Connection objects.
17              
18             =head1 VERSION
19              
20             Version 0.1.1
21              
22             =cut
23              
24             our $VERSION = '0.1.1';
25              
26              
27             =head1 SYNOPSIS
28              
29             use Net::Connection::lsof;
30              
31             my @objects;
32             eval{ @objects = &lsof_to_nc_objects; };
33              
34             # this time don't resolve ports, ptrs, or usernames
35             my $args={
36             ports=>0,
37             ptrs=>0,
38             uid_resolve=>0,
39             };
40             eval{ @objects = &lsof_to_nc_objects($args); };
41              
42             =head1 SUBROUTINES
43              
44             =head2 lsof_to_nc_objects
45              
46             This runs 'lsof -i UDP -i TCP -n -l -P' and parses the output
47             returns a array of L objects. If a non-zero exit code is
48             returned, it will die.
49              
50             There is one optional argument and that is hash reference that can take
51             several possible keys.
52              
53             =head3 args hash
54              
55             =head4 ports
56              
57             Attempt to resolve the port names.
58              
59             Defaults to 1.
60              
61             =head4 ptrs
62              
63             Attempt to resolve the PTRs.
64              
65             Defaults to 1.
66              
67             =head4 uid_resolve
68              
69             Attempt to resolve the UID to a username.
70              
71             Defaults to 1.
72              
73             =head4 proc_info
74              
75             Add assorted process information to the objects.
76              
77             Defaults to 1.
78              
79             my @objects;
80             eval{ @objects = &lsof_to_nc_objects( $args ); };
81              
82             =cut
83              
84             sub lsof_to_nc_objects{
85 0     0 1   my %func_args;
86 0 0         if(defined($_[0])){
87 0           %func_args= %{$_[0]};
  0            
88             };
89              
90 0 0         if ( !defined( $func_args{ptrs} ) ){
91 0           $func_args{ptrs}=1;
92             }
93 0 0         if ( !defined( $func_args{ports} ) ){
94 0           $func_args{ports}=1;
95             }
96 0 0         if ( !defined( $func_args{uid_resolve} ) ){
97 0           $func_args{uid_resolve}=1;
98             }
99 0 0         if ( !defined( $func_args{proc_info} ) ){
100 0           $func_args{proc_info}=1;
101             }
102              
103 0           my $output_raw=`lsof -i UDP -i TCP -n -l -P`;
104 0 0 0       if (
      0        
105             ( $? ne 0 ) &&
106             (
107             ( $^O =~ /linux/ ) &&
108             ( $? ne 256 )
109             )
110             ){
111 0           die('"lsof -i UDP -i TCP -n -l -P" exited with a non-zero value or in the case of some linux distros a non-1 value');
112             }
113 0           my @output_lines=split(/\n/, $output_raw);
114              
115 0           my @nc_objects;
116              
117             # process info caches
118             my %pid_proc;
119 0           my %pid_pctmem;
120 0           my %pid_pctcpu;
121 0           my %pid_wchan;
122 0           my %pid_start;
123              
124 0           my $proc_table;
125 0           my $physmem;
126 0 0         if ( $func_args{proc_info} ){
127 0           my $pt=Proc::ProcessTable->new;
128 0           $proc_table=$pt->table;
129 0 0         if ( $^O =~ /bsd/ ){
130 0           $physmem=`/sbin/sysctl -a hw.physmem`;
131 0           chomp( $physmem );
132 0           $physmem=~s/^.*\: //;
133             }
134             }
135              
136 0           my $line_int=1;
137 0           while ( defined( $output_lines[$line_int] ) ){
138 0           my $command=substr $output_lines[$line_int], 0, 9;
139 0           my $line=substr $output_lines[$line_int], 10;
140              
141 0           $line=~s/^[\t ]*//;
142              
143 0           my @line_split=split(/[\ \t]+/, $line );
144              
145             my $args={
146             pid=>$line_split[0],
147             uid=>$line_split[1],
148             ports=>$func_args{ports},
149             ptrs=>$func_args{ptrs},
150             uid_resolve=>$func_args{uid_resolve},
151 0           };
152              
153 0           my $type=$line_split[3];
154 0           my $mode=$line_split[6];
155 0           my $name=$line_split[7];
156              
157             # Use the name and type to build the proto.
158 0           my $proto='';
159 0 0         if ( $type =~ /6/ ){
    0          
160 0           $proto='6';
161             }elsif( $type =~ /4/ ){
162 0           $proto='4';
163             }
164 0 0         if ( $mode =~ /[Uu][Dd][Pp]/ ){
    0          
165 0           $proto='udp'.$proto;
166             }elsif( $mode =~ /[Tt][Cc][Pp]/ ){
167 0           $proto='tcp'.$proto;
168             }
169 0           $args->{proto}=$proto;
170              
171 0           my ( $local, $foreign )=split( /\-\>/, $name );
172              
173 0           my $ip;
174             my $port;
175              
176 0 0         if ( ! defined( $foreign ) ){
177 0           $args->{foreign_host}='*';
178 0           $args->{foreign_port}='*';
179             }else{
180 0 0         if ( $foreign =~ /\]/ ){
181 0           ( $ip, $port ) = split( /\]/, $foreign );
182 0           $ip=~s/^\[//;
183 0           $port=~s/\://;
184             }else{
185 0           ( $ip, $port ) = split( /\:/, $foreign );
186             }
187              
188 0           $args->{foreign_host}=$ip;
189 0           $args->{foreign_port}=$port;
190             }
191              
192 0 0         if ( $local =~ /\]/ ){
193 0           ( $ip, $port ) = split( /\]/, $local );
194 0           $ip=~s/^\[//;
195 0           $port=~s/\://;
196             }else{
197 0           ( $ip, $port ) = split( /\:/, $local );
198             }
199 0           $args->{local_host}=$ip;
200 0           $args->{local_port}=$port;
201              
202 0           $args->{state}='';
203 0 0         if ( defined( $line_split[8] ) ){
204 0           $args->{state}=$line_split[8];
205 0           $args->{state}=~s/[\(\)]//g;
206             }
207              
208             #
209             # put together process info if requested
210             #
211 0 0         if ( $func_args{proc_info} ){
212 0 0         if ( defined( $pid_proc{ $args->{pid} } ) ){
213 0           $args->{proc}=$pid_proc{ $args->{pid} };
214 0           $args->{wchan}=$pid_wchan{ $args->{pid} };
215 0           $args->{pctmem}=$pid_pctmem{ $args->{pid} };
216 0           $args->{pctcpu}=$pid_pctcpu{ $args->{pid} };
217 0           $args->{pid_start}=$pid_start{ $args->{pid} };
218             }else{
219 0           my $loop=1;
220 0           my $proc_int=0;
221 0   0       while(
222             defined( $proc_table->[ $proc_int ] ) &&
223             $loop
224             ){
225              
226             # matched
227 0 0         if ( $proc_table->[ $proc_int ]->{pid} eq $args->{pid} ){
228             # exit the loop
229 0           $loop = 0;
230              
231             # fetch and save the proc info
232 0 0         if ( $proc_table->[ $proc_int ]->cmndline =~ /^$/ ){
233             # kernel proc
234 0           $args->{proc}='['.$proc_table->[ $proc_int ]->{fname}.']';
235             }else{
236             # non-kernel proc
237 0           $args->{proc}=$proc_table->[ $proc_int ]->{cmndline};
238             }
239 0           $pid_proc{ $args->{pid} }=$args->{proc};
240              
241 0           $args->{wchan}=$proc_table->[ $proc_int ]->{wchan};
242 0           $pid_wchan{ $args->{pid} }=$args->{wchan};
243              
244 0           $args->{pid_start}=$proc_table->[ $proc_int ]->{pid_start};
245 0           $pid_start{ $args->{pid} }=$args->{pid_start};
246              
247 0           $args->{pctcpu}=$proc_table->[ $proc_int ]->{pctcpu};
248 0           $pid_pctcpu{ $args->{pid} }=$args->{pctcpu};
249              
250 0 0         if ($^O =~ /bsd/){
251 0           $args->{pctmem}= (( $proc_table->[ $proc_int ]->{rssize} * 1024 * 4 ) / $physmem) * 100;
252             }else{
253 0           $args->{pctmem}=$proc_table->[ $proc_int ]->{pctmem};
254             }
255 0           $pid_pctmem{ $args->{pid} }=$args->{pctmem};
256             }
257              
258 0           $proc_int++;
259             }
260             }
261             }
262              
263 0           push( @nc_objects, Net::Connection->new( $args ) );
264              
265 0           $line_int++;
266             }
267              
268 0           return @nc_objects;
269             }
270              
271             =head1 AUTHOR
272              
273             Zane C. Bowers-Hadley, C<< >>
274              
275             =head1 BUGS
276              
277             Please report any bugs or feature requests to C, or through
278             the web interface at L. I will be notified, and then you'll
279             automatically be notified of progress on your bug as I make changes.
280              
281              
282              
283              
284             =head1 SUPPORT
285              
286             You can find documentation for this module with the perldoc command.
287              
288             perldoc Net::Connection::lsof
289              
290              
291             You can also look for information at:
292              
293             =over 4
294              
295             =item * RT: CPAN's request tracker (report bugs here)
296              
297             L
298              
299             =item * AnnoCPAN: Annotated CPAN documentation
300              
301             L
302              
303             =item * CPAN Ratings
304              
305             L
306              
307             =item * Search CPAN
308              
309             L
310              
311             =item * Git Repo
312              
313             L
314              
315             =back
316              
317              
318             =head1 ACKNOWLEDGEMENTS
319              
320              
321             =head1 LICENSE AND COPYRIGHT
322              
323             This software is Copyright (c) 2019 by Zane C. Bowers-Hadley.
324              
325             This is free software, licensed under:
326              
327             The Artistic License 2.0 (GPL Compatible)
328              
329              
330             =cut
331              
332             1; # End of Net::Connection::lsof