This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f9fbd17bbe1bbdc36e0b0644ae16913b0b5501e2
[perl5.git] / cpan / HTTP-Tiny / t / 150_post_form.t
1 #!perl
2
3 use strict;
4 use warnings;
5 use open IN => ':raw';
6
7 use File::Basename;
8 use Test::More 0.88;
9 use t::Util    qw[tmpfile rewind slurp monkey_patch dir_list parse_case
10                   set_socket_source sort_headers $CRLF $LF];
11 use HTTP::Tiny;
12 BEGIN { monkey_patch() }
13
14 for my $file ( dir_list("t/cases", qr/^form/ ) ) {
15   my $data = do { local (@ARGV,$/) = $file; <> };
16   my ($params, $expect_req, $give_res) = split /--+\n/, $data;
17   # cleanup source data
18   my $version = HTTP::Tiny->VERSION || 0;
19   $expect_req =~ s{VERSION}{$version};
20   s{\n}{$CRLF}g for ($expect_req, $give_res);
21
22   # figure out what request to make
23   my $case = parse_case($params);
24   my $url = $case->{url}[0];
25   my %options;
26
27   my %headers;
28   for my $line ( @{ $case->{headers} } ) {
29     my ($k,$v) = ($line =~ m{^([^:]+): (.*)$}g);
30     $headers{$k} = $v;
31   }
32   $options{headers} = \%headers if %headers;
33
34   my @params = split "\\|", $case->{content}[0];
35   my $formdata;
36   if ( $case->{datatype} eq 'HASH' ) {
37     while ( @params ) {
38       my ($key, $value) = splice( @params, 0, 2 );
39       if ( ref $formdata->{$key} ) {
40         push @{$formdata->{$key}}, $value;
41       }
42       elsif ( exists $formdata->{$key} ) {
43         $formdata->{$key} = [ $formdata->{$key}, $value ];
44       }
45       else {
46         $formdata->{$key} = $value;
47       }
48     }
49   }
50   else {
51     $formdata = [ @params ];
52   }
53
54   # setup mocking and test
55   my $res_fh = tmpfile($give_res);
56   my $req_fh = tmpfile();
57
58   my $http = HTTP::Tiny->new;
59   set_socket_source($req_fh, $res_fh);
60
61   (my $url_basename = $url) =~ s{.*/}{};
62
63   my $response  = $http->post_form( $url, $formdata, %options ? (\%options) : ());
64
65   my $got_req = slurp($req_fh);
66
67   my $label = basename($file);
68
69   is( sort_headers($got_req), sort_headers($expect_req), "$label request" );
70
71   my ($rc) = $give_res =~ m{\S+\s+(\d+)}g;
72   is( $response->{status}, $rc, "$label response code $rc" )
73     or diag $response->{content};
74
75   if ( substr($rc,0,1) eq '2' ) {
76     ok( $response->{success}, "$label success flag true" );
77   }
78   else {
79     ok( ! $response->{success}, "$label success flag false" );
80   }
81 }
82
83 done_testing;