#!/usr/bin/perl

use warnings;
use strict;
use utf8;
use open qw(:std :utf8);
use lib qw(lib ../lib);
use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch);

use Test::More tests    => 335;
use Encode qw(decode encode);


BEGIN {
    my $builder = Test::More->builder;
    binmode $builder->output,         ":utf8";
    binmode $builder->failure_output, ":utf8";
    binmode $builder->todo_output,    ":utf8";

    use_ok 'DR::Tarantool', ':constant';
    use_ok 'File::Spec::Functions', 'catfile';
    use_ok 'File::Basename', 'dirname';
}

like TNT_INSERT,            qr{^\d+$}, 'TNT_INSERT';
like TNT_SELECT,            qr{^\d+$}, 'TNT_SELECT';
like TNT_UPDATE,            qr{^\d+$}, 'TNT_UPDATE';
like TNT_DELETE,            qr{^\d+$}, 'TNT_DELETE';
like TNT_CALL,              qr{^\d+$}, 'TNT_CALL';
like TNT_PING,              qr{^\d+$}, 'TNT_PING';

like TNT_FLAG_RETURN,       qr{^\d+$}, 'TNT_FLAG_RETURN';
like TNT_FLAG_ADD,          qr{^\d+$}, 'TNT_FLAG_ADD';
like TNT_FLAG_REPLACE,      qr{^\d+$}, 'TNT_FLAG_REPLACE';
# like TNT_FLAG_BOX_QUIET,    qr{^\d+$}, 'TNT_FLAG_BOX_QUIET';
# like TNT_FLAG_NOT_STORE,    qr{^\d+$}, 'TNT_FLAG_NOT_STORE';

my $LE = $] > 5.01 ? '<' : '';


# SELECT
my $sbody = DR::Tarantool::_pkt_select( 9, 8, 7, 6, 5, [ ['abc'], ['cde'] ] );
ok defined $sbody, '* select body';

my @a = unpack "( L$LE )*", $sbody;
is $a[0], TNT_SELECT, 'select type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 9, 'request id';
is $a[3], 8, 'space no';
is $a[4], 7, 'index no';
is $a[5], 6, 'offset';
is $a[6], 5, 'limit';
is $a[7], 2, 'tuple count';
ok !eval { DR::Tarantool::_pkt_select( 1, 2, 3, 4, 5, [ 6 ] ) }, 'keys format';
like $@ => qr{ARRAYREF of ARRAYREF}, 'error string';

# PING
$sbody = DR::Tarantool::_pkt_ping( 11 );
ok defined $sbody, '* ping body';
@a = unpack "( L$LE )*", $sbody;
is $a[0], TNT_PING, 'ping type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 11, 'request id';


# insert
$sbody = DR::Tarantool::_pkt_insert( 12, 13, 14, [ 'a', 'b', 'c', 'd' ]);
ok defined $sbody, '* insert body';
@a = unpack "( L$LE )*", $sbody;
is $a[0], TNT_INSERT, 'insert type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 12, 'request id';
is $a[3], 13, 'space no';
is $a[4], 14, 'flags';
is $a[5], 4,  'tuple size';

# delete
$sbody = DR::Tarantool::_pkt_delete( 119, 120, 121, [ 122, 123 ] );
ok defined $sbody, '* delete body';
@a = unpack "( L$LE )*", $sbody;
is $a[0], TNT_DELETE, 'delete type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 119, 'request id';

is $a[3], 120, 'space no';

if (TNT_DELETE == 20) {
    ok 1, '# skipped old delete code';
    is $a[4], 2,  'tuple size';
} else {
    is $a[4], 121, 'flags';  # libtarantool ignores flags
    is $a[5], 2,  'tuple size';
}

# call
$sbody = DR::Tarantool::_pkt_call_lua( 124, 125, 'tproc', [ 126, 127 ]);
ok defined $sbody, '* call body';
@a = unpack "L$LE L$LE L$LE L$LE w/Z* L$LE L$LE", $sbody;
is $a[0], TNT_CALL, 'call type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 124, 'request id';
is $a[3], 125, 'flags';
is $a[4], 'tproc',  'proc name';
is $a[5], 2, 'tuple size';


eval {
    DR::Tarantool::_pkt_update( 15, 16, 17, [ 18 ], [[ 10, 'abc cde', 20 ]])
};

like $@, qr{unknown update operation: `abc cde'}, 'wrong update operation';

# update
my @ops = map { [ int rand 100, $_, int rand 100 ] }
    qw(add and or xor set delete insert);
push @ops => [ 10, 'substr', 1, 2 ];
$sbody = DR::Tarantool::_pkt_update( 15, 16, 17, [ 18 ], \@ops);
ok defined $sbody, '* update body';
@a = unpack "( L$LE )*", $sbody;
is $a[0], TNT_UPDATE, 'update type';
is $a[1], length($sbody) - 3 * 4, 'body length';
is $a[2], 15, 'request id';
is $a[3], 16, 'space no';
is $a[4], 17, 'flags';
is $a[5], 1,  'tuple size';




$sbody = DR::Tarantool::_pkt_call_lua( 124, 125, 'tproc', [  ]);

# parser
ok !eval { DR::Tarantool::_pkt_parse_response( undef ) }, '* parser: undef';
my $res = DR::Tarantool::_pkt_parse_response( '' );
isa_ok $res => 'HASH', 'empty input';
like $res->{errstr}, qr{too short}, 'error message';
is $res->{status}, 'buffer', 'status';

my $data;
for (TNT_INSERT, TNT_UPDATE, TNT_SELECT, TNT_DELETE, TNT_CALL, TNT_PING) {
    my $msg = "test message";
    $data = pack "L$LE L$LE L$LE L$LE Z*",
        $_, 5 + length $msg, $_ + 100, 0x0101, $msg;
    $res = DR::Tarantool::_pkt_parse_response( $data );
    isa_ok $res => 'HASH', 'well input ' . $_;
    is $res->{req_id}, $_ + 100, 'request id';
    is $res->{type}, $_, 'request type';

    unless($res->{type} == TNT_PING) {
        is $res->{status}, 'error', "status $_";
        is $res->{code}, 0x101, 'code';
        is $res->{errstr}, $msg, 'errstr';
    }
    
    $res = DR::Tarantool::_pkt_parse_response( $data . 'aaaa' );
    isa_ok $res => 'HASH', 'well input ' . $_;
    is $res->{req_id}, $_ + 100, 'request id';
    is $res->{type}, $_, 'request type';

    unless($res->{type} == TNT_PING) {
        is $res->{status}, 'error', "status $_";
        is $res->{code}, 0x101, 'code';
        is $res->{errstr}, $msg, 'errstr';
    }
}

my $cfg_dir = catfile dirname(__FILE__), 'test-data';
ok -d $cfg_dir, 'directory with test data';
my @bins = glob catfile $cfg_dir, '*.bin';

for my $bin (sort @bins) {
    my ($type, $err, $status) =
        $bin =~ /(?>0*)?(\d+?)-0*(\d+)-(\w+)\.bin$/;
    next unless defined $bin;
    next unless $type;
    ok -r $bin, "$bin is readable";

    ok open(my $fh, '<:raw', $bin), "open $bin";
    my $pkt;
    { local $/; $pkt = <$fh>; }
    ok $pkt, "response body was read ($type): " .
        join '', map { sprintf '.%02x', $_ } unpack 'C*', $pkt;

    my $res = DR::Tarantool::_pkt_parse_response( $pkt );
    SKIP: {
        skip 'legacy delete packet', 4 if $type == 20 and TNT_DELETE != 20;
        is $res->{status}, $status, 'status ' . $type;
        is $res->{type}, $type, 'status ' . $type;
        is $res->{code}, $err, 'error code ' . $type;
        ok ( !($res->{code} xor $res->{errstr}), 'errstr ' . $type );
    }
    
    $res = DR::Tarantool::_pkt_parse_response( $pkt . 'aaaaa');
    SKIP: {
        skip 'legacy delete packet', 4 if $type == 20 and TNT_DELETE != 20;
        is $res->{status}, $status, 'status(trash) ' . $type;
        is $res->{type}, $type, 'status(trash) ' . $type;
        is $res->{code}, $err, 'error code(trash) ' . $type;
        ok ( !($res->{code} xor $res->{errstr}), 'errstr(trash) ' . $type );
    }
}

SKIP: {
#     skip 'Devel tests $ENV{DEVEL_TEST}=0', 120 unless $ENV{DEVEL_TEST};
for (1 .. 30) {
    my $body = join '', map { chr int rand 256 } 1 .. (300 + int rand 300);
    my $pkt =
        pack 'LLLLa*',
            TNT_SELECT,
            length $body,
            int rand 500,
            0,
            $body
        ;
    $res = DR::Tarantool::_pkt_parse_response( $pkt );
    diag explain $res unless
    is $res->{status}, 'buffer', "Broken package $_";
    $pkt =
        pack 'LLLLa*',
            TNT_SELECT,
            10 + length $body,
            int rand 500,
            0,
            $body
        ;
    $res = DR::Tarantool::_pkt_parse_response( $pkt );
    diag explain $res unless
    is $res->{status}, 'buffer', "Broken package $_, too long body";
    
    $pkt =
        pack 'LLLLa*',
            TNT_SELECT,
            -10 + length $body,
            int rand 500,
            0,
            $body
        ;
    $res = DR::Tarantool::_pkt_parse_response( $pkt );
    diag explain $res unless
    is $res->{status}, 'buffer', "Broken package $_, too short body";
    
    $pkt =
        pack 'LLLLa*',
            TNT_SELECT,
            int rand 500,
            int rand 500,
            0,
            ''
        ;
    $res = DR::Tarantool::_pkt_parse_response( $pkt );
    diag explain $res unless
    is $res->{status}, 'buffer', "Broken package $_, zero length body";
}
}