use strict;
use Test::More;
use Data::Dumper;
use Exception::Class::TryCatch;
use Getopt::Lucid ':all';
use Getopt::Lucid::Exception;
use t::ErrorMessages;
# Work around buffering that can show diags out of order
Test::More->builder->failure_output(*STDOUT) if $ENV{HARNESS_VERBOSE};
sub why {
my %vars = @_;
$Data::Dumper::Sortkeys = 1;
return "\n" . Data::Dumper->Dump([values %vars],[keys %vars]) . "\n";
}
#--------------------------------------------------------------------------#
# Test cases
#--------------------------------------------------------------------------#
my $spec = [
Switch("-t")->default(0),
Counter("-v")->default(1),
Param("--file-names")->default("hosts"),
List("-I")->default("/home"),
Keypair("-d")->default( arch => "i386" ),
Switch("-x")->default(1),
Param( '--undef' )->default( undef ),
Param( '--empty' )->default( '' ),
Param( '--no_param' )->default(),
Param( '--without_default' ),
];
my $case = {
argv => [ qw( -tvv -I /etc -I /lib -d version=1.0a ) ],
result => {
t => 1,
v => 3,
"file-names" => "hosts",
I => [qw(/home /etc /lib)],
d => { arch => "i386", version => "1.0a" },
x => 1,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
},
desc => "getopt"
};
my $config1 = {
t => 1,
v => 4,
"file-names" => "group",
I => [qw(/var /tmp)],
d => { os => "win32" },
z => 1, # extra not in the spec
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
# package variables for easier looping by name later
use vars qw(
$merge_default $merge_result
$append_default $append_result
$replace_default $replace_result
);
$merge_default = {
t => 1,
v => 4,
"file-names" => "group",
I => [qw(/var /tmp)],
d => { os => "win32" },
x => 1,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
$append_default = {
t => 1,
v => 5,
"file-names" => "group",
I => [qw(/home /var /tmp)],
d => { arch => "i386", os => "win32" },
x => 1,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
$replace_default = {
t => 1,
v => 4,
"file-names" => "group",
I => [qw(/var /tmp)],
d => { os => "win32" },
x => 0,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
$merge_result = {
t => 1,
v => 6,
"file-names" => "group",
I => [qw(/var /tmp /etc /lib)],
d => { os => "win32", version => "1.0a" },
x => 1,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
$append_result = {
t => 1,
v => 7,
"file-names" => "group",
I => [qw(/home /var /tmp /etc /lib)],
d => { arch => "i386", os => "win32", version => "1.0a" },
x => 1,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
$replace_result = {
t => 1,
v => 6,
"file-names" => "group",
I => [qw(/var /tmp /etc /lib)],
d => { os => "win32", version => "1.0a" },
x => 0,
undef => undef,
empty => '',
no_param => undef,
without_default => undef,
};
my $num_tests = 30 ;
plan tests => $num_tests ;
my ($gl, @cmd_line, $err);
try eval { $gl = Getopt::Lucid->new($spec, \@cmd_line) };
catch $err;
is( $err, undef, "spec should validate" );
SKIP: {
if ($err) {
skip "because spec did not validate", $num_tests - 1;
}
@cmd_line = @{$case->{argv}};
my %opts;
try eval { $gl->getopt };
catch my $err;
if ($err) {
fail( "$case->{desc} threw an exception")
or diag "Exception is '$err'";
skip "because getopt failed", $num_tests - 2;
} else {
my $expect = $case->{result} ;
my %basic_default;
for my $opt (@$spec) {
local $_ = $opt->{name};
(my $strip = $_) =~ s/^-+//g;
$basic_default{$strip} = (exists $opt->{default})
? $opt->{default}
: undef;
}
is_deeply( {$gl->defaults}, \%basic_default,
"basic default options returned correctly") or
diag why( got => {$gl->options}, expected => \%basic_default);
is_deeply( {$gl->options}, $expect,
"options with default from spec processed correctly") or
diag why( got => {$gl->options}, expected => $expect);
# Test things working correctly
for my $fcn ( qw( merge append replace ) ) {
no strict 'refs';
my $call = "${fcn}_defaults";
my ($default, $result) = map { "${fcn}_$_" } qw( default result );
for my $c ( 0 .. 1 ) {
$c ? $gl->$call( %$config1 )
: $gl->$call( $config1 );
my $msg = $c
? "hash version"
: "hashref version";
is_deeply( {$gl->defaults}, $$default,
"$call updated defaults correctly ($msg)") or
diag why( got => {$gl->defaults}, expected => $$default);
is_deeply( {$gl->options}, $$result,
"$call refreshed options correctly ($msg)") or
diag why( got => {$gl->options}, expected => $$result);
$gl->reset_defaults();
is_deeply( {$gl->options}, $expect,
"options reset to spec correctly ($msg)") or
diag why( got => {$gl->options}, expected => $expect);
}
}
# Test bad args
for my $fcn ( qw( merge append replace ) ) {
no strict 'refs';
my $call = "${fcn}_defaults";
eval { $gl->$call ( "bad_value" ) };
catch $err;
is( $err, _invalid_splat_defaults("$call()"),
"$call() with invalid arguments throws exception");
eval { $gl->$call ( I => {key => "value"} ) };
catch $err;
is( $err, _invalid_list("I","$call()"),
"$call() with invalid list option throws exception");
eval { $gl->$call ( d => [key => "value"] ) };
catch $err;
is( $err, _invalid_keypair("d","$call()"),
"$call() with invalid keypair option throws exception");
}
}
}