From eb56feb6339dfca5a0da269ccdb3229f62d9873c Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 12 Jun 2013 14:11:04 -0700 Subject: [PATCH 1/5] Add HTTP::Tiny interface for LWP replacement in tests --- cpanfile | 1 + lib/HTTP/Tiny/LWPLike.pm | 119 +++++++++++++++++++++++++++++++++++++++ lib/Plack/Test/Server.pm | 8 +-- lib/Plack/Test/Suite.pm | 6 +- 4 files changed, 126 insertions(+), 8 deletions(-) create mode 100644 lib/HTTP/Tiny/LWPLike.pm diff --git a/cpanfile b/cpanfile index 13174ae53..e6b25eb55 100644 --- a/cpanfile +++ b/cpanfile @@ -14,6 +14,7 @@ requires 'Try::Tiny'; requires 'URI', '1.59'; requires 'parent'; requires 'Apache::LogFormat::Compiler', '0.12'; +requires 'HTTP::Tiny', 0.024; on test => sub { requires 'Test::More', '0.88'; diff --git a/lib/HTTP/Tiny/LWPLike.pm b/lib/HTTP/Tiny/LWPLike.pm new file mode 100644 index 000000000..eb7462170 --- /dev/null +++ b/lib/HTTP/Tiny/LWPLike.pm @@ -0,0 +1,119 @@ +package HTTP::Tiny::LWPLike; +use strict; +use warnings; +use HTTP::Tiny; +use HTTP::Response; + +sub new { + my $class = shift; + my $self = bless {}, $class; + $self->{http} = @_ == 1 ? $_[0] : HTTP::Tiny->new(@_); + $self; +} + +sub _multiply_headers { + my($self, $headers) = @_; + + my $hdrs; + $headers->scan(sub { + if (exists $hdrs->{$_[0]}) { + push @{$hdrs->{$_[0]}}, $_[1]; + } else { + $hdrs->{$_[0]} = [ $_[1] ]; + } + }); + + while (my($k, $v) = each %$hdrs) { + $hdrs->{$k} = $v->[0] if @$v == 1; + } + + $hdrs; +} + +sub _flatten_headers { + my($self, $headers) = @_; + + my @hdrs; + while (my($k, $v) = each %$headers) { + if (ref $v eq 'ARRAY') { + push @hdrs, map { ($k => $_) } @$v; + } else { + push @hdrs, $k => $v; + } + } + + return \@hdrs; +} + +sub request { + my($self, $req) = @_; + + my $response = $self->{http}->request( + $req->method, $req->url, { + headers => $self->_multiply_headers($req->headers), + content => $req->content, + }, + ); + + my $res = HTTP::Response->new( + $response->{status}, + $response->{reason}, + $self->_flatten_headers($response->{headers}), + $response->{content}, + ); + $res->request($req); + + return $res; +} + +1; + +__END__ + +=head1 NAME + +HTTP::Tiny::LWPLike - HTTP::Request/Response compatible interface with HTTP::Tiny backend + +=head1 SYNOPSIS + + use HTTP::Tiny::LWPLike; + + my $request = HTTP::Request->new(GET => 'http://perl.com/'); + + my $ua = HTTP::Tiny::LWPLike->new; + my $res = $ua->request($request); # returns HTTP::Response + +=head1 DESCRIPTION + +This module is an adapter object that implements one method, +C that acts like L's request method +i.e. takes HTTP::Request object and returns HTTP::Response object. + +=head1 INCOMPATIBILITIES + +=over 4 + +=item * + +SSL is not supported unless required modules are installed. + +=item * + +authentication is not handled via the UA methods. You can encode the +C headers in the C<$request> by yourself. + +=cut + +There might be more - see L for the details. + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa + +=head1 SEE ALSO + +L L + +=cut diff --git a/lib/Plack/Test/Server.pm b/lib/Plack/Test/Server.pm index 843a8fb27..6481d9a05 100644 --- a/lib/Plack/Test/Server.pm +++ b/lib/Plack/Test/Server.pm @@ -2,18 +2,18 @@ package Plack::Test::Server; use strict; use warnings; use Carp; +use HTTP::Request; +use HTTP::Response; use Test::TCP; use Plack::Loader; -use Test::Requires (); +use HTTP::Tiny::LWPLike; sub test_psgi { my %args = @_; - Test::Requires::test_requires('LWP::UserAgent'); - my $client = delete $args{client} or croak "client test code needed"; my $app = delete $args{app} or croak "app needed"; - my $ua = delete $args{ua} || LWP::UserAgent->new; + my $ua = delete $args{ua} || HTTP::Tiny::LWPLike->new; test_tcp( client => sub { diff --git a/lib/Plack/Test/Suite.pm b/lib/Plack/Test/Suite.pm index 7bbbe88c5..d4eca2849 100644 --- a/lib/Plack/Test/Suite.pm +++ b/lib/Plack/Test/Suite.pm @@ -12,7 +12,7 @@ use Plack::Middleware::Lint; use Plack::Util; use Plack::Request; use Try::Tiny; -use Test::Requires (); +use HTTP::Tiny::LWPLike; my $share_dir = try { File::ShareDir::dist_dir('Plack') } || 'share'; @@ -741,8 +741,6 @@ sub runtests { sub run_server_tests { my($class, $server, $server_port, $http_port, %args) = @_; - Test::Requires::test_requires('LWP::UserAgent'); - if (ref $server ne 'CODE') { my $server_class = $server; $server = sub { @@ -757,7 +755,7 @@ sub run_server_tests { client => sub { my $port = shift; - my $ua = LWP::UserAgent->new; + my $ua = HTTP::Tiny::LWPLike->new; for my $i (0..$#TEST) { my $test = $TEST[$i]; note $test->[0]; From 0adc362bb6065fa9d83656612bacef585bb36e77 Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 12 Jun 2013 14:33:21 -0700 Subject: [PATCH 2/5] simplify the code using Hash::MultiValue --- lib/HTTP/Tiny/LWPLike.pm | 27 ++++++--------------------- 1 file changed, 6 insertions(+), 21 deletions(-) diff --git a/lib/HTTP/Tiny/LWPLike.pm b/lib/HTTP/Tiny/LWPLike.pm index eb7462170..3ef385b8e 100644 --- a/lib/HTTP/Tiny/LWPLike.pm +++ b/lib/HTTP/Tiny/LWPLike.pm @@ -3,6 +3,7 @@ use strict; use warnings; use HTTP::Tiny; use HTTP::Response; +use Hash::MultiValue; sub new { my $class = shift; @@ -11,25 +12,6 @@ sub new { $self; } -sub _multiply_headers { - my($self, $headers) = @_; - - my $hdrs; - $headers->scan(sub { - if (exists $hdrs->{$_[0]}) { - push @{$hdrs->{$_[0]}}, $_[1]; - } else { - $hdrs->{$_[0]} = [ $_[1] ]; - } - }); - - while (my($k, $v) = each %$hdrs) { - $hdrs->{$k} = $v->[0] if @$v == 1; - } - - $hdrs; -} - sub _flatten_headers { my($self, $headers) = @_; @@ -48,9 +30,12 @@ sub _flatten_headers { sub request { my($self, $req) = @_; + my @headers; + $req->headers->scan(sub { push @headers, @_ }); + my $response = $self->{http}->request( $req->method, $req->url, { - headers => $self->_multiply_headers($req->headers), + headers => Hash::MultiValue->new(@headers)->mixed, content => $req->content, }, ); @@ -58,7 +43,7 @@ sub request { my $res = HTTP::Response->new( $response->{status}, $response->{reason}, - $self->_flatten_headers($response->{headers}), + [ Hash::MultiValue->from_mixed($response->{headers})->flatten ], $response->{content}, ); $res->request($req); From 255a1bbfac610c316eb73fa9ab40750ad323559d Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 12 Jun 2013 14:34:52 -0700 Subject: [PATCH 3/5] force LWP client in chunked tests --- t/Plack-Middleware/chunked.t | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/t/Plack-Middleware/chunked.t b/t/Plack-Middleware/chunked.t index 11294e4f7..d4c6756f3 100644 --- a/t/Plack-Middleware/chunked.t +++ b/t/Plack-Middleware/chunked.t @@ -1,10 +1,11 @@ use strict; use Test::More; -use Test::Requires qw(IO::Handle::Util LWP::Protocol::http10); +use Test::Requires qw(IO::Handle::Util LWP::UserAgent LWP::Protocol::http10); use IO::Handle::Util qw(:io_from); use HTTP::Request::Common; use Plack::Test; use Plack::Middleware::Chunked; + $Plack::Test::Impl = "Server"; local $ENV{PLACK_SERVER} = "HTTP::Server::PSGI"; @@ -22,7 +23,9 @@ my @app = ( my $app = sub { (shift @app)->(@_) }; -test_psgi app => Plack::Middleware::Chunked->wrap($app), client => sub { +test_psgi + ua => LWP::UserAgent->new, # force LWP + app => Plack::Middleware::Chunked->wrap($app), client => sub { my $cb = shift; for my $proto (qw( HTTP/1.1 HTTP/1.0 )) { From 7dda8e7586ad060b5ec5e7d03f148d5d90666c21 Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 12 Jun 2013 14:47:50 -0700 Subject: [PATCH 4/5] remove unused code --- lib/HTTP/Tiny/LWPLike.pm | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/lib/HTTP/Tiny/LWPLike.pm b/lib/HTTP/Tiny/LWPLike.pm index 3ef385b8e..b6fe720fe 100644 --- a/lib/HTTP/Tiny/LWPLike.pm +++ b/lib/HTTP/Tiny/LWPLike.pm @@ -12,21 +12,6 @@ sub new { $self; } -sub _flatten_headers { - my($self, $headers) = @_; - - my @hdrs; - while (my($k, $v) = each %$headers) { - if (ref $v eq 'ARRAY') { - push @hdrs, map { ($k => $_) } @$v; - } else { - push @hdrs, $k => $v; - } - } - - return \@hdrs; -} - sub request { my($self, $req) = @_; From 705fcab4fd1c481384b69e013f0a59b0bc43cad9 Mon Sep 17 00:00:00 2001 From: Tatsuhiko Miyagawa Date: Wed, 12 Jun 2013 19:29:53 -0700 Subject: [PATCH 5/5] Only send content when there really is a content. --- lib/HTTP/Tiny/LWPLike.pm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/lib/HTTP/Tiny/LWPLike.pm b/lib/HTTP/Tiny/LWPLike.pm index b6fe720fe..c9ed4b791 100644 --- a/lib/HTTP/Tiny/LWPLike.pm +++ b/lib/HTTP/Tiny/LWPLike.pm @@ -18,12 +18,12 @@ sub request { my @headers; $req->headers->scan(sub { push @headers, @_ }); - my $response = $self->{http}->request( - $req->method, $req->url, { - headers => Hash::MultiValue->new(@headers)->mixed, - content => $req->content, - }, - ); + my $options = { + headers => Hash::MultiValue->new(@headers)->mixed, + }; + $options->{content} = $req->content if defined $req->content && length($req->content); + + my $response = $self->{http}->request($req->method, $req->url, $options); my $res = HTTP::Response->new( $response->{status},