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