File Coverage

blib/lib/Net/Connection/Match/RegexPTR.pm
Criterion Covered Total %
statement 54 63 85.7
branch 23 32 71.8
condition 9 27 33.3
subroutine 6 6 100.0
pod 2 2 100.0
total 94 130 72.3


line stmt bran cond sub pod time code
1             package Net::Connection::Match::RegexPTR;
2              
3 2     2   222438 use 5.006;
  2         41  
4 2     2   13 use strict;
  2         3  
  2         52  
5 2     2   10 use warnings;
  2         3  
  2         55  
6 2     2   519 use Net::DNS;
  2         94091  
  2         1479  
7              
8             =head1 NAME
9              
10             Net::Connection::Match::RegexPTR - Runs a PTR check against a Net::Connection object using regular expressions.
11              
12             =head1 VERSION
13              
14             Version 0.0.0
15              
16             =cut
17              
18             our $VERSION = '0.0.0';
19              
20              
21             =head1 SYNOPSIS
22              
23             use Net::Connection::Match::RegexPTR;
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',
46             ],
47             lptrs=>[
48             'bar',
49             ],
50             fptrs=>[
51             'f[oa]o',
52             ],
53             );
54            
55             my $checker=Net::Connection::Match::RegexPTR->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::RegexPTR->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 1230 my %args;
103 4 100       15 if(defined($_[1])){
104 3         6 %args= %{$_[1]};
  3         11  
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         9 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         25 my $self = {
133             ptrs=>[],
134             lptrs=>[],
135             fptrs=>[],
136             resolver=>Net::DNS::Resolver->new,
137             };
138 3         764 bless $self;
139              
140 3 100       12 if ( defined( $args{ptrs}[0] ) ){
141 1         8 $self->{ptrs}=$args{ptrs};
142             }
143 3 100       10 if ( defined( $args{lptrs}[0] ) ){
144 1         11 $self->{lptrs}=$args{lptrs};
145             }
146 3 100       10 if ( defined( $args{fptrs}[0] ) ){
147 1         2 $self->{fptrs}=$args{fptrs};
148             }
149              
150 3         22 return $self;
151             }
152              
153             =head2 match
154              
155             Checks if a single Net::Connection object matches the stack.
156              
157             One argument is taken and that is a Net::Connection object.
158              
159             The returned value is a boolean.
160              
161             If the *_ptr feilds for the object are undef, L
162             will be used for resolving the address.
163              
164             if ( $checker->match( $conn ) ){
165             print "The connection matches.\n";
166             }
167              
168             =cut
169              
170             sub match{
171 8     8 1 2874 my $self=$_[0];
172 8         13 my $object=$_[1];
173              
174 8 100       25 if ( !defined( $object ) ){
175 1         4 return 0;
176             }
177              
178 7 100       19 if ( ref( $object ) ne 'Net::Connection' ){
179 1         4 return 0;
180             }
181              
182 6         21 my $l_ptr=$object->local_ptr;
183 6         27 my $f_ptr=$object->foreign_ptr;
184              
185 6 50       24 if ( defined( $l_ptr ) ){
186             # If we have one, convert it to lower case for easier processing.
187 6         38 $l_ptr=lc( $l_ptr )
188             }else{
189             # We don't have it. Uppercase default will prevent it from being matched.
190 0         0 $l_ptr='NOTFOUND';
191             # See if we can look it up.
192 0         0 my $answer=$self->{resolver}->search( $object->local_host );
193 0 0 0     0 if ( defined( $answer->{answer}[0] ) &&
194             ( ref( $answer->{answer}[0] ) eq 'Net::DNS::RR::PTR' )
195             ){
196 0         0 $l_ptr=lc($answer->{answer}[0]->ptrdname);
197             }
198             }
199              
200 6 50       11 if ( defined( $f_ptr ) ){
201             # If we have one, convert it to lower case for easier processing.
202 6         13 $f_ptr=lc( $f_ptr )
203             }else{
204             # We don't have it. Uppercase default will prevent it from being matched.
205 0         0 $f_ptr='NOTFOUND';
206             # See if we can look it up.
207 0         0 my $answer=$self->{resolver}->search( $object->foreign_host );
208 0 0 0     0 if ( defined( $answer->{answer}[0] ) &&
209             ( ref( $answer->{answer}[0] ) eq 'Net::DNS::RR::PTR' )
210             ){
211 0         0 $f_ptr=lc($answer->{answer}[0]->ptrdname);
212             }
213             }
214              
215 6         10 foreach my $regex ( @{ $self->{ptrs} } ){
  6         15  
216 2 100       20 if ( $l_ptr =~ /$regex/ ){
217 1         5 return 1;
218             }
219 1 50       15 if ( $f_ptr =~ /$regex/ ){
220 1         4 return 1;
221             }
222             }
223 4         7 foreach my $regex ( @{ $self->{lptrs} } ){
  4         10  
224 2 100       19 if ( $l_ptr =~ /$regex/ ){
225 1         5 return 1;
226             }
227             }
228 3         6 foreach my $regex ( @{ $self->{fptrs} } ){
  3         7  
229 2 100       19 if ( $f_ptr =~ /$regex/ ){
230 1         4 return 1;
231             }
232             }
233              
234 2         7 return 0;
235             }
236              
237             =head1 AUTHOR
238              
239             Zane C. Bowers-Hadley, C<< >>
240              
241             =head1 BUGS
242              
243             Please report any bugs or feature requests to C, or through
244             the web interface at L. I will be notified, and then you'll
245             automatically be notified of progress on your bug as I make changes.
246              
247              
248              
249              
250             =head1 SUPPORT
251              
252             You can find documentation for this module with the perldoc command.
253              
254             perldoc Net::Connection::Match
255              
256              
257             You can also look for information at:
258              
259             =over 4
260              
261             =item * RT: CPAN's request tracker (report bugs here)
262              
263             L
264              
265             =item * AnnoCPAN: Annotated CPAN documentation
266              
267             L
268              
269             =item * CPAN Ratings
270              
271             L
272              
273             =item * Search CPAN
274              
275             L
276              
277             =back
278              
279              
280             =head1 ACKNOWLEDGEMENTS
281              
282              
283             =head1 LICENSE AND COPYRIGHT
284              
285             Copyright 2019 Zane C. Bowers-Hadley.
286              
287             This program is free software; you can redistribute it and/or modify it
288             under the terms of the the Artistic License (2.0). You may obtain a
289             copy of the full license at:
290              
291             L
292              
293             Any use, modification, and distribution of the Standard or Modified
294             Versions is governed by this Artistic License. By using, modifying or
295             distributing the Package, you accept this license. Do not use, modify,
296             or distribute the Package, if you do not accept this license.
297              
298             If your Modified Version has been derived from a Modified Version made
299             by someone other than you, you are nevertheless required to ensure that
300             your Modified Version complies with the requirements of this license.
301              
302             This license does not grant you the right to use any trademark, service
303             mark, tradename, or logo of the Copyright Holder.
304              
305             This license includes the non-exclusive, worldwide, free-of-charge
306             patent license to make, have made, use, offer to sell, sell, import and
307             otherwise transfer the Package with respect to any patent claims
308             licensable by the Copyright Holder that are necessarily infringed by the
309             Package. If you institute patent litigation (including a cross-claim or
310             counterclaim) against any party alleging that the Package constitutes
311             direct or contributory patent infringement, then this Artistic License
312             to you shall terminate on the date that such litigation is filed.
313              
314             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
315             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
316             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
317             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
318             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
319             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
320             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
321             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
322              
323              
324             =cut
325              
326             1; # End of Net::Connection::Match