diag
"If you want extra speed, install URL::Encode::XS"
if
!
$Dancer2::Core::Request::XS_URL_DECODE
;
diag
"If you want extra speed, install CGI::Deurl::XS"
if
!
$Dancer2::Core::Request::XS_PARSE_QUERY_STRING
;
sub
run_test {
my
$env
= {
'psgi.url_scheme'
=>
'http'
,
REQUEST_METHOD
=>
'GET'
,
SCRIPT_NAME
=>
'/foo'
,
PATH_INFO
=>
'/bar/baz'
,
REQUEST_URI
=>
'/foo/bar/baz'
,
QUERY_STRING
=>
'foo=42&bar=12&bar=13&bar=14'
,
SERVER_NAME
=>
'localhost'
,
SERVER_PORT
=> 5000,
SERVER_PROTOCOL
=>
'HTTP/1.1'
,
REMOTE_ADDR
=>
'127.0.0.1'
,
HTTP_X_FORWARDED_FOR
=>
'127.0.0.2'
,
HTTP_X_FORWARDED_HOST
=>
'secure.frontend'
,
HTTP_X_FORWARDED_PROTOCOL
=>
'https'
,
REMOTE_HOST
=>
'localhost'
,
HTTP_USER_AGENT
=>
'Mozilla'
,
REMOTE_USER
=>
'sukria'
,
HTTP_COOKIE
=>
'cookie.a=foo=bar; cookie.b=1234abcd; no.value.cookie'
,
};
my
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
note
"tests for accessors"
;
is
$req
->agent,
'Mozilla'
;
is
$req
->user_agent,
'Mozilla'
;
is
$req
->remote_address,
'127.0.0.1'
;
is
$req
->address,
'127.0.0.1'
;
is
$req
->forwarded_for_address,
'127.0.0.2'
;
is
$req
->remote_host,
'localhost'
;
is
$req
->protocol,
'HTTP/1.1'
;
is
$req
->port, 5000;
is
$req
->request_uri,
'/foo/bar/baz'
;
is
$req
->uri,
'/foo/bar/baz'
;
is
$req
->user,
'sukria'
;
is
$req
->script_name,
'/foo'
;
is
$req
->scheme,
'http'
;
is
$req
->referer,
undef
;
ok( !
$req
->secure );
is
$req
->method,
'GET'
;
is
$req
->request_method,
'GET'
;
ok(
$req
->is_get );
ok( !
$req
->is_post );
ok( !
$req
->is_put );
ok( !
$req
->is_delete );
ok( !
$req
->is_patch );
ok( !
$req
->is_head );
is
$req
->id, 1;
is
$req
->to_string,
'[#1] GET /bar/baz'
;
note
"tests params"
;
is_deeply {
$req
->params }, {
foo
=> 42,
bar
=> [ 12, 13, 14 ] };
note
"tests cookies"
;
is(
keys
%{
$req
->cookies }, 2,
"multiple cookies extracted"
);
my
$forward
= Dancer2::Core::App->new(
request
=>
$req
)
->make_forward_to(
'/somewhere'
);
is
$forward
->path_info,
'/somewhere'
;
is
$forward
->method,
'GET'
;
note
"tests for uri_for"
;
is
$req
->uri_for(
'bar'
, {
baz
=>
'baz'
} ),
is
$req
->uri_for(
'/bar'
,
undef
, 1 ),
'uri_for returns a URI (with $dont_escape)'
;
is
$req
->request_uri,
'/foo/bar/baz'
;
is
$req
->path_info,
'/bar/baz'
;
{
local
$env
->{SCRIPT_NAME} =
''
;
}
{
local
$env
->{SERVER_NAME} = 0;
local
$env
->{HTTP_HOST} =
'oddhostname:5000'
;
}
note
"testing behind proxy"
; {
my
$req
= Dancer2::Core::Request->new(
env
=>
$env
,
is_behind_proxy
=> 1
);
is
$req
->secure, 1;
is
$req
->host,
$env
->{HTTP_X_FORWARDED_HOST};
is
$req
->scheme,
'https'
;
}
note
"testing behind proxy when optional headers are not set"
; {
local
$env
->{HTTP_HOST} =
'oddhostname:5000'
;
delete
local
$env
->{
'HTTP_X_FORWARDED_FOR'
};
delete
local
$env
->{
'HTTP_X_FORWARDED_HOST'
};
delete
local
$env
->{
'HTTP_X_FORWARDED_PROTOCOL'
};
my
$req
= Dancer2::Core::Request->new(
env
=>
$env
,
is_behind_proxy
=> 1
);
is !
$req
->secure, 1;
is
$req
->host,
'oddhostname:5000'
;
is
$req
->scheme,
'http'
;
}
note
"testing path and uri_base"
; {
my
$base
= {
'psgi.url_scheme'
=>
'http'
,
REQUEST_METHOD
=>
'GET'
,
QUERY_STRING
=>
''
,
SERVER_NAME
=>
'localhost'
,
SERVER_PORT
=> 5000,
SERVER_PROTOCOL
=>
'HTTP/1.1'
,
};
my
$env
= {
%$base
,
SCRIPT_NAME
=>
'/foo'
,
PATH_INFO
=>
''
,
REQUEST_URI
=>
'/foo'
,
};
my
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is(
$req
->path,
'/'
,
'path corrent when empty PATH_INFO'
);
'uri_base correct when empty PATH_INFO'
);
$env
= {
%$base
,
SCRIPT_NAME
=>
''
,
PATH_INFO
=>
'/foo'
,
REQUEST_URI
=>
'/foo'
,
};
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is(
$req
->path,
'/foo'
,
'path corrent when empty SCRIPT_NAME'
);
'uri_base handles empty SCRIPT_NAME'
);
$env
= {
%$base
,
SCRIPT_NAME
=>
'/foo'
,
PATH_INFO
=>
'/bar/baz/'
,
REQUEST_URI
=>
'/foo/bar/baz/'
,
};
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is(
$req
->path,
'/bar/baz/'
,
'path corrent when both PATH_INFO and SCRIPT_NAME set'
);
'uri_base correct when both PATH_INFO and SCRIPT_NAME set'
,
);
$env
= {
%$base
,
SCRIPT_NAME
=>
''
,
PATH_INFO
=>
''
,
REQUEST_URI
=>
'/foo/'
,
};
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is(
$req
->path,
'/'
,
'path corrent when calculated from REQUEST_URI'
);
'uri_base correct when calculated from REQUEST_URI'
,
);
}
note
"testing forward"
;
$env
= {
'REQUEST_METHOD'
=>
'GET'
,
'REQUEST_URI'
=>
'/'
,
'PATH_INFO'
=>
'/'
,
'QUERY_STRING'
=>
'foo=bar&number=42'
,
};
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is
$req
->path,
'/'
,
'path is /'
;
is
$req
->method,
'GET'
,
'method is get'
;
is_deeply
scalar
(
$req
->params ), {
foo
=>
'bar'
,
number
=> 42 },
'params are parsed'
;
$req
= Dancer2::Core::App->new(
request
=>
$req
)
->make_forward_to(
'/new/path'
);
is
$req
->path,
'/new/path'
,
'path is changed'
;
is
$req
->method,
'GET'
,
'method is unchanged'
;
is_deeply
scalar
(
$req
->params ), {
foo
=>
'bar'
,
number
=> 42 },
'params are not touched'
;
$req
= Dancer2::Core::App->new(
request
=>
$req
)
->make_forward_to(
'/new/path'
,
undef
,
{
method
=>
'POST'
},
);
is
$req
->path,
'/new/path'
,
'path is changed'
;
is
$req
->method,
'POST'
,
'method is changed'
;
is_deeply
scalar
(
$req
->params ), {
foo
=>
'bar'
,
number
=> 42 },
'params are not touched'
;
note
"testing unicode params"
;
$env
= {
'REQUEST_METHOD'
=>
'GET'
,
'REQUEST_URI'
=>
'/'
,
'PATH_INFO'
=>
'/'
,
'QUERY_STRING'
=>
"M%C3%BCller=L%C3%BCdenscheid"
,
};
$req
= Dancer2::Core::Request->new(
env
=>
$env
);
is_deeply
scalar
(
$req
->params ), {
"M\N{U+00FC}ller"
,
"L\N{U+00FC}denscheid"
},
'multi byte unicode chars work in param keys and values'
;
{
note
"testing private _decode not to mangle hash"
;
my
@warnings
;
local
$SIG
{__WARN__} =
sub
{
push
@warnings
,
@_
;
};
my
$h
= {
zzz
=>
undef
, };
for
(
'aaa'
..
'fff'
) {
$h
->{
$_
} =
$_
;
}
my
$i
= Dancer2::Core::Request::_decode(
$h
);
is_deeply(
$i
,
$h
,
'hash not mangled'
);
ok( !
@warnings
,
'no warnings were issued'
);
}
}
note
"Run test with XS_URL_DECODE"
if
$Dancer2::Core::Request::XS_URL_DECODE
;
note
"Run test with XS_PARSE_QUERY_STRING"
if
$Dancer2::Core::Request::XS_PARSE_QUERY_STRING
;
run_test();
if
(
$Dancer2::Core::Request::XS_PARSE_QUERY_STRING
) {
note
"Run test without XS_PARSE_QUERY_STRING"
;
$Dancer2::Core::Request::XS_PARSE_QUERY_STRING
= 0;
$Dancer2::Core::Request::_id
= 0;
run_test();
}
if
(
$Dancer2::Core::Request::XS_URL_DECODE
) {
note
"Run test without XS_URL_DECODE"
;
$Dancer2::Core::Request::XS_URL_DECODE
= 0;
$Dancer2::Core::Request::_id
= 0;
run_test();
}
done_testing;