File Coverage

blib/lib/Net/IMP/HTTP/Example/BlockContentType.pm
Criterion Covered Total %
statement 15 62 24.1
branch 0 20 0.0
condition 0 8 0.0
subroutine 5 14 35.7
pod 8 9 88.8
total 28 113 24.7


line stmt bran cond sub pod time code
1 1     1   989 use strict;
  1         1  
  1         28  
2 1     1   4 use warnings;
  1         1  
  1         34  
3              
4             package Net::IMP::HTTP::Example::BlockContentType;
5 1     1   4 use base 'Net::IMP::HTTP::Request';
  1         1  
  1         101  
6 1     1   4 use Net::IMP; # import IMP_ constants
  1         1  
  1         75  
7 1     1   5 use Net::IMP::Debug;
  1         1  
  1         8  
8              
9 0     0 0   sub RTYPES { ( IMP_PASS, IMP_DENY ) }
10             sub new_analyzer {
11 0     0 1   my ($factory,%args) = @_;
12 0           my $self = $factory->SUPER::new_analyzer(%args);
13             # request data do not matter
14 0           $self->run_callback([ IMP_PASS,0,IMP_MAXOFFSET ]);
15 0 0 0       if ( ! $self->{factory_args}{whiterx}
16             && ! $self->{factory_args}{blackrx} ) {
17             # nothing to analyze
18 0           $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ]);
19             }
20 0           return $self;
21             }
22              
23             sub validate_cfg {
24 0     0 1   my ($class,%cfg) = @_;
25 0           my @err;
26 0           for my $k (qw(whiterx blackrx)) {
27 0 0         my $rx = delete $cfg{$k} or next;
28 0 0         ref($rx) and next;
29 0 0         push @err,"$k is no valid regexp: $@" if ! eval { qr/$rx/ };
  0            
30             }
31 0           return (@err,$class->SUPER::validate_cfg(%cfg));
32             }
33              
34             sub str2cfg {
35 0     0 1   my ($class,$str) = @_;
36 0           my %cfg = $class->SUPER::str2cfg($str);
37 0           for my $k (qw(whiterx blackrx)) {
38 0 0 0       next if ! $cfg{$k} or ref $cfg{$k};
39 0 0         $cfg{$k} = eval { qr/$cfg{$k}/ }
  0            
40             or die "invalid rx in $k: $@";
41             }
42 0           return %cfg;
43             }
44              
45 0     0 1   sub request_hdr {}
46 0     0 1   sub request_body {}
47 0     0 1   sub response_body {}
48 0     0 1   sub any_data {}
49              
50             sub response_hdr {
51 0     0 1   my ($self,$hdr) = @_;
52             # we only want selected image/ content types and not too big
53 0   0       my $ct = $hdr =~m{\nContent-type:[ \t]*([^\s;]+)}i && lc($1)
54             || 'unknown/unknown';
55              
56 0           my $reason;
57 0 0         if ( my $white = $self->{factory_args}{whiterx} ) {
58 0 0         if ( $ct =~ $white ) {
59 0           debug("allowed $ct because of white list");
60 0           goto pass;
61             } else {
62 0           debug("denied $ct because not in white list");
63 0           $reason = "denied $ct because not in white list";
64 0           goto deny;
65             }
66             }
67 0 0         if ( my $black = $self->{factory_args}{blackrx} ) {
68 0 0         if ( $ct =~ $black ) {
69 0           debug("denied $ct because in black list");
70 0           $reason = "denied $ct because in black list";
71 0           goto deny;
72             } else {
73 0           debug("allow $ct because not in black list");
74 0           goto pass;
75             }
76             }
77              
78             pass:
79 0           $self->run_callback([ IMP_PASS,1,IMP_MAXOFFSET ]);
80 0           return;
81              
82 0           deny:
83             $self->run_callback([ IMP_DENY,1,$reason ]);
84 0           return;
85             }
86              
87              
88             1;
89             __END__