use Test::More import => ['!pass'];
use strict;
use warnings;
use LWP::UserAgent;
eval "use Test::TCP";
plan skip_all => "need Test::TCP" if $@;
use Dancer::Core::Server::Standalone;
my @tests = (
$] >= 5.010
? [ [get => '/usr/delete/234'],
[200, [], [join(':', sort (qw'class usr action delete id 234'))]]
]
: (),
[ [get => '/'],
[200, ['Content-Type' => 'text/html'], ['t::lib::TestApp']]
],
[[get => '/mime/f'], [200, [], ['text/foo']]],
[[get => '/mime/foo'], [200, [], ['text/foo']]],
[[get => '/mime/something'], [200, [], ['text/bar']]],
[[get => '/haltme'], [200, [], ['t::lib::TestApp']]],
[ [get => '/content_type/svg'],
[200, ['Content-Type' => 'image/svg+xml'], ['1']]
],
[[get => '/content_type/f'], [200, ['Content-Type' => 'text/foo'], ['1']]],
[[get => '/rewrite_me'], [200, [], ['rewritten!']]],
[[post => '/dirname'], [200, [], ['/etc']]],
[[get => '/user/sukria/home'], [200, [], ['hello sukria']]],
[[get => '/config'], [200, [], ['1 1 and 42']]],
[[get => '/header/X-Test/42'], [200, ['X-Test' => 42], ['1']]],
[[get => '/header/X-Test/42/21'], [200, ['X-Test' => '42, 21'], ['1']]],
[[get => '/header_twice/X-Test/42/21'], [200, ['X-Test' => '21'], ['1']]],
[[get => '/booleans'], [200, [], ['1:0']]],
[[get => '/any'], [200, [], ['Called with method GET']]],
[[post => '/any'], [200, [], ['Called with method POST']]],
[[head => '/any'], [200, [], ['']]],
[[get => '/prefix/bar'], [200, [], ['/prefix/bar']]],
[[get => '/prefix/prefix1/bar'], [200, [], ['/prefix/prefix1/bar']]],
# - # FIXME : this is not supported yet, and wasnt neither in dancer 1
# branch topic/prefix_nightmare has a fix for it
#[
#[ get => '/prefix/prefix2/foo' ],
#[ 200, [ ], ['/prefix/prefix2/foo'] ]
#],
);
test_tcp(
client => sub {
my $port = shift;
for my $t (@tests) {
my $req = $t->[0];
my $expected = $t->[1];
# Using this approach it is not possible to test get/put
my $method = $req->[0];
my $path = $req->[1];
my $ua = LWP::UserAgent->new;
my $res = $ua->$method("http://localhost:${port}${path}");
is $res->code, $expected->[0], "status is ok for $method $path";
is $res->content, $expected->[2][0],
"content is ok for $method $path";
# headers
my $headers = $expected->[1];
for (my $i = 0; $i < scalar(@$headers); $i += 2) {
my $header = $headers->[$i];
my $value = $headers->[$i + 1];
is $res->header($header), $value,
"header $header is $value for $method $path";
}
}
},
server => sub {
my $port = shift;
use Dancer;
use t::lib::TestApp;
set server_port => $port;
start;
},
);
done_testing;