File Coverage

blib/lib/Net/Connection/Match/Ports.pm
Criterion Covered Total %
statement 49 71 69.0
branch 17 44 38.6
condition 12 30 40.0
subroutine 5 5 100.0
pod 2 2 100.0
total 85 152 55.9


line stmt bran cond sub pod time code
1             package Net::Connection::Match::Ports;
2              
3 3     3   224802 use 5.006;
  3         49  
4 3     3   17 use strict;
  3         7  
  3         92  
5 3     3   19 use warnings;
  3         6  
  3         2743  
6              
7             =head1 NAME
8              
9             Net::Connection::Match::Ports - Runs a basic port check against a Net::Connection object.
10              
11             =head1 VERSION
12              
13             Version 0.1.0
14              
15             =cut
16              
17             our $VERSION = '0.1.0';
18              
19              
20             =head1 SYNOPSIS
21              
22             use Net::Connection::Match::Port;
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             };
33            
34             my $conn=Net::Connection->new( $connection_args );
35            
36             my %args=(
37             ports=>[
38             'smtp',
39             '22',
40             ],
41             lports=>[
42             '21',
43             ],
44             fports=>[
45             'http',
46             '*',
47             ],
48             );
49            
50             my $checker=Net::Connection::Match::Ports->new( \%args );
51            
52             if ( $checker->match( $conn ) ){
53             print "It matches.\n";
54             }
55              
56             =head1 METHODS
57              
58             =head2 new
59              
60             This intiates the object.
61              
62             It takes a hash reference with atleast one of of the three
63             possible keys defined. The possible keys are 'ports'(which
64             matches either side), 'lports'(which matches the local side),
65             and 'fports'(which matches the foreign side).
66              
67             The value of each key is a array with either port numbers, '*', or
68             names. If names are given, getservbyname will be called. If
69             it errors for any of them, it will die.
70              
71             If the new method fails, it dies.
72              
73             my %args=(
74             ports=>[
75             'smtp',
76             '22',
77             ],
78             lports=>[
79             '21',
80             ],
81             fports=>[
82             'http',
83             ],
84             );
85            
86             my $checker=Net::Connection::Match::Ports->new( \%args );
87              
88             =cut
89              
90             sub new{
91 4     4 1 584 my %args;
92 4 100       15 if(defined($_[1])){
93 3         7 %args= %{$_[1]};
  3         16  
94             };
95              
96             # run some basic checks to make sure we have the minimum stuff required to work
97 4 50 66     21 if (
      33        
98             ( ! defined( $args{ports} ) ) &&
99             ( ! defined( $args{fports} ) ) &&
100             ( ! defined( $args{lports} ) )
101             ){
102 1         9 die ('No [fl]ports key specified in the argument hash');
103             }
104 3 0 33     21 if (
      0        
      33        
      0        
      0        
105             (
106             defined( $args{ports} ) &&
107             ( ! defined( $args{ports}[0] ) )
108             ) &&
109             (
110             defined( $args{lports} ) &&
111             ( ! defined( $args{lports}[0] ) )
112             ) &&
113             (
114             defined( $args{fports} ) &&
115             ( ! defined( $args{fports}[0] ) )
116             )
117             ){
118 0         0 die ('No ports defined in the in any of the [fl]ports array');
119             }
120              
121 3         11 my $self = {
122             ports=>{},
123             fports=>{},
124             lports=>{},
125             };
126 3         8 bless $self;
127              
128             # Process the ports for matching either
129 3         4 my $ports_int=0;
130 3 50       11 if ( defined( $args{ports} ) ){
131 3         9 while (defined( $args{ports}[$ports_int] )) {
132 3 50       19 if ( $args{ports}[$ports_int] =~ /^[0-9]+$/ ){
    0          
133 3         15 $self->{ports}{ $args{ports}[$ports_int] }= $args{ports}[$ports_int];
134             }elsif( $args{ports}[$ports_int] =~ /^\*$/ ){
135 0         0 $self->{ports}{'*'}='*';
136             }else{
137 0         0 my $port_number=(getservbyname( $args{ports}[$ports_int] , '' ))[2];
138              
139 0 0       0 if( !defined( $port_number ) ){
140 0         0 die("Could not resolve port '".$args{ports}[$ports_int]."' to a number");
141             }
142              
143 0         0 $self->{ports}{$port_number}=$port_number;
144             }
145              
146 3         9 $ports_int++;
147             }
148             }
149              
150             # Process the ports for matching local ports
151 3         5 $ports_int=0;
152 3 50       8 if ( defined( $args{lports} ) ){
153 3         8 while (defined( $args{lports}[$ports_int] )) {
154 3 50       12 if ( $args{lports}[$ports_int] =~ /^[0-9]+$/ ){
    0          
155 3         8 $self->{lports}{ $args{lports}[$ports_int] }= $args{lports}[$ports_int];
156             }elsif( $args{lports}[$ports_int] =~ /^\*$/ ){
157 0         0 $self->{lports}{'*'}='*';
158             }else{
159 0         0 my $port_number=(getservbyname( $args{lports}[$ports_int] , '' ))[2];
160              
161 0 0       0 if( !defined( $port_number ) ){
162 0         0 die("Could not resolve port '".$args{lports}[$ports_int]."' to a number");
163             }
164              
165 0         0 $self->{lports}{$port_number}=$port_number;
166             }
167              
168 3         9 $ports_int++;
169             }
170             }
171              
172             # Process the ports for matching foreign ports
173 3         5 $ports_int=0;
174 3 50       9 if ( defined( $args{fports} ) ){
175 3         7 while (defined( $args{fports}[$ports_int] )) {
176 3 50       11 if ( $args{fports}[$ports_int] =~ /^[0-9]+$/ ){
    0          
177 3         8 $self->{fports}{ $args{fports}[$ports_int] }= $args{fports}[$ports_int];
178             }elsif( $args{fports}[$ports_int] =~ /^\*$/ ){
179 0         0 $self->{fports}{'*'}='*';
180             }else{
181 0         0 my $port_number=(getservbyname( $args{fports}[$ports_int] , '' ))[2];
182              
183 0 0       0 if( !defined( $port_number ) ){
184 0         0 die("Could not resolve port '".$args{fports}[$ports_int]."' to a number");
185             }
186              
187 0         0 $self->{fports}{$port_number}=$port_number;
188             }
189              
190 3         33 $ports_int++;
191             }
192             }
193              
194 3         23 return $self;
195             }
196              
197             =head2 match
198              
199             Checks if a single Net::Connection object matches the stack.
200              
201             One argument is taken and that is a Net::Connection object.
202              
203             The returned value is a boolean.
204              
205             if ( $checker->match( $conn ) ){
206             print "The connection matches.\n";
207             }
208              
209             =cut
210              
211             sub match{
212 8     8 1 2578 my $self=$_[0];
213 8         15 my $object=$_[1];
214              
215 8 100       21 if ( !defined( $object ) ){
216 1         4 return 0;
217             }
218              
219 7 100       22 if ( ref( $object ) ne 'Net::Connection' ){
220 1         4 return 0;
221             }
222              
223 6         20 my $lport=$object->local_port;
224 6         34 my $fport=$object->foreign_port;
225              
226             # If either are non-numeric, resolve them if possible
227 6 50       45 if ( $lport !~ /^[0-9]+$/ ){
228 0         0 my $lport_number=(getservbyname( $lport , '' ))[2];
229 0 0       0 if ( defined( $lport_number ) ){
230 0         0 $lport=$lport_number;
231             }
232             }
233 6 50       20 if ( $fport !~ /^[0-9]+$/ ){
234 0         0 my $fport_number=(getservbyname( $fport , '' ))[2];
235 0 0       0 if ( defined( $fport_number ) ){
236 0         0 $fport=$fport_number;
237             }
238             }
239              
240             # check if this is one of the ones we are looking for
241 6 100 66     44 if (
      66        
      100        
242             defined( $self->{ports}{ $lport } ) ||
243             defined( $self->{ports}{ $fport } ) ||
244             defined( $self->{lports}{ $lport } ) ||
245             defined( $self->{fports}{ $fport } )
246             ){
247 5         19 return 1;
248             }
249              
250 1         4 return 0;
251             }
252              
253             =head1 AUTHOR
254              
255             Zane C. Bowers-Hadley, C<< >>
256              
257             =head1 BUGS
258              
259             Please report any bugs or feature requests to C, or through
260             the web interface at L. I will be notified, and then you'll
261             automatically be notified of progress on your bug as I make changes.
262              
263              
264              
265              
266             =head1 SUPPORT
267              
268             You can find documentation for this module with the perldoc command.
269              
270             perldoc Net::Connection::Match
271              
272              
273             You can also look for information at:
274              
275             =over 4
276              
277             =item * RT: CPAN's request tracker (report bugs here)
278              
279             L
280              
281             =item * AnnoCPAN: Annotated CPAN documentation
282              
283             L
284              
285             =item * CPAN Ratings
286              
287             L
288              
289             =item * Search CPAN
290              
291             L
292              
293             =back
294              
295              
296             =head1 ACKNOWLEDGEMENTS
297              
298              
299             =head1 LICENSE AND COPYRIGHT
300              
301             Copyright 2019 Zane C. Bowers-Hadley.
302              
303             This program is free software; you can redistribute it and/or modify it
304             under the terms of the the Artistic License (2.0). You may obtain a
305             copy of the full license at:
306              
307             L
308              
309             Any use, modification, and distribution of the Standard or Modified
310             Versions is governed by this Artistic License. By using, modifying or
311             distributing the Package, you accept this license. Do not use, modify,
312             or distribute the Package, if you do not accept this license.
313              
314             If your Modified Version has been derived from a Modified Version made
315             by someone other than you, you are nevertheless required to ensure that
316             your Modified Version complies with the requirements of this license.
317              
318             This license does not grant you the right to use any trademark, service
319             mark, tradename, or logo of the Copyright Holder.
320              
321             This license includes the non-exclusive, worldwide, free-of-charge
322             patent license to make, have made, use, offer to sell, sell, import and
323             otherwise transfer the Package with respect to any patent claims
324             licensable by the Copyright Holder that are necessarily infringed by the
325             Package. If you institute patent litigation (including a cross-claim or
326             counterclaim) against any party alleging that the Package constitutes
327             direct or contributory patent infringement, then this Artistic License
328             to you shall terminate on the date that such litigation is filed.
329              
330             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
331             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
332             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
333             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
334             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
335             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
336             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
337             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
338              
339              
340             =cut
341              
342             1; # End of Net::Connection::Match