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
CommitLineData
a3ab329f 1# vim: ts=4 sts=4 sw=4 et:
a3ab329f 2package HTTP::Tiny;
a3ab329f
DG
3use strict;
4use warnings;
35265876 5# ABSTRACT: A small, simple, correct HTTP/1.1 client
293dcbbb 6our $VERSION = '0.015'; # VERSION
a3ab329f
DG
7
8use Carp ();
9
10
11my @attributes;
12BEGIN {
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
22sub 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 }
77ccfaeb
DG
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
a3ab329f
DG
44 return bless $self, $class;
45}
46
47
35265876
CBW
48for 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 }
58HERE
59}
60
61
62sub 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 );
a3ab329f
DG
82}
83
84
85sub mirror {
86 my ($self, $url, $file, $args) = @_;
87 @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
77ccfaeb 88 or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
a3ab329f
DG
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
77ccfaeb 94 or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
b06ddfb0 95 binmode $fh;
a3ab329f
DG
96 $args->{data_callback} = sub { print {$fh} $_[0] };
97 my $response = $self->request('GET', $url, $args);
98 close $fh
77ccfaeb 99 or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
a3ab329f
DG
100 if ( $response->{success} ) {
101 rename $tempfile, $file
77ccfaeb 102 or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
a3ab329f
DG
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
114my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
115
116sub request {
117 my ($self, $method, $url, $args) = @_;
118 @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
77ccfaeb 119 or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
a3ab329f
DG
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
35265876
CBW
145
146sub 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
a3ab329f
DG
175my %DefaultPort = (
176 http => 80,
177 https => 443,
178);
179
180sub _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";
77ccfaeb 197 die(qq/HTTPS via proxy is not supported\n/)
a3ab329f
DG
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
230sub _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)
77ccfaeb 255 or die(qq/Wide character in request message body\n/);
a3ab329f
DG
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
268sub _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
288sub _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
304sub _split_url {
305 my $url = pop;
306
307 # URI regex adapted from the URI module
308 my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
77ccfaeb 309 or die(qq/Cannot parse URL: '$url'\n/);
a3ab329f
DG
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
326my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
327my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
328sub _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
337sub _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
35265876
CBW
356# URI escaping adapted from URI::Escape
357# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
358my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
359$escapes{' '}="+";
360my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
361
362sub _uri_escape {
363 my ($self, $str) = @_;
364 utf8::encode($str);
365 $str =~ s/($unsafe_char)/$escapes{$1}/ge;
366 return $str;
367}
368
a3ab329f
DG
369package
370 HTTP::Tiny::Handle; # hide from PAUSE/indexers
371use strict;
372use warnings;
373
a3ab329f
DG
374use Errno qw[EINTR EPIPE];
375use IO::Socket qw[SOCK_STREAM];
376
377sub BUFSIZE () { 32768 }
378
379my $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
388my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
389
390sub 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
435aa301
DG
401my $ssl_verify_args = {
402 check_cn => "when_only",
403 wildcards_in_alt => "anywhere",
404 wildcards_in_cn => "anywhere"
405};
406
a3ab329f 407sub connect {
77ccfaeb 408 @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
a3ab329f
DG
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'};
77ccfaeb 414 die(qq/IO::Socket::SSL must be installed for https support\n/)
a3ab329f
DG
415 unless $INC{'IO/Socket/SSL.pm'};
416 }
417 elsif ( $scheme ne 'http' ) {
77ccfaeb 418 die(qq/Unsupported URL scheme '$scheme'\n/);
a3ab329f
DG
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}
77ccfaeb 427 ) or die(qq/Could not connect to '$host:$port': $@\n/);
a3ab329f
DG
428
429 binmode($self->{fh})
77ccfaeb 430 or die(qq/Could not binmode() socket: '$!'\n/);
a3ab329f
DG
431
432 if ( $scheme eq 'https') {
433 IO::Socket::SSL->start_SSL($self->{fh});
434 ref($self->{fh}) eq 'IO::Socket::SSL'
435aa301
DG
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/);
a3ab329f
DG
438 }
439
440 $self->{host} = $host;
441 $self->{port} = $port;
442
443 return $self;
444}
445
446sub close {
77ccfaeb 447 @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
a3ab329f
DG
448 my ($self) = @_;
449 CORE::close($self->{fh})
77ccfaeb 450 or die(qq/Could not close socket: '$!'\n/);
a3ab329f
DG
451}
452
453sub write {
77ccfaeb 454 @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
a3ab329f
DG
455 my ($self, $buf) = @_;
456
457 if ( $] ge '5.008' ) {
458 utf8::downgrade($buf, 1)
77ccfaeb 459 or die(qq/Wide character in write()\n/);
a3ab329f
DG
460 }
461
462 my $len = length $buf;
463 my $off = 0;
464
465 local $SIG{PIPE} = 'IGNORE';
466
467 while () {
468 $self->can_write
77ccfaeb 469 or die(qq/Timed out while waiting for socket to become ready for writing\n/);
a3ab329f
DG
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) {
77ccfaeb 477 die(qq/Socket closed by remote server: $!\n/);
a3ab329f
DG
478 }
479 elsif ($! != EINTR) {
77ccfaeb 480 die(qq/Could not write to socket: '$!'\n/);
a3ab329f
DG
481 }
482 }
483 return $off;
484}
485
486sub read {
77ccfaeb 487 @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
a3ab329f
DG
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
77ccfaeb 501 or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
a3ab329f
DG
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) {
77ccfaeb 508 die(qq/Could not read from socket: '$!'\n/);
a3ab329f
DG
509 }
510 }
511 if ($len && !$allow_partial) {
77ccfaeb 512 die(qq/Unexpected end of stream\n/);
a3ab329f
DG
513 }
514 return $buf;
515}
516
517sub readline {
77ccfaeb 518 @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
a3ab329f
DG
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}) {
77ccfaeb 526 die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
a3ab329f
DG
527 }
528 $self->can_read
77ccfaeb 529 or die(qq/Timed out while waiting for socket to become ready for reading\n/);
a3ab329f
DG
530 my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
531 if (defined $r) {
532 last unless $r;
533 }
534 elsif ($! != EINTR) {
77ccfaeb 535 die(qq/Could not read from socket: '$!'\n/);
a3ab329f
DG
536 }
537 }
77ccfaeb 538 die(qq/Unexpected end of stream while looking for line\n/);
a3ab329f
DG
539}
540
541sub read_header_lines {
77ccfaeb 542 @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
a3ab329f
DG
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}) {
77ccfaeb 552 die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
a3ab329f
DG
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
77ccfaeb 569 or die(qq/Unexpected header continuation line\n/);
a3ab329f
DG
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 {
77ccfaeb 578 die(q/Malformed header line: / . $Printable->($line) . "\n");
a3ab329f
DG
579 }
580 }
581 return $headers;
582}
583
584sub write_request {
77ccfaeb 585 @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
a3ab329f
DG
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
592my %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
600sub write_header_lines {
77ccfaeb 601 (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
a3ab329f
DG
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
77ccfaeb 612 or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
a3ab329f
DG
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]/
77ccfaeb 618 or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
a3ab329f
DG
619 $buf .= "$field_name: $_\x0D\x0A";
620 }
621 }
622 $buf .= "\x0D\x0A";
623 return $self->write($buf);
624}
625
626sub read_body {
77ccfaeb 627 @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
a3ab329f
DG
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
639sub write_body {
77ccfaeb 640 @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
a3ab329f
DG
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
650sub read_content_body {
77ccfaeb 651 @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
a3ab329f
DG
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
671sub write_content_body {
77ccfaeb 672 @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
a3ab329f
DG
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)
77ccfaeb 684 or die(qq/Wide character in write_content()\n/);
a3ab329f
DG
685 }
686
687 $len += $self->write($data);
688 }
689
690 $len == $content_length
77ccfaeb 691 or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
a3ab329f
DG
692
693 return $len;
694}
695
696sub read_chunked_body {
77ccfaeb 697 @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
a3ab329f
DG
698 my ($self, $cb, $response) = @_;
699
700 while () {
701 my $head = $self->readline;
702
703 $head =~ /\A ([A-Fa-f0-9]+)/x
77ccfaeb 704 or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
a3ab329f
DG
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"
77ccfaeb 712 or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
a3ab329f
DG
713 }
714 $self->read_header_lines($response->{headers});
715 return;
716}
717
718sub write_chunked_body {
77ccfaeb 719 @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
a3ab329f
DG
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)
77ccfaeb 731 or die(qq/Wide character in write_chunked_body()\n/);
a3ab329f
DG
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
749sub read_response_header {
77ccfaeb 750 @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
a3ab329f
DG
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
77ccfaeb 756 or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
a3ab329f
DG
757
758 my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
759
77ccfaeb 760 die (qq/Unsupported HTTP protocol: $protocol\n/)
a3ab329f
DG
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
771sub write_request_header {
77ccfaeb 772 @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
a3ab329f
DG
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
779sub _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
77ccfaeb 786 or die(qq/select(2): 'Bad file descriptor'\n/);
a3ab329f
DG
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
77ccfaeb 800 or die(qq/select(2): '$!'\n/);
a3ab329f
DG
801 redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
802 $nfound = 0;
803 }
804 last;
805 }
806 $! = 0;
807 return $nfound;
808}
809
810sub can_read {
77ccfaeb 811 @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
a3ab329f
DG
812 my $self = shift;
813 return $self->_do_timeout('read', @_)
814}
815
816sub can_write {
77ccfaeb 817 @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
a3ab329f
DG
818 my $self = shift;
819 return $self->_do_timeout('write', @_)
820}
821
8221;
823
824
825
826__END__
827=pod
828
829=head1 NAME
830
831HTTP::Tiny - A small, simple, correct HTTP/1.1 client
832
833=head1 VERSION
834
293dcbbb 835version 0.015
a3ab329f
DG
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
35265876 857This is a very simple HTTP/1.1 client, designed for doing simple GET
a3ab329f
DG
858requests without the overhead of a large framework like L<LWP::UserAgent>.
859
860It is more correct and more complete than L<HTTP::Lite>. It supports
861proxies (currently only non-authenticating ones) and redirection. It
862also correctly resumes after EINTR.
863
864=head1 METHODS
865
866=head2 new
867
868 $http = HTTP::Tiny->new( %attributes );
869
870This constructor returns a new HTTP::Tiny object. Valid attributes include:
871
872=over 4
873
874=item *
875
876agent
877
878A user-agent string (defaults to 'HTTP::Tiny/$VERSION')
879
880=item *
881
882default_headers
883
884A hashref of default headers to apply to requests
885
886=item *
887
888max_redirect
889
890Maximum number of redirects allowed (defaults to 5)
891
892=item *
893
894max_size
895
896Maximum response size (only when not using a data callback). If defined,
897responses larger than this will die with an error message
898
899=item *
900
901proxy
902
77ccfaeb 903URL of a proxy server to use (default is C<$ENV{http_proxy}> if set)
a3ab329f
DG
904
905=item *
906
907timeout
908
909Request timeout in seconds (default is 60)
910
911=back
912
35265876 913=head2 get|head|put|post|delete
a3ab329f
DG
914
915 $response = $http->get($url);
916 $response = $http->get($url, \%options);
35265876
CBW
917 $response = $http->head($url);
918
919These methods are shorthand for calling C<request()> for the given method. The
920URL must have unsafe characters escaped and international domain names encoded.
921See 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);
a3ab329f 927
35265876
CBW
928This method executes a C<POST> request and sends the key/value pairs from a
929form data hash or array reference to the given URL with a C<content-type> of
930C<application/x-www-form-urlencoded>. See documentation for the
931C<www_form_urlencode> method for details on the encoding.
932
933The URL must have unsafe characters escaped and international domain names
934encoded. See C<request()> for valid options and a description of the response.
935Any C<content-type> header or content in the options hashref will be ignored.
a3ab329f
DG
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
944Executes a C<GET> request for the URL and saves the response body to the file
945name provided. The URL must have unsafe characters escaped and international
946domain names encoded. If the file already exists, the request will includes an
947C<If-Modified-Since> header with the modification timestamp of the file. You
948may specificy a different C<If-Modified-Since> header yourself in the C<<
949$options->{headers} >> hash.
950
951The C<success> field of the response will be true if the status code is 2XX
952or 304 (unmodified).
953
954If the file was modified and the server response includes a properly
955formatted C<Last-Modified> header, the file modification time will
956be updated accordingly.
957
958=head2 request
959
960 $response = $http->request($method, $url);
961 $response = $http->request($method, $url, \%options);
962
435aa301
DG
963Executes 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
a3ab329f
DG
965international domain names encoded. A hashref of options may be appended to
966modify the request.
967
968Valid options are:
969
970=over 4
971
972=item *
973
974headers
975
976A hashref containing headers to include with the request. If the value for
977a header is an array reference, the header will be output multiple times with
978each value in the array. These headers over-write any default headers.
979
980=item *
981
982content
983
984A scalar to include as the body of the request OR a code reference
985that will be called iteratively to produce the body of the response
986
987=item *
988
989trailer_callback
990
991A code reference that will be called if it exists to provide a hashref
992of trailing headers (only used with chunked transfer-encoding)
993
994=item *
995
996data_callback
997
998A code reference that will be called for each chunks of the response
999body received.
1000
1001=back
1002
1003If the C<content> option is a code reference, it will be called iteratively
1004to provide the content body of the request. It should return the empty
1005string or undef when the iterator is exhausted.
1006
1007If the C<data_callback> option is provided, it will be called iteratively until
1008the entire response body is received. The first argument will be a string
1009containing a chunk of the response body, the second argument will be the
1010in-progress response hash reference, as described below. (This allows
1011customizing the action of the callback based on the C<status> or C<headers>
1012received prior to the content body.)
1013
1014The C<request> method returns a hashref containing the response. The hashref
1015will have the following keys:
1016
1017=over 4
1018
1019=item *
1020
1021success
1022
1023Boolean indicating whether the operation returned a 2XX status code
1024
1025=item *
1026
1027status
1028
1029The HTTP status code of the response
1030
1031=item *
1032
1033reason
1034
1035The response phrase returned by the server
1036
1037=item *
1038
1039content
1040
1041The body of the response. If the response does not have any content
1042or if a data callback is provided to consume the response body,
1043this will be the empty string
1044
1045=item *
1046
1047headers
1048
1049A hashref of header fields. All header field names will be normalized
1050to be lower case. If a header is repeated, the value will be an arrayref;
1051it will otherwise be a scalar string containing the value
1052
1053=back
1054
1055On an exception during the execution of the request, the C<status> field will
1056contain 599, and the C<content> field will contain the text of the exception.
1057
35265876
CBW
1058=head2 www_form_urlencode
1059
1060 $params = $http->www_form_urlencode( $data );
1061 $response = $http->get("http://example.com/query?$params");
1062
1063This method converts the key/value pairs from a data hash or array reference
1064into a C<x-www-form-urlencoded> string. The keys and values from the data
1065reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an
1066array reference, the key will be repeated with each of the values of the array
1067reference. The key/value pairs in the resulting string will be sorted by key
1068and value.
1069
a3ab329f
DG
1070=for Pod::Coverage agent
1071default_headers
1072max_redirect
1073max_size
1074proxy
1075timeout
1076
1077=head1 LIMITATIONS
1078
1079HTTP::Tiny is I<conditionally compliant> with the
1080L<HTTP/1.1 specification|http://www.w3.org/Protocols/rfc2616/rfc2616.html>.
1081It attempts to meet all "MUST" requirements of the specification, but does not
1082implement all "SHOULD" requirements.
1083
1084Some particular limitations of note include:
1085
1086=over
1087
1088=item *
1089
1090HTTP::Tiny focuses on correct transport. Users are responsible for ensuring
1091that user-defined headers and content are compliant with the HTTP/1.1
1092specification.
1093
1094=item *
1095
1096Users must ensure that URLs are properly escaped for unsafe characters and that
1097international domain names are properly encoded to ASCII. See L<URI::Escape>,
1098L<URI::_punycode> and L<Net::IDN::Encode>.
1099
1100=item *
1101
1102Redirection is very strict against the specification. Redirection is only
1103automatic 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
1105mandated by the specification. There is no automatic support for status 305
1106("Use proxy") redirections.
1107
1108=item *
1109
293dcbbb 1110Persistent connections are not supported. The C<Connection> header will
a3ab329f
DG
1111always be set to C<close>.
1112
1113=item *
1114
1115Direct C<https> connections are supported only if L<IO::Socket::SSL> is
1116installed. There is no support for C<https> connections via proxy.
b06ddfb0
DG
1117Any SSL certificate that matches the host is accepted -- SSL certificates
1118are not verified against certificate authorities.
a3ab329f
DG
1119
1120=item *
1121
1122Cookies are not directly supported. Users that set a C<Cookie> header
1123should also set C<max_redirect> to zero to ensure cookies are not
1124inappropriately re-transmitted.
1125
1126=item *
1127
77ccfaeb
DG
1128Only the C<http_proxy> environment variable is supported in the format
1129C<http://HOST:PORT/>. If a C<proxy> argument is passed to C<new> (including
1130undef), then the C<http_proxy> environment variable is ignored.
a3ab329f
DG
1131
1132=item *
1133
1134There is no provision for delaying a request body using an C<Expect> header.
1135Unexpected C<1XX> responses are silently ignored as per the specification.
1136
1137=item *
1138
1139Only 'chunked' C<Transfer-Encoding> is supported.
1140
1141=item *
1142
1143There 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
1153L<LWP::UserAgent>
1154
1155=back
1156
452d0b70 1157=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders
44de791a
DG
1158
1159=head1 SUPPORT
1160
1161=head2 Bugs / Feature Requests
1162
452d0b70
DG
1163Please report any bugs or feature requests by email to C<bug-http-tiny at rt.cpan.org>, or through
1164the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=HTTP-Tiny>. You will be automatically notified of any
1165progress on the request by the system.
44de791a
DG
1166
1167=head2 Source Code
1168
1169This is open source software. The code repository is available for
1170public review and contribution under the terms of the license.
1171
35265876 1172L<https://github.com/dagolden/p5-http-tiny>
44de791a 1173
35265876 1174 git clone https://github.com/dagolden/p5-http-tiny.git
44de791a 1175
a3ab329f
DG
1176=head1 AUTHORS
1177
1178=over 4
1179
1180=item *
1181
1182Christian Hansen <chansen@cpan.org>
1183
1184=item *
1185
1186David Golden <dagolden@cpan.org>
1187
1188=back
1189
1190=head1 COPYRIGHT AND LICENSE
1191
1192This software is copyright (c) 2011 by Christian Hansen.
1193
1194This is free software; you can redistribute it and/or modify it under
1195the same terms as the Perl 5 programming language system itself.
1196
1197=cut
1198