File Coverage

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