line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
2
|
|
|
2
|
|
40979
|
use strict; |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
102
|
|
2
|
2
|
|
|
2
|
|
13
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
120
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Net::IMP::HTTP::Request; |
5
|
2
|
|
|
2
|
|
23
|
use base 'Net::IMP::Base'; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
1059
|
|
6
|
2
|
|
|
2
|
|
5932
|
use fields qw(dispatcher pos); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
53
|
|
7
|
2
|
|
|
2
|
|
168
|
use Net::IMP::HTTP; |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
237
|
|
8
|
2
|
|
|
2
|
|
15
|
use Net::IMP; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
239
|
|
9
|
2
|
|
|
2
|
|
14
|
use Carp 'croak'; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
1063
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# just define a typical set, maybe need to be redefined in subclass |
13
|
|
|
|
|
|
|
sub RTYPES { |
14
|
0
|
|
|
0
|
0
|
0
|
my $factory = shift; |
15
|
0
|
|
|
|
|
0
|
return (IMP_PASS, IMP_PREPASS, IMP_REPLACE, IMP_DENY, IMP_LOG) |
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
sub INTERFACE { |
19
|
1
|
|
|
1
|
0
|
3041
|
my $factory = shift; |
20
|
1
|
|
|
|
|
4
|
my @rt = $factory->RTYPES; |
21
|
|
|
|
|
|
|
return ( |
22
|
1
|
|
|
|
|
8
|
[ IMP_DATA_HTTPRQ, \@rt ], |
23
|
|
|
|
|
|
|
[ IMP_DATA_STREAM, \@rt, 'Net::IMP::Adaptor::STREAM2HTTPReq' ], |
24
|
|
|
|
|
|
|
); |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# we can overide data to handle the types directly, but per default we |
28
|
|
|
|
|
|
|
# dispatch to seperate methods |
29
|
|
|
|
|
|
|
sub data { |
30
|
0
|
|
|
0
|
1
|
|
my ($self,$dir,$data,$offset,$type) = @_; |
31
|
|
|
|
|
|
|
|
32
|
0
|
0
|
|
|
|
|
$self->{pos}[$dir] = $offset if $offset; |
33
|
0
|
|
|
|
|
|
$self->{pos}[$dir] += length($data); |
34
|
|
|
|
|
|
|
|
35
|
0
|
|
0
|
|
|
|
my $disp = $self->{dispatcher} ||= { |
36
|
|
|
|
|
|
|
IMP_DATA_HTTPRQ_HEADER+0 => [ |
37
|
|
|
|
|
|
|
$self->can('request_hdr'), |
38
|
|
|
|
|
|
|
$self->can('response_hdr'), |
39
|
|
|
|
|
|
|
], |
40
|
|
|
|
|
|
|
IMP_DATA_HTTPRQ_CONTENT+0 => [ |
41
|
|
|
|
|
|
|
$self->can('request_body'), |
42
|
|
|
|
|
|
|
$self->can('response_body'), |
43
|
|
|
|
|
|
|
], |
44
|
|
|
|
|
|
|
IMP_DATA_HTTPRQ_DATA+0 => $self->can('any_data') |
45
|
|
|
|
|
|
|
}; |
46
|
0
|
0
|
|
|
|
|
my $sub = $disp->{$type+0} or croak("cannot dispatch type $type"); |
47
|
0
|
0
|
|
|
|
|
if ( ref($sub) eq 'ARRAY' ) { |
48
|
0
|
0
|
|
|
|
|
$sub = $sub->[$dir] or croak("cannot dispatch type $type dir $dir"); |
49
|
0
|
|
|
|
|
|
$sub->($self,$data,$offset); |
50
|
|
|
|
|
|
|
} else { |
51
|
0
|
|
|
|
|
|
$sub->($self,$dir,$data,$offset); |
52
|
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub offset { |
56
|
0
|
|
|
0
|
0
|
|
my ($self,$dir) = @_; |
57
|
0
|
|
0
|
|
|
|
return $self->{pos}[$dir] // 0; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
########################################################################### |
62
|
|
|
|
|
|
|
# public interface |
63
|
|
|
|
|
|
|
# most of these methods need to be implemented in subclass |
64
|
|
|
|
|
|
|
########################################################################### |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
for my $subname ( |
67
|
|
|
|
|
|
|
'request_hdr', # ($self,$hdr) |
68
|
|
|
|
|
|
|
'request_body', # ($self,$data,[$offset]) |
69
|
|
|
|
|
|
|
'response_hdr', # ($self,$hdr) |
70
|
|
|
|
|
|
|
'response_body', # ($self,$data,[$offset]) |
71
|
|
|
|
|
|
|
'any_data', # ($self,$dir,$data,[$offset]) |
72
|
|
|
|
|
|
|
) { |
73
|
2
|
|
|
2
|
|
16
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
209
|
|
74
|
0
|
|
|
0
|
|
|
*$subname = sub { croak("$subname needs to be implemented in $_[0]") } |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
1; |
79
|
|
|
|
|
|
|
__END__ |