Commit fe56b620 authored by David Golden's avatar David Golden

add test for PUT and fix read_body bug

The body should only be read if there is
a content-length *or* a transfer-encoding.
parent 7432f28e
......@@ -241,7 +241,9 @@ sub _request {
}
else {
my $data_cb = $self->_prepare_data_cb($response, $args);
$handle->read_body($data_cb, $response->{headers}{'content-length'});
my $rh = $response->{headers};
$handle->read_body($data_cb, $rh->{'content-length'})
if $rh->{'content-length'} || $rh->{'transfer-encoding'};
}
$handle->close;
......
#!perl
use strict;
use warnings;
use Test::More 0.88;
use t::Util qw[tmpfile rewind slurp monkey_patch dir_list parse_case
set_socket_source sort_headers $CRLF $LF];
use HTTP::Tiny;
BEGIN { monkey_patch() }
my %response_codes = (
'new.txt' => '201',
);
for my $file ( dir_list("t/cases", qr/^put/ ) ) {
my $data = do { local (@ARGV,$/) = $file; <> };
my ($params, $expect_req, $give_res) = split /--+\n/, $data;
# cleanup source data
my $version = HTTP::Tiny->VERSION || 0;
$expect_req =~ s{VERSION}{$version};
s{\n}{$CRLF}g for ($expect_req, $give_res);
# figure out what request to make
my $case = parse_case($params);
my $url = $case->{url}->[0];
my %options;
my %headers;
for my $line ( @{ $case->{headers} } ) {
my ($k,$v) = ($line =~ m{^([^:]+): (.*)$}g);
$headers{$k} = $v;
}
$options{headers} = \%headers if %headers;
if ( $case->{content} ) {
$options{content} = $case->{content}->[0];
}
# setup mocking and test
my $res_fh = tmpfile($give_res);
my $req_fh = tmpfile();
my $http = HTTP::Tiny->new;
set_socket_source($req_fh, $res_fh);
(my $url_basename = $url) =~ s{.*/}{};
my @call_args = %options ? ($url, \%options) : ($url);
my $response = $http->request('PUT',@call_args);
my $got_req = slurp($req_fh);
my $label = "put on $url";
$label .= " (@{[keys %options]})" if %options;
# is( sort_headers($got_req), sort_headers($expect_req), "$label request" );
use Test::Differences;
eq_or_diff( sort_headers($got_req), sort_headers($expect_req), "$label request" );
my $rc = $response_codes{$url_basename};
is( $response->{status}, $rc, "$label response code $rc" )
or diag $response->{content};
if ( substr($rc,0,1) eq '2' ) {
ok( $response->{success}, "$label success flag true" );
}
else {
ok( ! $response->{success}, "$label success flag false" );
}
}
done_testing;
......@@ -96,9 +96,14 @@ sub parse_case {
sub sort_headers {
my ($text) = shift;
my @lines = split /$CRLF/, $text;
my @output = shift(@lines);
push @output, sort @lines;
return join($CRLF, @output);
my $request = shift(@lines);
my @headers;
while (my $line = shift @lines) {
last unless length $line;
push @headers, $line;
}
@headers = sort @headers;
return join($CRLF, $request, @headers, '', @lines);
}
{
......
url
http://example.com/new.txt
headers
Content-Type: text/plain
content
abcdefghijklmnopqrstuvwxyz1234567890abcdef
----------
PUT /new.txt HTTP/1.1
Host: example.com
Connection: close
User-Agent: HTTP-Tiny/VERSION
Content-Type: text/plain
Content-Length: 42
abcdefghijklmnopqrstuvwxyz1234567890abcdef
----------
HTTP/1.1 201 Created
Date: Thu, 03 Feb 1994 00:00:00 GMT
Location: http://example.com/new.txt
Content-Length: 0
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment