1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
#!perl
use strict;
use warnings;
use Test::More;
use App::Cmd::Tester;
use lib 't/lib';
use Test::MyCmd;
my $app = Test::MyCmd->new;
isa_ok($app, 'Test::MyCmd');
is_deeply(
[ sort $app->command_names ],
[ sort qw(help --help -h --version -? commands exit frob frobulate hello justusage savargs stock version) ],
"got correct list of registered command names",
);
is_deeply(
[ sort $app->command_plugins ],
[ qw(
App::Cmd::Command::commands
App::Cmd::Command::help
App::Cmd::Command::version
Test::MyCmd::Command::exit
Test::MyCmd::Command::frobulate
Test::MyCmd::Command::hello
Test::MyCmd::Command::justusage
Test::MyCmd::Command::savargs
Test::MyCmd::Command::stock
) ],
"got correct list of registered command plugins",
);
{
local @ARGV = qw(frob --widget wname your fat face);
eval { $app->run };
is(
$@,
"the widget name is wname - your fat face\n",
"command died with the correct string",
);
}
{
local @ARGV = qw(justusage);
eval { $app->run };
my $error = $@;
like(
$error,
qr/^basic.t justusage/,
"default usage_desc is okay",
);
}
{
local @ARGV = qw(stock);
eval { $app->run };
like($@, qr/mandatory method/, "un-subclassed &run leads to death");
}
my $return = test_app('Test::MyCmd', [ qw(--version) ]);
like(
$return->stdout,
qr{\Abasic\.t \(Test::MyCmd\) version 0\.123 \(t[\\/]basic\.t\)\Z},
"version plugin enabled"
);
is(
test_app('Test::MyCmd', [ qw(commands --help) ])->stdout,
test_app('Test::MyCmd', [ qw(help commands) ])->stdout,
"map --help to help command"
);
$return = test_app('Test::MyCmd', [ qw(commands) ]);
for my $name (qw(commands frobulate hello justusage stock)) {
like($return->stdout, qr/^\s+\Q$name\E/sm, "$name plugin in listing");
}
unlike($return->stdout, qr/--version/, "version plugin not in listing");
{
my $return = test_app('Test::MyCmd', [ qw(exit 1) ]);
is($return->exit_code, 1, "exit code is 1");
}
{
my $return = test_app('Test::MyCmd', [ qw(unknown) ]);
is($return->exit_code, 1, "exit code is 1");
}
{
my $return = test_app('Test::MyCmd', [ qw(help exit) ]);
is $return->stdout, <<HELP, 'description from Pod';
basic.t exit
This package exists to exiting with exit();
HELP
}
{
package Test::MyCmd::Command::savargs;
our @LAST_ARGS;
package main;
test_app('Test::MyCmd', [ qw(savargs a b c) ]);
is_deeply(
\@LAST_ARGS,
[ qw( a b c ) ],
"savargs: simplest case",
);
my $res = test_app('Test::MyCmd', [ qw(savargs a -- b c) ]);
is_deeply(
\@LAST_ARGS,
[ qw( a b c ) ],
"savargs: -- case",
);
}
done_testing;
|
