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 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149
|
use strict;
use Test::More;
use Data::Dumper;
use Exception::Class::TryCatch;
# Work around win32 console buffering that can show diags out of order
Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE};
use Getopt::Lucid ':all';
use Getopt::Lucid::Exception;
use t::ErrorMessages;
sub why {
my %vars = @_;
$Data::Dumper::Sortkeys = 1;
return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n";
}
#--------------------------------------------------------------------------#
# Test cases
#--------------------------------------------------------------------------#
my ($num_tests, @good_specs);
BEGIN {
push @good_specs, {
label => "mixed format names in spec",
spec => [
Counter("ver-bose|-v"),
Counter("--test|-t"),
Counter("-r"),
Param("f"),
],
cases => [
{
argv => [ qw( ver-bose -v -rtv f=test -r --test -- test ) ],
result => {
"ver-bose" => 3,
"test" => 2,
"r" => 2,
"f" => "test",
},
after => [qw( test )],
desc => "all three types in command line"
},
{
argv => [ qw( ver-bose -v -rtv f test -r --test -- test ) ],
result => {
"ver-bose" => 3,
"test" => 2,
"r" => 2,
"f" => "test",
},
after => [qw( test )],
desc => "bare param with bare like long-form in spec"
},
{
argv => [ qw( ver-bose -v -rtv f=test -r test ) ],
result => {
"ver-bose" => 3,
"test" => 1,
"r" => 2,
"f" => "test",
},
after => [qw( test )],
desc => "bareword like long-form in spec passed through"
},
{
argv => [ qw( -test ) ],
exception => "Getopt::Lucid::Exception::ARGV",
error_msg => _invalid_argument("-e"),
desc => "single dash with word"
},
{
argv => [ qw( --ver-bose ) ],
exception => "Getopt::Lucid::Exception::ARGV",
error_msg => _invalid_argument("--ver-bose"),
desc => "long form like bareword in spec"
},
{
argv => [ qw( --r ) ],
exception => "Getopt::Lucid::Exception::ARGV",
error_msg => _invalid_argument("--r"),
desc => "long form like short in spec"
},
{
argv => [ qw( -f=--test ) ],
exception => "Getopt::Lucid::Exception::ARGV",
error_msg => _invalid_argument("-f"),
desc => "shoft form like bare in spec"
},
]
};
} #BEGIN
for my $t (@good_specs) {
$num_tests += 1 + 2 * @{$t->{cases}};
}
plan tests => $num_tests;
#--------------------------------------------------------------------------#
# Test good specs
#--------------------------------------------------------------------------#
my ($trial, @cmd_line);
while ( $trial = shift @good_specs ) {
try eval { Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1}) };
catch my $err;
is( $err, undef, "$trial->{label}: spec should validate" );
SKIP: {
if ($err) {
my $num_tests = 2 * @{$trial->{cases}};
skip "because $trial->{label} spec did not validate", $num_tests;
}
for my $case ( @{$trial->{cases}} ) {
my $gl = Getopt::Lucid->new($trial->{spec}, \@cmd_line, {strict => 1});
@cmd_line = @{$case->{argv}};
my %opts;
try eval { %opts = $gl->getopt->options };
catch my $err;
if (defined $case->{exception}) { # expected
ok( $err && $err->isa( $case->{exception} ),
"$trial->{label}: $case->{desc} should throw exception" )
or diag why( got => ref($err), expected => $case->{exception});
is( $err, $case->{error_msg},
"$trial->{label}: $case->{desc} error message correct");
} elsif ($err) { # unexpected
fail( "$trial->{label}: $case->{desc} threw an exception")
or diag "Exception is '$err'";
pass("$trial->{label}: skipping \@ARGV check");
} else { # no exception
is_deeply( \%opts, $case->{result},
"$trial->{label}: $case->{desc}" ) or
diag why( got => \%opts, expected => $case->{result});
my $argv_after = $case->{after} || [];
is_deeply( \@cmd_line, $argv_after,
"$trial->{label}: \@cmd_line correct after processing") or
diag why( got => \@cmd_line, expected => $argv_after);
}
}
}
}
|