subtest
import
=>
sub
{
package
my
::yath;
my
@args
;
my
$control
= main::mock
$main::CLASS
=> (
override
=> [
do_exec
=>
sub
{ },
run_command
=>
sub
{
@args
=
@_
},
],
);
local
$App::Yath::SCRIPT
;
my
$ref
;
$main::CLASS
->
import
([
'help'
], \
$ref
);
main::ref_ok(
$ref
,
'CODE'
,
"got a coderef"
);
$ref
->();
main::is(
\
@args
,
[
$main::CLASS
,
'App::Yath::Command::help'
,
'help'
, main::hash(
sub
{ main::etc() })],
"the ref calls run_command with the correct args"
);
main::is(
$App::Yath::SCRIPT
,
'my-yath'
,
'set $App::Yath::SCRIPT'
);
$main::CLASS
->
import
([
'help'
], \
$ref
);
main::is(
$App::Yath::SCRIPT
,
'my-yath'
,
'$App::Yath::SCRIPT not changed'
);
};
subtest
load_command
=>
sub
{
is(
$CLASS
->load_command(
'help'
),
'App::Yath::Command::help'
,
"Loaded the help command"
);
is(
dies {
$CLASS
->load_command(
'a_fake_command'
) },
"yath command 'a_fake_command' not found. (did you forget to install App::Yath::Command::a_fake_command?)\n"
,
"Exception if the command is not valid"
);
local
@INC
= (
't/lib'
,
@INC
);
like(
dies {
$CLASS
->load_command(
'broken'
) },
qr/This command is broken! at/
,
"Exception is propogated if command dies on compile"
);
};
{
our
$RAN
;
our
$OUT
= 0;
our
$SHOW_BENCH
;
sub
settings { {} }
sub
new {
my
$class
=
shift
;
bless
{
@_
},
$class
;
}
sub
show_bench {
$SHOW_BENCH
}
sub
run {
$RAN
=
shift
;
$OUT
}
}
subtest
run_command
=>
sub
{
my
$out
=
$CLASS
->run_command(
'My::Command::a'
,
'a'
, [
foo
=> 1]);
is(
$out
, 0,
"got an exit value"
);
is(
$My::Command::a::RAN
,
{
args
=> [
foo
=> 1]},
"It ran"
,
);
$My::Command::a::OUT
= 1;
$out
=
$CLASS
->run_command(
'My::Command::a'
,
'a'
, [
foo
=> 1]);
is(
$out
, 1,
"got an exit value"
);
is(
dies {
local
$My::Command::a::OUT
;
$CLASS
->run_command(
'My::Command::a'
,
'a'
, [
foo
=> 1]) },
"Command 'a' did not return an exit value.\n"
,
"Commands must return an exit value"
);
my
$control1
= mock
'Test2::Util::Times'
=> (
override
=> {
render_bench
=>
sub
{
"hi"
},
},
);
my
@info
;
my
$control2
= mock
$CLASS
=> (
override
=> {
info
=>
sub
{
shift
;
@info
=
@_
},
},
);
$My::Command::a::SHOW_BENCH
= 1;
$CLASS
->run_command(
'My::Command::a'
,
'a'
, [
foo
=> 1]);
is(\
@info
, [
"hi"
,
"\n\n"
],
"Showed bench data"
);
};
subtest
command_from_argv
=>
sub
{
my
@info
;
my
$persist
= 0;
my
$control2
= mock
$CLASS
=> (
override
=> {
info
=>
sub
{
shift
;
@info
=
@_
},
find_pfile
=>
sub
{
$persist
},
},
);
my
(
@argv
,
$cmd
);
@info
= ();
$persist
= 0;
@argv
= ();
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'test'
,
"defaulted to test with no args"
);
is(\
@argv
, [],
"argv still empty"
);
is(\
@info
, [
"\n** Defaulting to the 'test' command **\n\n"
],
"Got printed info"
);
@info
= ();
$persist
= 1;
@argv
= ();
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'run'
,
"defaulted to run with no args, but persisting runner"
);
is(\
@argv
, [],
"argv still empty"
);
is(\
@info
, [
"\n** Persistent runner detected, defaulting to the 'run' command **\n\n"
],
"Got printed info"
);
@info
= ();
$persist
= 0;
@argv
= (
'-v'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'test'
,
"defaulted to test with an option"
);
is(\
@argv
, [
'-v'
],
"argv not changed"
);
is(\
@info
, [
"\n** Defaulting to the 'test' command **\n\n"
],
"Got printed info"
);
@info
= ();
$persist
= 1;
@argv
= (
'-v'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'run'
,
"defaulted to run with an option and persist"
);
is(\
@argv
, [
'-v'
],
"argv not changed"
);
is(\
@info
, [
"\n** Persistent runner detected, defaulting to the 'run' command **\n\n"
],
"Got printed info"
);
@info
= ();
$persist
= 0;
@argv
= (
't'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'test'
,
"defaulted to test with a dir"
);
is(\
@argv
, [
't'
],
"argv not changed"
);
is(\
@info
, [
"\n** Defaulting to the 'test' command **\n\n"
],
"Got printed info"
);
@info
= ();
$persist
= 1;
@argv
= (
't'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'run'
,
"defaulted to run a dir and persist"
);
is(\
@argv
, [
't'
],
"argv not changed"
);
is(\
@info
, [
"\n** Persistent runner detected, defaulting to the 'run' command **\n\n"
],
"Got printed info"
);
for
my
$arg
(
'h'
,
'-h'
,
'--h'
,
'help'
,
'--help'
,
'-help'
) {
@info
= ();
$persist
= 0;
@argv
= (
$arg
,
'x'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'help'
,
"'$arg' -> 'help'"
);
is(\
@argv
, [
'x'
],
"argv shifted"
);
is(\
@info
, [],
"No info"
);
}
for
my
$arg
(
'foo.jsonl'
,
'foo.jsonl.gz'
,
'foo.jsonl.bz2'
) {
@info
= ();
$persist
= 0;
@argv
= (
$arg
,
'x'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'replay'
,
"'$arg' means replay"
);
is(\
@argv
, [
$arg
,
'x'
],
"argv not changed"
);
is(\
@info
, [
"\n** First argument is a log file, defaulting to the 'replay' command **\n\n"
],
"got info"
);
}
@info
= ();
$persist
= 0;
@argv
= (
'test'
,
'x'
);
$cmd
=
$CLASS
->command_from_argv(\
@argv
);
is(
$cmd
,
'test'
,
"first arg is a command"
);
is(\
@argv
, [
'x'
],
"argv shifted"
);
is(\
@info
, [],
"No info"
);
};
subtest
pre_parse_args
=>
sub
{
my
$pp_argv
=
$CLASS
->pre_parse_args(
[
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
,
'-pFoo'
,
'--plugin'
=>
'Bar'
,
'-p=Baz'
,
'-I=foo'
,
'-I'
=>
'bar'
,
'--include=baz'
,
'--include'
=>
'bat'
,
'--plugin=Bat'
,
'--'
,
'-p'
=>
'uhg'
,
'bleh'
,
'blotch'
,
'::'
,
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
,
]
);
is(
$pp_argv
->{opts}, [
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
,
'-I=foo'
,
'-I'
=>
'bar'
,
'--include=baz'
,
'--include'
=>
'bat'
],
"Got opts"
);
is(
$pp_argv
->{list}, [
'-p'
,
'uhg'
,
'bleh'
,
'blotch'
],
"Got list"
);
is(
$pp_argv
->{pass}, [
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
],
"Got args to pass"
);
is(
$pp_argv
->{plugins}, [
qw/Foo Bar Baz Bat/
],
"Got plugins"
);
like(
$pp_argv
->{inc}, [
qw{foo bar baz bat}
,
qr{lib$}
,
qr{blib/lib$}
,
qr{blib/arch$}
],
"Got libs"
);
$pp_argv
=
$CLASS
->pre_parse_args(
[
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
,
'-pFoo'
,
'--plugin'
=>
'Bar'
,
'-p=Baz'
,
'-I=foo'
,
'-I'
=>
'bar'
,
'--include=baz'
,
'--include'
=>
'bat'
,
'--no-lib'
,
'--no-blib'
,
'--tlib'
,
'--no-plugins'
,
'--plugin=Bat'
,
'--'
,
'-p'
=>
'uhg'
,
'bleh'
,
'blotch'
,
'::'
,
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
,
]
);
is(
$pp_argv
->{opts}, [
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
,
'-I=foo'
,
'-I'
=>
'bar'
,
'--include=baz'
,
'--include'
=>
'bat'
,
'--no-lib'
,
'--no-blib'
,
'--tlib'
],
"Got opts"
);
is(
$pp_argv
->{list}, [
'-p'
,
'uhg'
,
'bleh'
,
'blotch'
],
"Got list"
);
is(
$pp_argv
->{pass}, [
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
],
"Got args to pass"
);
is(
$pp_argv
->{plugins}, [
qw/Bat/
],
"Got only 1 plugin"
);
like(
$pp_argv
->{inc}, [
qw{foo bar baz bat}
,
qr{t/lib$}
],
"Got libs"
);
$pp_argv
=
$CLASS
->pre_parse_args(
[
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
,
'-pFoo'
,
'--plugin'
=>
'Bar'
,
'-p=Baz'
,
'--plugin=Bat'
,
'::'
,
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
,
]
);
is(
$pp_argv
->{opts}, [
'-x'
,
'--longer'
=>
'arg'
,
qw/foo bar baz/
],
"Got opts"
);
is(
$pp_argv
->{list}, [],
"Got empty list"
);
is(
$pp_argv
->{pass}, [
'pear'
,
'apple'
,
'bananananan'
,
'-xyz'
],
"Got args to pass"
);
is(
$pp_argv
->{plugins}, [
qw/Foo Bar Baz Bat/
],
"Got plugins"
);
};
done_testing;