File Coverage

blib/lib/Net/Connection/Match.pm
Criterion Covered Total %
statement 81 92 88.0
branch 24 38 63.1
condition 6 12 50.0
subroutine 9 9 100.0
pod 2 2 100.0
total 122 153 79.7


line stmt bran cond sub pod time code
1             package Net::Connection::Match;
2              
3 2     2   230864 use 5.006;
  2         46  
4 2     2   14 use strict;
  2         5  
  2         50  
5 2     2   11 use warnings;
  2         6  
  2         99  
6 2     2   14 use base 'Error::Helper';
  2         4  
  2         1339  
7              
8             =head1 NAME
9              
10             Net::Connection::Match - Runs a stack of checks to match Net::Connection objects.
11              
12             =head1 VERSION
13              
14             Version 0.3.0
15              
16             =cut
17              
18             our $VERSION = '0.3.0';
19              
20              
21             =head1 SYNOPSIS
22              
23             use Net::Connection::Match;
24             use Net::Connection;
25            
26             my $connection_args={
27             foreign_host=>'10.0.0.1',
28             foreign_port=>'22',
29             local_host=>'10.0.0.2',
30             local_port=>'12322',
31             proto=>'tcp4',
32             state=>'LISTEN',
33             };
34             my $conn=Net::Connection->new( $connection_args );
35            
36             my %args=(
37             checks=>[
38             {
39             type=>'Ports',
40             invert=>0,
41             args=>{
42             ports=>[
43             '22',
44             ],
45             lports=>[
46             '53',
47             ],
48             fports=>[
49             '12345',
50             ],
51             }
52             },
53             {
54             type=>'Protos',
55             invert=>0,
56             args=>{
57             protos=>[
58             'tcp4',
59             ],
60             }
61             }
62             ]
63             );
64            
65             my $checker;
66             eval{
67             $checker=Net::Connection::Match->new( \%args );
68             } or die "New failed with...".$@;
69            
70             if ( $check->match( $conn ) ){
71             print "It matched!\n";
72             }
73              
74             =head1 METHODS
75              
76             =head2 new
77              
78             This initializes a new check object.
79              
80             It takes one value and thht is a hash ref with the key checks.
81             This is a array of hashes.
82              
83             If new fails, it will die.
84              
85             =head3 checks hash keys
86              
87             =head4 type
88              
89             This is the name of the check relative to 'Net::Connection::Match::'.
90              
91             So 'Net::Connection::Match::PTR' would become 'PTR'.
92              
93             =head4 args
94              
95             This is a hash or args to pash to the check. These are passed to the new
96             method of the check module.
97              
98             =head4 invert
99              
100             This is either boolean on if the check should be inverted or not.
101              
102             my $mce;
103             eval{
104             $ncm=Net::Connection::Match->new( $args );
105             };
106              
107             =cut
108              
109             sub new{
110 3     3 1 1366 my %args;
111 3 100       12 if(defined($_[1])){
112 2         7 %args= %{$_[1]};
  2         10  
113             };
114              
115             # Provides some basic checks.
116             # Could make these all one if, but this provides more
117             # granularity for some one using it.
118 3 100       9 if ( ! defined( $args{checks} ) ){
119 1         10 die ('No check key specified in the argument hash');
120             }
121 2 50       4 if ( ref( @{ $args{checks} } ) eq 'ARRAY' ){
  2         8  
122 0         0 die ('The checks key is not a array');
123             }
124             # Will never match anything.
125 2 50       7 if ( ! defined $args{checks}[0] ){
126 0         0 die ('Nothing in the checks array');
127             }
128 2 50       3 if ( ref( %{ $args{checks}[0] } ) eq 'HASH' ){
  2         8  
129 0         0 die ('The first item in the checks array is not a hash');
130             }
131              
132 2         15 my $self = {
133             perror=>undef,
134             error=>undef,
135             errorString=>"",
136             testing=>0,
137             errorExtra=>{
138             flags=>{
139             1=>'failedCheckInit',
140             2=>'notNCobj',
141             }
142             },
143             checks=>[],
144             };
145 2         4 bless $self;
146              
147             # will hold the created check objects
148 2         4 my @checks;
149              
150             # Loads up each check or dies if it fails to.
151 2         5 my $check_int=0;
152 2         7 while( defined( $args{checks}[$check_int] ) ){
153 3         9 my %new_check=(
154             type=>undef,
155             args=>undef,
156             invert=>undef,
157             );
158              
159             # make sure we have a check type
160 3 50       9 if ( defined($args{checks}[$check_int]{'type'}) ){
161 3         7 $new_check{type}=$args{checks}[$check_int]{'type'};
162             }else{
163 0         0 die('No type defined for check '.$check_int);
164             }
165              
166             # does a quick check on the tpye name
167 3         5 my $type_test=$new_check{type};
168 3         19 $type_test=~s/[A-Za-z0-9]//g;
169 3         6 $type_test=~s/\:\://g;
170 3 50       13 if ( $type_test !~ /^$/ ){
171 0         0 die 'The type "'.$new_check{type}.'" for check '.$check_int.' is not a valid check name';
172             }
173              
174             # makes sure we have a args object and that it is a hash
175 3 50 33     30 if (
176             ( defined($args{checks}[$check_int]{'args'}) ) &&
177             ( ref( $args{checks}[$check_int]{'args'} ) eq 'HASH' )
178             ){
179 3         8 $new_check{args}=$args{checks}[$check_int]{'args'};
180             }else{
181 0         0 die('No type defined for check '.$check_int.' or it is not a HASH');
182             }
183              
184             # makes sure we have a args object and that it is a hash
185 3 50 33     24 if (
    50 33        
186             ( defined($args{checks}[$check_int]{'invert'}) ) &&
187             ( ref( \$args{checks}[$check_int]{'invert'} ) ne 'SCALAR' )
188             ){
189 0         0 die('Invert defined for check '.$check_int.' but it is not a SCALAR');
190             }elsif(
191             ( defined($args{checks}[$check_int]{'invert'}) ) &&
192             ( ref( \$args{checks}[$check_int]{'invert'} ) eq 'SCALAR' )
193             ){
194 3         5 $new_check{invert}=$args{checks}[$check_int]{'invert'};
195             }
196              
197 3         7 my $check;
198             my $eval_string='use Net::Connection::Match::'.$new_check{type}.';'.
199 3         10 '$check=Net::Connection::Match::'.$new_check{type}.'->new( $new_check{args} );';
200 3     1   246 eval( $eval_string );
  1     1   500  
  1     1   3  
  1         38  
  1         8  
  1         2  
  1         44  
  1         489  
  1         3  
  1         36  
201              
202 3 50       11 if (!defined( $check )){
203 0         0 die 'Failed to init the check for '.$check_int.' as it returned undef... '.$@;
204             }
205              
206 3         6 $new_check{check}=$check;
207              
208 3         6 push(@{ $self->{checks} }, \%new_check );
  3         21  
209              
210 3         10 $check_int++;
211             }
212              
213 2 50       8 if ( $args{testing} ){
214 2         5 $self->{testing}=1;
215             }
216              
217 2         11 return $self;
218             }
219              
220             =head2 match
221              
222             Checks if a single Net::Connection object matches the stack.
223              
224             One object is argument is taken and that is the Net::Connection to check.
225              
226             The return value is a boolean.
227              
228             if ( $ncm->match( $conn ) ){
229             print "It matched.\n";
230             }
231              
232             =cut
233              
234             sub match{
235 5     5 1 3103 my $self=$_[0];
236 5         7 my $conn=$_[1];
237              
238 5 50       24 if( ! $self->errorblank ){
239 0         0 return undef;
240             }
241              
242 5 100 100     70 if (
243             ( ! defined( $conn ) ) ||
244             ( ref( $conn ) ne 'Net::Connection' )
245             ){
246 2         5 $self->{error}=2;
247 2         5 $self->{errorString}='Either the connection is undefined or is not a Net::Connection object';
248 2 50       6 if ( ! $self->{testing} ){
249 0         0 $self->warn;
250             }
251 2         7 return undef;
252             }
253              
254             # Stores the number of hits
255 3         5 my $hits=0;
256 3         8 my $required=0;
257 3         5 foreach my $check ( @{ $self->{checks} } ){
  3         10  
258 4         5 my $hit;
259 4         7 eval{
260 4         13 $hit=$check->{check}->match($conn);
261             };
262              
263             # If $hits is undef, then one of the checks errored and we skip processing the results.
264             # Should only be 0 or 1.
265 4 50       12 if ( defined( $hit ) ){
266             # invert if needed
267 4 50       9 if ( $check->{invert} ){
268 0         0 $hit = $hit ^ 1;
269             }
270              
271             # increment the hits count if we hit
272 4 100       9 if ( $hit ){
273 3         6 $hits++;
274             }
275             }
276              
277 4         8 $required++;
278             }
279              
280             # if these are the same, then we have a match
281 3 100       8 if ( $required eq $hits ){
282 2         6 return 1;
283             }
284              
285             # If we get here, it is not a match
286 1         3 return 0;
287             }
288              
289             =head1 ERROR HANDLING / FLAGS
290              
291             Error handling is provided by L.
292              
293             =head2 2 / notNCobj
294              
295             Not a Net::Connection object. Either is is not defined
296             or what is being passed is not a Net::Connection object.
297              
298             =head1 AUTHOR
299              
300             Zane C. Bowers-Hadley, C<< >>
301              
302             =head1 BUGS
303              
304             Please report any bugs or feature requests to C, or through
305             the web interface at L. I will be notified, and then you'll
306             automatically be notified of progress on your bug as I make changes.
307              
308              
309              
310              
311             =head1 SUPPORT
312              
313             You can find documentation for this module with the perldoc command.
314              
315             perldoc Net::Connection::Match
316              
317              
318             You can also look for information at:
319              
320             =over 4
321              
322             =item * RT: CPAN's request tracker (report bugs here)
323              
324             L
325              
326             =item * AnnoCPAN: Annotated CPAN documentation
327              
328             L
329              
330             =item * CPAN Ratings
331              
332             L
333              
334             =item * Search CPAN
335              
336             L
337              
338             =item * Git Repo
339              
340             L
341              
342             =back
343              
344              
345             =head1 ACKNOWLEDGEMENTS
346              
347              
348             =head1 LICENSE AND COPYRIGHT
349              
350             Copyright 2019 Zane C. Bowers-Hadley.
351              
352             This program is free software; you can redistribute it and/or modify it
353             under the terms of the the Artistic License (2.0). You may obtain a
354             copy of the full license at:
355              
356             L
357              
358             Any use, modification, and distribution of the Standard or Modified
359             Versions is governed by this Artistic License. By using, modifying or
360             distributing the Package, you accept this license. Do not use, modify,
361             or distribute the Package, if you do not accept this license.
362              
363             If your Modified Version has been derived from a Modified Version made
364             by someone other than you, you are nevertheless required to ensure that
365             your Modified Version complies with the requirements of this license.
366              
367             This license does not grant you the right to use any trademark, service
368             mark, tradename, or logo of the Copyright Holder.
369              
370             This license includes the non-exclusive, worldwide, free-of-charge
371             patent license to make, have made, use, offer to sell, sell, import and
372             otherwise transfer the Package with respect to any patent claims
373             licensable by the Copyright Holder that are necessarily infringed by the
374             Package. If you institute patent litigation (including a cross-claim or
375             counterclaim) against any party alleging that the Package constitutes
376             direct or contributory patent infringement, then this Artistic License
377             to you shall terminate on the date that such litigation is filed.
378              
379             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
380             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
381             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
382             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
383             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
384             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
385             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
386             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
387              
388              
389             =cut
390              
391             1; # End of Net::Connection::Match