File Coverage

blib/lib/Net/Connection/Match/Command.pm
Criterion Covered Total %
statement 11 55 20.0
branch 0 24 0.0
condition 0 3 0.0
subroutine 4 6 66.6
pod 2 2 100.0
total 17 90 18.8


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