File Coverage

blib/lib/Net/Connection/Match/PID.pm
Criterion Covered Total %
statement 37 49 75.5
branch 20 32 62.5
condition 3 3 100.0
subroutine 5 5 100.0
pod 2 2 100.0
total 67 91 73.6


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