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