The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
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");
        }
    }
}