File Coverage

blib/lib/Net/ICAP/Client.pm
Criterion Covered Total %
statement 68 397 17.1
branch 10 174 5.7
condition 0 26 0.0
subroutine 16 49 32.6
pod 14 14 100.0
total 108 660 16.3


line stmt bran cond sub pod time code
1             package Net::ICAP::Client;
2              
3 2     2   164042 use strict;
  2         19  
  2         59  
4 2     2   10 use warnings;
  2         3  
  2         56  
5 2     2   1126 use English qw(-no_match_vars);
  2         5372  
  2         11  
6 2     2   1726 use IO::Socket::INET();
  2         33680  
  2         81  
7 2     2   1730 use IO::Socket::SSL();
  2         131493  
  2         76  
8 2     2   17 use Carp();
  2         4  
  2         32  
9 2     2   1426 use URI();
  2         13287  
  2         45  
10 2     2   1009 use HTTP::Request();
  2         28649  
  2         49  
11 2     2   1013 use HTTP::Response();
  2         14985  
  2         71  
12 2     2   20 use POSIX();
  2         4  
  2         11137  
13              
14             our $VERSION = '0.08';
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 990 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       9745 if ( $self->{_uri}->_scheme() eq 'icaps' ) {
32 1         128 $self->{_ssl} = { SSL_verify_mode => 1 };
33 1         5 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       135 if ( -f $possible_ca_file ) {
39 0         0 $self->{_ssl}->{SSL_ca_file} = $possible_ca_file;
40             }
41             }
42 1         5 foreach my $possible_ca_path ( '/usr/share/ca-certificates', ) {
43 1 50       44 if ( -f $possible_ca_path ) {
44 0         0 $self->{_ssl}->{SSL_ca_path} = $possible_ca_path;
45             }
46             }
47 1         6 $self->{_ssl}->{SSL_verifycn_scheme} = 'http';
48 1         10 $self->{_ssl}->{SSL_verifycn_name} = $self->{_uri}->host();
49 1         82 delete $params{SSL};
50             }
51 2         71 foreach my $key ( sort { $a cmp $b } keys %params ) {
  0         0  
52 1 50       6 if ( $key =~ /^SSL_/smx ) {
53 1         5 $self->{_ssl}->{$key} = delete $params{$key};
54             }
55             }
56 2         7 bless $self, $class;
57 2         20 return $self;
58             }
59              
60             sub debug {
61 1     1 1 5 my ( $self, $debug ) = @_;
62 1         4 my $old = $self->{_debug};
63 1 50       4 if ( @ARG > 1 ) {
64 1         3 $self->{_debug} = $debug;
65             }
66 1         5 return $old;
67             }
68              
69             sub allow_204 {
70 1     1 1 6 my ( $self, $allow_204 ) = @_;
71 1         3 my $old = $self->{_allow_204};
72 1 50       4 if ( @ARG > 1 ) {
73 1         2 $self->{_allow_204} = $allow_204;
74             }
75 1         5 return $old;
76             }
77              
78             sub allow_preview {
79 1     1 1 6 my ( $self, $allow_preview ) = @_;
80 1         3 my $old = $self->{_allow_preview};
81 1 50       7 if ( @ARG > 1 ) {
82 1         4 $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 1359 my ($self) = @_;
94 6         35 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 1434 my ( $self, $agent ) = @_;
412 4         8 my $old = $self->{_agent};
413 4 100       13 if ( @ARG > 1 ) {
414 1         2 $self->{_agent} = $agent;
415             }
416 4         24 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__