Compiler-Parser
view release on metacpan or search on metacpan
t/app/Plack/Test/Suite.t view on Meta::CPAN
use strict;
use warnings;
use Test::More;
use Compiler::Lexer;
use Compiler::Parser;
use Compiler::Parser::AST::Renderer;
use Test::Compiler::Parser;
subtest 'parse Plack/Test/Suite.pm' => sub {
my $script = do { local $/; <DATA> };
my $tokens = Compiler::Lexer->new('')->tokenize($script);
my $ast = Compiler::Parser->new->parse($tokens);
Compiler::Parser::AST::Renderer->new->render($ast);
node_ok($ast->root, [
Test::Compiler::Parser::package { 'Plack::Test::Suite',
},
module { 'strict',
},
module { 'warnings',
},
module { 'Digest::MD5',
},
module { 'File::ShareDir',
},
module { 'HTTP::Request',
},
module { 'HTTP::Request::Common',
},
module { 'LWP::UserAgent',
},
module { 'Test::More',
},
module { 'Test::TCP',
},
module { 'Plack::Loader',
},
module { 'Plack::Middleware::Lint',
},
module { 'Plack::Util',
},
module { 'Plack::Request',
},
module { 'Try::Tiny',
},
branch { '=',
left => leaf '$share_dir',
right => function_call { 'try',
args => [
branch { '||',
left => hash_ref { '{}',
data => function_call { 'File::ShareDir::dist_dir',
args => [
leaf 'Plack',
],
},
},
right => leaf 'share',
},
],
},
},
branch { '=',
left => hash { '$ENV',
key => hash_ref { '{}',
data => leaf 'PLACK_TEST_SCRIPT_NAME',
},
},
right => leaf '',
},
branch { '=',
left => leaf '@TEST',
right => list { '()',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
t/app/Plack/Test/Suite.t view on Meta::CPAN
left => leaf '$env',
right => hash_ref { '{}',
data => leaf 'CONTENT_LENG...
},
},
},
},
right => branch { '=>',
left => leaf 'Client-Content-Type',
right => branch { '->',
left => leaf '$env',
right => hash_ref { '{}',
data => leaf 'CONTENT_TYPE',
},
},
},
},
},
},
},
right => array_ref { '[]',
data => branch { '.',
left => leaf 'Hello, ',
right => leaf '$body',
},
},
},
},
},
},
],
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'big POST',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
branch { '=',
left => leaf '$chunk',
right => branch { 'x',
left => leaf 'abcdefgh',
right => leaf '12000',
},
},
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { '=>',
left => leaf 'POST',
right => leaf 'http://127.0.0.1/',
},
},
],
},
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content_length',
args => [
function_call { 'length',
args => [
leaf '$chunk',
],
},
],
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content_type',
args => [
leaf 'application/octet-stream',
],
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content',
args => [
leaf '$chunk',
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'code',
args => [
],
},
},
right => leaf '200',
t/app/Plack/Test/Suite.t view on Meta::CPAN
},
right => function { 'sub',
body => [
branch { '=',
left => leaf '$env',
right => function_call { 'shift',
args => [
],
},
},
function_call { 'open',
args => [
branch { ',',
left => branch { ',',
left => leaf '$io',
right => leaf '>',
},
right => single_term_operator { '\\',
expr => leaf '$error',
},
},
],
},
branch { '=',
left => branch { '->',
left => leaf '$env',
right => hash_ref { '{}',
data => leaf 'psgi.errors',
},
},
right => leaf '$io',
},
function_call { 'die',
args => [
leaf 'Throwing an exception from app handler. Server shouldn\'t crash.',
],
},
],
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'multi headers (request)',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { ',',
left => branch { '=>',
left => leaf 'GET',
right => leaf 'http://127.0.0.1/',
},
},
},
],
},
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'push_header',
args => [
list { '()',
data => branch { '=>',
left => leaf 'Foo',
right => leaf 'bar',
},
},
],
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'push_header',
args => [
list { '()',
data => branch { '=>',
left => leaf 'Foo',
right => leaf 'baz',
},
},
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'like',
args => [
list { '()',
data => branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
],
},
},
t/app/Plack/Test/Suite.t view on Meta::CPAN
right => function { 'sub',
body => [
branch { '=',
left => leaf '$env',
right => function_call { 'shift',
args => [
],
},
},
Test::Compiler::Parser::return { 'return',
body => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => leaf '200',
right => array_ref { '[]',
data => branch { ',',
left => branch { '=>',
left => leaf 'Content-Type',
right => leaf 'text/plain',
},
},
},
},
right => array_ref { '[]',
data => branch { '->',
left => leaf '$env',
right => hash_ref { '{}',
data => leaf 'HTTP_FOO',
},
},
},
},
},
},
],
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'multi headers (response)',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { '=>',
left => leaf 'GET',
right => leaf 'http://127.0.0.1/',
},
},
],
},
},
},
},
},
branch { '=',
left => leaf '$foo',
right => branch { '->',
left => leaf '$res',
right => function_call { 'header',
args => [
leaf 'X-Foo',
],
},
},
},
function_call { 'like',
args => [
branch { ',',
left => leaf '$foo',
right => reg_prefix { 'qr',
expr => leaf 'foo,\s*bar,\s*baz',
},
},
],
},
],
},
},
right => function { 'sub',
body => [
branch { '=',
left => leaf '$env',
right => function_call { 'shift',
args => [
],
},
},
Test::Compiler::Parser::return { 'return',
body => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => leaf '200',
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { ',',
left => branch { '=>',
left => leaf 'Content-Type',
right => leaf 'text/plain',
},
right => leaf 'X-Foo',
},
right => leaf 'foo',
},
right => leaf 'X-Foo',
},
right => leaf 'bar, baz',
},
},
},
right => array_ref { '[]',
data => leaf 'hi',
},
},
},
},
],
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'Do not set $env->{COOKIE}',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { ',',
left => branch { '=>',
left => leaf 'GET',
right => leaf 'http://127.0.0.1/',
},
},
},
],
},
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'push_header',
args => [
list { '()',
data => branch { '=>',
left => leaf 'Cookie',
right => leaf 'foo=bar',
},
},
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'is',
args => [
list { '()',
data => branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'header',
args => [
leaf 'X-Cookie',
],
},
},
right => leaf '0',
},
},
],
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
t/app/Plack/Test/Suite.t view on Meta::CPAN
],
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
],
},
},
right => leaf 'Not Found',
},
],
},
],
},
},
right => function { 'sub',
body => Test::Compiler::Parser::return { 'return',
body => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => leaf '404',
right => array_ref { '[]',
data => branch { ',',
left => leaf 'Content-Type',
right => leaf 'text/plain',
},
},
},
right => array_ref { '[]',
data => leaf 'Not Found',
},
},
},
},
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'request->input seekable',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { '=>',
left => leaf 'POST',
right => leaf 'http://127.0.0.1/',
},
},
],
},
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content',
args => [
leaf 'body',
],
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content_type',
args => [
leaf 'text/plain',
],
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'content_length',
args => [
leaf '4',
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
],
},
},
right => leaf 'body',
},
],
},
],
t/app/Plack/Test/Suite.t view on Meta::CPAN
data => branch { ',',
left => leaf 'Content-Type',
right => leaf 'text/plain',
},
},
},
right => array_ref { '[]',
data => leaf 'OK',
},
},
},
},
],
},
},
},
},
},
right => array_ref { '[]',
data => branch { ',',
left => branch { ',',
left => branch { ',',
left => leaf 'handle Authorization header',
right => function { 'sub',
body => [
branch { '=',
left => leaf '$cb',
right => function_call { 'shift',
args => [
],
},
},
block { '',
body => [
if_stmt { 'if',
expr => branch { 'eq',
left => branch { '||',
left => hash { '$ENV',
key => hash_ref { '{}',
data => leaf 'PLACK_TEST_HANDLER',
},
},
right => leaf '',
},
right => leaf 'CGI',
},
true_stmt => function_call { 'skip',
args => [
branch { ',',
left => leaf 'Authorization header is unsupported under CGI',
right => leaf '4',
},
],
},
},
block { '',
body => [
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { ',',
left => branch { '=>',
left => leaf 'GET',
right => leaf 'http://127.0.0.1/',
},
},
},
],
},
},
},
branch { '->',
left => leaf '$req',
right => function_call { 'push_header',
args => [
list { '()',
data => branch { '=>',
left => leaf 'Authorization',
right => leaf 'Basic XXXX',
},
},
],
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'header',
args => [
leaf 'X-AUTHORIZATION',
],
},
},
right => leaf '1',
},
],
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
],
},
},
right => leaf 'Basic XXXX',
},
],
},
],
},
block { '',
body => [
branch { '=',
left => leaf '$req',
right => branch { '->',
left => leaf 'HTTP::Request',
right => function_call { 'new',
args => [
list { '()',
data => branch { ',',
left => branch { '=>',
left => leaf 'GET',
right => leaf 'http://127.0.0.1/',
},
},
},
],
},
},
},
branch { '=',
left => leaf '$res',
right => branch { '->',
left => leaf '$cb',
right => list { '()',
data => leaf '$req',
},
},
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'header',
args => [
leaf 'X-AUTHORIZATION',
],
},
},
right => leaf '0',
},
],
},
function_call { 'is',
args => [
branch { ',',
left => branch { '->',
left => leaf '$res',
right => function_call { 'content',
args => [
],
},
},
right => leaf '',
},
],
},
],
},
],
},
],
},
},
right => function { 'sub',
t/app/Plack/Test/Suite.t view on Meta::CPAN
},
},
right => branch { '=>',
left => leaf 'port',
right => leaf '$server_port',
},
},
},
},
],
},
],
},
function { 'test_app_handler',
body => Test::Compiler::Parser::return { 'return',
body => function { 'sub',
body => [
branch { '=',
left => leaf '$env',
right => function_call { 'shift',
args => [
],
},
},
branch { '->',
left => branch { '->',
left => array { '$TEST',
idx => array_ref { '[]',
data => branch { '->',
left => leaf '$env',
right => hash_ref { '{}',
data => leaf 'HTTP_X_PLACK_TEST',
},
},
},
},
right => array_ref { '[]',
data => leaf '2',
},
},
right => list { '()',
data => leaf '$env',
},
},
],
},
},
},
leaf '1',
]);
};
done_testing;
__DATA__
package Plack::Test::Suite;
use strict;
use warnings;
use Digest::MD5;
use File::ShareDir;
use HTTP::Request;
use HTTP::Request::Common;
use LWP::UserAgent;
use Test::More;
use Test::TCP;
use Plack::Loader;
use Plack::Middleware::Lint;
use Plack::Util;
use Plack::Request;
use Try::Tiny;
my $share_dir = try { File::ShareDir::dist_dir('Plack') } || 'share';
$ENV{PLACK_TEST_SCRIPT_NAME} = '';
# 0: test name
# 1: request generator coderef.
# 2: request handler
# 3: test case for response
our @TEST = (
[
'SCRIPT_NAME',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->content, $ENV{PLACK_TEST_SCRIPT_NAME};
},
sub {
my $env = shift;
return [ 200, ["Content-Type", "text/plain"], [ $env->{SCRIPT_NAME} ] ];
},
],
[
'GET',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/?name=miyagawa");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, 'Hello, name=miyagawa';
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ 'Hello, ' . $env->{QUERY_STRING} ],
];
},
],
[
'POST',
sub {
my $cb = shift;
my $res = $cb->(POST "http://127.0.0.1/", [name => 'tatsuhiko']);
is $res->code, 200;
is $res->message, 'OK';
is $res->header('Client-Content-Length'), 14;
is $res->header('Client-Content-Type'), 'application/x-www-form-urlencoded';
is $res->header('content_type'), 'text/plain';
is $res->content, 'Hello, name=tatsuhiko';
},
sub {
my $env = shift;
my $body;
$env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH});
return [
200,
[ 'Content-Type' => 'text/plain',
'Client-Content-Length' => $env->{CONTENT_LENGTH},
'Client-Content-Type' => $env->{CONTENT_TYPE},
],
[ 'Hello, ' . $body ],
];
},
],
[
'big POST',
sub {
my $cb = shift;
my $chunk = "abcdefgh" x 12000;
my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
$req->content_length(length $chunk);
$req->content_type('application/octet-stream');
$req->content($chunk);
my $res = $cb->($req);
is $res->code, 200;
is $res->message, 'OK';
is $res->header('Client-Content-Length'), length $chunk;
is length $res->content, length $chunk;
is Digest::MD5::md5_hex($res->content), Digest::MD5::md5_hex($chunk);
},
sub {
my $env = shift;
my $len = $env->{CONTENT_LENGTH};
my $body = '';
my $spin;
while ($len > 0) {
my $rc = $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}, length $body);
$len -= $rc;
last if $spin++ > 2000;
}
return [
200,
[ 'Content-Type' => 'text/plain',
'Client-Content-Length' => $env->{CONTENT_LENGTH},
'Client-Content-Type' => $env->{CONTENT_TYPE},
],
[ $body ],
];
},
],
[
'psgi.url_scheme',
sub {
my $cb = shift;
my $res = $cb->(POST "http://127.0.0.1/");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, 'http';
},
sub {
my $env = $_[0];
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{'psgi.url_scheme'} ],
];
},
],
[
'return glob',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
like $res->content, qr/^package /;
like $res->content, qr/END_MARK_FOR_TESTING$/;
t/app/Plack/Test/Suite.t view on Meta::CPAN
return [
200,
[ 'Content-Type' => 'text/plain', ],
CalledClose->new(),
];
},
],
[
'has errors',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/has_errors");
is $res->content, 1;
},
sub {
my $env = shift;
my $err = $env->{'psgi.errors'};
my $has_errors = defined $err;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[$has_errors]
];
},
],
[
'status line',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo/?dankogai=kogaidan");
is($res->status_line, '200 OK');
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[1]
];
},
],
[
'Do not crash when the app dies',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 500;
is $res->message, 'Internal Server Error';
},
sub {
my $env = shift;
open my $io, '>', \my $error;
$env->{'psgi.errors'} = $io;
die "Throwing an exception from app handler. Server shouldn't crash.";
},
],
[
'multi headers (request)',
sub {
my $cb = shift;
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Foo => "bar");
$req->push_header(Foo => "baz");
my $res = $cb->($req);
like($res->content, qr/^bar,\s*baz$/);
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{HTTP_FOO} ]
];
},
],
[
'multi headers (response)',
sub {
my $cb = shift;
my $res = $cb->(HTTP::Request->new(GET => "http://127.0.0.1/"));
my $foo = $res->header('X-Foo');
like $foo, qr/foo,\s*bar,\s*baz/;
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-Foo', 'foo', 'X-Foo', 'bar, baz' ],
[ 'hi' ]
];
},
],
[
'Do not set $env->{COOKIE}',
sub {
my $cb = shift;
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Cookie => "foo=bar");
my $res = $cb->($req);
is($res->header('X-Cookie'), 0);
is $res->content, 'foo=bar';
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-Cookie' => $env->{COOKIE} ? 1 : 0 ],
[ $env->{HTTP_COOKIE} ]
];
},
],
[
'no entity headers on 304',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 304;
is $res->message, 'Not Modified';
is $res->content, '';
ok ! defined $res->header('content_type'), "No Content-Type";
ok ! defined $res->header('content_length'), "No Content-Length";
ok ! defined $res->header('transfer_encoding'), "No Transfer-Encoding";
},
sub {
my $env = shift;
return [ 304, [], [] ];
},
],
[
'REQUEST_URI is set',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz%73?x=a");
is $res->content, $ENV{PLACK_TEST_SCRIPT_NAME} . "/foo/bar%20baz%73?x=a";
},
sub {
my $env = shift;
return [ 200, [ 'Content-Type' => 'text/plain' ], [ $env->{REQUEST_URI} ] ];
},
],
[
'filehandle with path()',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/foo.jpg");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'image/jpeg';
is length $res->content, 4745;
},
sub {
my $env = shift;
open my $fh, '<', "$share_dir/face.jpg";
Plack::Util::set_io_path($fh, "$share_dir/face.jpg");
return [
t/app/Plack/Test/Suite.t view on Meta::CPAN
},
sub {
my $env = shift;
$env->{'psgi.streaming'} or return [ 501, ['Content-Type','text/plain'], [] ];
return sub {
my $respond = shift;
my $writer = $respond->([
200,
[ 'Content-Type' => 'text/plain', ],
]);
$writer->write("Hello, ");
$writer->write($env->{QUERY_STRING});
$writer->close();
}
},
],
[
'CRLF output and FCGI parse bug',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->header("Foo"), undef;
is $res->content, "Foo: Bar\r\n\r\nHello World";
},
sub {
return [ 200, [ "Content-Type", "text/plain" ], [ "Foo: Bar\r\n\r\nHello World" ] ];
},
],
[
'newlines',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is length($res->content), 7;
},
sub {
return [ 200, [ "Content-Type", "text/plain" ], [ "Bar\nBaz" ] ];
},
],
[
'test 404',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
is $res->code, 404;
is $res->message, 'Not Found';
is $res->content, 'Not Found';
},
sub {
return [ 404, [ "Content-Type", "text/plain" ], [ "Not Found" ] ];
},
],
[
'request->input seekable',
sub {
my $cb = shift;
my $req = HTTP::Request->new(POST => "http://127.0.0.1/");
$req->content("body");
$req->content_type('text/plain');
$req->content_length(4);
my $res = $cb->($req);
is $res->content, 'body';
},
sub {
my $req = Plack::Request->new(shift);
return [ 200, [ "Content-Type", "text/plain" ], [ $req->content ] ];
},
],
[
'request->content on GET',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1/");
ok $res->is_success;
},
sub {
my $req = Plack::Request->new(shift);
$req->content;
return [ 200, [ "Content-Type", "text/plain" ], [ "OK" ] ];
},
],
[
'handle Authorization header',
sub {
my $cb = shift;
SKIP: {
skip "Authorization header is unsupported under CGI", 4 if ($ENV{PLACK_TEST_HANDLER} || "") eq "CGI";
{
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
$req->push_header(Authorization => 'Basic XXXX');
my $res = $cb->($req);
is $res->header('X-AUTHORIZATION'), 1;
is $res->content, 'Basic XXXX';
};
{
my $req = HTTP::Request->new(
GET => "http://127.0.0.1/",
);
my $res = $cb->($req);
is $res->header('X-AUTHORIZATION'), 0;
is $res->content, '';
};
};
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', 'X-AUTHORIZATION' => exists($env->{HTTP_AUTHORIZATION}) ? 1 : 0 ],
[ $env->{HTTP_AUTHORIZATION} || '' ],
];
},
],
[
'repeated slashes',
sub {
my $cb = shift;
my $res = $cb->(GET "http://127.0.0.1//foo///bar/baz");
is $res->code, 200;
is $res->message, 'OK';
is $res->header('content_type'), 'text/plain';
is $res->content, '//foo///bar/baz';
},
sub {
my $env = shift;
return [
200,
[ 'Content-Type' => 'text/plain', ],
[ $env->{PATH_INFO} ],
];
},
],
);
sub runtests {
my($class, $runner) = @_;
for my $test (@TEST) {
$runner->(@$test);
}
}
sub run_server_tests {
my($class, $server, $server_port, $http_port, %args) = @_;
if (ref $server ne 'CODE') {
my $server_class = $server;
$server = sub {
my($port, $app) = @_;
my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1", %args);
$app = Plack::Middleware::Lint->wrap($app);
$server->run($app);
}
}
test_tcp(
client => sub {
( run in 0.753 second using v1.01-cache-2.11-cpan-d7a12ab2c7f )