# Database schema upgrade pre-checks

use strict;
use warnings;

use Data::Dumper;
use DBI;
use File::Temp qw( :seekable );
use IO::Scalar;
use MIME::Base64;

use Test::More 'no_plan';
use Test::Exception;


use LedgerSMB::Database::ChangeChecks qw( :DEFAULT run_with_formatters
       run_checks load_checks );


#
#
#
#  Tests to assert validity of internal helpers
#

my $encoded_pk =
    LedgerSMB::Database::ChangeChecks::_encode_pk(
        { num => 3, str => 'abc', not_avail => undef },
        [ 'num', 'str', 'not_avail' ]
    );

my %pk;
@pk{('num', 'str', 'not_avail')} =
    @{LedgerSMB::Database::ChangeChecks::_decode_pk($encoded_pk)};

is LedgerSMB::Database::ChangeChecks::_encode_pk(
    \%pk, [ 'num', 'str', 'not_avail' ]),
    $encoded_pk, 'primary key encoding + decoding';


#
#
#
#  Tests to assert correct loading of pre-check code
#


my $tests = <<HEREDOC;
package PreCheckTests;

1;

HEREDOC


my $fh = IO::Scalar->new(\$tests);
lives_and(sub { is scalar &load_checks($fh), 0 },
          'Loading empty checks from file-handle');


my $th = File::Temp->new();
print $th $tests;
$th->flush;
lives_and(sub { is scalar &load_checks($th->filename), 0 },
          'Loading empty checks from file');
close $th or die "Failed to close empty test file: $!";


throws_ok(sub { &load_checks('/tmp/non-existant') },
          qr/Schema-upgrade pre-check failed/,
          'Loading from non-existant file fails');



$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };

1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
lives_and(sub { is scalar &load_checks($fh), 1 },
          'Loading a single check from file-handle');



$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title1',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };


check 'title2',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };


1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
lives_and(sub { is scalar &load_checks($fh), 2 },
          'Loading two checks from file-handle');



$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };


check 'title',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };


1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
throws_ok(sub { &load_checks($fh) },
          qr/^Multiple checks with the same name not supported/,
          'Loading two equally named checks from file-handle');


###TODO: Do we need to validate that the checks have unique names?!


#
#
#
#  Tests to assert correct requiring of required arguments
#

$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    query => q|a query|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };

1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
throws_ok(sub { &load_checks($fh) }, qr/doesn't define a description/,
    '"check" keyword bails without a description');


$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    description => q|a description|,
    on_submit => sub { return 1; },
    on_failure => sub { return 1; };

1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
throws_ok(sub { &load_checks($fh) }, qr/doesn't define a query/,
    '"check" keyword bails without a query');



$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    description => q|a description|,
    query => q|a query|,
    on_failure => sub { return 1; };

1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
throws_ok(sub { &load_checks($fh) }, qr/doesn't define 'on_submit'/,
    '"check" keyword bails without an "on_submit"');


$tests = <<HEREDOC;
package PreCheckTests;

use LedgerSMB::Database::ChangeChecks;

check 'title',
    description => q|a description|,
    query => q|a query|,
    on_submit => sub { return 1; };


1;
HEREDOC

$fh = IO::Scalar->new(\$tests);
throws_ok(sub { &load_checks($fh) }, qr/doesn't define 'on_failure'/,
    '"check" keyword bails without an "on_failure"');


#
#
#
#  Tests to assert successfully detecting failure and successful completion
#

# create a fake database handle...
my $dbh = DBI->connect('DBI:Mock:', '', '');


#
# Single succeeding scenario

$dbh->{mock_add_resultset} = {
    sql     => 'something',
    results => [
        [ 'headers' ],
        ],
};

lives_and( sub {
    is &run_checks( $dbh,
                    checks => [
                        {
                            query => 'something',
                            on_failure => sub { die 'on_failure called?!' },
                        },
                    ]
        ), 1
    }, 'single completed check');



#
# Multiple succeeding scenarios

$dbh->{mock_add_resultset} = {
    sql     => 'something',
    results => [
        [ 'headers' ],
        ],
};
$dbh->{mock_add_resultset} = {
    sql     => 'something else',
    results => [
        [ 'headers' ],
        ],
};

lives_and( sub {
    is &run_checks( $dbh,
                    checks => [
                        {
                            query => 'something',
                            on_failure =>
                                sub { die 'on_failure called?!' },
                        },
                        {
                            query => 'something else',
                            on_failure =>
                                sub { die 'on_failure (2) called?!' },
                        },
                    ]
        ), 1
           }, 'multiple completed checks');


#
# Single failing scenario

$dbh = DBI->connect('DBI:Mock:', '', '');
$dbh->{mock_add_resultset} = {
    sql     => 'something',
    results => [
        [ 'headers' ],
        [ 'failing row' ],
        ],
};

my $result = undef;

run_with_formatters {
    lives_and {
        is &run_checks( $dbh,
                        checks => [
                            {
                                query => 'something',
                                on_failure => sub { $result = 'called'; },
                            },
                        ]
            ), 0
    } 'single failed check: indicates failure';
} {
    confirm => sub {},
    describe => sub {},
    grid => sub {},
    provided => sub { return 0; },
};

is $result, 'called', 'single failed check: "on_failure" called';


#
# Multiple scenarios, first failing

$dbh->{mock_add_resultset} = {
    sql     => 'something',
    results => [
        [ 'headers' ],
        [ 'failing row' ],
        ],
};
# No need for a second resultset: it won't be queried...

$result = [];
run_with_formatters {
    lives_and {
        is &run_checks( $dbh,
                        checks => [
                            {
                                query => 'something',
                                on_failure =>
                                    sub { push @$result, 'called 1' },
                            },
                            {
                                query => 'something else',
                                on_failure =>
                                    sub { die 'on_failure (2) called?!' },
                            },
                        ]
            ), 0
    } 'multiple checks, first failing';
} {
    confirm => sub {},
    describe => sub {},
    grid => sub {},
    provided => sub { return 0; },
};

# second "on_failure" not called: processing aborted after first one
is_deeply $result, [ 'called 1' ],
    'multiple checks, first failing; "on_failure" called';


#
# Multiple scenarios, second failing

$dbh = DBI->connect('DBI:Mock:', '', '');
$dbh->{mock_add_resultset} = {
    sql     => 'something',
    results => [
        [ 'headers' ],
        ],
};
$dbh->{mock_add_resultset} = {
    sql     => 'something else',
    results => [
        [ 'headers' ],
        [ 'failing row' ],
        ],
};

$result = [];
run_with_formatters {
    lives_and {
        is &run_checks( $dbh,
                        checks => [
                            {
                                query => 'something',
                                on_failure =>
                                    sub { push @$result, 'called 1' },
                            },
                            {
                                query => 'something else',
                                on_failure =>
                                    sub { push @$result, 'called 2' },
                            },
                        ]
            ), 0
    } 'multiple checks, first failing';
} {
    confirm => sub {},
    describe => sub {},
    grid => sub {},
    provided => sub { return 0; },
};

# first "on_failure" not called: query succeeded.
is_deeply $result, [ 'called 2' ],
    'multiple checks, first failing; "on_failure" called';



#
#
#
#  Tests to assert successful establishing of execution environment
#

{
    # The call to C<grid> depends on the $check context
    local $LedgerSMB::Database::ChangeChecks::check = {
        tables => {
            'a' => { prim_key => 'a' }
        }
    };


    throws_ok { confirm(); } qr/can't be called outside/,
         '"confirm" throws error outside formatter-context';
    throws_ok { describe(); } qr/can't be called outside/,
         '"describe" throws error outside formatter-context';
    throws_ok { grid [], name => 'a'; } qr/can't be called outside/,
         '"grid" throws error outside formatter-context';
    throws_ok { LedgerSMB::Database::ChangeChecks::provided(); }
         qr/can't be called outside/,
        '"provided" throws error outside formatter-context';

    run_with_formatters {
        lives_ok { confirm(); } '"confirm" runs inside formatter-context';
        lives_ok { describe(); } '"describe" runs inside formatter-context';
        lives_ok { grid [], name => 'a'; }
                 '"grid" runs inside formatter-context';
        lives_ok { LedgerSMB::Database::ChangeChecks::provided(); }
        '"provided" runs inside formatter-context';
    } {
        confirm => sub {},
        describe => sub {},
        grid => sub {},
        provided => sub {},
    };
}

#
#
#
#  Tests to assert the 'provided' protocol
#

{
    local $LedgerSMB::Database::ChangeChecks::check = 'the-check';
    run_with_formatters {
        lives_and { is LedgerSMB::Database::ChangeChecks::provided(), 1,
                    '"provided" without arguments'; }
        lives_and { is LedgerSMB::Database::ChangeChecks::provided('name'),
                    'name', '"provided" with argument'; }
    } {
        confirm => sub {},
        describe => sub {},
        grid => sub {},
        provided => sub {
            shift; # remove the check being passed in
            return 1 if ! @_;
            return shift;
        },
    };
}


# Result set with failures
$dbh = DBI->connect('DBI:Mock:', '', '');
$dbh->{mock_add_resultset} = [
    [ 'headers' ],
    [ 'failing-row' ],
    ];

# Result set without failures, so we fake that the data was fixed
$dbh->{mock_add_resultset} = [
    [ 'headers' ],
    ];

$result = 'failed';
run_with_formatters {
    lives_and {
        is &run_checks( $dbh,
                        checks => [
                            {
                                query => 'something',
                                on_failure => sub { },
                                on_submit => sub { $result = 'success' },
                            },
                        ]
            ), 1
    } 'No call to "on_failure" when data "provided"';
} {
    confirm => sub {},
    describe => sub {},
    grid => sub {},
    provided => sub { return 1; }
};
is $result, 'success', 'due to "provided" data, "on_submit" is called';



#
#
#
#  Tests to assert the correctness of 'save_grid'
#


# Result set with failures
$dbh = DBI->connect('DBI:Mock:', '', '');
$dbh->{mock_add_resultset} = [
    [ qw/a d e/ ],
    [ qw/z y x/ ],
    [ qw/w v u/ ],
    ];
$dbh->{mock_add_resultset} = [
    [ qw/d/ ],
    [] ];
$dbh->{mock_add_resultset} = [
    [ qw/d/ ],
    [] ];

run_with_formatters {
    LedgerSMB::Database::ChangeChecks::_run_check(
        $dbh,
        {
            tables => {
                'abc' => { prim_key => 'a' },
            },
            query => 'dummy',
            on_failure => sub {
                my ($check, $dbh, $rows) = @_;
                grid $rows,
                  name => 'b',
                  table => 'abc',
                  columns => [ qw/d e/ ],
                  edit_columns => [ 'd' ],
                ;
            },
            on_submit => sub {
                save_grid $dbh, [
                    { a => 'z', d => 'y', e => 'x' },
                    { a => 'w', d => 'v', e => 'u' },
                ], name => 'b', table => 'abc';
            },
        });
} {
    provided => sub {
        return [ { __pk => encode_base64('z', ''), a => 'z', d => 'a' },
                 { __pk => encode_base64('w', ''), a => 'w', d => 'b' },
            ];
    },
    confirm => sub {},
    describe => sub {},
    grid => sub {},
};

my $sql_history = ${$dbh->{mock_all_history}}[-2];
my $stmt = $sql_history->statement;
$stmt =~ s/\s+/ /g;

is $stmt, q{UPDATE "abc" SET "d" = ? WHERE "a" = ?},
    'Found the correct update statement';
is_deeply $sql_history->bound_params, [ 'b', 'w' ],
    'Found the correct bound parameters';

done_testing;
