File Coverage

blib/lib/Net/Connection/Match/PTR.pm
Criterion Covered Total %
statement 51 60 85.0
branch 18 26 69.2
condition 18 36 50.0
subroutine 6 6 100.0
pod 2 2 100.0
total 95 130 73.0


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