File Coverage

blib/lib/Net/IMP/Pattern.pm
Criterion Covered Total %
statement 111 136 81.6
branch 55 102 53.9
condition 14 30 46.6
subroutine 12 13 92.3
pod 4 5 80.0
total 196 286 68.5


line stmt bran cond sub pod time code
1 5     5   2518 use strict;
  5         10  
  5         122  
2 5     5   24 use warnings;
  5         10  
  5         170  
3 5     5   1527 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  5         34  
  5         29  
4              
5             package Net::IMP::Pattern;
6 5     5   362 use base 'Net::IMP::Base';
  5         10  
  5         1072  
7             use fields (
8 5         28 'rx', # Regexp from args rx|string
9             'rxlen', # max size rx can match
10             'rxdir', # only check this direction
11             'action', # deny|reject|replace
12             'actdata', # data for action
13             'buf', # locally buffered data to match rx,
14             'buftype', # type of data in buffer
15             'offset', # buf[dir][0] is at offset in input stream dir
16 5     5   33 );
  5         10  
17              
18 5     5   444 use Net::IMP; # import IMP_ constants
  5         9  
  5         350  
19 5     5   28 use Net::IMP::Debug;
  5         11  
  5         27  
20 5     5   30 use Carp 'croak';
  5         9  
  5         5604  
21              
22             sub INTERFACE {
23 0     0 0 0 my Net::IMP::Pattern $factory = shift;
24 0         0 my $action = $factory->{factory_args}{action};
25 0         0 my @rv = IMP_PASS;
26 0 0       0 push @rv,
    0          
    0          
    0          
27             $action eq 'deny' ? IMP_DENY :
28             $action eq 'reject' ? (IMP_REPLACE, IMP_TOSENDER) :
29             $action eq 'replace' ? IMP_REPLACE :
30             ! $action ? IMP_DENY :
31             croak("invalid action $action");
32 0         0 return [ undef, \@rv ];
33             };
34              
35             sub validate_cfg {
36 16     16 1 487 my ($class,%args) = @_;
37              
38 16         21 my @err;
39 16         30 my $rx = delete $args{rx};
40 16         28 my $string = delete $args{string};
41 16         23 my $rxdir = delete $args{rxdir};
42              
43 16 50       42 if ($rx) {
44 16         26 my $rxlen = delete $args{rxlen};
45 16 50 33     137 push @err, "rxlen must be given and >0" unless
      33        
46             $rxlen and $rxlen =~m{^\d+$} and $rxlen>0;
47 16 50       82 if ( ref($rx) ne 'Regexp' ) {
    50          
48 0 0       0 push @err, "rx must be regex" if ref($rx) ne 'Regexp'
49             } elsif ( '' =~ $rx ) {
50 0         0 push @err,"rx should not match empty string"
51             }
52             }
53              
54 16 50       52 if ( defined $string ) {
    50          
55 0 0       0 push @err, "only rx or string should be given, not both" if $rx;
56             } elsif ( ! $rx ) {
57 0         0 push @err, "rx+rxlen or string need to be given for pattern";
58             }
59              
60 16 50 33     43 push @err, "rxdir must be 0|1" if defined $rxdir and not $rxdir ~~ [0,1];
61              
62 16         28 my $act = delete $args{action};
63 16 50 33     90 push @err, "action can only be deny|reject|replace" unless
64             $act and $act ~~ [qw(deny reject replace)];
65 16 50       43 push @err, "action $act needs actdata" if ! defined(delete $args{actdata});
66              
67 16         57 push @err, $class->SUPER::validate_cfg(%args);
68 16         46 return @err;
69             }
70              
71              
72             # create new analyzer object
73             sub new_analyzer {
74 19     19 1 45 my ($factory,%args) = @_;
75 19         36 my $fargs = $factory->{factory_args};
76              
77 19         31 my $rxlen;
78 19         31 my $rx = $fargs->{rx};
79 19 50       41 if ($rx) {
80 19         33 $rxlen = $fargs->{rxlen};
81             } else {
82 0         0 $rx = $fargs->{string};
83 0         0 $rxlen = length($rx);
84 0         0 $rx = qr/\Q$rx/;
85             }
86              
87             my Net::IMP::Pattern $self = $factory->SUPER::new_analyzer(
88             %args, # cb, meta
89             rx => $rx,
90             rxlen => $rxlen,
91             rxdir => $fargs->{rxdir},
92             action => $fargs->{action},
93             actdata => $fargs->{actdata},
94 19         110 buf => ['',''], # per direction
95             buftype => [0,0], # per direction
96             offset => [0,0], # per direction
97             );
98              
99 19 50       62 if ( defined $self->{rxdir} ) {
100             # if rx is specified only for one direction immediatly issue PASS until
101             # end for the other direction
102             $self->run_callback([
103             IMP_PASS,
104 0 0       0 $self->{rxdir} ? 0:1,
105             IMP_MAXOFFSET,
106             ]);
107             }
108              
109 19         67 return $self;
110             }
111              
112             sub data {
113 82     82 1 119 my Net::IMP::Pattern $self = shift;
114 82         166 my ($dir,$data,$offset,$type) = @_;
115              
116 82 50       165 $offset and die "cannot deal with gaps in data";
117              
118             # if this is the wrong dir return, we already issued PASS
119 82 50 33     217 return if defined $self->{rxdir} and $dir != $self->{rxdir};
120              
121             # accumulate results
122 82         143 my @rv;
123              
124             my $buf;
125 82 100 100     325 if ( $type > 0 or $type != $self->{buftype}[$dir] ) {
126             # packet data or other streaming type
127 24         39 $buf = $data;
128 24 100 100     146 if ( $self->{buf}[$dir] ne '' ) {
    100          
129             # pass previous buffer and reset it
130 1         6 debug("reset buffer because type=$type, buftype=$self->{buftype}[$dir]");
131 1         3 $self->{offset}[$dir] += length($self->{buf}[$dir]);
132 1         5 $self->{buf}[$dir] = '';
133 1         4 push @rv, [ IMP_PASS,$dir,$self->{offset}[$dir] ];
134             } elsif ( ! $self->{buftype}[$dir] and not $type > 0 ) {
135             # initial streaming buf
136 20         44 $self->{buf}[$dir] = $buf;
137             }
138 24         45 $self->{buftype}[$dir] = $type;
139             } else {
140             # streaming data, match can span multiple chunks
141 58         123 $buf = ( $self->{buf}[$dir] .= $data );
142             }
143              
144             $DEBUG && debug("got %d bytes $type on %d, bufsz=%d, rxlen=%d",
145 82 50       168 length($data),$dir,length($buf),$self->{rxlen});
146              
147             # for packet types we accumulate datain newdata and set changed if newdata
148             # are different from old
149 82         122 my $changed = 0;
150 82         113 my $newdata = '';
151              
152 82         121 while (1) {
153 109 100       1321 if ( my ($good,$match) = $buf =~m{\A(.*?)($self->{rx})}s ) {
    100          
    100          
    100          
154             # rx matched:
155             # - strip up to end of rx from buf
156             # - issue IMP_PASS for all data in front of rx
157             # - handle rx according to action
158             # - continue with buf after rx (e.g. redo loop)
159              
160 34 50       110 if ( length($match)> $self->{rxlen} ) {
161             # user specified a rx, which could match more than rxlen, e.g.
162             # something like qr{\d+}. make sure we only match rxlen bytes
163 0 0       0 if ( substr($match,0,$self->{rxlen}) =~m{\A($self->{rx})} ) {
164 0         0 $match = $1;
165             } else {
166             # no match possible in rxlen bytes, reset match
167             # and add one char from original match to $good
168             # so that we don't try to match here again
169 0         0 $good .= substr($match,0,1);
170 0         0 $match = '';
171             }
172             } else {
173             # we checked in new_analyzer already that rx does not match
174             # empty string, so we should be save here that rxlen>=match>0
175             }
176              
177 34 100       81 if ( $good ne '' ) {
178 23 50       58 $DEBUG && debug("pass %d bytes in front of match",
179             length($good));
180             # pass everything before the match and advance offset
181 23         43 $self->{offset}[$dir]+=length($good);
182 23 100       49 if ( $type>0 ) {
183             # keep good
184 3         9 $newdata .= substr($buf,0,length($good),'');
185             } else {
186             # pass good
187 20         53 push @rv, [ IMP_PASS, $dir, $self->{offset}[$dir] ];
188 20         50 substr($buf,0,length($good),'');
189             }
190             }
191             # remove match
192 34         64 substr($buf,0,length($match),'');
193 34         59 $self->{offset}[$dir] += length($match);
194              
195 34 50       138 if ( $match eq '' ) {
    50          
    50          
    50          
196             # match got reset if >rxlen -> no action
197              
198             # handle the matched pattern according to action
199             } elsif ( $self->{action} eq 'deny' ) {
200             # deny everything after
201 0   0     0 push @rv,[ IMP_DENY,$dir,$self->{actdata}//'' ];
202 0         0 last; # deny is final
203              
204             } elsif ( $self->{action} eq 'reject' ) {
205             # forward nothing, send smthg back to sender
206 0 0       0 if ( $type > 0 ) {
207             # no need to add nothing to $newdata :)
208 0         0 $changed = 1;
209             } else {
210             push @rv,[
211             IMP_REPLACE,
212             $dir,
213 0         0 $self->{offset}[$dir],
214             '',
215             ];
216             }
217             push @rv,[ IMP_TOSENDER,$dir,$self->{actdata} ]
218 0 0       0 if $self->{actdata} ne '';
219              
220             } elsif ( $self->{action} eq 'replace' ) {
221             # forward something else
222 34 100       67 if ( $type > 0 ) {
223 3   50     7 $newdata .= $self->{actdata}//'';
224 3         5 $changed = 1;
225             } else {
226             push @rv,[
227             IMP_REPLACE,
228             $dir,
229             $self->{offset}[$dir],
230 31   50     113 $self->{actdata}//''
231             ];
232             }
233              
234             } else {
235             # should not happen, because action was already checked
236 0         0 die "invalid action $self->{action}";
237             }
238              
239 34 100       99 last if $buf eq ''; # need more data
240              
241             } elsif ( $type > 0 ) {
242             # no matches across packets are allowed
243 3         7 $self->{offset}[$dir] += length($buf);
244 3 50       8 $newdata .= $buf if $changed;
245 3         6 last;
246              
247             } elsif ( (my $d = length($buf) - $self->{rxlen} + 1) > 0 ) {
248             # rx did not match, but >=rxlen bytes in buf:
249             # we can IMP_PASS some, but rxlen-1 data needs to be kept in buffer
250             # so that we retry rx when new data come in
251 24 50       59 $DEBUG && debug("can pass %d of %d bytes",$d,length($buf));
252 24         68 push @rv, [ IMP_PASS, $dir, $self->{offset}[$dir] += $d ];
253 24         48 substr($buf,0,$d,'');
254              
255 24         58 last; # need more data
256              
257             } elsif ( $data eq '' ) {
258             # rx did not match, but eof:
259             # no more data will come which can match rx so we can pass the rest
260 23 50       64 $DEBUG && debug("pass rest of data on eof");
261 23         64 push @rv,[ IMP_PASS,$dir,IMP_MAXOFFSET ];
262 23         39 $buf = '';
263              
264 23         46 last; # there will be no more matches because of no data
265              
266             } else {
267             # rx did not match, but no eof:
268 25         57 last; # need more data
269             }
270             }
271              
272 82 100       182 if ( $type > 0 ) {
273 3 50       15 if ( grep { IMP_DENY == $_->[0] } @rv ) {
  1 50       4  
274             # leave deny alone
275             } elsif ( $changed ) {
276             # replace whole packet
277 3         10 push @rv, [ IMP_REPLACE,$dir,$self->{offset}[$dir],$newdata ];
278             } else {
279             # pass whole packet
280 0         0 push @rv, [ IMP_PASS,$dir,$self->{offset}[$dir] ];
281             }
282             }
283              
284 82 100       179 if ( @rv ) {
285 69 100       177 $self->{buf}[$dir] = $buf unless $type > 0; # $buf got changed, put back
286 69         266 debug("bufsize=".length($self->{buf}[$dir]));
287 69         213 $self->run_callback(@rv);
288             } else {
289 13 50       37 $DEBUG && debug("need more data");
290             }
291             }
292              
293             sub str2cfg {
294 3     3 1 976 my ($class,$str) = @_;
295 3         29 my %cfg = $class->SUPER::str2cfg($str);
296 3 50       9 if ($cfg{rx}) {
297 3   33     4 $cfg{rx} = eval { qr/$cfg{rx}/ }
298             || croak("'$cfg{rx}' is no valid regex");
299             }
300 3         17 return %cfg;
301             }
302              
303              
304             1;
305              
306             __END__