File Coverage

blib/lib/Net/IMP/HTTP/Connection.pm
Criterion Covered Total %
statement 39 57 68.4
branch 5 18 27.7
condition 0 2 0.0
subroutine 11 16 68.7
pod 4 7 57.1
total 59 100 59.0


line stmt bran cond sub pod time code
1 2     2   26347 use strict;
  2         5  
  2         84  
2 2     2   11 use warnings;
  2         3  
  2         93  
3              
4             package Net::IMP::HTTP::Connection;
5 2     2   12 use base 'Net::IMP::Base';
  2         9  
  2         1034  
6 2     2   8158 use fields qw(dispatcher pos);
  2         4  
  2         14  
7 2     2   122 use Net::IMP::HTTP;
  2         4  
  2         183  
8 2     2   9 use Net::IMP;
  2         2  
  2         169  
9 2     2   9 use Carp 'croak';
  2         2  
  2         1305  
10              
11             # just define a typical set, maybe need to be redefined in subclass
12             sub RTYPES {
13 0     0 0 0 my $factory = shift;
14 0         0 return (IMP_PASS, IMP_PREPASS, IMP_REPLACE, IMP_DENY, IMP_LOG)
15             }
16              
17             sub INTERFACE {
18 2     2 0 17 my $factory = shift;
19 2         4 my @rtx = my @rt = $factory->RTYPES;
20 2 50       12 push @rtx, IMP_DENY if ! grep { IMP_DENY == $_ } @rtx;
  6         11  
21             return (
22 2         9 [ IMP_DATA_HTTP, \@rt ],
23             [ IMP_DATA_HTTPRQ, \@rt ],
24             [ IMP_DATA_STREAM, \@rtx, 'Net::IMP::Adaptor::STREAM2HTTPConn' ],
25             );
26             }
27              
28             sub set_interface {
29 2     2 1 3738 my ($factory,$interface) = @_;
30 2 100       11 my $newf = $factory->SUPER::set_interface($interface)
31             or return;
32 1 50       72 return $newf if $newf != $factory;
33              
34             # original factory, set dispatcher based on input data type
35 1 50       4 if ( $interface->[0] == IMP_DATA_HTTP ) {
    0          
36 1         41 $factory->{dispatcher} = {
37             IMP_DATA_HTTP_HEADER+0 => [
38             $factory->can('request_hdr'),
39             $factory->can('response_hdr'),
40             ],
41             IMP_DATA_HTTP_BODY+0 => [
42             $factory->can('request_body'),
43             $factory->can('response_body'),
44             ],
45             IMP_DATA_HTTP_CHKHDR+0 => [
46             undef,
47             $factory->can('rsp_chunk_hdr')
48             ],
49             IMP_DATA_HTTP_CHKTRAILER+0 => [
50             undef,
51             $factory->can('rsp_chunk_trailer')
52             ],
53             IMP_DATA_HTTP_DATA+0 => $factory->can('any_data'),
54             IMP_DATA_HTTP_JUNK+0 => $factory->can('junk_data')
55             }
56             } elsif ( $interface->[0] == IMP_DATA_HTTPRQ ) {
57 0         0 $factory->{dispatcher} = {
58             # HTTP request interface
59             IMP_DATA_HTTPRQ_HEADER+0 => [
60             $factory->can('request_hdr'),
61             $factory->can('response_hdr'),
62             ],
63             IMP_DATA_HTTPRQ_CONTENT+0 => [
64             $factory->can('request_body'),
65             $factory->can('response_body'),
66             ],
67             IMP_DATA_HTTPRQ_DATA+0 => $factory->can('any_data'),
68             }
69             } else {
70 0         0 die "unknown input data type $interface->[0]"
71             }
72              
73 1         3 return $factory;
74             }
75              
76             sub new_analyzer {
77 1     1 1 11 my ($factory,%args) = @_;
78 1         5 my $analyzer = $factory->SUPER::new_analyzer(%args);
79 1         108 $analyzer->{dispatcher} = $factory->{dispatcher};
80 1         2 return $analyzer;
81             }
82              
83              
84             # we can overide data to handle the types directly, but per default we
85             # dispatch to seperate methods
86             sub data {
87 0     0 1   my ($self,$dir,$data,$offset,$type) = @_;
88 0 0         $self->{pos}[$dir] = $offset if $offset;
89 0           $self->{pos}[$dir] += length($data);
90 0           my $disp = $self->{dispatcher};
91 0 0         my $sub = $disp->{$type+0} or croak("cannot dispatch type $type".Data::Dumper::Dumper($disp));
92 0 0         if ( ref($sub) eq 'ARRAY' ) {
93 0 0         $sub = $sub->[$dir] or croak("cannot dispatch type $type dir $dir");
94 0           $sub->($self,$data,$offset);
95             } else {
96 0           $sub->($self,$dir,$data,$offset);
97             }
98             }
99              
100             sub offset {
101 0     0 0   my ($self,$dir) = @_;
102 0   0       return $self->{pos}[$dir] // 0;
103             }
104              
105             ###########################################################################
106             # public interface
107             # most of these methods need to be implemented in subclass
108             ###########################################################################
109              
110             for my $subname (
111             'request_hdr', # ($self,$hdr)
112             'request_body', # ($self,$data,[$offset])
113             'response_hdr', # ($self,$hdr)
114             'response_body', # ($self,$data,[$offset])
115             'rsp_chunk_hdr', # ($self,$hdr)
116             'rsp_chunk_trailer', # ($self,$hdr)
117             'any_data', # ($self,$dir,$data,[$offset])
118             ) {
119 2     2   13 no strict 'refs';
  2         3  
  2         193  
120 0     0     *$subname = sub { croak("$subname needs to be implemented") }
121             }
122              
123             # by default simply ignore junk data (leading \n before message header)
124             sub junk_data {
125 0     0 1   my ($self,$dir,$data,$offset) = @_;
126             return
127 0           }
128              
129              
130              
131             1;
132             __END__