File Coverage

blib/lib/Net/IMP/Filter.pm
Criterion Covered Total %
statement 99 173 57.2
branch 52 116 44.8
condition 11 47 23.4
subroutine 10 15 66.6
pod 7 7 100.0
total 179 358 50.0


line stmt bran cond sub pod time code
1 3     3   28947 use strict;
  3         6  
  3         101  
2 3     3   14 use warnings;
  3         6  
  3         119  
3 3     3   16 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  3         6  
  3         17  
4              
5             package Net::IMP::Filter;
6 3     3   190 use Net::IMP;
  3         10  
  3         222  
7 3     3   16 use Net::IMP::Debug;
  3         5  
  3         19  
8 3     3   926 use Hash::Util 'lock_ref_keys';
  3         3872  
  3         16  
9 3     3   193 use Scalar::Util 'weaken';
  3         6  
  3         4260  
10              
11              
12             ############################################################################
13             # these need to be redefined in subclass
14             ############################################################################
15             # analyzed data output
16             sub out {
17 0     0 1 0 my ($self,$dir,$data) = @_;
18 0         0 return;
19             }
20              
21             sub deny {
22 0     0 1 0 my ($self,$msg,$dir,@extmsg) = @_;
23 0         0 while (@extmsg) {
24 0         0 my ($k,$v) = splice(@extmsg,0,2);
25 0         0 $msg .= " $k:$v";
26             }
27 0 0       0 $DEBUG && debug("deny $msg");
28 0         0 return;
29             }
30              
31             sub fatal {
32 0     0 1 0 my ($self,$msg) = @_;
33 0 0       0 $DEBUG && debug("fatal $msg");
34 0         0 return;
35             }
36              
37             sub log {
38 0     0 1 0 my ($self,$level,$msg,$dir,$offset,$len,@extmsg) = @_;
39 0         0 while (@extmsg) {
40 0         0 my ($k,$v) = splice(@extmsg,0,2);
41 0         0 $msg .= " $k:$v";
42             }
43 0 0       0 $DEBUG && debug("log [$level] $msg");
44 0         0 return;
45             }
46              
47             sub acctfld {
48 0     0 1 0 my ($self,$key,$value) = @_;
49 0 0       0 $DEBUG && debug("acctfld $key=$value");
50 0         0 return;
51             }
52              
53             ############################################################################
54             # Implementation
55             ############################################################################
56             sub new {
57 10     10 1 29 my ($class,$imp,%args) = @_;
58 10 50       25 if (ref($class)) {
59 0         0 %args = (%$class, %args);
60 0   0     0 $imp ||= $class->{imp};
61             }
62 10   33     121 my $self = lock_ref_keys( bless {
63             %args,
64             imp => $imp, # analyzer object
65             buf => [
66             # list of buffered data [ offset,buf,type ] per dir
67             # buffers for same streaming type will be concatenated
68             [ [0,'',0] ],
69             [ [0,'',0] ],
70             ],
71             pass => [0,0], # may pass up to this offset
72             prepass => [0,0], # may prepass up to this offset
73             skipped => [0,0], # flag if last data got not send to analyzer
74             # because of pass into future
75             eof => [0,0], # flag if eof received
76             dead => 0, # set if deny|fatal received
77             },(ref $class || $class) );
78              
79 10 50       107 if ($imp) {
80 10         36 weaken( my $weak = $self );
81 10         32 $imp->set_callback(\&_imp_cb,$weak);
82             }
83 10         25 return $self;
84             }
85              
86             # data into analyzer
87             sub in {
88 25     25 1 166 my ($self,$dir,$data,$type) = @_;
89 25 50       57 $self->{dead} and return;
90              
91 25   100     92 $type ||= IMP_DATA_STREAM;
92 25 50       50 $DEBUG && debug("in($dir,$type) %d bytes",length($data));
93              
94 25 100       83 $self->{eof}[$dir] = 1 if $data eq '';
95 25 50       59 return $self->out($dir,$data,$type) if ! $self->{imp};
96              
97 25         40 my $buf = $self->{buf}[$dir];
98              
99             # (pre)pass as much as possible
100 25         45 for my $w (qw(pass prepass)) {
101 50 50       124 my $maxoff = $self->{$w}[$dir] or next;
102 0 0 0     0 @$buf == 1 and ! $buf->[0][2] or die "buf should be empty";
103 0 0 0     0 if ( $maxoff == IMP_MAXOFFSET
104             or $maxoff > $buf->[-1][0] + length($data) ) {
105 0 0       0 $DEBUG && debug("can $w everything");
106 0   0     0 my $lastoff = $self->{skipped}[$dir] && $buf->[0][0];
107 0         0 $buf->[0][0] += length($data);
108 0         0 $self->out($dir,$data,$type);
109 0 0 0     0 if ($w eq 'prepass') {
    0          
110 0         0 $self->{imp}->data($dir,$data,$lastoff,$type);
111 0         0 $self->{skipped}[$dir] = 0;
112             } elsif ( $data eq '' and $maxoff != IMP_MAXOFFSET ) {
113 0         0 $self->{imp}->data($dir,$data,$lastoff,$type);
114 0         0 $self->{skipped}[$dir] = 0;
115             } else {
116 0         0 $self->{skipped}[$dir] = 1;
117             }
118 0         0 return;
119             }
120              
121 0         0 my $canfw = $maxoff - $buf->[-1][0];
122 0 0 0     0 if ( $type > 0 and $canfw != length($data)) {
123             # packet types need to be handled as a single piece
124 0         0 debug("partial $w for $type ignored");
125 0         0 next;
126             }
127              
128 0 0       0 $DEBUG && debug("can $w %d bytes of %d", $canfw, length($data));
129 0         0 my $fwd = substr($data,0,$canfw,'');
130 0   0     0 my $lastoff = $self->{skipped}[$dir] && $buf->[0][0];
131 0         0 $buf->[0][0] += length($fwd);
132 0         0 $self->{$w}[$dir] = 0; # no more (pre)pass
133 0         0 $self->out($dir,$fwd,$type);
134 0 0       0 if ($w eq 'prepass') {
135 0         0 $self->{imp}->data($dir,$fwd,$lastoff,$type);
136 0         0 $self->{skipped}[$dir] = 0;
137             } else {
138 0         0 $self->{skipped}[$dir] = 1;
139             }
140             }
141              
142             # data left which need to be forwarded to analyzer
143 25 100 66     97 if ( ! $buf->[-1][2] ) {
    100          
144             # replace empty (untyped) buffer with new data
145 12         21 $buf->[-1][1] = $data;
146 12         22 $buf->[-1][2] = $type;
147             } elsif ( $type < 0 and $buf->[-1][2] == $type ) {
148             # streaming data of same type can be added to current buffer
149 12         24 $buf->[-1][1] .= $data;
150             } else {
151             # need new buffer
152 1         4 push @$buf,[
153             $buf->[-1][0] + length($buf->[-1][1]), # base = end of last
154             $data,
155             $type
156             ];
157             }
158              
159 25 50       56 $DEBUG && debug("buffer and analyze %d bytes of data", length($data));
160 25   33     61 my $lastoff = $self->{skipped}[$dir] && $buf->[0][0];
161 25         76 $self->{imp}->data($dir,$data,$lastoff,$type);
162 25         98 $self->{skipped}[$dir] = 0;
163             }
164              
165             # callback from analyzer
166             sub _imp_cb {
167 68     68   104 my $self = shift;
168 68 50       141 $self->{dead} and return;
169              
170 68         92 my @fwd;
171 68         112 for my $rv (@_) {
172 71         119 my $rtype = shift(@$rv);
173 71 50       145 $DEBUG && debug("$rtype ".join(" ",map { "'$_'" } @$rv));
  0         0  
174              
175 71 50       327 if ( $rtype == IMP_DENY ) {
    50          
    50          
    50          
    100          
    50          
    0          
176 0         0 my ($dir,$msg,@extmsg) = @$rv;
177 0         0 $self->deny($msg,$dir,@extmsg);
178 0         0 $self->{dead} = 1;
179 0         0 return;
180             } elsif ( $rtype == IMP_FATAL ) {
181 0         0 my $reason = shift;
182 0         0 $self->fatal($reason);
183 0         0 $self->{dead} = 1;
184 0         0 return;
185              
186             } elsif ( $rtype == IMP_LOG ) {
187 0         0 my ($dir,$offset,$len,$level,$msg,@extmsg) = @$rv;
188 0         0 $self->log($level,$msg,$dir,$offset,$len,@extmsg);
189              
190             } elsif ( $rtype == IMP_ACCTFIELD ) {
191 0         0 my ($key,$value) = @$rv;
192 0         0 $self->acctfld($key,$value);
193              
194             } elsif ( $rtype ~~ [ IMP_PASS, IMP_PREPASS ] ) {
195 40         66 my ($dir,$offset) = @$rv;
196 40 50       85 $DEBUG && debug("got %s %d|%d", $rtype,$dir,$offset);
197              
198 40 50 0     93 if ( $self->{pass}[$dir] == IMP_MAXOFFSET ) {
    50 0        
    0          
199 0         0 next; # cannot get better than previous pass
200             } elsif ( $rtype == IMP_PASS ) {
201 40 100       92 if ( $offset == IMP_MAXOFFSET ) {
    50          
202 9         13 $self->{pass}[$dir] = $offset;
203 9         15 $self->{prepass}[$dir] = 0;
204             } elsif ( $offset > $self->{pass}[$dir] ) {
205 31         47 $self->{pass}[$dir] = $offset;
206             $self->{prepass}[$dir] = 0
207 31 50       75 if $offset >= $self->{prepass}[$dir];
208             } else {
209 0         0 next; # not better than previous pass
210             }
211              
212             # IMP_PREPASS
213             } elsif ( $offset == IMP_MAXOFFSET or (
214             $offset > $self->{pass}[$dir] and
215             $offset > $self->{prepass}[$dir] )) {
216             # update for prepass
217 0         0 $self->{prepass}[$dir] = $offset
218             } else {
219             # next; # no better than previous prepass
220             }
221              
222 40         61 my $buf = $self->{buf}[$dir];
223 40         52 my $end;
224              
225 40         86 while ($buf->[0][2]) {
226 32         54 my $buf0 = shift(@$buf);
227 32         50 $end = $buf0->[0] + length($buf0->[1]);
228 32 100 66     150 if ( $offset == IMP_MAXOFFSET
    50          
    100          
    50          
229             or $offset >= $end ) {
230 10 50       22 $DEBUG && debug("pass complete buf");
231 10         21 push @fwd, [ $dir, $buf0->[1], $buf0->[2] ];
232             # keep dummy in buf
233 10 100       28 if ( ! @$buf ) {
234 9         22 unshift @$buf,[ $buf0->[0] + length($buf0->[1]),'',0 ];
235             push @fwd,[$dir,'',$buf0->[2]]
236 9 50       30 if $self->{eof}[$dir]; # fwd eof
237 9         19 last;
238             }
239             } elsif ( $offset < $buf0->[0] ) {
240 0 0       0 $DEBUG && debug("duplicate $rtype $offset ($buf0->[0])");
241 0         0 unshift @$buf,$buf0;
242 0         0 last;
243             } elsif ( $offset == $buf0->[0] ) {
244             # at border, e.g. forward 0 bytes
245 1         2 unshift @$buf,$buf0;
246 1         2 last;
247             } elsif ( $buf0->[2] < 0 ) {
248             # streaming type, can pass part of buf
249 21 50       44 $DEBUG && debug("pass part of buf");
250 21         66 push @fwd, [
251             $dir,
252             substr($buf0->[1],0,$offset - $end,''),
253             $buf0->[2],
254             ];
255             # put back with adjusted offset
256 21         38 $buf0->[0] = $offset;
257 21         34 unshift @$buf, $buf0;
258 21         32 last;
259             } else {
260 0 0       0 $DEBUG && debug(
261             "ignore partial $rtype for $buf0->[2] (offset=$offset,pos=$buf0->[0])");
262 0         0 unshift @$buf, $buf0; # put back
263 0         0 last;
264             }
265             }
266              
267 40 100 66     151 if ( $offset != IMP_MAXOFFSET and $offset <= $end ) {
268             # limit reached, reset (pre)pass
269 31 50       94 $self->{ $rtype == IMP_PASS ? 'pass':'prepass' }[$dir] = 0;
270             }
271              
272             } elsif ( $rtype == IMP_REPLACE ) {
273 31         62 my ($dir,$offset,$newdata) = @$rv;
274 31 50       64 $DEBUG && debug("got %s %d|%d", $rtype,$dir,$offset);
275              
276 31 50 33     126 if ( $self->{pass}[$dir] or $self->{prepass}[$dir] ) {
277             # we are allowed to (pre)pass in future, so we cannot replace
278 0         0 die "cannot replace already passed data";
279             }
280              
281 31         55 my $buf = $self->{buf}[$dir];
282 31         43 my $buf0 = $buf->[0];
283 31         52 my $eob = $buf0->[0] + length($buf0->[1]);
284 31 50       71 if ( $eob < $offset ) {
    100          
285 0         0 die "replacement cannot span different types or packets";
286             } elsif ( $eob == $offset ) {
287             # full replace
288 3 50       7 $DEBUG && debug("full replace");
289 3         8 push @fwd,[ $dir,$newdata,$buf0->[2] ];
290 3         4 shift(@$buf);
291 3 50       14 push @$buf, [ $eob,'',0 ] if ! @$buf;
292             } else {
293 28 50       62 die "no partial replacement for packet types allowed"
294             if $buf0->[2]>0;
295 28 50       52 $DEBUG && debug("partial replace");
296 28         61 push @fwd,[ $dir,$newdata,$buf0->[2] ];
297 28         56 substr( $buf0->[1],0,$offset - $buf0->[0],'');
298 28         61 $buf0->[0] = $offset;
299             }
300              
301             } elsif ( $rtype ~~ [ IMP_PAUSE, IMP_CONTINUE ] ) {
302             # ignore
303             } else {
304 0         0 die "cannot handle Net::IMP rtype $rtype";
305             }
306             }
307 68         205 $self->out(@$_) for (@fwd);
308             }
309              
310              
311             1;
312             __END__