#!/usr/bin/env perl
use
warnings
qw(FATAL all NONFATAL misc)
;
BEGIN {
if
(-d (
my
$dir
=
"$FindBin::RealBin/../../../../t"
)) {
local
(
@_
, $@) =
$dir
;
do
"$dir/t_lib.pl"
;
die
$@
if
$@;
}
}
my
(
$app_root
);
BEGIN {
if
(-r __FILE__) {
$app_root
= dirname(dirname(File::Spec->rel2abs(__FILE__)));
}
else
{
$app_root
= Cwd::cwd();
}
}
BEGIN {
foreach
my
$req
(
qw(Plack::Test)
) {
unless
(
eval
qq{require $req}
) {
plan(
skip_all
=>
"$req is not installed."
);
exit
;
}
}
}
my
MY
$tests
= MY->load_tests([
dir
=>
"$FindBin::Bin/../html"
]
,
@ARGV
?
@ARGV
:
$FindBin::Bin
);
$tests
->enter;
plan
$tests
->test_plan(+4);
$ENV
{YATT_DOCUMENT_ROOT} = cwd;
{
ok(
my
$site
= Factory->load_factory_script(
"$FindBin::Bin/../app.psgi"
)
,
"load_psgi"
);
is_refcount(
$site
, 2,
"refcount after load_factory_script(includes sub2self)"
);
test_psgi
$site
->to_app,
sub
{
my
(
$cb
) =
shift
;
foreach
my
File
$sect
(@{
$tests
->{files}}) {
my
$dir
=
$tests
->{cf_dir};
my
$sect_name
=
$tests
->file_title(
$sect
);
foreach
my
Item
$item
(@{
$sect
->{items}}) {
SKIP: {
if
(
$item
->{cf_PERL_MINVER} and $] <
$item
->{cf_PERL_MINVER}) {
Test::More::skip
"by perl-$] < PERL_MINVER($item->{cf_PERL_MINVER}) $sect_name"
, 1;
}
if
(
$item
->{cf_BREAK}) {
YATT::Lite::Breakpoint::breakpoint();
}
if
(
my
$action
=
$item
->{cf_ACTION}) {
my
(
$method
,
@args
) =
@$action
;
my
$sub
=
$tests
->can(
"action_$method"
)
or
die
"No such action: $method"
;
$sub
->(
$tests
,
@args
);
next
;
}
$item
->{cf_METHOD} //=
'GET'
;
my
$T
=
defined
$item
->{cf_TITLE} ?
"[$item->{cf_TITLE}]"
:
''
;
my
$res
=
do
{
$site
->cf_let([lexpand(
$item
->{cf_SITE_CONFIG})]
,
sub
{
$tests
->run_psgicb(
$cb
,
$item
);
});
};
if
(
$item
->{cf_ERROR}) {
(
my
$str
=
$res
->content) =~ s/^Internal Server error\n//;
like
$str
,
qr{$item->{cf_ERROR}
}
,
"[$sect_name] $T ERROR $item->{cf_METHOD} $item->{cf_FILE}"
;
next
;
}
elsif
(
$item
->{cf_STATUS}
?
$item
->{cf_STATUS} ==
$res
->code
:
$res
->code >= 300 &&
$res
->code < 500) {
}
elsif
(
$res
->code != 200) {
Test::More::fail
$item
->{cf_FILE};
Test::More::diag
$res
->content;
next
;
}
if
(
$item
->{cf_METHOD} eq
'POST'
and
$item
->{cf_HEADER}) {
my
@header
= @{
$item
->{cf_HEADER}};
while
(
my
(
$f
,
$v
) =
splice
@header
, 0, 2) {
my
$name
=
"[$sect_name] $T POST $item->{cf_FILE} $f"
;
my
$got
=
$res
->header(
$f
);
if
(
defined
$got
) {
like
$got
,
qr/$v/
,
$name
;
}
else
{
fail
$name
; diag(
"Header '$f' was undef"
);
}
}
}
elsif
(
ref
$item
->{cf_BODY}) {
like nocr(
$res
->content),
$tests
->mkseqpat(
$item
->{cf_BODY})
,
"[$sect_name] $T $item->{cf_METHOD} $item->{cf_FILE}"
;
}
else
{
eq_or_diff trimlast(nocr(
$res
->content)),
$item
->{cf_BODY}
,
"[$sect_name] $T $item->{cf_METHOD} $item->{cf_FILE}"
;
}
}
}
}
};
is_refcount(
$site
, 1,
"refcount after test_psgi"
);
}
is_deeply [YATT::Lite::Factory->n_created, YATT::Lite::Factory->n_destroyed]
, [1, 1],
"Site apps are destroyed correctly."
;
sub
base_url {
}