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