File Coverage

blib/lib/Net/Connection/Match/PctMem.pm
Criterion Covered Total %
statement 11 74 14.8
branch 0 42 0.0
condition 0 6 0.0
subroutine 4 6 66.6
pod 2 2 100.0
total 17 130 13.0


line stmt bran cond sub pod time code
1             package Net::Connection::Match::PctMem;
2              
3 1     1   66461 use 5.006;
  1         14  
4 1     1   5 use strict;
  1         3  
  1         19  
5 1     1   4 use warnings;
  1         2  
  1         25  
6 1     1   452 use Proc::ProcessTable;
  1         4777  
  1         748  
7              
8             =head1 NAME
9              
10             Net::Connection::Match::PctMem - Check if the pctmem of a process matches for the process that has the connection.
11              
12             =head1 VERSION
13              
14             Version 0.0.0
15              
16             =cut
17              
18             our $VERSION = '0.0.0';
19              
20             =head1 SYNOPSIS
21              
22             use Net::Connection::Match::PctMem;
23             use Net::Connection;
24            
25             my $connection_args={
26             foreign_host=>'10.0.0.1',
27             foreign_port=>'22',
28             local_host=>'10.0.0.2',
29             local_port=>'12322',
30             proto=>'tcp4',
31             state=>'ESTABLISHED',
32             pid=>0,
33             pctmem=>'5.03',
34             };
35            
36             my $conn=Net::Connection->new( $connection_args );
37            
38             my %args=(
39             pctmems=>[
40             '>1',
41             ],
42             );
43            
44             my $checker=Net::Connection::Match::PctMem->new( \%args );
45            
46             if ( $checker->match( $conn ) ){
47             print "It matches.\n";
48             }
49              
50             =head1 METHODS
51              
52             =head2 new
53              
54             This intiates the object.
55              
56             It takes a hash reference with one key. One key is required and
57             that is 'pctmems', which is a array of pctmem value.
58              
59             The pctmem values can be prefixed with the equalities below for doing
60             additional comparisons.
61              
62             <
63             <=
64             >
65             >=
66              
67             Atleast one must be specified.
68              
69              
70             If the new method fails, it dies.
71              
72             my %args=(
73             pctmems=>[
74             '>1',
75             ],
76             );
77            
78             my $checker=Net::Connection::Match::PctMem->new( \%args );
79              
80             =cut
81              
82             sub new{
83 0     0 1   my %args;
84 0 0         if(defined($_[1])){
85 0           %args= %{$_[1]};
  0            
86             };
87              
88             # run some basic checks to make sure we have the minimum stuff required to work
89 0 0         if ( ! defined( $args{pctmems} ) ){
90 0           die ('No pctcpus key specified in the argument hash');
91             }
92 0 0         if ( ref( \$args{pctmems} ) eq 'ARRAY' ){
93 0           die ('The pctmems key is not a array');
94             }
95 0 0         if ( ! defined $args{pctmems}[0] ){
96 0           die ('Nothing defined in the pctmems array');
97             }
98              
99             my $self = {
100             pctmems=>$args{pctmems},
101 0           };
102 0           bless $self;
103              
104 0 0         if ( $^O =~ /bsd/ ){
105 0           my $physmem=`/sbin/sysctl -a hw.physmem`;
106 0           chomp( $physmem );
107 0           $physmem=~s/^.*\: //;
108 0           $self->{physmem}=$physmem;
109             }
110              
111 0           return $self;
112             }
113              
114             =head2 match
115              
116             Checks if a single Net::Connection object matches the stack.
117              
118             One argument is taken and that is a Net::Connection object.
119              
120             The returned value is a boolean.
121              
122             if ( $checker->match( $conn ) ){
123             print "The connection matches.\n";
124             }
125              
126             =cut
127              
128             sub match{
129 0     0 1   my $self=$_[0];
130 0           my $object=$_[1];
131              
132 0 0         if ( !defined( $object ) ){
133 0           return 0;
134             }
135              
136 0 0         if ( ref( $object ) ne 'Net::Connection' ){
137 0           return 0;
138             }
139              
140 0           my $conn_pid=$object->pid;
141              
142             # don't bother proceeding, the object won't match ever
143             # as it does not have a PID
144 0 0         if ( ! defined( $conn_pid ) ){
145 0           return 0;
146             }
147              
148              
149 0           my $loop=0;
150 0           my $pctmem;
151 0 0         if ( ! defined( $object->proc ) ){
152             # go through each proc and look for a matching pid
153 0           my $proctable=Proc::ProcessTable->new;
154 0           my $procs=$proctable->table;
155 0           my $proc_int=0;
156 0           my $loop=1;
157 0   0       while (
158             $loop &&
159             defined( $procs->[$proc_int] )
160             ){
161              
162 0 0         if ( $conn_pid eq $procs->[$proc_int]->{pid} ){
163 0 0         if ($^O =~ /bsd/){
164 0           $pctmem= (( $procs->[ $proc_int ]->{rssize} * 1024 * 4 ) / $self->{physmem}) * 100;
165             }else{
166 0           $pctmem=$procs->[$proc_int]->{pctmem};
167             }
168              
169             # exit the loop as we found it
170 0           $loop=0;
171             }
172              
173 0           $proc_int++;
174             }
175             }else{
176 0           $pctmem=$object->pctmem;
177             }
178              
179             # likely a dead connection that is handing around...
180             # or disappeared since grabbing the connection list
181             # and starting processing
182 0 0         if ( !defined( $pctmem ) ){
183 0           return 0;
184             }
185              
186             # use while as foreach will reference the value
187 0           my $pctmem_int=0;
188 0           while (defined( $self->{pctmems}[$pctmem_int] )){
189 0           my $value=$self->{pctmems}[$pctmem_int];
190 0 0 0       if (
    0          
    0          
    0          
    0          
191             ( $value =~ /^[0-9.]+$/ ) &&
192             ( $value eq $pctmem )
193             ){
194 0           return 1;
195             }elsif( $value =~ /^\<\=[0-9.]+$/ ){
196 0           $value=~s/^\<\=//;
197 0 0         if ( $value <= $pctmem ){
198 0           return 1;
199             }
200             }elsif( $value =~ /^\<[0-9.]+$/ ){
201 0           $value=~s/^\
202 0 0         if ( $pctmem < $value ){
203 0           return 1;
204             }
205             }elsif( $value =~ /^\>\=[0-9.]+$/ ){
206 0           $value=~s/^\>\=//;
207 0 0         if ( $pctmem >= $value ){
208 0           return 1;
209             }
210             }elsif( $value =~ /^\>[0-9.]+$/ ){
211 0           $value=~s/^\>//;
212 0 0         if ( $pctmem > $value ){
213 0           return 1;
214             }
215             }
216 0           $pctmem_int++;
217             }
218              
219 0           return 0;
220             }
221              
222             =head1 AUTHOR
223              
224             Zane C. Bowers-Hadley, C<< >>
225              
226             =head1 BUGS
227              
228             Please report any bugs or feature requests to C, or through
229             the web interface at L. I will be notified, and then you'll
230             automatically be notified of progress on your bug as I make changes.
231              
232              
233              
234              
235             =head1 SUPPORT
236              
237             You can find documentation for this module with the perldoc command.
238              
239             perldoc Net::Connection::Match
240              
241              
242             You can also look for information at:
243              
244             =over 4
245              
246             =item * RT: CPAN's request tracker (report bugs here)
247              
248             L
249              
250             =item * AnnoCPAN: Annotated CPAN documentation
251              
252             L
253              
254             =item * CPAN Ratings
255              
256             L
257              
258             =item * Search CPAN
259              
260             L
261              
262             =back
263              
264              
265             =head1 ACKNOWLEDGEMENTS
266              
267              
268             =head1 LICENSE AND COPYRIGHT
269              
270             Copyright 2019 Zane C. Bowers-Hadley.
271              
272             This program is free software; you can redistribute it and/or modify it
273             under the terms of the the Artistic License (2.0). You may obtain a
274             copy of the full license at:
275              
276             L
277              
278             Any use, modification, and distribution of the Standard or Modified
279             Versions is governed by this Artistic License. By using, modifying or
280             distributing the Package, you accept this license. Do not use, modify,
281             or distribute the Package, if you do not accept this license.
282              
283             If your Modified Version has been derived from a Modified Version made
284             by someone other than you, you are nevertheless required to ensure that
285             your Modified Version complies with the requirements of this license.
286              
287             This license does not grant you the right to use any trademark, service
288             mark, tradename, or logo of the Copyright Holder.
289              
290             This license includes the non-exclusive, worldwide, free-of-charge
291             patent license to make, have made, use, offer to sell, sell, import and
292             otherwise transfer the Package with respect to any patent claims
293             licensable by the Copyright Holder that are necessarily infringed by the
294             Package. If you institute patent litigation (including a cross-claim or
295             counterclaim) against any party alleging that the Package constitutes
296             direct or contributory patent infringement, then this Artistic License
297             to you shall terminate on the date that such litigation is filed.
298              
299             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
300             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
301             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
302             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
303             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
304             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
305             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
306             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
307              
308              
309             =cut
310              
311             1; # End of Net::Connection::Match