This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update HTTP::Tiny to CPAN version 0.012
[perl5.git] / cpan / HTTP-Tiny / lib / HTTP / Tiny.pm
1 # vim: ts=4 sts=4 sw=4 et:
2 #
3 # This file is part of HTTP-Tiny
4 #
5 # This software is copyright (c) 2011 by Christian Hansen.
6 #
7 # This is free software; you can redistribute it and/or modify it under
8 # the same terms as the Perl 5 programming language system itself.
9 #
10 package HTTP::Tiny;
11 BEGIN {
12   $HTTP::Tiny::VERSION = '0.012';
13 }
14 use strict;
15 use warnings;
16 # ABSTRACT: A small, simple, correct HTTP/1.1 client
17
18 use Carp ();
19
20
21 my @attributes;
22 BEGIN {
23     @attributes = qw(agent default_headers max_redirect max_size proxy timeout);
24     no strict 'refs';
25     for my $accessor ( @attributes ) {
26         *{$accessor} = sub {
27             @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
28         };
29     }
30 }
31
32 sub new {
33     my($class, %args) = @_;
34     (my $agent = $class) =~ s{::}{-}g;
35     my $self = {
36         agent        => $agent . "/" . ($class->VERSION || 0),
37         max_redirect => 5,
38         timeout      => 60,
39     };
40     for my $key ( @attributes ) {
41         $self->{$key} = $args{$key} if exists $args{$key}
42     }
43     return bless $self, $class;
44 }
45
46
47 sub get {
48     my ($self, $url, $args) = @_;
49     @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
50       or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/);
51     return $self->request('GET', $url, $args || {});
52 }
53
54
55 sub mirror {
56     my ($self, $url, $file, $args) = @_;
57     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
58       or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/);
59     if ( -e $file and my $mtime = (stat($file))[9] ) {
60         $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
61     }
62     my $tempfile = $file . int(rand(2**31));
63     open my $fh, ">", $tempfile
64         or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!/);
65     binmode $fh;
66     $args->{data_callback} = sub { print {$fh} $_[0] };
67     my $response = $self->request('GET', $url, $args);
68     close $fh
69         or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!/);
70     if ( $response->{success} ) {
71         rename $tempfile, $file
72             or Carp::croak "Error replacing $file with $tempfile: $!\n";
73         my $lm = $response->{headers}{'last-modified'};
74         if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
75             utime $mtime, $mtime, $file;
76         }
77     }
78     $response->{success} ||= $response->{status} eq '304';
79     unlink $tempfile;
80     return $response;
81 }
82
83
84 my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
85
86 sub request {
87     my ($self, $method, $url, $args) = @_;
88     @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
89       or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
90     $args ||= {}; # we keep some state in this during _request
91
92     # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
93     my $response;
94     for ( 0 .. 1 ) {
95         $response = eval { $self->_request($method, $url, $args) };
96         last unless $@ && $idempotent{$method}
97             && $@ =~ m{^(?:Socket closed|Unexpected end)};
98     }
99
100     if (my $e = "$@") {
101         $response = {
102             success => q{},
103             status  => 599,
104             reason  => 'Internal Exception',
105             content => $e,
106             headers => {
107                 'content-type'   => 'text/plain',
108                 'content-length' => length $e,
109             }
110         };
111     }
112     return $response;
113 }
114
115 my %DefaultPort = (
116     http => 80,
117     https => 443,
118 );
119
120 sub _request {
121     my ($self, $method, $url, $args) = @_;
122
123     my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
124
125     my $request = {
126         method    => $method,
127         scheme    => $scheme,
128         host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
129         uri       => $path_query,
130         headers   => {},
131     };
132
133     my $handle  = HTTP::Tiny::Handle->new(timeout => $self->{timeout});
134
135     if ($self->{proxy}) {
136         $request->{uri} = "$scheme://$request->{host_port}$path_query";
137         croak(qq/HTTPS via proxy is not supported/)
138             if $request->{scheme} eq 'https';
139         $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
140     }
141     else {
142         $handle->connect($scheme, $host, $port);
143     }
144
145     $self->_prepare_headers_and_cb($request, $args);
146     $handle->write_request($request);
147
148     my $response;
149     do { $response = $handle->read_response_header }
150         until (substr($response->{status},0,1) ne '1');
151
152     if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
153         $handle->close;
154         return $self->_request(@redir_args, $args);
155     }
156
157     if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
158         # response has no message body
159     }
160     else {
161         my $data_cb = $self->_prepare_data_cb($response, $args);
162         $handle->read_body($data_cb, $response);
163     }
164
165     $handle->close;
166     $response->{success} = substr($response->{status},0,1) eq '2';
167     return $response;
168 }
169
170 sub _prepare_headers_and_cb {
171     my ($self, $request, $args) = @_;
172
173     for ($self->{default_headers}, $args->{headers}) {
174         next unless defined;
175         while (my ($k, $v) = each %$_) {
176             $request->{headers}{lc $k} = $v;
177         }
178     }
179     $request->{headers}{'host'}         = $request->{host_port};
180     $request->{headers}{'connection'}   = "close";
181     $request->{headers}{'user-agent'} ||= $self->{agent};
182
183     if (defined $args->{content}) {
184         $request->{headers}{'content-type'} ||= "application/octet-stream";
185         if (ref $args->{content} eq 'CODE') {
186             $request->{headers}{'transfer-encoding'} = 'chunked'
187               unless $request->{headers}{'content-length'}
188                   || $request->{headers}{'transfer-encoding'};
189             $request->{cb} = $args->{content};
190         }
191         else {
192             my $content = $args->{content};
193             if ( $] ge '5.008' ) {
194                 utf8::downgrade($content, 1)
195                     or Carp::croak(q/Wide character in request message body/);
196             }
197             $request->{headers}{'content-length'} = length $content
198               unless $request->{headers}{'content-length'}
199                   || $request->{headers}{'transfer-encoding'};
200             $request->{cb} = sub { substr $content, 0, length $content, '' };
201         }
202         $request->{trailer_cb} = $args->{trailer_callback}
203             if ref $args->{trailer_callback} eq 'CODE';
204     }
205     return;
206 }
207
208 sub _prepare_data_cb {
209     my ($self, $response, $args) = @_;
210     my $data_cb = $args->{data_callback};
211     $response->{content} = '';
212
213     if (!$data_cb || $response->{status} !~ /^2/) {
214         if (defined $self->{max_size}) {
215             $data_cb = sub {
216                 $_[1]->{content} .= $_[0];
217                 die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
218                   if length $_[1]->{content} > $self->{max_size};
219             };
220         }
221         else {
222             $data_cb = sub { $_[1]->{content} .= $_[0] };
223         }
224     }
225     return $data_cb;
226 }
227
228 sub _maybe_redirect {
229     my ($self, $request, $response, $args) = @_;
230     my $headers = $response->{headers};
231     my ($status, $method) = ($response->{status}, $request->{method});
232     if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
233         and $headers->{location}
234         and ++$args->{redirects} <= $self->{max_redirect}
235     ) {
236         my $location = ($headers->{location} =~ /^\//)
237             ? "$request->{scheme}://$request->{host_port}$headers->{location}"
238             : $headers->{location} ;
239         return (($status eq '303' ? 'GET' : $method), $location);
240     }
241     return;
242 }
243
244 sub _split_url {
245     my $url = pop;
246
247     # URI regex adapted from the URI module
248     my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
249       or Carp::croak(qq/Cannot parse URL: '$url'/);
250
251     $scheme     = lc $scheme;
252     $path_query = "/$path_query" unless $path_query =~ m<\A/>;
253
254     my $host = (length($authority)) ? lc $authority : 'localhost';
255        $host =~ s/\A[^@]*@//;   # userinfo
256     my $port = do {
257        $host =~ s/:([0-9]*)\z// && length $1
258          ? $1
259          : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
260     };
261
262     return ($scheme, $host, $port, $path_query);
263 }
264
265 # Date conversions adapted from HTTP::Date
266 my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
267 my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
268 sub _http_date {
269     my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
270     return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
271         substr($DoW,$wday*4,3),
272         $mday, substr($MoY,$mon*4,3), $year+1900,
273         $hour, $min, $sec
274     );
275 }
276
277 sub _parse_http_date {
278     my ($self, $str) = @_;
279     require Time::Local;
280     my @tl_parts;
281     if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
282         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
283     }
284     elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
285         @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
286     }
287     elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
288         @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
289     }
290     return eval {
291         my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
292         $t < 0 ? undef : $t;
293     };
294 }
295
296 package
297     HTTP::Tiny::Handle; # hide from PAUSE/indexers
298 use strict;
299 use warnings;
300
301 use Carp       qw[croak];
302 use Errno      qw[EINTR EPIPE];
303 use IO::Socket qw[SOCK_STREAM];
304
305 sub BUFSIZE () { 32768 }
306
307 my $Printable = sub {
308     local $_ = shift;
309     s/\r/\\r/g;
310     s/\n/\\n/g;
311     s/\t/\\t/g;
312     s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
313     $_;
314 };
315
316 my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
317
318 sub new {
319     my ($class, %args) = @_;
320     return bless {
321         rbuf             => '',
322         timeout          => 60,
323         max_line_size    => 16384,
324         max_header_lines => 64,
325         %args
326     }, $class;
327 }
328
329 my $ssl_verify_args = {
330     check_cn => "when_only",
331     wildcards_in_alt => "anywhere",
332     wildcards_in_cn => "anywhere"
333 };
334
335 sub connect {
336     @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
337     my ($self, $scheme, $host, $port) = @_;
338
339     if ( $scheme eq 'https' ) {
340         eval "require IO::Socket::SSL"
341             unless exists $INC{'IO/Socket/SSL.pm'};
342         croak(qq/IO::Socket::SSL must be installed for https support\n/)
343             unless $INC{'IO/Socket/SSL.pm'};
344     }
345     elsif ( $scheme ne 'http' ) {
346       croak(qq/Unsupported URL scheme '$scheme'/);
347     }
348
349     $self->{fh} = 'IO::Socket::INET'->new(
350         PeerHost  => $host,
351         PeerPort  => $port,
352         Proto     => 'tcp',
353         Type      => SOCK_STREAM,
354         Timeout   => $self->{timeout}
355     ) or croak(qq/Could not connect to '$host:$port': $@/);
356
357     binmode($self->{fh})
358       or croak(qq/Could not binmode() socket: '$!'/);
359
360     if ( $scheme eq 'https') {
361         IO::Socket::SSL->start_SSL($self->{fh});
362         ref($self->{fh}) eq 'IO::Socket::SSL'
363             or die(qq/SSL connection failed for $host\n/);
364         $self->{fh}->verify_hostname( $host, $ssl_verify_args )
365             or die(qq/SSL certificate not valid for $host\n/);
366     }
367
368     $self->{host} = $host;
369     $self->{port} = $port;
370
371     return $self;
372 }
373
374 sub close {
375     @_ == 1 || croak(q/Usage: $handle->close()/);
376     my ($self) = @_;
377     CORE::close($self->{fh})
378       or croak(qq/Could not close socket: '$!'/);
379 }
380
381 sub write {
382     @_ == 2 || croak(q/Usage: $handle->write(buf)/);
383     my ($self, $buf) = @_;
384
385     if ( $] ge '5.008' ) {
386         utf8::downgrade($buf, 1)
387             or croak(q/Wide character in write()/);
388     }
389
390     my $len = length $buf;
391     my $off = 0;
392
393     local $SIG{PIPE} = 'IGNORE';
394
395     while () {
396         $self->can_write
397           or croak(q/Timed out while waiting for socket to become ready for writing/);
398         my $r = syswrite($self->{fh}, $buf, $len, $off);
399         if (defined $r) {
400             $len -= $r;
401             $off += $r;
402             last unless $len > 0;
403         }
404         elsif ($! == EPIPE) {
405             croak(qq/Socket closed by remote server: $!/);
406         }
407         elsif ($! != EINTR) {
408             croak(qq/Could not write to socket: '$!'/);
409         }
410     }
411     return $off;
412 }
413
414 sub read {
415     @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/);
416     my ($self, $len, $allow_partial) = @_;
417
418     my $buf  = '';
419     my $got = length $self->{rbuf};
420
421     if ($got) {
422         my $take = ($got < $len) ? $got : $len;
423         $buf  = substr($self->{rbuf}, 0, $take, '');
424         $len -= $take;
425     }
426
427     while ($len > 0) {
428         $self->can_read
429           or croak(q/Timed out while waiting for socket to become ready for reading/);
430         my $r = sysread($self->{fh}, $buf, $len, length $buf);
431         if (defined $r) {
432             last unless $r;
433             $len -= $r;
434         }
435         elsif ($! != EINTR) {
436             croak(qq/Could not read from socket: '$!'/);
437         }
438     }
439     if ($len && !$allow_partial) {
440         croak(q/Unexpected end of stream/);
441     }
442     return $buf;
443 }
444
445 sub readline {
446     @_ == 1 || croak(q/Usage: $handle->readline()/);
447     my ($self) = @_;
448
449     while () {
450         if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
451             return $1;
452         }
453         if (length $self->{rbuf} >= $self->{max_line_size}) {
454             croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/);
455         }
456         $self->can_read
457           or croak(q/Timed out while waiting for socket to become ready for reading/);
458         my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
459         if (defined $r) {
460             last unless $r;
461         }
462         elsif ($! != EINTR) {
463             croak(qq/Could not read from socket: '$!'/);
464         }
465     }
466     croak(q/Unexpected end of stream while looking for line/);
467 }
468
469 sub read_header_lines {
470     @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
471     my ($self, $headers) = @_;
472     $headers ||= {};
473     my $lines   = 0;
474     my $val;
475
476     while () {
477          my $line = $self->readline;
478
479          if (++$lines >= $self->{max_header_lines}) {
480              croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/);
481          }
482          elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
483              my ($field_name) = lc $1;
484              if (exists $headers->{$field_name}) {
485                  for ($headers->{$field_name}) {
486                      $_ = [$_] unless ref $_ eq "ARRAY";
487                      push @$_, $2;
488                      $val = \$_->[-1];
489                  }
490              }
491              else {
492                  $val = \($headers->{$field_name} = $2);
493              }
494          }
495          elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
496              $val
497                or croak(q/Unexpected header continuation line/);
498              next unless length $1;
499              $$val .= ' ' if length $$val;
500              $$val .= $1;
501          }
502          elsif ($line =~ /\A \x0D?\x0A \z/x) {
503             last;
504          }
505          else {
506             croak(q/Malformed header line: / . $Printable->($line));
507          }
508     }
509     return $headers;
510 }
511
512 sub write_request {
513     @_ == 2 || croak(q/Usage: $handle->write_request(request)/);
514     my($self, $request) = @_;
515     $self->write_request_header(@{$request}{qw/method uri headers/});
516     $self->write_body($request) if $request->{cb};
517     return;
518 }
519
520 my %HeaderCase = (
521     'content-md5'      => 'Content-MD5',
522     'etag'             => 'ETag',
523     'te'               => 'TE',
524     'www-authenticate' => 'WWW-Authenticate',
525     'x-xss-protection' => 'X-XSS-Protection',
526 );
527
528 sub write_header_lines {
529     (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
530     my($self, $headers) = @_;
531
532     my $buf = '';
533     while (my ($k, $v) = each %$headers) {
534         my $field_name = lc $k;
535         if (exists $HeaderCase{$field_name}) {
536             $field_name = $HeaderCase{$field_name};
537         }
538         else {
539             $field_name =~ /\A $Token+ \z/xo
540               or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
541             $field_name =~ s/\b(\w)/\u$1/g;
542             $HeaderCase{lc $field_name} = $field_name;
543         }
544         for (ref $v eq 'ARRAY' ? @$v : $v) {
545             /[^\x0D\x0A]/
546               or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_));
547             $buf .= "$field_name: $_\x0D\x0A";
548         }
549     }
550     $buf .= "\x0D\x0A";
551     return $self->write($buf);
552 }
553
554 sub read_body {
555     @_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/);
556     my ($self, $cb, $response) = @_;
557     my $te = $response->{headers}{'transfer-encoding'} || '';
558     if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
559         $self->read_chunked_body($cb, $response);
560     }
561     else {
562         $self->read_content_body($cb, $response);
563     }
564     return;
565 }
566
567 sub write_body {
568     @_ == 2 || croak(q/Usage: $handle->write_body(request)/);
569     my ($self, $request) = @_;
570     if ($request->{headers}{'content-length'}) {
571         return $self->write_content_body($request);
572     }
573     else {
574         return $self->write_chunked_body($request);
575     }
576 }
577
578 sub read_content_body {
579     @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
580     my ($self, $cb, $response, $content_length) = @_;
581     $content_length ||= $response->{headers}{'content-length'};
582
583     if ( $content_length ) {
584         my $len = $content_length;
585         while ($len > 0) {
586             my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
587             $cb->($self->read($read, 0), $response);
588             $len -= $read;
589         }
590     }
591     else {
592         my $chunk;
593         $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
594     }
595
596     return;
597 }
598
599 sub write_content_body {
600     @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
601     my ($self, $request) = @_;
602
603     my ($len, $content_length) = (0, $request->{headers}{'content-length'});
604     while () {
605         my $data = $request->{cb}->();
606
607         defined $data && length $data
608           or last;
609
610         if ( $] ge '5.008' ) {
611             utf8::downgrade($data, 1)
612                 or croak(q/Wide character in write_content()/);
613         }
614
615         $len += $self->write($data);
616     }
617
618     $len == $content_length
619       or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
620
621     return $len;
622 }
623
624 sub read_chunked_body {
625     @_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/);
626     my ($self, $cb, $response) = @_;
627
628     while () {
629         my $head = $self->readline;
630
631         $head =~ /\A ([A-Fa-f0-9]+)/x
632           or croak(q/Malformed chunk head: / . $Printable->($head));
633
634         my $len = hex($1)
635           or last;
636
637         $self->read_content_body($cb, $response, $len);
638
639         $self->read(2) eq "\x0D\x0A"
640           or croak(q/Malformed chunk: missing CRLF after chunk data/);
641     }
642     $self->read_header_lines($response->{headers});
643     return;
644 }
645
646 sub write_chunked_body {
647     @_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/);
648     my ($self, $request) = @_;
649
650     my $len = 0;
651     while () {
652         my $data = $request->{cb}->();
653
654         defined $data && length $data
655           or last;
656
657         if ( $] ge '5.008' ) {
658             utf8::downgrade($data, 1)
659                 or croak(q/Wide character in write_chunked_body()/);
660         }
661
662         $len += length $data;
663
664         my $chunk  = sprintf '%X', length $data;
665            $chunk .= "\x0D\x0A";
666            $chunk .= $data;
667            $chunk .= "\x0D\x0A";
668
669         $self->write($chunk);
670     }
671     $self->write("0\x0D\x0A");
672     $self->write_header_lines($request->{trailer_cb}->())
673         if ref $request->{trailer_cb} eq 'CODE';
674     return $len;
675 }
676
677 sub read_response_header {
678     @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
679     my ($self) = @_;
680
681     my $line = $self->readline;
682
683     $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
684       or croak(q/Malformed Status-Line: / . $Printable->($line));
685
686     my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
687
688     croak (qq/Unsupported HTTP protocol: $protocol/)
689         unless $version =~ /0*1\.0*[01]/;
690
691     return {
692         status   => $status,
693         reason   => $reason,
694         headers  => $self->read_header_lines,
695         protocol => $protocol,
696     };
697 }
698
699 sub write_request_header {
700     @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
701     my ($self, $method, $request_uri, $headers) = @_;
702
703     return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
704          + $self->write_header_lines($headers);
705 }
706
707 sub _do_timeout {
708     my ($self, $type, $timeout) = @_;
709     $timeout = $self->{timeout}
710         unless defined $timeout && $timeout >= 0;
711
712     my $fd = fileno $self->{fh};
713     defined $fd && $fd >= 0
714       or croak(q/select(2): 'Bad file descriptor'/);
715
716     my $initial = time;
717     my $pending = $timeout;
718     my $nfound;
719
720     vec(my $fdset = '', $fd, 1) = 1;
721
722     while () {
723         $nfound = ($type eq 'read')
724             ? select($fdset, undef, undef, $pending)
725             : select(undef, $fdset, undef, $pending) ;
726         if ($nfound == -1) {
727             $! == EINTR
728               or croak(qq/select(2): '$!'/);
729             redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
730             $nfound = 0;
731         }
732         last;
733     }
734     $! = 0;
735     return $nfound;
736 }
737
738 sub can_read {
739     @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
740     my $self = shift;
741     return $self->_do_timeout('read', @_)
742 }
743
744 sub can_write {
745     @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
746     my $self = shift;
747     return $self->_do_timeout('write', @_)
748 }
749
750 1;
751
752
753
754 __END__
755 =pod
756
757 =head1 NAME
758
759 HTTP::Tiny - A small, simple, correct HTTP/1.1 client
760
761 =head1 VERSION
762
763 version 0.012
764
765 =head1 SYNOPSIS
766
767     use HTTP::Tiny;
768
769     my $response = HTTP::Tiny->new->get('http://example.com/');
770
771     die "Failed!\n" unless $response->{success};
772
773     print "$response->{status} $response->{reason}\n";
774
775     while (my ($k, $v) = each %{$response->{headers}}) {
776         for (ref $v eq 'ARRAY' ? @$v : $v) {
777             print "$k: $_\n";
778         }
779     }
780
781     print $response->{content} if length $response->{content};
782
783 =head1 DESCRIPTION
784
785 This is a very simple HTTP/1.1 client, designed primarily for doing simple GET
786 requests without the overhead of a large framework like L<LWP::UserAgent>.
787
788 It is more correct and more complete than L<HTTP::Lite>.  It supports
789 proxies (currently only non-authenticating ones) and redirection.  It
790 also correctly resumes after EINTR.
791
792 =head1 METHODS
793
794 =head2 new
795
796     $http = HTTP::Tiny->new( %attributes );
797
798 This constructor returns a new HTTP::Tiny object.  Valid attributes include:
799
800 =over 4
801
802 =item *
803
804 agent
805
806 A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
807
808 =item *
809
810 default_headers
811
812 A hashref of default headers to apply to requests
813
814 =item *
815
816 max_redirect
817
818 Maximum number of redirects allowed (defaults to 5)
819
820 =item *
821
822 max_size
823
824 Maximum response size (only when not using a data callback).  If defined,
825 responses larger than this will die with an error message
826
827 =item *
828
829 proxy
830
831 URL of a proxy server to use.
832
833 =item *
834
835 timeout
836
837 Request timeout in seconds (default is 60)
838
839 =back
840
841 =head2 get
842
843     $response = $http->get($url);
844     $response = $http->get($url, \%options);
845
846 Executes a C<GET> request for the given URL.  The URL must have unsafe
847 characters escaped and international domain names encoded.  Internally, it just
848 calls C<request()> with 'GET' as the method.  See C<request()> for valid
849 options and a description of the response.
850
851 =head2 mirror
852
853     $response = $http->mirror($url, $file, \%options)
854     if ( $response->{success} ) {
855         print "$file is up to date\n";
856     }
857
858 Executes a C<GET> request for the URL and saves the response body to the file
859 name provided.  The URL must have unsafe characters escaped and international
860 domain names encoded.  If the file already exists, the request will includes an
861 C<If-Modified-Since> header with the modification timestamp of the file.  You
862 may specificy a different C<If-Modified-Since> header yourself in the C<<
863 $options->{headers} >> hash.
864
865 The C<success> field of the response will be true if the status code is 2XX
866 or 304 (unmodified).
867
868 If the file was modified and the server response includes a properly
869 formatted C<Last-Modified> header, the file modification time will
870 be updated accordingly.
871
872 =head2 request
873
874     $response = $http->request($method, $url);
875     $response = $http->request($method, $url, \%options);
876
877 Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST',
878 'PUT', etc.) on the given URL.  The URL must have unsafe characters escaped and
879 international domain names encoded.  A hashref of options may be appended to
880 modify the request.
881
882 Valid options are:
883
884 =over 4
885
886 =item *
887
888 headers
889
890 A hashref containing headers to include with the request.  If the value for
891 a header is an array reference, the header will be output multiple times with
892 each value in the array.  These headers over-write any default headers.
893
894 =item *
895
896 content
897
898 A scalar to include as the body of the request OR a code reference
899 that will be called iteratively to produce the body of the response
900
901 =item *
902
903 trailer_callback
904
905 A code reference that will be called if it exists to provide a hashref
906 of trailing headers (only used with chunked transfer-encoding)
907
908 =item *
909
910 data_callback
911
912 A code reference that will be called for each chunks of the response
913 body received.
914
915 =back
916
917 If the C<content> option is a code reference, it will be called iteratively
918 to provide the content body of the request.  It should return the empty
919 string or undef when the iterator is exhausted.
920
921 If the C<data_callback> option is provided, it will be called iteratively until
922 the entire response body is received.  The first argument will be a string
923 containing a chunk of the response body, the second argument will be the
924 in-progress response hash reference, as described below.  (This allows
925 customizing the action of the callback based on the C<status> or C<headers>
926 received prior to the content body.)
927
928 The C<request> method returns a hashref containing the response.  The hashref
929 will have the following keys:
930
931 =over 4
932
933 =item *
934
935 success
936
937 Boolean indicating whether the operation returned a 2XX status code
938
939 =item *
940
941 status
942
943 The HTTP status code of the response
944
945 =item *
946
947 reason
948
949 The response phrase returned by the server
950
951 =item *
952
953 content
954
955 The body of the response.  If the response does not have any content
956 or if a data callback is provided to consume the response body,
957 this will be the empty string
958
959 =item *
960
961 headers
962
963 A hashref of header fields.  All header field names will be normalized
964 to be lower case. If a header is repeated, the value will be an arrayref;
965 it will otherwise be a scalar string containing the value
966
967 =back
968
969 On an exception during the execution of the request, the C<status> field will
970 contain 599, and the C<content> field will contain the text of the exception.
971
972 =for Pod::Coverage agent
973 default_headers
974 max_redirect
975 max_size
976 proxy
977 timeout
978
979 =head1 LIMITATIONS
980
981 HTTP::Tiny is I<conditionally compliant> with the
982 L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
983 It attempts to meet all "MUST" requirements of the specification, but does not
984 implement all "SHOULD" requirements.
985
986 Some particular limitations of note include:
987
988 =over
989
990 =item *
991
992 HTTP::Tiny focuses on correct transport.  Users are responsible for ensuring
993 that user-defined headers and content are compliant with the HTTP/1.1
994 specification.
995
996 =item *
997
998 Users must ensure that URLs are properly escaped for unsafe characters and that
999 international domain names are properly encoded to ASCII. See L<URI::Escape>,
1000 L<URI::_punycode> and L<Net::IDN::Encode>.
1001
1002 =item *
1003
1004 Redirection is very strict against the specification.  Redirection is only
1005 automatic for response codes 301, 302 and 307 if the request method is 'GET' or
1006 'HEAD'.  Response code 303 is always converted into a 'GET' redirection, as
1007 mandated by the specification.  There is no automatic support for status 305
1008 ("Use proxy") redirections.
1009
1010 =item *
1011
1012 Persistant connections are not supported.  The C<Connection> header will
1013 always be set to C<close>.
1014
1015 =item *
1016
1017 Direct C<https> connections are supported only if L<IO::Socket::SSL> is
1018 installed.  There is no support for C<https> connections via proxy.
1019 Any SSL certificate that matches the host is accepted -- SSL certificates
1020 are not verified against certificate authorities.
1021
1022 =item *
1023
1024 Cookies are not directly supported.  Users that set a C<Cookie> header
1025 should also set C<max_redirect> to zero to ensure cookies are not
1026 inappropriately re-transmitted.
1027
1028 =item *
1029
1030 Proxy environment variables are not supported.
1031
1032 =item *
1033
1034 There is no provision for delaying a request body using an C<Expect> header.
1035 Unexpected C<1XX> responses are silently ignored as per the specification.
1036
1037 =item *
1038
1039 Only 'chunked' C<Transfer-Encoding> is supported.
1040
1041 =item *
1042
1043 There is no support for a Request-URI of '*' for the 'OPTIONS' request.
1044
1045 =back
1046
1047 =head1 SEE ALSO
1048
1049 =over 4
1050
1051 =item *
1052
1053 L<LWP::UserAgent>
1054
1055 =back
1056
1057 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
1058
1059 =head1 SUPPORT
1060
1061 =head2 Bugs / Feature Requests
1062
1063 Please report any bugs or feature requests by email to C<bug-http-tiny at rt.cpan.org>, or through
1064 the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>. You will be automatically notified of any
1065 progress on the request by the system.
1066
1067 =head2 Source Code
1068
1069 This is open source software.  The code repository is available for
1070 public review and contribution under the terms of the license.
1071
1072 L<http://github.com/dagolden/p5-http-tiny/tree>
1073
1074   git clone git://github.com/dagolden/p5-http-tiny.git
1075
1076 =head1 AUTHORS
1077
1078 =over 4
1079
1080 =item *
1081
1082 Christian Hansen <chansen@cpan.org>
1083
1084 =item *
1085
1086 David Golden <dagolden@cpan.org>
1087
1088 =back
1089
1090 =head1 COPYRIGHT AND LICENSE
1091
1092 This software is copyright (c) 2011 by Christian Hansen.
1093
1094 This is free software; you can redistribute it and/or modify it under
1095 the same terms as the Perl 5 programming language system itself.
1096
1097 =cut
1098