From b5d66ba6e274eed251da951bb943b9ff67765290 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Wed, 18 Jul 2012 16:22:08 -0500 Subject: import the Plack::Request test suite --- t/base.t | 53 +++++++++++++++++++++++++ t/body.t | 23 +++++++++++ t/content-on-get.t | 25 ++++++++++++ t/content.t | 26 +++++++++++++ t/cookie.t | 59 ++++++++++++++++++++++++++++ t/data/baybridge.jpg | Bin 0 -> 79838 bytes t/data/foo1.txt | 1 + t/data/foo2.txt | 1 + t/double_port.t | 24 ++++++++++++ t/hostname.t | 15 ++++++++ t/many_upload.t | 77 +++++++++++++++++++++++++++++++++++++ t/multi_read.t | 27 +++++++++++++ t/new.t | 30 +++++++++++++++ t/parameters.t | 27 +++++++++++++ t/params.t | 26 +++++++++++++ t/path_info.t | 36 +++++++++++++++++ t/path_info_escaped.t | 33 ++++++++++++++++ t/readbody.t | 25 ++++++++++++ t/request_uri.t | 25 ++++++++++++ t/upload-basename.t | 13 +++++++ t/upload-large.t | 33 ++++++++++++++++ t/upload.t | 61 +++++++++++++++++++++++++++++ t/uri.t | 104 ++++++++++++++++++++++++++++++++++++++++++++++++++ t/uri_utf8.t | 17 +++++++++ 24 files changed, 761 insertions(+) create mode 100644 t/base.t create mode 100644 t/body.t create mode 100644 t/content-on-get.t create mode 100644 t/content.t create mode 100644 t/cookie.t create mode 100644 t/data/baybridge.jpg create mode 100644 t/data/foo1.txt create mode 100644 t/data/foo2.txt create mode 100644 t/double_port.t create mode 100644 t/hostname.t create mode 100644 t/many_upload.t create mode 100644 t/multi_read.t create mode 100644 t/new.t create mode 100644 t/parameters.t create mode 100644 t/params.t create mode 100644 t/path_info.t create mode 100644 t/path_info_escaped.t create mode 100644 t/readbody.t create mode 100644 t/request_uri.t create mode 100644 t/upload-basename.t create mode 100644 t/upload-large.t create mode 100644 t/upload.t create mode 100644 t/uri.t create mode 100644 t/uri_utf8.t (limited to 't') diff --git a/t/base.t b/t/base.t new file mode 100644 index 0000000..af1a4ed --- /dev/null +++ b/t/base.t @@ -0,0 +1,53 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request; + +my @tests = ( + { host => 'localhost', + base => 'http://localhost/' }, + { script_name => '/foo', + host => 'localhost', + base => 'http://localhost/foo' }, + { script_name => '/foo bar', + host => 'localhost', + base => 'http://localhost/foo%20bar' }, + { scheme => 'http', + host => 'localhost:91', + base => 'http://localhost:91/' }, + { scheme => 'http', + host => 'example.com', + base => 'http://example.com/' }, + { scheme => 'https', + host => 'example.com', + base => 'https://example.com/' }, + { scheme => 'http', + server_name => 'example.com', + server_port => 80, + base => 'http://example.com/' }, + { scheme => 'http', + server_name => 'example.com', + server_port => 8080, + base => 'http://example.com:8080/' }, + { host => 'foobar.com', + server_name => 'example.com', + server_port => 8080, + base => 'http://foobar.com/' }, +); + +for my $block (@tests) { + my $env = { + 'psgi.url_scheme' => $block->{scheme} || 'http', + HTTP_HOST => $block->{host} || undef, + SERVER_NAME => $block->{server_name} || undef, + SERVER_PORT => $block->{server_port} || undef, + SCRIPT_NAME => $block->{script_name} || '', + }; + + my $req = Web::Request->new_from_env($env); + is $req->base_uri, $block->{base}; +} + +done_testing; diff --git a/t/body.t b/t/body.t new file mode 100644 index 0000000..4c04bd2 --- /dev/null +++ b/t/body.t @@ -0,0 +1,23 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + is_deeply $req->body_parameters, { foo => 'bar' }; + is $req->content, 'foo=bar'; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + my $res = $cb->(POST "/", { foo => "bar" }); + ok $res->is_success; +}; + +done_testing; diff --git a/t/content-on-get.t b/t/content-on-get.t new file mode 100644 index 0000000..99df1b9 --- /dev/null +++ b/t/content-on-get.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + is $req->content, ''; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + my $res = $cb->(GET "/"); + ok $res->is_success or diag $res->content; + + $res = $cb->(HEAD "/"); + ok $res->is_success or diag $res->content; +}; + +done_testing; diff --git a/t/content.t b/t/content.t new file mode 100644 index 0000000..aa39a1e --- /dev/null +++ b/t/content.t @@ -0,0 +1,26 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + is $req->content, 'body'; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + + my $req = HTTP::Request->new(POST => "/"); + $req->content("body"); + $req->content_type('text/plain'); + $req->content_length(4); + $cb->($req); +}; + +done_testing; + diff --git a/t/cookie.t b/t/cookie.t new file mode 100644 index 0000000..b32b2d0 --- /dev/null +++ b/t/cookie.t @@ -0,0 +1,59 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request; +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + + is $req->cookies->{undef}, undef; + is $req->cookies->{Foo}, 'Bar'; + is $req->cookies->{Bar}, 'Baz'; + is $req->cookies->{XXX}, 'Foo Bar'; + is $req->cookies->{YYY}, 0; + + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + my $req = HTTP::Request->new(GET => "/"); + $req->header(Cookie => 'Foo=Bar; Bar=Baz; XXX=Foo%20Bar; YYY=0; YYY=3'); + $cb->($req); +}; + +$app = sub { + my $req = Web::Request->new_from_env(shift); + is_deeply $req->cookies, {}; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + $cb->(HTTP::Request->new(GET => "/")); +}; + +$app = sub { + my $warn = 0; + local $SIG{__WARN__} = sub { $warn++ }; + + my $req = Web::Request->new_from_env(shift); + + is $req->cookies->{Foo}, 'Bar'; + is $warn, 0; + + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + my $req = HTTP::Request->new(GET => "/"); + $req->header(Cookie => 'Foo=Bar,; Bar=Baz;'); + $cb->($req); +}; + +done_testing; diff --git a/t/data/baybridge.jpg b/t/data/baybridge.jpg new file mode 100644 index 0000000..484bcda Binary files /dev/null and b/t/data/baybridge.jpg differ diff --git a/t/data/foo1.txt b/t/data/foo1.txt new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/t/data/foo1.txt @@ -0,0 +1 @@ +foo diff --git a/t/data/foo2.txt b/t/data/foo2.txt new file mode 100644 index 0000000..257cc56 --- /dev/null +++ b/t/data/foo2.txt @@ -0,0 +1 @@ +foo diff --git a/t/double_port.t b/t/double_port.t new file mode 100644 index 0000000..2bb1c82 --- /dev/null +++ b/t/double_port.t @@ -0,0 +1,24 @@ +#!/usr/bin/env perl +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +$Plack::Test::Impl = 'Server'; +local $ENV{PLACK_SERVER} = "HTTP::Server::PSGI"; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + return [200, [], [ $req->uri ]]; +}; + +test_psgi app => $app, client => sub { + my $cb = shift; + my $res = $cb->(GET "http://localhost/foo"); + ok $res->content !~ /:\d+:\d+/; +}; + +done_testing; + + diff --git a/t/hostname.t b/t/hostname.t new file mode 100644 index 0000000..7b0e20d --- /dev/null +++ b/t/hostname.t @@ -0,0 +1,15 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use Web::Request; + +my $req = Web::Request->new_from_env({ REMOTE_HOST => "foo.example.com" }); +is $req->remote_host, "foo.example.com"; + +$req = Web::Request->new_from_env({ REMOTE_HOST => '', REMOTE_ADDR => '127.0.0.1' }); +is $req->address, "127.0.0.1"; + +done_testing; diff --git a/t/many_upload.t b/t/many_upload.t new file mode 100644 index 0000000..77789a6 --- /dev/null +++ b/t/many_upload.t @@ -0,0 +1,77 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request; + +my $content = qq{------BOUNDARY +Content-Disposition: form-data; name="test_upload_file"; filename="yappo.txt" +Content-Type: text/plain + +SHOGUN +------BOUNDARY +Content-Disposition: form-data; name="test_upload_file"; filename="yappo2.txt" +Content-Type: text/plain + +SHOGUN2 +------BOUNDARY +Content-Disposition: form-data; name="test_upload_file3"; filename="yappo3.txt" +Content-Type: text/plain + +SHOGUN3 +------BOUNDARY +Content-Disposition: form-data; name="test_upload_file4"; filename="yappo4.txt" +Content-Type: text/plain + +SHOGUN4 +------BOUNDARY +Content-Disposition: form-data; name="test_upload_file4"; filename="yappo5.txt" +Content-Type: text/plain + +SHOGUN4 +------BOUNDARY +Content-Disposition: form-data; name="test_upload_file6"; filename="yappo6.txt" +Content-Type: text/plain + +SHOGUN6 +------BOUNDARY-- +}; +$content =~ s/\r\n/\n/g; +$content =~ s/\n/\r\n/g; + +{ + open my $in, '<', \$content; + my $req = Web::Request->new_from_env({ + 'psgi.input' => $in, + CONTENT_LENGTH => length($content), + CONTENT_TYPE => 'multipart/form-data; boundary=----BOUNDARY', + REQUEST_METHOD => 'POST', + SCRIPT_NAME => '/', + SERVER_PORT => 80, + }); + + my $uploads = $req->uploads; + + ok !exists $uploads->{undef}; + + my @uploads = @{ $req->all_uploads->{test_upload_file} }; + + like slurp($uploads[0]), qr|^SHOGUN|; + like slurp($uploads[1]), qr|^SHOGUN|; + is slurp($req->uploads->{test_upload_file4}), 'SHOGUN4'; + + my $test_upload_file3 = $req->uploads->{test_upload_file3}; + is slurp($test_upload_file3), 'SHOGUN3'; + + my @test_upload_file6 = @{ $req->all_uploads->{test_upload_file6} }; + is slurp($test_upload_file6[0]), 'SHOGUN6'; +} + +done_testing; + +sub slurp { + my $up = shift; + open my $fh, "<", $up->tempname or die; + join '', <$fh>; +} diff --git a/t/multi_read.t b/t/multi_read.t new file mode 100644 index 0000000..a4c8403 --- /dev/null +++ b/t/multi_read.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $app = sub { + my $env = shift; + my $req = Web::Request->new_from_env($env); + is $req->content, 'foo=bar'; + is $req->content, 'foo=bar'; + + $req = Web::Request->new_from_env($env); + is $req->content, 'foo=bar'; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + my $res = $cb->(POST "/", { foo => "bar" }); + ok $res->is_success; +}; + +done_testing; diff --git a/t/new.t b/t/new.t new file mode 100644 index 0000000..46aff08 --- /dev/null +++ b/t/new.t @@ -0,0 +1,30 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request; + +my $req = Web::Request->new_from_env({ + REQUEST_METHOD => 'GET', + SERVER_PROTOCOL => 'HTTP/1.1', + SERVER_PORT => 80, + SERVER_NAME => 'example.com', + SCRIPT_NAME => '/foo', + REMOTE_ADDR => '127.0.0.1', + 'psgi.version' => [ 1, 0 ], + 'psgi.input' => undef, + 'psgi.errors' => undef, + 'psgi.url_scheme' => 'http', +}); + +isa_ok($req, 'Web::Request'); + +is($req->address, '127.0.0.1', 'address'); +is($req->method, 'GET', 'method'); +is($req->protocol, 'HTTP/1.1', 'protocol'); +is($req->uri, 'http://example.com/foo', 'uri'); +is($req->port, 80, 'port'); +is($req->scheme, 'http', 'url_scheme'); + +done_testing; diff --git a/t/parameters.t b/t/parameters.t new file mode 100644 index 0000000..6f47739 --- /dev/null +++ b/t/parameters.t @@ -0,0 +1,27 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + my $b = $req->body_parameters; + is $b->{foo}, 'bar'; + my $q = $req->query_parameters; + is $q->{bar}, 'baz'; + + is_deeply $req->parameters, { foo => 'bar', 'bar' => 'baz' }; + + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + $cb->(POST "/?bar=baz", { foo => "bar" }); +}; + +done_testing; diff --git a/t/params.t b/t/params.t new file mode 100644 index 0000000..6d96fee --- /dev/null +++ b/t/params.t @@ -0,0 +1,26 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request; + +my $req = Web::Request->new_from_env({ QUERY_STRING => "foo=bar" }); +is_deeply $req->parameters, { foo => "bar" }; +is $req->param('foo'), "bar"; +is_deeply [ keys %{ $req->parameters } ], [ 'foo' ]; + +$req = Web::Request->new_from_env({ QUERY_STRING => "foo=bar&foo=baz" }); +is_deeply $req->parameters, { foo => "baz" }; +is $req->param('foo'), "baz"; +is_deeply $req->all_parameters->{foo}, [ qw(bar baz) ]; +is_deeply [ keys %{ $req->parameters } ], [ 'foo' ]; + +$req = Web::Request->new_from_env({ QUERY_STRING => "foo=bar&foo=baz&bar=baz" }); +is_deeply $req->parameters, { foo => "baz", bar => "baz" }; +is_deeply $req->query_parameters, { foo => "baz", bar => "baz" }; +is $req->param('foo'), "baz"; +is_deeply $req->all_parameters->{foo}, [ qw(bar baz) ]; +is_deeply [ sort keys %{ $req->parameters } ], [ 'bar', 'foo' ]; + +done_testing; diff --git a/t/path_info.t b/t/path_info.t new file mode 100644 index 0000000..bab50b9 --- /dev/null +++ b/t/path_info.t @@ -0,0 +1,36 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Plack::App::URLMap; +use Web::Request; + +my $path_app = sub { + my $req = Web::Request->new_from_env(shift); + my $res = $req->new_response(status => 200); + $res->content_type('text/plain'); + $res->body($req->path_info); + return $res->finalize; +}; + +my $app = Plack::App::URLMap->new; +$app->map("/foo" => $path_app); +$app->map("/" => $path_app); + +test_psgi app => $app->to_app, client => sub { + my $cb = shift; + + my $res = $cb->(GET "http://localhost/foo"); + is $res->content, ''; + + $res = $cb->(GET "http://localhost/foo/bar"); + is $res->content, '/bar'; + + $res = $cb->(GET "http://localhost/xxx/yyy"); + is $res->content, '/xxx/yyy'; +}; + +done_testing; diff --git a/t/path_info_escaped.t b/t/path_info_escaped.t new file mode 100644 index 0000000..28e712c --- /dev/null +++ b/t/path_info_escaped.t @@ -0,0 +1,33 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use Data::Dumper; +use HTTP::Request::Common; +use Web::Request; + +my $path_app = sub { + my $req = Web::Request->new_from_env(shift); + my $res = $req->new_response(status => 200); + $res->content_type('text/plain'); + $res->body('my ' . Dumper([ $req->uri, $req->parameters ])); + return $res->finalize; +}; + +test_psgi $path_app, sub { + my $cb = shift; + + my $res = $cb->(GET "http://localhost/foo.bar-baz?a=b"); + is_deeply eval($res->content), [ URI->new("http://localhost/foo.bar-baz?a=b"), { a => 'b' } ]; + + $res = $cb->(GET "http://localhost/foo%2fbar#ab"); + is_deeply eval($res->content), [ URI->new("http://localhost/foo/bar"), {} ], + "%2f vs / can't be distinguished - that's alright"; + + $res = $cb->(GET "http://localhost/%23foo?a=b"); + is_deeply eval($res->content), [ URI->new("http://localhost/%23foo?a=b"), { a => 'b' } ]; +}; + +done_testing; diff --git a/t/readbody.t b/t/readbody.t new file mode 100644 index 0000000..44fa057 --- /dev/null +++ b/t/readbody.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use Try::Tiny; +use Web::Request; + +{ + try { + my $data = 'a'; + open my $input, "<", \$data; + my $req = Web::Request->new_from_env({ + 'psgi.input' => $input, + CONTENT_LENGTH => 3, + CONTENT_TYPE => 'application/octet-stream' + }); + $req->body_parameters; + } catch { + like $_, qr/Bad Content-Length/; + } +} + +done_testing; diff --git a/t/request_uri.t b/t/request_uri.t new file mode 100644 index 0000000..b3adcbd --- /dev/null +++ b/t/request_uri.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + return [ 200, [], [ $req->request_uri ] ]; +}; + +test_psgi $app, sub { + my $cb = shift; + + my $res = $cb->(GET "http://localhost/foo%20bar"); + is $res->content, '/foo%20bar'; + + $res = $cb->(GET "http://localhost:2020/FOO/bar,baz"); + is $res->content, '/FOO/bar,baz'; +}; + +done_testing; diff --git a/t/upload-basename.t b/t/upload-basename.t new file mode 100644 index 0000000..d13c489 --- /dev/null +++ b/t/upload-basename.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request::Upload; + +my $upload = Web::Request::Upload->new( + filename => '/tmp/foo/bar/hoge.txt', +); +is $upload->basename, 'hoge.txt'; + +done_testing; diff --git a/t/upload-large.t b/t/upload-large.t new file mode 100644 index 0000000..39e14a7 --- /dev/null +++ b/t/upload-large.t @@ -0,0 +1,33 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my $file = "t/data/baybridge.jpg"; + +my @backends = qw( Server MockHTTP ); +sub flip_backend { $Plack::Test::Impl = shift @backends } + +local $ENV{PLACK_SERVER} = "HTTP::Server::PSGI"; + +my $app = sub { + my $req = Web::Request->new_from_env(shift); + is $req->uploads->{image}->size, -s $file; + is $req->uploads->{image}->content_type, 'image/jpeg'; + is $req->uploads->{image}->basename, 'baybridge.jpg'; + $req->new_response(status => 200)->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + $cb->(POST "/", Content_Type => 'form-data', Content => [ + image => [ $file ], + ]); +} while flip_backend; + +done_testing; + diff --git a/t/upload.t b/t/upload.t new file mode 100644 index 0000000..a024b3d --- /dev/null +++ b/t/upload.t @@ -0,0 +1,61 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Plack::Test; + +use HTTP::Request::Common; +use Web::Request; + +my @temp_files = (); + +my $app = sub { + my $env = shift; + my $req = Web::Request->new_from_env($env); + + isa_ok $req->uploads->{foo}, 'HASH'; + is $req->uploads->{foo}->{filename}, 'foo2.txt'; + + my @files = $req->upload('foo'); + is scalar(@files), 2; + is $files[0]->filename, 'foo1.txt'; + is $files[1]->filename, 'foo2.txt'; + ok -e $files[0]->tempname; + + is join(', ', sort { $a cmp $b } $req->upload()), 'bar, foo'; + + for (qw(foo bar)) { + my $temp_file = $req->upload($_)->path; + ok -f $temp_file; + push @temp_files, $temp_file; + } + + my $res = $req->new_response(status => 200); + + undef $req; # Simulate when we instantiate Web::Request multiple times + + # redo the test with the same $env + $req = Web::Request->new_from_env($env); + @files = $req->upload('foo'); + is scalar(@files), 2; + is $files[0]->filename, 'foo1.txt'; + ok -e $files[0]->tempname; + + $res->finalize; +}; + +test_psgi $app, sub { + my $cb = shift; + + $cb->(POST "/", Content_Type => 'form-data', Content => [ + foo => [ "t/data/foo1.txt" ], + foo => [ "t/data/foo2.txt" ], + bar => [ "t/data/foo1.txt" ], + ]); +}; + +# Check if the temp files got cleaned up properly +ok !-f $_ for @temp_files; + +done_testing; + diff --git a/t/uri.t b/t/uri.t new file mode 100644 index 0000000..08aa584 --- /dev/null +++ b/t/uri.t @@ -0,0 +1,104 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Web::Request; + +my @tests = ( + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + }, + uri => 'http://example.com/', + parameters => {} }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + PATH_INFO => "/foo bar", + }, + uri => 'http://example.com/foo%20bar', + parameters => {} }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => '/test.c', + }, + uri => 'http://example.com/test.c', + parameters => {} }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => '/test.c', + PATH_INFO => '/info', + }, + uri => 'http://example.com/test.c/info', + parameters => {} }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => '/test', + QUERY_STRING => 'dynamic=daikuma', + }, + uri => 'http://example.com/test?dynamic=daikuma', + parameters => { dynamic => 'daikuma' } }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => '/exec/' + }, + uri => 'http://example.com/exec/', + parameters => {} }, + { add_env => { + SERVER_NAME => 'example.com' + }, + uri => 'http://example.com/', + parameters => {} }, + { add_env => {}, + uri => 'http:///', + parameters => {} }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + QUERY_STRING => 'aco=tie' + }, + uri => 'http://example.com/?aco=tie', + parameters => { aco => 'tie' } }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + QUERY_STRING => "foo_only" + }, + uri => 'http://example.com/?foo_only', + parameters => { foo_only => '' } }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + QUERY_STRING => "foo&bar=baz" + }, + uri => 'http://example.com/?foo&bar=baz', + parameters => { foo => '', bar => 'baz' } }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "", + QUERY_STRING => 0 + }, + uri => 'http://example.com/?0', + parameters => { 0 => '' } }, + { add_env => { + HTTP_HOST => 'example.com', + SCRIPT_NAME => "/foo bar", + PATH_INFO => "/baz quux", + }, + uri => 'http://example.com/foo%20bar/baz%20quux', + parameters => {} } +); + +for my $block (@tests) { + my $env = {SERVER_PORT => 80}; + while (my($key, $val) = each %{ $block->{add_env} || {} }) { + $env->{$key} = $val; + } + my $req = Web::Request->new_from_env($env); + + is $req->uri, $block->{uri}; + is_deeply $req->query_parameters, $block->{parameters}; +}; + +done_testing; diff --git a/t/uri_utf8.t b/t/uri_utf8.t new file mode 100644 index 0000000..f10a745 --- /dev/null +++ b/t/uri_utf8.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use utf8; +use Test::More; + +use HTTP::Request; +use Web::Request; + +my $path = "/Платежи"; + +my $hreq = HTTP::Request->new(GET => "http://localhost" . $path); +my $req = Web::Request->new_from_request($hreq); + +is $req->uri->path, '/%D0%9F%D0%BB%D0%B0%D1%82%D0%B5%D0%B6%D0%B8'; + +done_testing; -- cgit v1.2.3-54-g00ecf