File Coverage

blib/lib/Net/IMP/ProtocolPinning.pm
Criterion Covered Total %
statement 320 334 95.8
branch 190 264 71.9
condition 77 112 68.7
subroutine 20 21 95.2
pod 6 7 85.7
total 613 738 83.0


line stmt bran cond sub pod time code
1 3     3   2265 use strict;
  3         6  
  3         71  
2 3     3   14 use warnings;
  3         5  
  3         85  
3 3     3   474 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  3         13  
  3         14  
4              
5             package Net::IMP::ProtocolPinning;
6 3     3   178 use base 'Net::IMP::Base';
  3         5  
  3         526  
7             use fields (
8 3         13 'buf', # buffered data for each direction
9             'off_buf', # start of buf[dir] relativ to input stream
10             'off_passed', # offset up to which already passed
11             'ruleset', # active rules per dir
12             'paused', # if there is active IMP_PAUSE for dir
13             # if allow_dup already matched packets are put with key md5(seed+packet)
14             # and rule number as value into matched[dir]{...}
15             'matched', # hash of already matched packets
16             'matched_seed', # random seed for matched hash (new for each analyzer)
17 3     3   17 );
  3         6  
18              
19 3     3   243 use Net::IMP; # import IMP_ constants
  3         5  
  3         192  
20 3     3   30 use Net::IMP::Debug;
  3         7  
  3         12  
21 3     3   1565 use Storable 'dclone';
  3         7381  
  3         157  
22 3     3   1021 use Data::Dumper;
  3         10574  
  3         134  
23 3     3   18 use Carp 'croak';
  3         6  
  3         103  
24 3     3   16 use Digest::MD5 'md5';
  3         6  
  3         8180  
25              
26             sub INTERFACE { return ([
27             undef, # we can stream and packets, although they behave differently
28             [
29 0     0 0 0 IMP_PASS, # pass data unchanged
30             IMP_DENY, # deny if rule is not matched
31             # send pause/continue if last rule of dir is reached and
32             # max_unbound is undef
33             IMP_PAUSE,
34             IMP_CONTINUE,
35             ]
36             ])}
37              
38             sub _compile_cfg {
39 60     60   157 my %args = @_;
40              
41 60         123 my $ignore_order = delete $args{ignore_order};
42 60         105 my $allow_reorder = delete $args{allow_reorder};
43 60 50       165 my $r = delete $args{rules} or die "rules need to be given\n";
44 60         102 my $max_unbound = delete $args{max_unbound};
45              
46 60 100       141 if ($max_unbound) {
47 50 50       125 die "max_unbound should be [max0,max1]\n" if @$max_unbound>2;
48 50         107 for (0,1) {
49 100 100       247 defined $max_unbound->[$_] or next;
50 68 50       298 die "max_unbound[$_] should be number >=0\n"
51             if $max_unbound->[$_] !~m{^\d+$};
52             }
53             }
54              
55             # compile $args{rules} into list of rulesets per dir
56             # $ruleset[$dir][$i] -> [r1,r2,.] | undef
57             # - [ r1,r2.. ] - these rules can match, multiple rules at a time are only
58             # possible if reorder. The rules will be tried in the given order until
59             # one matches.
60             # - undef - no data for this dir allowed at this stage. If ignore_order
61             # there can be rules for each dir at the same time, else not.
62             # When processing data it will remove completely matched rules, but
63             # put rules which might match more (e.g. data
64             # If no more rules are open inside a ruleset it will remove the ruleset
65             # and then
66             # - if there is a next ruleset for the same dir continue with it
67             # (e.g no change after removing the done ruleset)
68             # - if there is no next ruleset (e.g. all rules done or next is undef)
69             # remove any undef set from the other dir
70             # It will remove the ruleset of no more open rules are inside.
71              
72 60         171 my @ruleset = ([],[]);
73 60         101 my $lastdir;
74 60         162 for (my $i=0;$i<@$r;$i++) {
75 132         252 my $dir = $r->[$i]{dir};
76 132 50 50     482 die "rule$i.dir must be 0|1\n" unless ($dir//-1 ) ~~ [0,1];
77 132 50 50     418 die "rule$i.rxlen must be >0\n" unless ($r->[$i]{rxlen}||0)>0;
78 132         214 my $rx = $r->[$i]{rx};
79 132 50       317 die "rule$i.rx should be regex\n" if ref($rx) ne 'Regexp';
80 132 50       377 die "rule$i.rx should not match empty string\n" if '' ~~ $rx;
81              
82 132 100       267 if ( ! $ignore_order ) {
    100          
83             # initial rule or direction change
84 76 100 100     256 $lastdir //= $dir ? 0:1;
85 76 100       161 if ( $lastdir != $dir ) {
86 58         84 push @{ $ruleset[$dir] }, []; # new ruleset
  58         113  
87 58         89 push @{ $ruleset[$lastdir] },undef; # no more allowd
  58         103  
88 58         91 $lastdir = $dir;
89             }
90 56         133 } elsif ( not @{ $ruleset[$dir] } ) {
91             # initialize when ignore_order
92 48         70 push @{ $ruleset[$dir] },[];
  48         90  
93             }
94              
95             # set ruleset to this rule
96             # if allow_reorder try to add it to existing ruleset
97 132 100 100     306 if ( $allow_reorder
98 94         273 or ! @{ $ruleset[$dir][-1] } ) {
99 120         165 push @{ $ruleset[$dir][-1] },$i;
  120         391  
100             } else {
101 12         21 push @{ $ruleset[$dir] },[ $i ];
  12         52  
102             }
103             }
104              
105             return (
106             rules => $r,
107             ruleset => \@ruleset,
108             allow_dup => $args{allow_dup},
109 60         411 max_unbound => $max_unbound,
110             %args,
111             );
112             }
113              
114             sub new_factory {
115 30     30 1 158 my $class = shift;
116 30         69 return $class->SUPER::new_factory( _compile_cfg(@_));
117             }
118              
119             sub validate_cfg {
120 30     30 1 18477 my ($class,%args) = @_;
121 30         55 my @err;
122 30 50       59 push @err,$@ if ! eval { my @x = _compile_cfg(%args) };
  30         89  
123 30         112 delete @args{qw/rules max_unbound ignore_order allow_dup allow_reorder/};
124 30         128 push @err,$class->SUPER::validate_cfg(%args);
125 30         82 return @err;
126             }
127              
128             # create new analyzer object
129             sub new_analyzer {
130 41     41 1 6809 my ($factory,%args) = @_;
131              
132 41         78 my $fargs = $factory->{factory_args};
133             my Net::IMP::ProtocolPinning $self = $factory->SUPER::new_analyzer(
134             %args,
135              
136             # buffer per direction
137             buf => [ '','' ],
138              
139             # offset for buffer per direction
140             off_buf => [0,0],
141              
142             # amount of data already passed
143             off_passed => [0,0],
144              
145             # clone ruleset because we will modify it
146             ruleset => dclone($fargs->{ruleset}),
147              
148             # hash of already matched packets (per dir) if allow_dup
149 41 100       996 matched => $fargs->{allow_dup} ? [] : undef,
150             # seed for hashing matched packets, gets initialized on first use
151             matched_seed => undef,
152             );
153              
154 41         111 return $self;
155             }
156              
157              
158             # matches buffer against rule
159             # if match impossible returns ()
160             # if no match, but might by possible if more data are added returns (0,0)
161             # if matched and data got removed because bufsize >=rxlen returns (size,size)
162             # if matched and data are still in buffer (match may be longer) returns (size,0)
163             sub _match_stream {
164 63     63   118 my ($r,$rbuf) = @_;
165 63 50       132 if ( $DEBUG ) {
166 0         0 my ($pkg,undef,$line) = caller;
167             debug("try match from=%s[%d] rxlen=%d rx=%s buf=%d/'%s'",
168 0         0 $pkg,$line, $r->{rxlen},$r->{rx},length($$rbuf),$$rbuf);
169             }
170 63         106 my $lbuf = length($$rbuf);
171 63 100       136 if ($r->{rxlen} <= $lbuf ) {
172 32 100       533 if ( substr($$rbuf,0,$r->{rxlen}) =~s{\A$r->{rx}}{} ) {
173 30         72 my $lm = $lbuf - length($$rbuf);
174 30 50       62 $DEBUG && debug("final match of $lm in $r->{rxlen} bytes");
175 30         93 return ($lm,$lm) # (matched,removed=matched)
176             }
177 2 50       8 $DEBUG && debug("final failed match in $r->{rxlen} bytes");
178 2         6 return; # could never match because rxlen reached
179             } else {
180 31 100       427 if ( $$rbuf =~m{\A$r->{rx}}g ) {
181             # might match later again and more
182 19         44 my $lm = pos($$rbuf);
183 19 50       44 $DEBUG && debug("preliminary match of $lm in $lbuf bytes");
184 19         61 return ($lm,0); # (matched,removed=0)
185             }
186 12 50       36 $DEBUG && debug("preliminary failed match in $lbuf bytes");
187 12         34 return (0,0); # could match if more data
188             }
189             }
190              
191             # like _match_stream but matches rx against whole packet.
192             # result can either be final (size,size) or never ()
193             sub _match_packet {
194 30     30   57 my ($r,$rbuf) = @_;
195             # try to match full packet
196 30         50 my $len = length($$rbuf);
197 30 50       76 return if $r->{rxlen} < $len; # could not match full packet
198 30 100       462 return $$rbuf =~m{\A$r->{rx}\Z} ? ($len,$len) : ();
199             }
200              
201             sub data {
202 114     114 1 476 my Net::IMP::ProtocolPinning $self = shift;
203 114         265 my ($dir,$data,$offset,$type) = @_;
204              
205             # buf gets removed at final reply
206 114 100       312 if ( ! $self->{buf} ) {
207             # we gave already the final reply
208 8 50       18 $DEBUG && debug("data[$dir] after final reply");
209 8         18 return;
210             }
211              
212             # never did IMP_PASS into future, so no offset allowed
213 106 50       234 $offset and die "no offset allowed";
214              
215 106         185 my $rs = $self->{ruleset}[$dir]; # [r]ule[s]et
216 106         169 my $rules = $self->{factory_args}{rules};
217 106 100       260 my $match = $type>0 ? \&_match_packet:\&_match_stream;
218              
219 106 100       271 if ($data eq '' ) {
220             # eof - remove leading rule with extendable match and then
221             # check if all rules are done
222             $DEBUG && debug("eof dir=%d rules=%s", $dir,
223 7 50       19 Data::Dumper->new([$self->{ruleset}])->Indent(0)->Terse(1)->Dump);
224              
225 7 100 66     49 if ( @$rs and my $match_in_progress =
226             $self->{off_passed}[$dir] - $self->{off_buf}[$dir] ) {
227             # rule done
228 2         5 $self->{off_buf}[$dir] = $self->{off_passed}[$dir];
229 2         3 $self->{buf}[$dir] = '';
230             # remove matched rule
231             # don't care for duplicates, they won't come anymore
232 2         5 shift(@{$rs->[0]});
  2         4  
233             # remove ruleset if empty
234 2 50       3 if (! @{$rs->[0]}) {
  2         6  
235 2         5 shift(@$rs);
236             # switch to other dir if this dir is done for now
237 2 50 33     9 if ( ! @$rs || ! $rs->[0] ) {
238 2 50       7 my $ors = $self->{ruleset}[$dir?0:1];
239 2 50 33     11 shift @$ors if @$ors && ! $ors->[0];
240             }
241 2 50       7 goto CHECK_DONE if ! @$rs;
242             }
243             }
244             # still unmatched rules but we have eof, thus no more rules
245             # can match on this dir
246 7 100       19 if ( my ($r) = grep { $_ } @$rs ) {
  9         28  
247 5         11 $self->{buf} = undef;
248 5         20 $self->run_callback([
249             IMP_DENY,
250             $dir,
251 5         27 "eof on $dir but unmatched rule#@{$r}"
252             ]);
253             } else {
254             # no more rules on eof side
255             # as long as further rules on other side gets matched everything
256             # is fine
257             }
258 7         39 return;
259             }
260              
261             # collect maximal offset to pass, will pass in PASS_AND_RETURN
262 99         147 my $pass_until;
263              
264             NEXT_RULE:
265             $DEBUG && debug("next rule dir=%d rules=%s |data=%d/'%s'",
266 115 50       249 $dir,Data::Dumper->new([$self->{ruleset}])->Indent(0)->Terse(1)->Dump,
267             length($data),substr($data,0,100));
268              
269 115 100       252 if ( ! @$rs ) {
270             # no (more) rules for $dir, accumulate data until all rules for other
271             # direction are completed
272 15 50       40 $self->{buf}[$dir] eq '' or die "buffer should be empty";
273              
274             # check if other side has matched already with last rule
275 15 100       33 my $odir = $dir ? 0:1;
276 15         25 my $ors = $self->{ruleset}[$odir];
277 15 100 66     63 if ( @$ors == 1 and @{$ors->[0]} == 1
  15   100     84  
278             and $self->{off_passed}[$odir] - $self->{off_buf}[$odir] >0 ) {
279 1         3 shift(@$ors);
280 1         12 goto CHECK_DONE;
281             }
282              
283 14         72 $self->{off_buf}[$dir] += length($data);
284              
285 14         28 my $max_unbound = $self->{factory_args}{max_unbound};
286 14   100     49 $max_unbound = $max_unbound && $max_unbound->[$dir];
287 14 100       37 if ( ! defined $max_unbound ) {
288 7 50       18 $DEBUG && debug(
289             "buffer data for dir $dir because buffering not bound");
290 7 100       22 if ( ! $self->{paused}[$dir] ) {
291             # ask data provider to stop sending data
292 5         12 $self->{paused}[$dir] = 1;
293 5         22 $self->run_callback([ IMP_PAUSE, $dir ]);
294             }
295             # if pass_until>0 we had something to pass
296 7         94 goto PASS_AND_RETURN;
297             }
298              
299 7         13 my $unbound = $self->{off_buf}[$dir] - $self->{off_passed}[$dir];
300             $DEBUG && debug("dir=%d off=%d passed=%d -> unbound=%d",
301 7 50       14 $dir,$self->{off_buf}[$dir],$self->{off_passed}[$dir],$unbound);
302 7 100       18 if ( $unbound <= $max_unbound ) {
303 4 50       8 $DEBUG && debug("buffer data for dir $dir because ".
304             "unbound($unbound)<=max_unbound($max_unbound)");
305 4         36 goto PASS_AND_RETURN;
306             }
307              
308 3         5 $self->{buf} = undef;
309 3         18 $self->run_callback([
310             IMP_DENY,
311             $dir,
312             "unbound buffer size=$unbound > max_unbound($max_unbound)"
313             ]);
314 3         20 return;
315             }
316              
317             # append new data to buf, for packet data we work directly with $data
318 100 100       215 unless ( $type > 0 ) {
319 70         148 $self->{buf}[$dir] .= $data;
320 70         120 $data = '';
321             }
322              
323 100         169 my $crs = $rs->[0]; # crs - [c]urrent [r]ule[s]et
324 100 100       221 if ( ! $crs ) {
325             # data from $dir are not allowed at this stage
326              
327             # finish a preliminary match on the other side and then try again
328 9 100       23 my $odir = $dir ? 0:1;
329 9         19 my $ors = $self->{ruleset}[$odir];
330 9 100 33     81 if ( @$ors and $ors->[0] and my $omatch_in_progress
      66        
331             = $self->{off_passed}[$odir] - $self->{off_buf}[$odir] ) {
332 5 50       19 $DEBUG && debug("finish preliminary match on $odir");
333 5         10 $self->{off_buf}[$odir] = $self->{off_passed}[$odir];
334 5         19 substr($self->{buf}[$odir],0,$omatch_in_progress,'');
335 5         11 shift(@{$ors->[0]});
  5         12  
336 5 50       10 if ( ! @{$ors->[0]} ) {
  5         22  
337 5         12 shift(@$ors); # ruleset done
338 5 50 33     27 shift(@$rs) if ! @$ors or ! $ors->[0]; # switch dir
339 5 0 33     16 goto CHECK_DONE if ! @$ors && ! @$rs;
340 5         64 goto NEXT_RULE; # and try again
341             }
342             }
343              
344             # ignore if it is a duplicate packet
345             # duplicate checking is only done for packet types
346 4 0 66     18 if ( $type>0 and $self->{matched} and $self->{buf}[$dir] eq ''
      33        
      33        
347             and my $matched = $self->{matched}[$dir] ) {
348 0         0 my $hpkt = md5($self->{matched_seed} . $data);
349 0 0       0 if ( defined( my $r = $matched->{$hpkt} )) {
350 0 0       0 $DEBUG && debug("ignored DUP[$dir] for rule $r");
351             $pass_until = $self->{off_passed}[$dir]
352 0         0 = $self->{off_buf}[$dir] += length($data);
353 0         0 goto PASS_AND_RETURN;
354             }
355             }
356 4 50       11 $DEBUG && debug("data[$dir] but rule -> DENY");
357 4         9 $self->{buf} = undef;
358             $self->run_callback([ IMP_DENY, $dir, "rule#"
359 4 100       38 .( $self->{ruleset}[$dir?0:1][0][0] )." data from wrong dir $dir"
360             ]);
361 4         36 return;
362             }
363              
364             # if there was a last match try to extend it or to mark rule as done
365 91 100       232 if ( my $match_in_progress =
366             $self->{off_passed}[$dir] - $self->{off_buf}[$dir] ) {
367             # last rule matched already
368 5 50       11 unless ( $type>0 ) {
369             # try to extend match for streams
370             my ($matched,$removed) =
371 5         16 $match->($rules->[$crs->[0]],\$self->{buf}[$dir]);
372 5 50       16 die "expected $crs->[0] to match" if ! $matched;
373 5 100       13 if ( $removed ) {
    50          
374             # rule finished, probably because rxlen reached
375 4 50       11 $DEBUG && debug("completed preliminary match rule $crs->[0]");
376 4         11 $self->{off_buf}[$dir] += $removed;
377 4 100       12 if ( $removed > $match_in_progress ) {
378             $pass_until = $self->{off_passed}[$dir]
379 3         6 = $self->{off_buf}[$dir];
380             }
381             # no return, might match more
382              
383             } elsif ( $matched > $match_in_progress ) {
384             # keep rule open but issue extended IMP_PASS
385 1 50       4 $DEBUG && debug("extended preliminary match rule $crs->[0]");
386             $pass_until = $self->{off_passed}[$dir]
387 1         3 = $self->{off_buf}[$dir]+$matched;
388 1         21 goto PASS_AND_RETURN; # need more data
389             } else {
390             # keep rule open waiting for more data
391 0 0       0 $DEBUG && debug("still preliminary(?) match rule $crs->[0]");
392 0         0 goto PASS_AND_RETURN; # need more data
393             }
394              
395             } else {
396             # stream followed by packet, so rule cannot be extended
397             # remove from buf until end of last match
398 0 0       0 $DEBUG && debug("finished match rule $crs->[0] on packet $type");
399 0         0 substr($self->{buf}[$dir],0,$match_in_progress,'');
400 0         0 $self->{off_buf}[$dir] = $self->{off_passed}[$dir];
401             }
402              
403             # match of previously matching rule done
404             # remove it and continue with next rule if there are more data
405 4         8 shift(@$crs);
406 4 50       11 if (! @$crs) {
407 4         7 shift(@$rs);
408             # switch to other dir if this dir is done for now
409 4 100 66     18 if ( ! @$rs || ! $rs->[0] ) {
410 2 50       6 my $ors = $self->{ruleset}[$dir ? 0:1];
411 2 50 33     11 shift @$ors if @$ors && ! $ors->[0];
412 2 0 33     7 goto CHECK_DONE if ! @$ors && ! @$rs;
413             }
414             }
415 4 100 66     20 if ( $type>0 or $self->{buf}[$dir] ne '' ) {
416             # unmatched data exist in data/buf
417 3 100       7 if ( ! @$rs ) {
418             # all rules done from this direction, put back all
419             # from buf to $data before calling NEXT_RULE
420 1         3 $data = $self->{buf}[$dir];
421 1         2 $self->{buf}[$dir] = '';
422             }
423 3         28 goto NEXT_RULE;
424             }
425 1         18 goto PASS_AND_RETURN; # wait for more data
426             }
427              
428             # check against current set
429 86 100       184 if ( $type>0 ) {
430             # packet data
431 28 50       74 if ( $self->{buf}[$dir] ne '' ) {
432 0         0 $self->run_callback([
433             IMP_DENY,
434             $dir,
435             "packet data after unmatched streaming data"
436             ]);
437             }
438 28         77 for( my $i=0;$i<@$crs;$i++ ) {
439 30 100       75 if ( my ($len) = $match->($rules->[$crs->[$i]],\$data)) {
440             # match
441             $pass_until = $self->{off_passed}[$dir] =
442 22         60 $self->{off_buf}[$dir] += $len;
443 22 100       51 if ( $self->{matched} ) {
444             # preserve hash of matched packet so that duplicates are
445             # detected later
446             $self->{matched}[$dir]{ md5(
447 9   66     125 ( $self->{matched_seed} //= pack("N",rand(2**32)) ).
448             $data
449             )} = $crs->[$i]
450             }
451              
452 22 100       56 if (@$crs>1) {
453             # remove rule, keep rest in ruleset
454 4 50       10 $DEBUG && debug(
455             "full match rule $crs->[$i] - remove from ruleset");
456 4         8 splice(@$crs,$i,1);
457             } else {
458             # remove ruleset with last rule in it
459 18 50       40 $DEBUG && debug(
460             "full match rule $crs->[$i] - remove ruleset");
461 18         32 shift(@$rs);
462             # switch to other dir if this dir is done for now
463 18 100 100     68 if ( ! @$rs || ! $rs->[0] ) {
464 14 100       34 my $ors = $self->{ruleset}[$dir ? 0:1];
465 14 100 100     57 shift @$ors if @$ors && ! $ors->[0];
466             }
467             }
468              
469             # pass data
470 22 100       289 goto CHECK_DONE if ! @$rs;
471 12         349 goto PASS_AND_RETURN; # wait for more data
472             }
473             }
474              
475             # no rule from ruleset matched, check for duplicates
476 6 100 66     35 if ( $self->{matched} and my $dup = $self->{matched}[$dir] ) {
477 5         27 my $r = $dup->{ md5($self->{matched_seed} . $data ) };
478 5 50       19 if ( defined $r ) {
479             # matched again - pass data
480             $pass_until = $self->{off_passed}[$dir]
481 5         14 = $self->{off_buf}[$dir] += length($data);
482 5 50       12 $DEBUG && debug("ignore DUP[$dir] for rule $r");
483 5         117 goto PASS_AND_RETURN; # wait for more data
484             }
485             }
486              
487             # no rule and no duplicates matched, must be bad data
488 1 50       4 $DEBUG && debug("no matching rule for ${type}[$dir] - deny");
489 1         2 $self->{buf} = undef;
490 1         6 $self->run_callback([
491             IMP_DENY,
492             $dir,
493             "rule#@$crs did not match"
494             ]);
495 1         49 return;
496              
497             } else {
498             # streaming data
499 58         96 my $temp_fail;
500             my $final_match;
501 58         141 for( my $i=0;$i<@$crs;$i++ ) {
502             my ($len,$removed)
503 58         160 = $match->($rules->[$crs->[$i]],\$self->{buf}[$dir]);
504 58 100       197 if ( ! defined $len ) {
    100          
505             # will never match against rule
506 2         6 next;
507             } elsif ( ! $len ) {
508             # note that it might match if buf gets longer but check other
509             # rules in ruleset if they match better
510 12         19 $temp_fail = 1;
511 12         34 next;
512             }
513              
514 44 100 66     197 if ( ! $removed and @$crs == 1 and @$rs == 1 ) {
      100        
515             # last rule for dir - no need to extend preliminary matches
516             # as long as max_unbound is not restrictive
517 9         40 my $ma = $self->{factory_args}{max_unbound};
518 9 100 66     43 if ( ! defined( $ma && $ma->[$dir] )) {
519 2         5 $removed = $len;
520 2         6 substr($self->{buf}[$dir],0,$removed,'');
521             }
522             }
523              
524             # rule matched
525 44 100       89 if ( ! $removed ) {
526             # match might not be final, wait for more data but put rule
527             # at the beginning of ruleset if it's not already there
528 16 50       39 unshift @$crs,splice(@$crs,$i,1) if $i>0;
529              
530             # advance off_passed, but keep off_buf
531             $pass_until = $self->{off_passed}[$dir]
532 16         35 = $self->{off_buf}[$dir] + $len;
533              
534             # if this is was the last completely open rule we don't need
535             # to check if the matched could be extended
536 16 100 66     74 if (@$crs == 1 and @$rs == 1 ) {
537             # last rule on this side
538 7 100       17 my $ors = $self->{ruleset}[$dir?0:1];
539 7 100 66     45 if (
    100 66        
    100 66        
      100        
      100        
540             # other side has no rules
541             ! @$ors
542             # other side has empty rule
543             or @$ors == 1 and ! $ors->[0]
544             # other side has single rule which matched already
545 5         33 or @$ors == 1 and @{ $ors->[0] } == 1 and
546             $self->{off_passed}[$dir?0:1]
547             - $self->{off_buf}[$dir?0:1] > 0 ) {
548              
549             # we are done and there is no need to extend the match
550 3         7 @$ors = @$rs = ();
551 3         87 goto CHECK_DONE;
552             }
553             }
554              
555             } else {
556             # final match of rule
557             $pass_until = $self->{off_passed}[$dir]
558 28         60 = $self->{off_buf}[$dir] += $len;
559 28 100       57 if (@$crs>1) {
560             # remove rule, keep rest in ruleset
561 3 50       8 $DEBUG && debug(
562             "full match rule $crs->[$i] - remove from ruleset");
563 3         6 splice(@$crs,$i,1);
564             } else {
565             # remove ruleset with last rule in it
566 25 50       50 $DEBUG && debug(
567             "full match rule $crs->[$i] - remove ruleset");
568 25         43 shift(@$rs);
569             # switch to other dir if this dir is done for now
570 25 100 100     78 if ( ! @$rs || ! $rs->[0] ) {
571 23 100       51 my $ors = $self->{ruleset}[$dir ? 0:1];
572 23 100 100     88 shift @$ors if @$ors && ! $ors->[0];
573 23 50 66     467 goto CHECK_DONE if ! @$ors && ! @$rs;
574             }
575             }
576 15         25 $final_match = 1;
577             # no allow_dup for streaming
578             }
579              
580             # pass data
581 28 100 100     105 if ( $final_match and $self->{buf}[$dir] ne '' ) {
582             # try to match more
583 8         17 $data = $self->{buf}[$dir];
584 8         16 $self->{buf}[$dir] = '';
585 8         245 goto NEXT_RULE;
586             }
587 20 100       80 goto CHECK_DONE if ! @$rs;
588 19         702 goto PASS_AND_RETURN;
589             }
590              
591 14 100       32 if ( ! $temp_fail ) {
592             # no rule and no duplicates matched, must be bad data
593 2 50       5 $DEBUG && debug("no matching rule for ${type}[$dir] - deny");
594 2         3 $self->{buf} = undef;
595 2         13 $self->run_callback([
596             IMP_DENY,
597             $dir,
598             "rule#@$crs did not match"
599             ]);
600             }
601 14         328 goto PASS_AND_RETURN;
602             }
603              
604 28 50       75 CHECK_DONE:
605             return if @$rs; # still unmatched rules
606              
607             # pass only current data
608 28 100       41 goto PASS_AND_RETURN if @{$self->{ruleset}[ $dir ? 0:1 ] };
  28 100       89  
609              
610             # rulesets for both dirs are done, pass all data
611 26 50       56 $DEBUG && debug("all rules done - pass rest");
612 26         51 $self->{buf} = undef;
613 26         101 my @rv = (
614             [ IMP_PASS,0,IMP_MAXOFFSET ],
615             [ IMP_PASS,1,IMP_MAXOFFSET ]
616             );
617 26         60 for(0,1) {
618 52 100       137 $self->{paused}[$_] or next;
619 5         13 $self->{paused}[$_] = 0;
620 5         16 unshift @rv, [ IMP_CONTINUE,$_ ];
621             }
622 26         111 $self->run_callback(@rv);
623 26         180 return;
624              
625 65 100       184 PASS_AND_RETURN:
626             return if ! $pass_until;
627 46         219 $self->run_callback([ IMP_PASS, $dir, $pass_until ]);
628 46         287 return;
629             }
630              
631             # cfg2str and str2cfg are redefined because our config hash is deeper
632             # nested due to rules and max_unbound
633             sub cfg2str {
634 2     2 1 645 my Net::IMP::ProtocolPinning $self = shift;
635 2         7 my %cfg = @_;
636              
637 2 50       7 my $rules = delete $cfg{rules} or croak("no rules defined");
638             # re-insert [[dir,rxlen,rx],... ] as dir0,rxlen0,rx0,dir1,...
639 2         7 for (my $i=0;$i<@$rules;$i++) {
640 3         4 @cfg{ "dir$i","rxlen$i","rx$i" } = @{ $rules->[$i] }{qw( dir rxlen rx)};
  3         18  
641             }
642 2 50       6 if ( my $max_unbound = delete $cfg{max_unbound} ) {
643             # re-insert [mo0,mo1] as max_unbound0,max_unbound1
644 2         4 @cfg{ 'max_unbound0', 'max_unbound1' } = @$max_unbound;
645             }
646 2         13 return $self->SUPER::cfg2str(%cfg);
647             }
648              
649             sub str2cfg {
650 6     6 1 1482 my Net::IMP::ProtocolPinning $self = shift;
651 6         23 my %cfg = $self->SUPER::str2cfg(@_);
652 6         15 my $rules = $cfg{rules} = [];
653 6         12 for ( my $i=0;1;$i++ ) {
654 15 100       46 defined( my $dir = delete $cfg{"dir$i"} ) or last;
655 9 50       21 defined( my $rxlen = delete $cfg{"rxlen$i"} )
656             or croak("no rxlen$i defined but dir$i");
657 9 50       25 defined( my $rx = delete $cfg{"rx$i"} )
658             or croak("no rx$i defined but dir$i");
659 9 50       12 $rx = eval { qr/$rx/ } or croak("invalid regex rx$i");
  9         90  
660 9         34 push @$rules, { dir => $dir, rxlen => $rxlen, rx => $rx };
661              
662              
663             }
664 6 50       14 @$rules or croak("no rules defined");
665 6         12 my $max_unbound = $cfg{max_unbound} = [];
666 6         11 for (0,1) {
667             $max_unbound->[$_] = delete $cfg{"max_unbound$_"}
668 12 50       39 if exists $cfg{"max_unbound$_"};
669             }
670              
671             # sanity check
672 6         18 my %scfg = %cfg;
673 6         15 delete @scfg{qw(rules max_unbound ignore_order allow_dup allow_reorder)};
674 6 50       14 %scfg and croak("unhandled config keys: ".join(' ',sort keys %scfg));
675              
676 6         28 return %cfg;
677             }
678              
679              
680             1;
681              
682             __END__