line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::ICAP::Client; |
2
|
|
|
|
|
|
|
|
3
|
2
|
|
|
2
|
|
55095
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
57
|
|
4
|
2
|
|
|
2
|
|
9
|
use warnings; |
|
2
|
|
|
|
|
2
|
|
|
2
|
|
|
|
|
60
|
|
5
|
2
|
|
|
2
|
|
1222
|
use English qw(-no_match_vars); |
|
2
|
|
|
|
|
5675
|
|
|
2
|
|
|
|
|
11
|
|
6
|
2
|
|
|
2
|
|
2017
|
use IO::Socket::INET(); |
|
2
|
|
|
|
|
27944
|
|
|
2
|
|
|
|
|
49
|
|
7
|
2
|
|
|
2
|
|
1729
|
use IO::Socket::SSL(); |
|
2
|
|
|
|
|
97395
|
|
|
2
|
|
|
|
|
50
|
|
8
|
2
|
|
|
2
|
|
12
|
use Carp(); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
23
|
|
9
|
2
|
|
|
2
|
|
1017
|
use URI(); |
|
2
|
|
|
|
|
8435
|
|
|
2
|
|
|
|
|
43
|
|
10
|
2
|
|
|
2
|
|
1028
|
use HTTP::Request(); |
|
2
|
|
|
|
|
24244
|
|
|
2
|
|
|
|
|
39
|
|
11
|
2
|
|
|
2
|
|
864
|
use HTTP::Response(); |
|
2
|
|
|
|
|
8967
|
|
|
2
|
|
|
|
|
38
|
|
12
|
2
|
|
|
2
|
|
20
|
use POSIX(); |
|
2
|
|
|
|
|
3
|
|
|
2
|
|
|
|
|
7757
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our $VERSION = '0.07'; |
15
|
|
|
|
|
|
|
|
16
|
0
|
|
|
0
|
|
0
|
sub _CHUNK_SIZE { return 4096 } |
17
|
0
|
|
|
0
|
|
0
|
sub _FILE_READ_SIZE { return 8192 } |
18
|
0
|
|
|
0
|
|
0
|
sub _ENTIRE_ICAP_HEADERS_REGEX { return qr/\A(.*?)\r?\n\r?\n/smx } |
19
|
0
|
|
|
0
|
|
0
|
sub _STAT_SIZE_IDX { return 7 } |
20
|
0
|
|
|
0
|
|
0
|
sub _DEBUG_PREFIX_SIZE { return 3 } |
21
|
0
|
|
|
0
|
|
0
|
sub _ICAP_RESPONSE_PEEK_SIZE { return 1 } |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub new { |
24
|
2
|
|
|
2
|
1
|
458
|
my ( $class, $uri, %params ) = @_; |
25
|
2
|
|
|
|
|
11
|
my $self = { |
26
|
|
|
|
|
|
|
_uri => URI->new($uri), |
27
|
|
|
|
|
|
|
_agent => "perl($class) v$VERSION", |
28
|
|
|
|
|
|
|
_allow_204 => 1, |
29
|
|
|
|
|
|
|
_allow_preview => 1, |
30
|
|
|
|
|
|
|
}; |
31
|
2
|
100
|
|
|
|
195
|
if ( $self->{_uri}->_scheme() eq 'icaps' ) { |
32
|
1
|
|
|
|
|
100
|
$self->{_ssl} = { SSL_verify_mode => 1 }; |
33
|
1
|
|
|
|
|
18
|
foreach my $possible_ca_file ( |
34
|
|
|
|
|
|
|
'/etc/pki/tls/certs/ca-bundle.crt', |
35
|
|
|
|
|
|
|
'/usr/share/ssl/certs/ca-bundle.crt', |
36
|
|
|
|
|
|
|
) |
37
|
|
|
|
|
|
|
{ |
38
|
2
|
50
|
|
|
|
88
|
if ( -f $possible_ca_file ) { |
39
|
0
|
|
|
|
|
0
|
$self->{_ssl}->{SSL_ca_file} = $possible_ca_file; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
} |
42
|
1
|
|
|
|
|
2
|
foreach my $possible_ca_path ( '/usr/share/ca-certificates', ) { |
43
|
1
|
50
|
|
|
|
27
|
if ( -f $possible_ca_path ) { |
44
|
0
|
|
|
|
|
0
|
$self->{_ssl}->{SSL_ca_path} = $possible_ca_path; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
} |
47
|
1
|
|
|
|
|
3
|
$self->{_ssl}->{SSL_verifycn_scheme} = 'http'; |
48
|
1
|
|
|
|
|
6
|
$self->{_ssl}->{SSL_verifycn_name} = $self->{_uri}->host(); |
49
|
1
|
|
|
|
|
48
|
delete $params{SSL}; |
50
|
|
|
|
|
|
|
} |
51
|
2
|
|
|
|
|
54
|
foreach my $key ( sort { $a cmp $b } keys %params ) { |
|
0
|
|
|
|
|
0
|
|
52
|
1
|
50
|
|
|
|
5
|
if ( $key =~ /^SSL_/smx ) { |
53
|
1
|
|
|
|
|
3
|
$self->{_ssl}->{$key} = delete $params{$key}; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
} |
56
|
2
|
|
|
|
|
6
|
bless $self, $class; |
57
|
2
|
|
|
|
|
5
|
return $self; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub debug { |
61
|
1
|
|
|
1
|
1
|
2
|
my ( $self, $debug ) = @_; |
62
|
1
|
|
|
|
|
1
|
my $old = $self->{_debug}; |
63
|
1
|
50
|
|
|
|
4
|
if ( @ARG > 1 ) { |
64
|
1
|
|
|
|
|
2
|
$self->{_debug} = $debug; |
65
|
|
|
|
|
|
|
} |
66
|
1
|
|
|
|
|
3
|
return $old; |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub allow_204 { |
70
|
1
|
|
|
1
|
1
|
2
|
my ( $self, $allow_204 ) = @_; |
71
|
1
|
|
|
|
|
1
|
my $old = $self->{_allow_204}; |
72
|
1
|
50
|
|
|
|
4
|
if ( @ARG > 1 ) { |
73
|
1
|
|
|
|
|
2
|
$self->{_allow_204} = $allow_204; |
74
|
|
|
|
|
|
|
} |
75
|
1
|
|
|
|
|
6
|
return $old; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
sub allow_preview { |
79
|
1
|
|
|
1
|
1
|
2
|
my ( $self, $allow_preview ) = @_; |
80
|
1
|
|
|
|
|
2
|
my $old = $self->{_allow_preview}; |
81
|
1
|
50
|
|
|
|
3
|
if ( @ARG > 1 ) { |
82
|
1
|
|
|
|
|
2
|
$self->{_allow_preview} = $allow_preview; |
83
|
|
|
|
|
|
|
} |
84
|
1
|
|
|
|
|
3
|
return $old; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub _scheme { |
88
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
89
|
0
|
|
|
|
|
0
|
return $self->uri()->scheme(); |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
sub uri { |
93
|
6
|
|
|
6
|
1
|
1155
|
my ($self) = @_; |
94
|
6
|
|
|
|
|
27
|
return $self->{_uri}; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub max_connections { |
98
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
99
|
0
|
|
|
|
|
0
|
$self->_options(); |
100
|
0
|
|
|
|
|
0
|
return $self->{_options}->{max_connections}; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub service { |
104
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
105
|
0
|
|
|
|
|
0
|
$self->_options(); |
106
|
0
|
|
|
|
|
0
|
return $self->{_options}->{service}; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub ttl { |
110
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
111
|
0
|
|
|
|
|
0
|
$self->_options(); |
112
|
0
|
|
|
|
|
0
|
return $self->{_options}->{ttl}; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub preview_size { |
116
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
117
|
0
|
|
|
|
|
0
|
$self->_options(); |
118
|
0
|
|
|
|
|
0
|
return $self->{_options}->{preview}; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub server_allows_204 { |
122
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
123
|
0
|
|
|
|
|
0
|
$self->_options(); |
124
|
0
|
|
|
|
|
0
|
return $self->{_options}->{allowed}->{'204'}; |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub _debug { |
128
|
0
|
|
|
0
|
|
0
|
my ( $self, $string ) = @_; |
129
|
0
|
0
|
|
|
|
0
|
if ( $self->{_debug} ) { |
130
|
0
|
|
|
|
|
0
|
my $direction = substr $string, 0, _DEBUG_PREFIX_SIZE(), q[]; |
131
|
0
|
0
|
0
|
|
|
0
|
$direction eq '>> ' |
132
|
|
|
|
|
|
|
or $direction eq '<< ' |
133
|
|
|
|
|
|
|
or Carp::croak('Incorrectly formatted debug line'); |
134
|
0
|
0
|
0
|
|
|
0
|
if ( ( defined $self->{_previous_direction} ) |
|
|
0
|
|
|
|
|
|
135
|
|
|
|
|
|
|
&& ( $self->{_previous_direction} eq $direction ) ) |
136
|
|
|
|
|
|
|
{ |
137
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} .= $string; |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
elsif ( $self->{_previous_direction} ) { |
140
|
|
|
|
|
|
|
my $quoted_previous_direction = |
141
|
0
|
|
|
|
|
0
|
quotemeta $self->{_previous_direction}; |
142
|
|
|
|
|
|
|
$self->{_debug_buffer} =~ |
143
|
0
|
|
|
|
|
0
|
s/(\r?\n)/$1$self->{_previous_direction}/smxg; |
144
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} =~ s/\A/$self->{_previous_direction}/smxg; |
145
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} =~ s/$quoted_previous_direction\Z//smxg; |
146
|
0
|
0
|
|
|
|
0
|
print {*STDERR} "$self->{_debug_buffer}" |
|
0
|
|
|
|
|
0
|
|
147
|
|
|
|
|
|
|
or Carp::croak("Failed to write to STDERR:$EXTENDED_OS_ERROR"); |
148
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} = $string; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
else { |
151
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} = $string; |
152
|
|
|
|
|
|
|
} |
153
|
0
|
|
|
|
|
0
|
while ( $self->{_debug_buffer} =~ s/\A([^\n]+\r?\n)//smx ) { |
154
|
0
|
0
|
|
|
|
0
|
print {*STDERR} "$direction$1" |
|
0
|
|
|
|
|
0
|
|
155
|
|
|
|
|
|
|
or Carp::croak("Failed to write to STDERR:$EXTENDED_OS_ERROR"); |
156
|
|
|
|
|
|
|
} |
157
|
0
|
|
|
|
|
0
|
$self->{_previous_direction} = $direction; |
158
|
|
|
|
|
|
|
} |
159
|
0
|
|
|
|
|
0
|
return; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
sub _debug_flush { |
163
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
164
|
0
|
0
|
|
|
|
0
|
if ( $self->{_debug} ) { |
165
|
0
|
|
|
|
|
0
|
my $quoted_previous_direction = quotemeta $self->{_previous_direction}; |
166
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} =~ s/(\r?\n)/$1$self->{_previous_direction}/smxg; |
167
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} =~ s/\A/$self->{_previous_direction}/smxg; |
168
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} =~ s/$quoted_previous_direction\Z//smxg; |
169
|
0
|
0
|
|
|
|
0
|
print {*STDERR} "$self->{_debug_buffer}" |
|
0
|
|
|
|
|
0
|
|
170
|
|
|
|
|
|
|
or Carp::croak("Failed to write to STDERR:$EXTENDED_OS_ERROR"); |
171
|
0
|
|
|
|
|
0
|
$self->{_debug_buffer} = q[]; |
172
|
|
|
|
|
|
|
} |
173
|
0
|
|
|
|
|
0
|
return; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
sub _write { |
177
|
0
|
|
|
0
|
|
0
|
my ( $self, $string ) = @_; |
178
|
0
|
|
|
|
|
0
|
my $icap_uri = $self->uri(); |
179
|
0
|
|
|
|
|
0
|
my $socket = $self->_socket(); |
180
|
0
|
|
|
|
|
0
|
$self->_debug(">> $string"); |
181
|
0
|
0
|
|
|
|
0
|
my $number_of_bytes = syswrite $socket, "$string" |
182
|
|
|
|
|
|
|
or Carp::croak( |
183
|
|
|
|
|
|
|
"Failed to write to icap server at $icap_uri:$EXTENDED_OS_ERROR"); |
184
|
0
|
|
|
|
|
0
|
return $number_of_bytes; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub _socket { |
188
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
189
|
0
|
|
|
|
|
0
|
return $self->{_socket}; |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
sub _connect { |
193
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
194
|
0
|
0
|
|
|
|
0
|
if ( !$self->{_socket} ) { |
195
|
0
|
|
|
|
|
0
|
my $socket_class = 'IO::Socket::INET'; |
196
|
0
|
|
|
|
|
0
|
my %options; |
197
|
0
|
0
|
|
|
|
0
|
if ( $self->_scheme() eq 'icaps' ) { |
198
|
0
|
|
|
|
|
0
|
$socket_class = 'IO::Socket::SSL'; |
199
|
0
|
|
|
|
|
0
|
%options = %{ $self->{_ssl} }; |
|
0
|
|
|
|
|
0
|
|
200
|
|
|
|
|
|
|
} |
201
|
0
|
0
|
|
|
|
0
|
my $socket = $socket_class->new( |
|
|
0
|
|
|
|
|
|
202
|
|
|
|
|
|
|
PeerAddr => $self->uri()->host(), |
203
|
|
|
|
|
|
|
PeerPort => $self->uri()->port(), |
204
|
|
|
|
|
|
|
Proto => 'tcp', |
205
|
|
|
|
|
|
|
%options, |
206
|
|
|
|
|
|
|
) |
207
|
|
|
|
|
|
|
or Carp::croak( |
208
|
|
|
|
|
|
|
'Failed to connect to ' |
209
|
|
|
|
|
|
|
. $self->uri()->host() |
210
|
|
|
|
|
|
|
. ' on port ' |
211
|
|
|
|
|
|
|
. $self->uri()->port() . q[:] |
212
|
|
|
|
|
|
|
. ( |
213
|
|
|
|
|
|
|
$socket_class eq 'IO::Socket::SSL' |
214
|
|
|
|
|
|
|
? $socket_class->errstr() |
215
|
|
|
|
|
|
|
: $EXTENDED_OS_ERROR |
216
|
|
|
|
|
|
|
) |
217
|
|
|
|
|
|
|
); |
218
|
|
|
|
|
|
|
|
219
|
0
|
|
|
|
|
0
|
$self->{_socket} = $socket; |
220
|
|
|
|
|
|
|
} |
221
|
0
|
|
|
|
|
0
|
return $self->{_socket}; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub _disconnect { |
225
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
226
|
0
|
|
|
|
|
0
|
delete $self->{_socket}; |
227
|
0
|
|
|
|
|
0
|
return; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
sub _process_icap_headers { |
231
|
0
|
|
|
0
|
|
0
|
my ( $self, $icap_headers, $icap_method ) = @_; |
232
|
0
|
|
|
|
|
0
|
my $quoted_pair = qr/\\./smx; |
233
|
0
|
|
|
|
|
0
|
my $qdtext = qr/[^"]/smx; |
234
|
0
|
|
|
|
|
0
|
my $quoted_string = qr/"((?:$quoted_pair|$qdtext)+)"/smx; |
235
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nISTag:[ ]*$quoted_string(?:\r?\n|$)/smx ) { |
|
|
0
|
|
|
|
|
|
236
|
0
|
|
|
|
|
0
|
$self->{_is_tag} = ($1); |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
elsif ( $icap_headers =~ /\r?\nISTag:[ ]*(\S+)(?:\r?\n|$)/smx ) |
239
|
|
|
|
|
|
|
{ # This violates RFC but is necessary to get the c-icap project to work |
240
|
0
|
|
|
|
|
0
|
$self->{_is_tag} = ($1); |
241
|
|
|
|
|
|
|
} |
242
|
0
|
0
|
|
|
|
0
|
if ( $icap_method eq 'OPTIONS' ) { |
243
|
0
|
|
|
|
|
0
|
delete $self->{_options}; |
244
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nMethods:[ ]*(.*?)(?:\r?\n|$)/smx ) { |
245
|
0
|
|
|
|
|
0
|
foreach my $method ( split /,[ ]*/smx, $1 ) { |
246
|
0
|
|
|
|
|
0
|
$self->{_options}->{methods}->{$method} = 1; |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
} |
249
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nPreview:[ ]*(\d+)(?:\r?\n|$)/smx ) { |
250
|
0
|
|
|
|
|
0
|
$self->{_options}->{preview} = $1; |
251
|
|
|
|
|
|
|
} |
252
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nService:[ ]*(.*?)(?:\r?\n|$)/smx ) { |
253
|
0
|
|
|
|
|
0
|
$self->{_options}->{service} = $1; |
254
|
|
|
|
|
|
|
} |
255
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nMax\-Connections:[ ]*(\d+)(?:\r?\n|$)/smx ) |
256
|
|
|
|
|
|
|
{ |
257
|
0
|
|
|
|
|
0
|
$self->{_options}->{max_connections} = $1; |
258
|
|
|
|
|
|
|
} |
259
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nOptions\-TTL:[ ]*(\d+)(?:\r?\n|$)/smx ) { |
260
|
0
|
|
|
|
|
0
|
$self->{_options}->{ttl} = $1; |
261
|
0
|
|
|
|
|
0
|
$self->{_options}->{expiry} = time + $1; |
262
|
|
|
|
|
|
|
} |
263
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /\r?\nAllow:[ ]*(.*?)(?:\r?\n|$)/smx ) { |
264
|
0
|
|
|
|
|
0
|
foreach my $allowed ( split /,[ ]*/smx, $1 ) { |
265
|
0
|
|
|
|
|
0
|
$self->{_options}->{allowed}->{$allowed} = 1; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
} |
269
|
0
|
|
|
|
|
0
|
return; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
sub _get_icap_header { |
273
|
0
|
|
|
0
|
|
0
|
my ( $self, $peek_buffer ) = @_; |
274
|
0
|
0
|
|
|
|
0
|
$peek_buffer = defined $peek_buffer ? $peek_buffer : q[]; |
275
|
0
|
|
|
|
|
0
|
my $entire_icap_headers_regex = _ENTIRE_ICAP_HEADERS_REGEX(); |
276
|
0
|
|
|
|
|
0
|
my $icap_uri = $self->uri(); |
277
|
0
|
|
|
|
|
0
|
my $socket = $self->_socket(); |
278
|
0
|
|
|
|
|
0
|
while ( $peek_buffer !~ /$entire_icap_headers_regex/smx ) { |
279
|
0
|
0
|
|
|
|
0
|
sysread $socket, my $buffer, _ICAP_RESPONSE_PEEK_SIZE() |
280
|
|
|
|
|
|
|
or Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
281
|
0
|
|
|
|
|
0
|
$peek_buffer .= $buffer; |
282
|
|
|
|
|
|
|
} |
283
|
0
|
0
|
|
|
|
0
|
if ( $peek_buffer =~ /^ICAP\/1[.]0[ ]([45]\d\d)[ ]/smx ) { |
284
|
0
|
|
|
|
|
0
|
$self->_disconnect(); |
285
|
0
|
|
|
|
|
0
|
Carp::croak("ICAP Server returned a $1 error"); |
286
|
|
|
|
|
|
|
} |
287
|
0
|
|
|
|
|
0
|
return $peek_buffer; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
sub _icap_response { |
291
|
0
|
|
|
0
|
|
0
|
my ( $self, %params ) = @_; |
292
|
0
|
|
|
|
|
0
|
my $icap_uri = $self->uri(); |
293
|
0
|
|
|
|
|
0
|
my $socket = $self->_socket(); |
294
|
0
|
|
|
|
|
0
|
my $peek_buffer = $self->_get_icap_header( $params{peek_buffer} ); |
295
|
0
|
|
|
|
|
0
|
$self->_debug("<< $peek_buffer"); |
296
|
0
|
|
|
|
|
0
|
my $entire_icap_headers_regex = _ENTIRE_ICAP_HEADERS_REGEX(); |
297
|
0
|
|
|
|
|
0
|
my ( $headers, $body_handle ); |
298
|
0
|
0
|
|
|
|
0
|
if ( $peek_buffer =~ s/$entire_icap_headers_regex//smx ) { |
299
|
0
|
|
|
|
|
0
|
my ($icap_headers) = ($1); |
300
|
0
|
|
|
|
|
0
|
$self->_process_icap_headers( $icap_headers, $params{icap_method} ); |
301
|
0
|
|
|
|
|
0
|
my $encapsulated_header_regex = |
302
|
|
|
|
|
|
|
qr/\r?\nEncapsulated:[ ]?(?:re[sq]\-hdr=(\d+),[ ]?)?(req|res|null)\-body=(\d+)(?:\r?\n|$)/smx; |
303
|
0
|
0
|
|
|
|
0
|
if ( $icap_headers =~ /$encapsulated_header_regex/smx ) { |
|
|
0
|
|
|
|
|
|
304
|
0
|
|
|
|
|
0
|
my ( $header_start_position, $type, $body_start_position ) = |
305
|
|
|
|
|
|
|
( $1, $2, $3 ); |
306
|
0
|
0
|
|
|
|
0
|
if ( defined $header_start_position ) { |
307
|
0
|
|
|
|
|
0
|
substr $peek_buffer, 0, $header_start_position, q[]; |
308
|
0
|
|
|
|
|
0
|
my $header_content = substr $peek_buffer, 0, |
309
|
|
|
|
|
|
|
$body_start_position, q[]; |
310
|
0
|
0
|
|
|
|
0
|
sysread $socket, my $buffer, |
311
|
|
|
|
|
|
|
$body_start_position - ( length $header_content ) |
312
|
|
|
|
|
|
|
or Carp::croak( |
313
|
|
|
|
|
|
|
"Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
314
|
0
|
|
|
|
|
0
|
$self->_debug("<< $buffer"); |
315
|
0
|
|
|
|
|
0
|
$header_content .= $buffer; |
316
|
0
|
0
|
|
|
|
0
|
if ( $type eq 'res' ) { |
|
|
0
|
|
|
|
|
|
317
|
0
|
|
|
|
|
0
|
$headers = HTTP::Response->parse($header_content); |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
elsif ( $type eq 'req' ) { |
320
|
0
|
|
|
|
|
0
|
$headers = HTTP::Request->parse($header_content); |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
} |
323
|
0
|
0
|
|
|
|
0
|
if ( $type eq 'null' ) { |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
else { |
326
|
0
|
|
|
|
|
0
|
$body_handle = File::Temp::tempfile(); |
327
|
0
|
|
|
|
|
0
|
while ( my $buffer = $self->_read_chunk() ) { |
328
|
0
|
|
|
|
|
0
|
$body_handle->print($buffer); |
329
|
|
|
|
|
|
|
} |
330
|
0
|
0
|
|
|
|
0
|
$body_handle->seek( Fcntl::SEEK_SET(), 0 ) |
331
|
|
|
|
|
|
|
or Carp::croak( |
332
|
|
|
|
|
|
|
"Failed to seek to start of temporary file:$EXTENDED_OS_ERROR" |
333
|
|
|
|
|
|
|
); |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
elsif ( $icap_headers =~ /^ICAP\/1[.]0[ ]204[ ]/smx ) { |
337
|
0
|
|
|
|
|
0
|
$self->_process_icap_headers( $icap_headers, $params{icap_method} ); |
338
|
0
|
|
|
|
|
0
|
$self->_reset_content_handle( $params{content_handle} ); |
339
|
0
|
|
|
|
|
0
|
$self->_debug_flush(); |
340
|
0
|
0
|
|
|
|
0
|
if ( defined $params{response} ) { |
341
|
0
|
|
|
|
|
0
|
return ( $params{response}, $params{content_handle} ); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
else { |
344
|
0
|
|
|
|
|
0
|
return ( $params{request}, $params{content_handle} ); |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
else { |
348
|
0
|
|
|
|
|
0
|
Carp::croak('Unable to parse Encapsulated header'); |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
else { |
352
|
0
|
|
|
|
|
0
|
Carp::croak('Unable to parse ICAP header'); |
353
|
|
|
|
|
|
|
} |
354
|
0
|
|
|
|
|
0
|
$self->_debug_flush(); |
355
|
0
|
|
|
|
|
0
|
return ( $headers, $body_handle ); |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub _read_chunk { |
359
|
0
|
|
|
0
|
|
0
|
my ($self) = @_; |
360
|
0
|
|
|
|
|
0
|
my $icap_uri = $self->uri(); |
361
|
0
|
|
|
|
|
0
|
my $socket = $self->_socket(); |
362
|
0
|
|
|
|
|
0
|
my $chunk_buffer = q[]; |
363
|
0
|
|
|
|
|
0
|
my $chunk_regex = qr/([a-f\d]+)\r?\n/smxi; |
364
|
0
|
|
|
|
|
0
|
while ( $chunk_buffer !~ /$chunk_regex/smxi ) { |
365
|
0
|
0
|
|
|
|
0
|
sysread $socket, my $byte, 1 |
366
|
|
|
|
|
|
|
or Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
367
|
0
|
|
|
|
|
0
|
$chunk_buffer .= $byte; |
368
|
|
|
|
|
|
|
} |
369
|
0
|
|
|
|
|
0
|
$self->_debug("<< $chunk_buffer"); |
370
|
0
|
0
|
|
|
|
0
|
if ( $chunk_buffer =~ /^$chunk_regex/smxi ) { |
371
|
0
|
|
|
|
|
0
|
my ($chunk_length) = ($1); |
372
|
0
|
0
|
|
|
|
0
|
if ( hex $chunk_length == 0 ) { |
373
|
0
|
|
|
|
|
0
|
my $length_of_crlf = length $Socket::CRLF; |
374
|
0
|
0
|
|
|
|
0
|
sysread $socket, my $chunk_content, $length_of_crlf |
375
|
|
|
|
|
|
|
or |
376
|
|
|
|
|
|
|
Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
377
|
0
|
|
|
|
|
0
|
$self->_debug("<< $chunk_content"); |
378
|
0
|
|
|
|
|
0
|
return; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
else { |
381
|
0
|
0
|
|
|
|
0
|
sysread $socket, my $chunk_content, hex $chunk_length |
382
|
|
|
|
|
|
|
or |
383
|
|
|
|
|
|
|
Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
384
|
0
|
|
|
|
|
0
|
$self->_debug("<< $chunk_content"); |
385
|
0
|
|
|
|
|
0
|
return $chunk_content; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
else { |
389
|
0
|
|
|
|
|
0
|
Carp::croak('Failed to parse chunking length'); |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
sub _write_in_chunks { |
394
|
0
|
|
|
0
|
|
0
|
my ( $self, $content ) = @_; |
395
|
0
|
|
|
|
|
0
|
my $CRLF = $Socket::CRLF; |
396
|
0
|
|
|
|
|
0
|
while ($content) { |
397
|
0
|
|
|
|
|
0
|
my $chunk = substr $content, 0, _CHUNK_SIZE(), q[]; |
398
|
0
|
|
|
|
|
0
|
$self->_write( |
399
|
|
|
|
|
|
|
POSIX::sprintf( '%x', ( length $chunk ) ) . "$CRLF$chunk$CRLF" ); |
400
|
|
|
|
|
|
|
} |
401
|
0
|
|
|
|
|
0
|
return; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
sub is_tag { |
405
|
0
|
|
|
0
|
1
|
0
|
my ($self) = @_; |
406
|
0
|
|
|
|
|
0
|
$self->_options(); |
407
|
0
|
|
|
|
|
0
|
return $self->{_is_tag}; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
sub agent { |
411
|
4
|
|
|
4
|
1
|
990
|
my ( $self, $agent ) = @_; |
412
|
4
|
|
|
|
|
4
|
my $old = $self->{_agent}; |
413
|
4
|
100
|
|
|
|
10
|
if ( @ARG > 1 ) { |
414
|
1
|
|
|
|
|
2
|
$self->{_agent} = $agent; |
415
|
|
|
|
|
|
|
} |
416
|
4
|
|
|
|
|
14
|
return $old; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
sub _options { |
420
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
421
|
0
|
0
|
0
|
|
|
|
if ( ( defined $self->{_options} ) |
|
|
|
0
|
|
|
|
|
422
|
|
|
|
|
|
|
&& ( defined $self->{_options}->{expiry} ) |
423
|
|
|
|
|
|
|
&& ( defined $self->{_options}->{expiry} < time ) ) |
424
|
|
|
|
|
|
|
{ |
425
|
|
|
|
|
|
|
} |
426
|
|
|
|
|
|
|
else { |
427
|
0
|
|
|
|
|
|
$self->_connect(); |
428
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
429
|
0
|
|
|
|
|
|
my $icap_uri = $self->uri(); |
430
|
0
|
|
|
|
|
|
my $icap_host = $icap_uri->host(); |
431
|
0
|
|
|
|
|
|
my $icap_agent = $self->agent(); |
432
|
0
|
|
|
|
|
|
my $icap_method = 'OPTIONS'; |
433
|
0
|
|
|
|
|
|
$self->_write( |
434
|
|
|
|
|
|
|
"$icap_method $icap_uri ICAP/1.0${CRLF}Host: $icap_host${CRLF}User-Agent: $icap_agent${CRLF}Encapsulated: null-body=0$CRLF$CRLF" |
435
|
|
|
|
|
|
|
); |
436
|
0
|
|
|
|
|
|
$self->_icap_response( icap_method => $icap_method ); |
437
|
|
|
|
|
|
|
} |
438
|
0
|
|
|
|
|
|
return; |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
sub _determine_icap_preview_header { |
442
|
0
|
|
|
0
|
|
|
my ( $self, $message, $content_handle ) = @_; |
443
|
0
|
|
|
|
|
|
my $preview_header = q[]; |
444
|
0
|
0
|
0
|
|
|
|
if ( ( $self->allow_preview() ) && ( defined $self->preview_size() ) ) { |
445
|
0
|
|
|
|
|
|
my $content_size; |
446
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
|
|
0
|
|
|
|
|
|
447
|
0
|
|
|
|
|
|
my @stat = stat $content_handle; |
448
|
|
|
|
|
|
|
scalar @stat |
449
|
0
|
0
|
|
|
|
|
or |
450
|
|
|
|
|
|
|
Carp::croak("Failed to stat content handle:$EXTENDED_OS_ERROR"); |
451
|
0
|
|
|
|
|
|
$content_size = $stat[ _STAT_SIZE_IDX() ]; |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
elsif ( my $content = $message->content() ) { |
454
|
0
|
|
|
|
|
|
$content_size = length $content; |
455
|
|
|
|
|
|
|
} |
456
|
0
|
0
|
0
|
|
|
|
if ( ( defined $content_size ) |
457
|
|
|
|
|
|
|
&& ( $content_size > $self->preview_size() ) ) |
458
|
|
|
|
|
|
|
{ |
459
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
460
|
0
|
|
|
|
|
|
$preview_header = 'Preview: ' . $self->preview_size() . $CRLF; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
} |
463
|
0
|
|
|
|
|
|
return $preview_header; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
sub _determine_icap_204_header { |
467
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
468
|
0
|
|
|
|
|
|
my $header_204 = q[]; |
469
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
470
|
0
|
0
|
0
|
|
|
|
if ( ( $self->allow_204() ) && ( $self->server_allows_204() ) ) { |
471
|
0
|
|
|
|
|
|
$header_204 .= 'Allow: 204' . $CRLF; |
472
|
|
|
|
|
|
|
} |
473
|
0
|
|
|
|
|
|
return $header_204; |
474
|
|
|
|
|
|
|
} |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
sub _get_request_headers { |
477
|
0
|
|
|
0
|
|
|
my ( $self, $request ) = @_; |
478
|
0
|
|
|
|
|
|
my $request_headers = q[]; |
479
|
0
|
0
|
|
|
|
|
if ( defined $request ) { |
480
|
0
|
|
|
|
|
|
my $http_uri = $request->uri(); |
481
|
0
|
|
|
|
|
|
my $http_host = $http_uri->host(); |
482
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
483
|
0
|
|
0
|
|
|
|
$request_headers = |
484
|
|
|
|
|
|
|
$request->method() . q[ ] |
485
|
|
|
|
|
|
|
. $request->uri()->path_query() . q[ ] |
486
|
|
|
|
|
|
|
. ( $request->protocol() || 'HTTP/1.1' ) |
487
|
|
|
|
|
|
|
. "${CRLF}Host: $http_host$CRLF" |
488
|
|
|
|
|
|
|
. $request->headers()->as_string($CRLF) |
489
|
|
|
|
|
|
|
. $CRLF; |
490
|
|
|
|
|
|
|
} |
491
|
0
|
|
|
|
|
|
return $request_headers; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
sub _get_response_headers { |
495
|
0
|
|
|
0
|
|
|
my ( $self, $request, $response ) = @_; |
496
|
0
|
|
|
|
|
|
my $response_headers = q[]; |
497
|
0
|
0
|
|
|
|
|
if ( defined $response ) { |
498
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
499
|
0
|
0
|
0
|
|
|
|
$response_headers = |
500
|
|
|
|
|
|
|
( defined $request |
501
|
|
|
|
|
|
|
&& $request->protocol() ? $request->protocol() : 'HTTP/1.1' ) |
502
|
|
|
|
|
|
|
. q[ ] |
503
|
|
|
|
|
|
|
. $response->code() . q[ ] |
504
|
|
|
|
|
|
|
. $response->message() |
505
|
|
|
|
|
|
|
. $CRLF |
506
|
|
|
|
|
|
|
. $response->headers()->as_string($CRLF) |
507
|
|
|
|
|
|
|
. $CRLF; |
508
|
|
|
|
|
|
|
} |
509
|
0
|
|
|
|
|
|
return $response_headers; |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
sub response { |
513
|
0
|
|
|
0
|
1
|
|
my ( $self, $request, $response, $content_handle ) = @_; |
514
|
0
|
|
|
|
|
|
$self->_connect(); |
515
|
0
|
|
|
|
|
|
my $request_headers = $self->_get_request_headers($request); |
516
|
0
|
|
|
|
|
|
my $response_headers = $self->_get_response_headers( $request, $response ); |
517
|
0
|
|
|
|
|
|
my $icap_uri = $self->uri(); |
518
|
0
|
|
|
|
|
|
my $icap_host = $icap_uri->host(); |
519
|
0
|
|
|
|
|
|
my $icap_agent = $self->agent(); |
520
|
0
|
|
|
|
|
|
my $icap_method = 'RESPMOD'; |
521
|
0
|
|
|
|
|
|
my $preview_header = |
522
|
|
|
|
|
|
|
$self->_determine_icap_preview_header( $response, $content_handle ); |
523
|
|
|
|
|
|
|
|
524
|
0
|
|
|
|
|
|
my $header_204 = $self->_determine_icap_204_header(); |
525
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
526
|
0
|
0
|
|
|
|
|
my $req_hdr = defined $request ? 'req-hdr=0, ' : q[]; |
527
|
0
|
|
|
|
|
|
$self->_write( |
528
|
|
|
|
|
|
|
"$icap_method $icap_uri ICAP/1.0${CRLF}Host: $icap_host${CRLF}User-Agent: $icap_agent${CRLF}${preview_header}${header_204}Encapsulated: ${req_hdr}res-hdr=" |
529
|
|
|
|
|
|
|
. ( length $request_headers ) |
530
|
|
|
|
|
|
|
. ', res-body=' |
531
|
|
|
|
|
|
|
. ( ( length $request_headers ) + ( length $response_headers ) ) |
532
|
|
|
|
|
|
|
. "$CRLF$CRLF$request_headers$response_headers" ); |
533
|
|
|
|
|
|
|
|
534
|
0
|
0
|
|
|
|
|
if ($preview_header) { |
535
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
|
|
0
|
|
|
|
|
|
536
|
0
|
|
|
|
|
|
my $bytes_read; |
537
|
0
|
|
|
|
|
|
while ( $bytes_read = sysread $content_handle, my $content, |
538
|
|
|
|
|
|
|
$self->preview_size() ) |
539
|
|
|
|
|
|
|
{ |
540
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
541
|
0
|
|
|
|
|
|
last; |
542
|
|
|
|
|
|
|
} |
543
|
0
|
0
|
|
|
|
|
defined $bytes_read |
544
|
|
|
|
|
|
|
or Carp::croak( |
545
|
|
|
|
|
|
|
"Failed to read from content handle:$EXTENDED_OS_ERROR"); |
546
|
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
elsif ( my $content = $response->content() ) { |
548
|
0
|
|
|
|
|
|
my $preview = substr $content, 0, $self->preview_size(); |
549
|
0
|
|
|
|
|
|
$response->content($content); |
550
|
0
|
|
|
|
|
|
$self->_write_in_chunks($preview); |
551
|
|
|
|
|
|
|
} |
552
|
0
|
|
|
|
|
|
$self->_write_terminating_chunk(); |
553
|
0
|
|
|
|
|
|
my $entire_icap_headers_regex = _ENTIRE_ICAP_HEADERS_REGEX(); |
554
|
0
|
|
|
|
|
|
my $socket = $self->_socket(); |
555
|
0
|
|
|
|
|
|
my $peek_buffer = q[]; |
556
|
0
|
|
|
|
|
|
while ( $peek_buffer !~ /$entire_icap_headers_regex/smx ) { |
557
|
0
|
0
|
|
|
|
|
sysread $socket, my $buffer, _ICAP_RESPONSE_PEEK_SIZE() |
558
|
|
|
|
|
|
|
or |
559
|
|
|
|
|
|
|
Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
560
|
0
|
|
|
|
|
|
$self->_debug("<< $buffer"); |
561
|
0
|
|
|
|
|
|
$peek_buffer .= $buffer; |
562
|
|
|
|
|
|
|
} |
563
|
0
|
0
|
|
|
|
|
if ( $peek_buffer =~ /$entire_icap_headers_regex/smx ) { |
564
|
0
|
|
|
|
|
|
my ($icap_headers) = ($1); |
565
|
0
|
|
|
|
|
|
$self->_process_icap_headers( $icap_headers, $icap_method ); |
566
|
|
|
|
|
|
|
} |
567
|
0
|
0
|
|
|
|
|
if ( $peek_buffer =~ /^ICAP\/1[.]0[ ]100[ ]/smx ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
568
|
|
|
|
|
|
|
} |
569
|
|
|
|
|
|
|
elsif ( $peek_buffer =~ /^ICAP\/1[.]0[ ]204[ ]/smx ) { |
570
|
0
|
|
|
|
|
|
$self->_reset_content_handle($content_handle); |
571
|
0
|
|
|
|
|
|
return ( $response, $content_handle ); |
572
|
|
|
|
|
|
|
} |
573
|
|
|
|
|
|
|
elsif ( $peek_buffer =~ /^ICAP\/1[.]0[ ]([45]\d\d)[ ]/smx ) { |
574
|
0
|
|
|
|
|
|
$self->_disconnect(); |
575
|
0
|
|
|
|
|
|
Carp::croak("ICAP Server returned a $1 error"); |
576
|
|
|
|
|
|
|
} |
577
|
|
|
|
|
|
|
else { |
578
|
0
|
|
|
|
|
|
return $self->_icap_response( |
579
|
|
|
|
|
|
|
icap_method => $icap_method, |
580
|
|
|
|
|
|
|
peek_buffer => $peek_buffer, |
581
|
|
|
|
|
|
|
request => $request, |
582
|
|
|
|
|
|
|
response => $response, |
583
|
|
|
|
|
|
|
content_handle => $content_handle |
584
|
|
|
|
|
|
|
); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
} |
587
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
|
|
0
|
|
|
|
|
|
588
|
0
|
|
|
|
|
|
my $bytes_read; |
589
|
0
|
|
|
|
|
|
while ( $bytes_read = read $content_handle, my $content, |
590
|
|
|
|
|
|
|
_FILE_READ_SIZE() ) |
591
|
|
|
|
|
|
|
{ |
592
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
593
|
|
|
|
|
|
|
} |
594
|
0
|
0
|
|
|
|
|
defined $bytes_read |
595
|
|
|
|
|
|
|
or |
596
|
|
|
|
|
|
|
Carp::croak("Failed to read from content handle:$EXTENDED_OS_ERROR"); |
597
|
|
|
|
|
|
|
} |
598
|
|
|
|
|
|
|
elsif ( my $content = $response->content() ) { |
599
|
0
|
0
|
|
|
|
|
if ($preview_header) { |
600
|
0
|
|
|
|
|
|
substr $content, 0, $self->preview_size(), q[]; |
601
|
|
|
|
|
|
|
} |
602
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
603
|
|
|
|
|
|
|
} |
604
|
0
|
|
|
|
|
|
$self->_write_terminating_chunk(); |
605
|
0
|
|
|
|
|
|
return $self->_icap_response( |
606
|
|
|
|
|
|
|
icap_method => $icap_method, |
607
|
|
|
|
|
|
|
request => $request, |
608
|
|
|
|
|
|
|
response => $response, |
609
|
|
|
|
|
|
|
content_handle => $content_handle |
610
|
|
|
|
|
|
|
); |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
sub _reset_content_handle { |
614
|
0
|
|
|
0
|
|
|
my ( $self, $content_handle ) = @_; |
615
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
616
|
0
|
0
|
|
|
|
|
seek $content_handle, Fcntl::SEEK_SET(), 0 |
617
|
|
|
|
|
|
|
or Carp::croak( |
618
|
|
|
|
|
|
|
"Failed to seek to start of content handle:$EXTENDED_OS_ERROR"); |
619
|
|
|
|
|
|
|
} |
620
|
0
|
|
|
|
|
|
return; |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
sub request { |
624
|
0
|
|
|
0
|
1
|
|
my ( $self, $request, $content_handle ) = @_; |
625
|
0
|
|
|
|
|
|
$self->_connect(); |
626
|
0
|
|
|
|
|
|
my $request_headers = $self->_get_request_headers($request); |
627
|
0
|
|
|
|
|
|
my $icap_uri = $self->uri(); |
628
|
0
|
|
|
|
|
|
my $icap_host = $icap_uri->host(); |
629
|
0
|
|
|
|
|
|
my $icap_agent = $self->agent(); |
630
|
0
|
|
|
|
|
|
my $icap_method = 'REQMOD'; |
631
|
0
|
|
|
|
|
|
my $preview_header = |
632
|
|
|
|
|
|
|
$self->_determine_icap_preview_header( $request, $content_handle ); |
633
|
|
|
|
|
|
|
|
634
|
0
|
|
|
|
|
|
my $header_204 = $self->_determine_icap_204_header(); |
635
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
636
|
0
|
|
|
|
|
|
$self->_write( |
637
|
|
|
|
|
|
|
"$icap_method $icap_uri ICAP/1.0${CRLF}Host: $icap_host${CRLF}User-Agent: $icap_agent${CRLF}${preview_header}${header_204}Encapsulated: req-hdr=0, req-body=" |
638
|
|
|
|
|
|
|
. ( length $request_headers ) |
639
|
|
|
|
|
|
|
. "$CRLF$CRLF$request_headers" ); |
640
|
0
|
0
|
|
|
|
|
if ($preview_header) { |
641
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
|
|
0
|
|
|
|
|
|
642
|
0
|
|
|
|
|
|
my $bytes_read; |
643
|
0
|
|
|
|
|
|
while ( $bytes_read = sysread $content_handle, my $content, |
644
|
|
|
|
|
|
|
$self->preview_size() ) |
645
|
|
|
|
|
|
|
{ |
646
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
647
|
0
|
|
|
|
|
|
last; |
648
|
|
|
|
|
|
|
} |
649
|
0
|
0
|
|
|
|
|
defined $bytes_read |
650
|
|
|
|
|
|
|
or Carp::croak( |
651
|
|
|
|
|
|
|
"Failed to read from content handle:$EXTENDED_OS_ERROR"); |
652
|
|
|
|
|
|
|
} |
653
|
|
|
|
|
|
|
elsif ( my $content = $request->content() ) { |
654
|
0
|
|
|
|
|
|
my $preview = substr $content, 0, $self->preview_size(); |
655
|
0
|
|
|
|
|
|
$request->content($content); |
656
|
0
|
|
|
|
|
|
$self->_write_in_chunks($preview); |
657
|
|
|
|
|
|
|
} |
658
|
0
|
|
|
|
|
|
$self->_write_terminating_chunk(); |
659
|
0
|
|
|
|
|
|
my $entire_icap_headers_regex = _ENTIRE_ICAP_HEADERS_REGEX(); |
660
|
0
|
|
|
|
|
|
my $socket = $self->_socket(); |
661
|
0
|
|
|
|
|
|
my $peek_buffer = q[]; |
662
|
0
|
|
|
|
|
|
while ( $peek_buffer !~ /$entire_icap_headers_regex/smx ) { |
663
|
0
|
0
|
|
|
|
|
sysread $socket, my $buffer, _ICAP_RESPONSE_PEEK_SIZE() |
664
|
|
|
|
|
|
|
or |
665
|
|
|
|
|
|
|
Carp::croak("Failed to read from $icap_uri:$EXTENDED_OS_ERROR"); |
666
|
0
|
|
|
|
|
|
$self->_debug("<< $buffer"); |
667
|
0
|
|
|
|
|
|
$peek_buffer .= $buffer; |
668
|
|
|
|
|
|
|
} |
669
|
0
|
0
|
|
|
|
|
if ( $peek_buffer =~ /$entire_icap_headers_regex/smx ) { |
670
|
0
|
|
|
|
|
|
my ($icap_headers) = ($1); |
671
|
0
|
|
|
|
|
|
$self->_process_icap_headers( $icap_headers, $icap_method ); |
672
|
|
|
|
|
|
|
} |
673
|
0
|
0
|
|
|
|
|
if ( $peek_buffer =~ /^ICAP\/1[.]0[ ]100[ ]/smx ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
elsif ( $peek_buffer =~ /^ICAP\/1[.]0[ ]204[ ]/smx ) { |
676
|
0
|
|
|
|
|
|
$self->_reset_content_handle($content_handle); |
677
|
0
|
|
|
|
|
|
return ( $request, $content_handle ); |
678
|
|
|
|
|
|
|
} |
679
|
|
|
|
|
|
|
elsif ( $peek_buffer =~ /^ICAP\/1[.]0[ ]([45]\d\d)[ ]/smx ) { |
680
|
0
|
|
|
|
|
|
$self->_disconnect(); |
681
|
0
|
|
|
|
|
|
Carp::croak("ICAP Server returned a $1 error"); |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
else { |
684
|
0
|
|
|
|
|
|
return $self->_icap_response( |
685
|
|
|
|
|
|
|
icap_method => $icap_method, |
686
|
|
|
|
|
|
|
peek_buffer => $peek_buffer, |
687
|
|
|
|
|
|
|
request => $request, |
688
|
|
|
|
|
|
|
content_handle => $content_handle |
689
|
|
|
|
|
|
|
); |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
} |
692
|
0
|
0
|
|
|
|
|
if ( defined $content_handle ) { |
|
|
0
|
|
|
|
|
|
693
|
0
|
|
|
|
|
|
my $bytes_read; |
694
|
0
|
|
|
|
|
|
while ( $bytes_read = read $content_handle, my $content, |
695
|
|
|
|
|
|
|
_FILE_READ_SIZE() ) |
696
|
|
|
|
|
|
|
{ |
697
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
698
|
|
|
|
|
|
|
} |
699
|
0
|
0
|
|
|
|
|
defined $bytes_read |
700
|
|
|
|
|
|
|
or |
701
|
|
|
|
|
|
|
Carp::croak("Failed to read from content handle:$EXTENDED_OS_ERROR"); |
702
|
|
|
|
|
|
|
} |
703
|
|
|
|
|
|
|
elsif ( my $content = $request->content() ) { |
704
|
0
|
0
|
|
|
|
|
if ($preview_header) { |
705
|
0
|
|
|
|
|
|
substr $content, 0, $self->preview_size(), q[]; |
706
|
|
|
|
|
|
|
} |
707
|
0
|
|
|
|
|
|
$self->_write_in_chunks($content); |
708
|
|
|
|
|
|
|
} |
709
|
0
|
|
|
|
|
|
$self->_write_terminating_chunk(); |
710
|
0
|
|
|
|
|
|
return $self->_icap_response( |
711
|
|
|
|
|
|
|
icap_method => $icap_method, |
712
|
|
|
|
|
|
|
request => $request, |
713
|
|
|
|
|
|
|
content_handle => $content_handle |
714
|
|
|
|
|
|
|
); |
715
|
|
|
|
|
|
|
} |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
sub _write_terminating_chunk { |
718
|
0
|
|
|
0
|
|
|
my ($self) = @_; |
719
|
0
|
|
|
|
|
|
my $CRLF = $Socket::CRLF; |
720
|
0
|
|
|
|
|
|
return $self->_write("0$CRLF$CRLF"); |
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
1; |
724
|
|
|
|
|
|
|
__END__ |