From b37371736ef3619891224281d5c46928b0c98f13 Mon Sep 17 00:00:00 2001
From: "Dmitry E. Oboukhov" <unera@debian.org>
Date: Mon, 2 Jul 2012 15:56:35 +0400
Subject: [PATCH] rewrite box.pl as usual test
---
connector/perl/lib/MR/Tarantool/Box.pm | 13 +-
connector/perl/t/02-two-servers.t | 29 +-
connector/perl/t/03-box.t | 1057 ++++++++++++++++++++++++
connector/perl/t/data/box.t.cfg | 61 ++
connector/perl/t/data/init.lua | 33 +-
5 files changed, 1165 insertions(+), 28 deletions(-)
create mode 100644 connector/perl/t/03-box.t
create mode 100644 connector/perl/t/data/box.t.cfg
diff --git a/connector/perl/lib/MR/Tarantool/Box.pm b/connector/perl/lib/MR/Tarantool/Box.pm
index 265355623c..0873c4779d 100644
--- a/connector/perl/lib/MR/Tarantool/Box.pm
+++ b/connector/perl/lib/MR/Tarantool/Box.pm
@@ -639,6 +639,7 @@ sub Call {
$x;
} @$tuple ];
+
$self->_chat (
msg => 22,
payload => pack("L w/a* L(w/a*)*", $flags, $sp_name, scalar(@$tuple), @$tuple),
@@ -741,9 +742,10 @@ sub Insert {
my $chk_divisor = $namespace->{long_tuple} ? @$long_fmt : @$fmt;
confess "Wrong fields number in tuple" if 0 != (@tuple - @$fmt) % $chk_divisor;
for (0..$#tuple) {
- confess "$self->{name}: ref in tuple $_=`$tuple[$_]'" if ref $tuple[$_];
+ confess "$self->{name}: ref in tuple $_=`$tuple[$_]'"
+ if ref $tuple[$_];
no warnings 'uninitialized';
- Encode::_utf8_off($_) if Encode::is_utf8($_,0);
+ Encode::_utf8_off($tuple[$_]) if Encode::is_utf8($tuple[$_],0);
if(exists $chkkey->{$_}) {
if($chkkey->{$_}) {
confess "$self->{name}: undefined key $_" unless defined $tuple[$_];
@@ -1217,9 +1219,8 @@ my %update_ops = (
or => OP_OR,
splice => sub {
confess "value for operation splice must be an ARRAYREF of <int[, int[, string]]>" if ref $_[0] ne 'ARRAY' || @{$_[0]} < 1;
- $_[0]->[0] = 0x7FFFFFFF unless defined $_[0]->[0];
- $_[0]->[0] = pack 'l', $_[0]->[0];
- $_[0]->[1] = defined $_[0]->[1] ? pack 'l', $_[0]->[1] : '';
+ $_[0]->[0] = pack 'l', defined($_[0]->[0]) ? $_[0]->[0] : 0x7FFF_FFFF;
+ $_[0]->[1] = pack 'l', defined($_[0]->[1]) ? $_[0]->[1] : 0x7FFF_FFFF;
$_[0]->[2] = '' unless defined $_[0]->[2];
return (OP_SPLICE, [ pack '(w/a*)*', @{$_[0]} ]);
},
@@ -1565,7 +1566,7 @@ L</UpdateMulti> can be given a field number in several ways:
$box->UpdateMulti(5, [ 5 => set => $val ]) #3: set 6 to $val
-=item an arrayref of [$index_of_folded_subtuple_int, $long_field_name_str_or_index_int]
+=item an arrayref of [$index_of_folded_subtuple_int, $long_field_name_str_or_index_int]
$box->UpdateMulti(5, [ [1,0] => set => $val ]) #3: set 6 to $val
$box->UpdateMulti(5, [ [1,'d1'] => set => $val ]) #3: set 6 to $val
diff --git a/connector/perl/t/02-two-servers.t b/connector/perl/t/02-two-servers.t
index 3383b1f469..da95c5d98f 100644
--- a/connector/perl/t/02-two-servers.t
+++ b/connector/perl/t/02-two-servers.t
@@ -6,7 +6,7 @@ use utf8;
use open qw(:std :utf8);
use lib qw(lib ../lib);
-use Test::More tests => 17;
+use Test::More tests => 16;
use Encode qw(decode encode);
@@ -103,28 +103,15 @@ ok $box_union, 'connector is created';
ok $box1, 'connector is created';
ok $box2, 'connector is created';
+
my %resps;
-for (1 .. 2) {
- my $tuples = $box_union->Call(tst_sleep => [], { unpack_format => '$$' });
+for (1 .. 20) {
+ my $tuples = $box_union->Call(
+ tst_server_name => [], { unpack_format => '$' }
+ );
$resps{ $tuples->[0][0] }++;
}
-ok exists $resps{first}, 'first server was used';
-ok exists $resps{second}, 'second server was used';
-
-
-%resps = ();
-for (1 .. 100) {
- my $started = time;
- my $tuples = $box_union->Call(tst_sleep => [], { unpack_format => '$$' });
- my $done = time - $started;
-
- if ($done <= .3) {
- $resps{ok}++;
- } else {
- $resps{fail}++;
- }
-}
-
-ok $resps{fail} < $resps{ok} / 8, 'random fails';
+is 1, scalar keys %resps, 'one server was used for all requests';
+is $resps{first} || $resps{second}, 20, 'all requests were handled';
diff --git a/connector/perl/t/03-box.t b/connector/perl/t/03-box.t
new file mode 100644
index 0000000000..eb51050fcf
--- /dev/null
+++ b/connector/perl/t/03-box.t
@@ -0,0 +1,1057 @@
+#!/usr/bin/perl
+
+# Tarantool/Box config below
+
+use strict;
+use warnings;
+BEGIN {
+ sub mPOP::Config::GetValue ($) {
+ die;
+ }
+}
+use FindBin qw($Bin);
+use lib "$Bin";
+use lib "$Bin/../lib";
+use Carp qw/confess/;
+
+use Test::More tests => 372;
+use Test::Exception;
+
+BEGIN {
+ warn $Bin;
+ use_ok 'Test::Tarantool';
+ use_ok 'POSIX';
+}
+
+use List::MoreUtils qw/zip/;
+
+local $SIG{__DIE__} = \&confess;
+
+our $CLASS;
+BEGIN {
+ $CLASS = $ENV{BOXCLASS} || 'MR::Tarantool::Box';
+ eval "require $CLASS" or die $@;
+}
+
+POSIX::setlocale(LC_ALL, 'C');
+
+use constant ILL_PARAM => qr/Error (00000202|00002A02)/;
+use constant TUPLE_NOT_EXISTS => qr/Error 00003102/;
+use constant TUPLE_EXISTS => qr/Error 00003702/;
+use constant INDEX_VIOLATION => qr/Error 00003802/;
+
+use constant NO_SUCCESS => qr/no success after/;
+
+use constant TOO_BIG_FIELD => qr/too big field/;
+
+
+our $box;
+
+
+my $tarantool_config = "$Bin/data/box.t.cfg";
+ok -r $tarantool_config, "-r $tarantool_config";
+my $tnt_srv = Test::Tarantool->run(cfg => 't/data/box.t.cfg');
+ok $tnt_srv, 'server instance created';
+diag $tnt_srv->log unless ok $tnt_srv->started, 'server is started';
+
+
+our $server = shift || $ENV{BOX} ||
+ sprintf '127.0.0.1:%d', $tnt_srv->primary_port;
+
+ok $server, 'server address was defined ' . $server || 'undef';
+
+our %opts = (
+ debug => $ENV{DEBUG}||0,
+ ipdebug => $ENV{IPDEBUG}||0,
+ raise => 1,
+);
+
+sub cleanup ($) {
+ my ($id) = @_;
+ die unless defined $id;
+ ok defined $box->Delete($id), 'delete of possible existing record';
+ ok $box->Delete($id) == 0, 'delete of non existing record';
+}
+
+sub def_param {
+ my $format = shift || 'l& SSLL';
+ return { servers => $server,
+ name => $CLASS,
+ namespaces => [ {
+ indexes => [ {
+ index_name => 'primary_id',
+ keys => [0],
+ }, {
+ index_name => 'primary_email',
+ keys => [1],
+ }, ],
+ namespace => 0,
+ format => $format,
+ default_index => 'primary_id',
+ name => 'main',
+ } ],
+ default_space => "main",
+ %opts,
+ }
+}
+
+$box = $CLASS->new(def_param('l&SSLL&'));
+ok $box->isa($CLASS), 'connect';
+cleanup 13;
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '777',{space => 'main'}), 'insert';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '777'], 'select/insert';
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 2, 2, 3, 4, '666',{namespace => 'main'}), 'replace';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 2, 3, 4, '666'], 'select/replace';
+
+ok $box->Update(13, 3 => 1) == 1, 'update of some field';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, '666'], 'select/update';
+
+ok $box->Append( 13, 6 => 'APPEND') , 'append op';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, '666APPEND'], 'select/append';
+
+ok $box->Prepend(13, 6 => 'PREPEND'), 'prepend op';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, 'PREPEND666APPEND'], 'select/prepend';
+
+ok $box->Cutbeg(13, 6 => 2), 'cutbeg op';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, 'EPEND666APPEND'], 'select/cutbeg';
+
+ok $box->Cutend(13, 6 => 2), 'cutend op';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, 'EPEND666APPE'], 'select/cutend';
+
+ok $box->Substr(13, 6 => [3,4,'12345']), 'substr op';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, 'EPE123456APPE'], 'select/substr';
+
+
+
+ok $box->UpdateMulti(13, [6 => splice => [0]]), 'generic splice (offset = 0)';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4, ''], 'select/splice (offset = 0)';
+
+cleanup 13;
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'insert';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/insert';
+
+throws_ok sub { $box->UpdateMulti(13, [6 => splice => [-10]]) }, ILL_PARAM, "splice/bad_params_1";
+
+ok $box->UpdateMulti(13, [6 => splice => [100]]), "splice/big_offset";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [5]]), "splice/cut_tail_pos_offset";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '12345'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [-2]]), "splice/cut_tail_neg_offset";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123'], 'select';
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'replace';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [8, 1000]]), "splice/big_pos_length";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '12345678'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [1, -1000]]), "splice/big_neg_length";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '12345678'], 'select';
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'replace';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [0x7fffffff]]), "splice/max_offset";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select';
+
+ok $box->UpdateMulti(13, [6 => splice => [1, 2]], [6 => splice => [-2, -1, 'qwe']]), "splice/multi";
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '14567qwe9'], 'select';
+
+
+
+cleanup 13;
+cleanup 14;
+throws_ok sub { $box->Replace(13, q/some_email@test.mail.ru/, 5, 5, 5, 5, '555555555')}, TUPLE_NOT_EXISTS, 'replace';
+
+ok $box->Add(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'add';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/add';
+
+throws_ok sub { $box->Add(13, q/some_email@test.mail.ru/, 5, 5, 5, 5, '555555555')}, TUPLE_EXISTS, 'add2';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/add2';
+is_deeply scalar $box->Select(q/some_email@test.mail.ru/, {use_index => "primary_email"}), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/add2';
+
+throws_ok sub { $box->Add(14, q/some_email@test.mail.ru/, 5, 5, 5, 5, '555555555')}, INDEX_VIOLATION, 'add3';
+
+ok $box->Add(14, q/some1email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'add4';
+is_deeply scalar $box->Select(14), [14, 'some1email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/add4';
+is_deeply scalar $box->Select(q/some1email@test.mail.ru/, {use_index => "primary_email"}), [14, 'some1email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/add4';
+
+throws_ok sub { $box->Replace(13, q/some1email@test.mail.ru/, 6, 6, 6, 6, '666666666')}, INDEX_VIOLATION, 'replace';
+throws_ok sub { $box->Set(13, q/some1email@test.mail.ru/, 6, 6, 6, 6, '666666666')}, INDEX_VIOLATION, 'set';
+
+ok $box->Set(13, q/some_email@test.mail.ru/, 5, 5, 5, 5, '555555555'), 'set';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 5, 5, 5, 5, '555555555'], 'select/set';
+
+ok $box->Replace(13, q/some_email@test.mail.ru/, 1, 2, 3, 4, '123456789'), 'replace';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 'select/replace';
+
+
+is_deeply [$box->Select([13], {raise => 0, hash_by => 0, raw => 1})], [{13 => [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789']}], 'select/rawhash1';
+is_deeply [$box->Select([13,14], {raise => 0, hash_by => 0, raw => 1})], [{13 => [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], 14 => [14, 'some1email@test.mail.ru', 1, 2, 3, 4, '123456789']}], 'select/rawhash2';
+
+
+do {
+ my $continuation = $box->Select(13,{ return_fh => 1 });
+ ok $continuation, "select/continuation";
+
+ my $rin = '';
+ vec($rin,$continuation->{fh}->fileno,1) = 1;
+ my $ein = $rin;
+ ok 0 <= select($rin,undef,$ein,2), "select/continuation/select";
+
+ my $res = $continuation->{continue}->();
+ use Data::Dumper;
+ is_deeply $res, [13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789'], "select/continuation/result";
+};
+
+our $ANYEVENT = 1 && eval { require AnyEvent; 1 };
+SKIP:{
+ skip "AnyEvent not found", 60 unless $ANYEVENT;
+
+ local $opts{raise} = 0;
+ $box = $CLASS->new(def_param('l&SSLL&'));
+
+ my $tt = [ [1, 'rtokarev@corp.mail.ru', 11, 111, 1111, 11111, "1111111111111"],
+ [2, 'vostrikov@corp.mail.ru', 22, 222, 2222, 22222, "2222222222222"],
+ [3, 'aleinikov@corp.mail.ru', 33, 333, 3333, 33333, "3333333333333"],
+ [4, 'roman.s.tokarev@gmail.com', 44, 444, 4444, 44444, "4444444444444"],
+ [5, 'vostrIIIkov@corp.mail.ru', 55, 555, 5555, 55555, "5555555555555"] ];
+
+ foreach my $tuple (@$tt) {
+ cleanup $tuple->[0];
+ }
+
+ AnyEvent->now_update;
+ my $cv = AnyEvent->condvar;
+ foreach my $tuple (@$tt) {
+ $cv->begin;
+ ok $box->Insert(@$tuple, {callback => sub { ok $_[0], "async/insert$tuple->[0]/result"; $cv->end; }}), "async/insert$tuple->[0]";
+ }
+ $cv->recv;
+
+
+ AnyEvent->now_update;
+ $cv = AnyEvent->condvar;
+ $cv->begin;
+ ok $box->Select(1,2,3,{callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, [@$tt[0,1,2]], "async/select1/result";
+ }}), "async/select1";
+
+ $cv->begin;
+ ok $box->Select(4,5,{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, [@$tt[3,4]], "async/select2/result";
+ }}), "async/select2";
+
+ $cv->recv;
+
+
+ AnyEvent->now_update;
+ $cv = AnyEvent->condvar;
+ foreach my $tuple (@$tt) {
+ $tuple->[4] += 10000;
+ $cv->begin;
+ ok $box->UpdateMulti($tuple->[0], [ 4 => add => 10000 ], {callback => sub { ok $_[0], "async/update1-$tuple->[0]/result"; $cv->end; }}), "async/update1-$tuple->[0]";
+ }
+ $cv->begin;
+ ok $box->Select((map{$_->[0]}@$tt),{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, $tt, "async/update1-select/result";
+ }}), "async/update1-select";
+ $cv->recv;
+
+ AnyEvent->now_update;
+ $cv = AnyEvent->condvar;
+ foreach my $tuple (@$tt) {
+ $tuple->[4] += 10000;
+ $cv->begin;
+ ok $box->UpdateMulti($tuple->[0], [ 4 => add => 10000 ], {want_result => 1, callback => sub { is_deeply $_[0], $tuple, "async/update2-$tuple->[0]/result"; $cv->end; }}), "async/update2-$tuple->[0]";
+ }
+ $cv->begin;
+ ok $box->Select((map{$_->[0]}@$tt),{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, $tt, "async/update2-select/result";
+ }}), "async/update2-select";
+ $cv->recv;
+
+ AnyEvent->now_update;
+ $cv = AnyEvent->condvar;
+ foreach my $tuple (@$tt) {
+ $cv->begin;
+ ok $box->Delete($tuple->[0], {want_result => 1, callback => sub { is_deeply $_[0], $tuple, "async/delete-$tuple->[0]/result"; $cv->end; }}), "async/delete-$tuple->[0]";
+ }
+ $cv->begin;
+ ok $box->Select((map{$_->[0]}@$tt),{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, [], "async/delete-select/result";
+ }}), "async/delete-select";
+ $cv->recv;
+}
+
+sub countwarn {
+ my ($qr, $counter) = @_;
+ return sub {
+ ++$$counter if $_[0] =~ $qr;
+# note "caught warning: ", @_;
+ };
+};
+
+do {
+ local $server = sprintf "127.0.0.1:%s", Test::Tarantool::_find_free_port;
+ local $opts{raise} = 0;
+ my $try = 3;
+
+ my $counter = 0;
+ local $SIG{__WARN__} = countwarn(qr/refused/i, \$counter);
+
+ my $box = $CLASS->new(def_param('l&SSLL&'));
+
+ throws_ok sub{my$x=$box->Select(13,{ want => "arrayref", raise => 1 })}, NO_SUCCESS, "reject/select/raise/sync";
+ is $counter, $try, "reject/select/raise/sync/counter";
+ $counter = 0;
+
+ ok !$box->Select(13,{ want => "arrayref", raise => 0 }), "reject/select/noraise/sync";
+ ok $counter == $try, "reject/select/noraise/sync/counter";
+ $counter = 0;
+
+ my $continuation = $box->Select(13,{ return_fh => 1, raise => 0 });
+ ok !$continuation, "reject/select/continuation";
+ ok $counter == 1, "reject/select/continuation/counter";
+ $counter = 0;
+
+
+ SKIP:{
+ skip "AnyEvent not found", 5 unless $ANYEVENT;
+
+ AnyEvent->now_update;
+ my $cv = AnyEvent->condvar;
+ $cv->begin;
+ ok $box->Select(4,5,{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ ok !$res, "reject/select/async/noraise/cb";
+ ok $box->Error, "reject/select/async/noraise/cb/error";
+ ok $box->ErrorStr, "reject/select/async/noraise/cb/errorstr";
+ }}), "reject/select/async/noraise";
+
+ $cv->recv;
+ ok $counter == $try, "reject/select/async/noraise/counter";
+ $counter = 0;
+ }
+};
+
+do {
+ my $pid;
+ local $SIG{INT} = $SIG{TERM} = sub { kill 'TERM', $pid };
+
+ $pid = fork();
+ die unless defined $pid;
+ unless($pid) {
+ $0 = "$0 <SERVER>";
+ my $stop = 0;
+ my $h;
+ my $l = IO::Socket::INET->new(
+ LocalAddr => '127.0.0.1',
+ LocalPort => 1111,
+ Proto => 'tcp',
+ Listen => 10,
+ Blocking => 1,
+ ReuseAddr => 1,
+ ) or die $!;
+ $SIG{INT} = $SIG{TERM} = sub { ++$stop; close $l; close $h; exit; };
+ while(!$stop) {
+ $h = $l->accept;
+ my $data;
+ while($h->read($data,1024) > 0) { 0; }
+ close $h;
+ }
+ exit;
+ }
+
+
+ local $server = "127.0.0.1:1111";
+ local $opts{raise} = 0;
+ local $opts{timeout} = 0.1;
+ local $opts{select_timeout} = 0.1;
+
+ my $try = 3;
+
+ my $counter = 0;
+ local $SIG{__WARN__} = countwarn(qr/timed? ?out/i, \$counter);
+
+ my $box = $CLASS->new(def_param('l&SSLL&'));
+
+ sleep 1;
+
+ throws_ok sub{my$x=$box->Select(13,{ want => "arrayref", raise => 1 })}, NO_SUCCESS, "timeout1/select/raise/sync";
+ ok $counter == $try, "timeout1/select/raise/sync/counter";
+ $counter = 0;
+
+ ok !$box->Select(13,{ want => "arrayref", raise => 0 }), "timeout1/select/noraise/sync";
+ ok $counter == $try, "/counter";
+ $counter = 0;
+
+ my $continuation = $box->Select(13,{ return_fh => 1, raise => 0 });
+ ok $continuation, "timeout1/select/continuation";
+ ok !$continuation->{continue}->(), "timeout1/select/continuation/result";
+ ok $counter == 1, "timeout1/select/continuation/counter";
+ $counter = 0;
+
+
+ SKIP:{
+ skip "AnyEvent not found", 5 unless $ANYEVENT;
+
+ AnyEvent->now_update;
+ my $cv = AnyEvent->condvar;
+ $cv->begin;
+ ok $box->Select(4,5,{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ ok !$res, "timeout1/select/async/noraise/cb";
+ ok $box->Error, "timeout1/select/async/noraise/cb/error";
+ ok $box->ErrorStr, "timeout1/select/async/noraise/cb/errorstr";
+ }}), "timeout1/select/async/noraise";
+
+ $cv->recv;
+ ok $counter == $try, "timeout1/select/async/noraise/counter";
+ $counter = 0;
+ }
+
+ kill 'TERM', $pid;
+};
+
+do {
+ my $pid;
+ local $SIG{INT} = $SIG{TERM} = sub { kill 'TERM', $pid };
+
+ $pid = fork();
+ die unless defined $pid;
+ unless($pid) {
+ $0 = "$0 <SERVER>";
+ my $stop = 0;
+ my $h;
+ my @ok = (0,0,1,0,0,1,1,0,0,1);
+ my $l = IO::Socket::INET->new(
+ LocalAddr => '127.0.0.1',
+ LocalPort => 1111,
+ Proto => 'tcp',
+ Listen => 10,
+ Blocking => 1,
+ ReuseAddr => 1,
+ ) or die $!;
+ my ($host, $port) = split /:/, $server;
+ my $box = IO::Socket::INET->new(
+ PeerAddr => $host,
+ PeerPort => $port,
+ Proto => 'tcp',
+ Blocking => 1,
+ ) or die;
+ $SIG{INT} = $SIG{TERM} = sub { ++$stop; close $l; close $h; close $box; exit; };
+
+ while(!$stop) {
+ $h = $l->accept;
+ $h->blocking(1);
+ my $data = '';
+ if (shift @ok) {
+ while(!$stop) {
+ $h->blocking(0);
+ $h->read($data,1024,length$data);
+ if(length$data) {
+ $h->blocking(1);
+ $h->read($data,12-length$data,length$data) while length $data < 12;
+ my ($len) = unpack 'x4L', $data;
+ $h->read($data,12+$len-length$data,length$data) while length $data < 12+$len;
+ $box->write($data);
+
+ $data = '';
+ $box->read($data,12-length$data, length$data) while length $data < 12;
+ ($len) = unpack 'x4L', $data;
+ $box->read($data,12+$len-length$data,length$data) while length $data < 12+$len;
+ $h->write($data);
+ close $h;
+ last;
+ }
+ sleep 0.1;
+ }
+ } else {
+ while($h->read($data,1024) > 0) { 0; }
+ }
+ close $h;
+ }
+ close $l;
+ close $box;
+ exit;
+ }
+
+
+ local $server = "127.0.0.1:1111";
+ local $opts{raise} = 0;
+ local $opts{timeout} = 0.1;
+ local $opts{select_timeout} = 0.1;
+
+ my $try = 2;
+
+ my $counter = 0;
+ local $SIG{__WARN__} = countwarn(qr/timed? ?out/i, \$counter);
+
+ my $box = $CLASS->new(def_param('l&SSLL&'));
+
+ sleep 1;
+
+ is_deeply $box->Select(13,{ want => "arrayref", raise => 1 }), [[13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789']], "timeout2/select/raise/sync";
+ ok !$box->Error, "timeout2/select/raise/sync/error";
+ ok !$box->ErrorStr, "timeout2/select/raise/sync/errorstr";
+ ok $counter == $try, "timeout2/select/raise/sync/counter";
+ $counter = 0;
+
+ is_deeply $box->Select(13,{ want => "arrayref", raise => 0 }), [[13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789']], "timeout2/select/noraise/sync";
+ ok !$box->Error, "timeout2/select/noraise/sync/error";
+ ok !$box->ErrorStr, "timeout2/select/noraise/sync/errorstr";
+ ok $counter == $try, "timeout2/select/noraise/sync/counter";
+ $counter = 0;
+
+ my $continuation = $box->Select(13,{ return_fh => 1, raise => 0, want => 'arrayref' });
+ ok $continuation, "timeout2/select/continuation";
+ is_deeply $continuation->{continue}->(), [[13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789']], "timeout2/select/continuation/result";
+ ok !$box->Error, "timeout2/select/continuation/error";
+ ok !$box->ErrorStr, "timeout2/select/continuation/errorstr";
+ ok $counter == 0, "timeout2/select/continuation/counter";
+ $counter = 0;
+
+
+ SKIP:{
+ skip "AnyEvent not found", 5 unless $ANYEVENT;
+
+ AnyEvent->now_update;
+ my $cv = AnyEvent->condvar;
+ $cv->begin;
+ ok $box->Select(13,{ callback => sub {
+ my ($res) = @_;
+ $cv->end;
+ is_deeply $res, [[13, 'some_email@test.mail.ru', 1, 2, 3, 4, '123456789']], "timeout2/select/async/noraise/cb";
+ ok !$box->Error, "timeout2/select/async/noraise/cb/error";
+ ok !$box->ErrorStr, "timeout2/select/async/noraise/cb/errorstr";
+ }}), "timeout2/select/async/noraise";
+
+ $cv->recv;
+ ok $counter == $try, "timeout2/select/async/noraise/counter";
+ $counter = 0;
+ }
+
+ kill 'TERM', $pid;
+};
+
+
+$box = $CLASS->new(def_param);
+ok $box->isa($CLASS), 'connect';
+cleanup 13;
+
+ok $box->Insert(13, q/some_email@test.mail.ru/, 1, 2, 3, 4), 'insert';
+ok $box->Insert(13, q/some_email@test.mail.ru/, 2, 2, 3, 4), 'replace';
+
+ok $box->Update(13, 3 => 1) == 1, 'update of some field';
+is_deeply scalar $box->Select(13), [13, 'some_email@test.mail.ru', 2, 1, 3, 4], 'select/update';
+
+cleanup 14;
+ok $box->Insert(14, 'aaa@test.mail.ru', 0, 0, 1, 1), 'insert';
+
+is_deeply scalar $box->Select(14), [14, 'aaa@test.mail.ru', 0, 0, 1, 1], 'select';
+is_deeply scalar $box->Select('aaa@test.mail.ru', {use_index => 'primary_email'}), [14, 'aaa@test.mail.ru', 0, 0, 1, 1], 'select';
+
+
+ok $box->Update(14, 2 => 2), 'update of some field';
+
+
+is_deeply scalar $box->Select(14), [14, 'aaa@test.mail.ru', 2, 0, 1, 1], 'select';
+is_deeply scalar $box->Select('aaa@test.mail.ru', {use_index => 'primary_email'}), [14, 'aaa@test.mail.ru', 2, 0, 1, 1], 'select';
+
+
+
+$box = $CLASS->new(def_param);
+ok $box->isa($CLASS), 'connect';
+
+
+
+for (1..3) {
+ %MR::IProto::sockets = ();
+ %MR::IProto::sockets = ();
+ $box = $CLASS->new(def_param);
+ ok $box->isa($CLASS), 'connect';
+
+ cleanup 14;
+
+ ok $box->Insert(14, 'aaa@test.mail.ru', 0, 0, 1, 1), 'insert';
+
+ ok $box->Update(14, 2 => 2), 'update of field';
+}
+
+# interfaces
+# 0 1 2 3 4 5
+my @tuple = (14, 'aaa@test.mail.ru', 0, 0, 1, 0);
+my $id = $tuple[0];
+my $email = $tuple[1];
+
+cleanup 14;
+ok $box->Insert(@tuple), 'insert';
+
+is_deeply scalar $box->Select($id), \@tuple, 'select';
+
+
+### Bit ops
+
+# zero namespace
+$box->Bit($id, 5, bit_set => (1 << 15));
+$tuple[5] |= (1 << 15);
+is_deeply scalar $box->Select($id), \@tuple, 'bit set';
+
+$box->Bit($id, 5, bit_clear => (1 << 15));
+$tuple[5] &= ~(1 << 15);
+is_deeply scalar $box->Select($id), \@tuple, 'bit clear';
+
+$box->Bit($id, 5, bit_set => (1 << 15), bit_clear => (1 << 16));
+$tuple[5] |= (1 << 15);
+$tuple[5] &= ~(1 << 16);
+is_deeply scalar $box->Select($id), \@tuple, 'bit_set + bit_clear';
+
+$box->Bit($id, 5, set => 4095, bit_set => (1 << 5), bit_clear => (1 << 6));
+$tuple[5] = 4095;
+$tuple[5] |= (1 << 5);
+$tuple[5] &= ~(1 << 6);
+is_deeply scalar $box->Select($id), \@tuple, 'set + bit_set + bit_clear';
+
+$box->Bit($id, 5, set => 123);
+$tuple[5] = 123;
+is_deeply scalar $box->Select($id), \@tuple, 'set via Bit';
+
+
+
+
+## Num ops
+
+# zero namespace
+$box->Num($id, 5, num_add => 1);
+$tuple[5] += 1;
+is_deeply scalar $box->Select($id), \@tuple, 'num_add';
+
+$box->Num($id, 5, num_sub => 1);
+$tuple[5] -= 1;
+is_deeply scalar $box->Select($id), \@tuple, 'num_sub';
+
+$box->Num($id, 5, set => 123);
+$tuple[5] = 123;
+is_deeply scalar $box->Select($id), \@tuple, 'set via Num';
+
+$box->Num($id, 5, set => 4095, num_add => 5, num_sub => 10);
+$tuple[5] = 4095;
+$tuple[5] += 5;
+$tuple[5] -= 10;
+is_deeply scalar $box->Select($id), \@tuple, 'set + num_add + num_sub';
+
+
+### Bit & Num opt parse
+throws_ok sub { $box->Bit($id, 5, update => 123) }, qr/unknown op 'update'/, 'bad op for Bit';
+throws_ok sub { $box->Bit($id, 5, hxxxxx => 123) }, qr/unknown op 'hxxxxx'/, 'bad op for Bit';
+throws_ok sub { $box->Num($id, 5, update => 123) }, qr/unknown op 'update'/, 'bad op for Num';
+throws_ok sub { $box->Num($id, 5, hxxxxx => 123) }, qr/unknown op 'hxxxxx'/, 'bad op for Num';
+
+
+### AndXorAdd
+
+$box->AndXorAdd($id, 5, 4095, 5, 10);
+$tuple[5] &= 4095;
+$tuple[5] ^= 5;
+$tuple[5] += 10;
+is_deeply scalar $box->Select($id), \@tuple, 'AndXorAdd namespace=1';
+
+
+### key parser
+throws_ok sub { my $a = $box->Select('some@test.mai;.ru') }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Num('some@test.mai;.ru', 5, num_add => 1) }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Delete('some@test.mai;.ru') }, qr/not numeric key/, 'validation of $key';
+
+throws_ok sub { my $a = $box->Select('1.1') }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Num('1.1', 5, num_add => 1) }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Delete('1.1') }, qr/not numeric key/, 'validation of $key';
+
+throws_ok sub { my $a = $box->Select('') }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Num('', 5, num_add => 1) }, qr/not numeric key/, 'validation of $key';
+throws_ok sub { my $a = $box->Delete('') }, qr/not numeric key/, 'validation of $key';
+
+
+## Detete
+cleanup $id;
+ok $box->Insert(@tuple), 'insert';
+ok $box->Delete($id), 'delete by id';
+ok 0 == $box->Delete($id), 'delete by id';
+
+## UpdateMulti
+cleanup $id;
+ok $box->Insert(@tuple), 'insert';
+
+ok $box->UpdateMulti($id, ([5 => set => 1]) x 127), 'big update multi';
+# CANT TEST throws_ok sub { $box->UpdateMulti($id, ([5 => set => 1]) x 128) }, ILL_PARAM, 'too big update multi';
+throws_ok sub { $box->UpdateMulti($id, ([5 => set => 1]) x 129) }, qr/too many op/, 'too big update multi';
+{
+ my $box = $CLASS->new(def_param(q/l& SSL&/));
+ my @tuple = @tuple;
+ ok $box->isa($CLASS), 'connect';
+
+ ok $box->UpdateMulti($id, map { [5 => set => 'x' x 127] } (1..127)), 'big update multi';
+ $tuple[5] = 'x' x 127;
+ is_deeply scalar $box->Select($id), \@tuple, 'result of update multi';
+
+ # DISABLED since no BER IN BOX yet
+ # ok $box->UpdateMulti($id, ([5 => set => 'x' x 6554])), 'very big update multi';
+ # $tuple[5] = 'x' x 6554;
+ # is_deeply scalar $box->Select($id), \@tuple, 'result of update multi';
+}
+
+{
+ my $box = $CLASS->new(def_param(q/l& &&&&/));
+ my @tuple = @tuple;
+ my $id = $tuple[0];
+ ok $box->isa($CLASS), 'connect';
+
+ ok $box->UpdateMulti($id, [2 => set => 'ab'], [5 => set => 'z' x 127]), 'update multi no teplate';
+ $tuple[2] = 'ab';
+ $tuple[5] = 'z' x 127;
+ my @r = @{$box->Select($id)};
+ is_deeply scalar [@r[2,5]], [@tuple[2,5]] , 'result of update multi';
+}
+
+throws_ok sub { $box->UpdateMulti($id, [5 => and_xor_add => [1,2,3,4]]) }, qr/bad op <and_xor_add>/, 'bad and_xor_add';
+throws_ok sub { $box->UpdateMulti($id, [5 => and_xor_add => [1,2]]) }, qr/bad op <and_xor_add>/, 'bad and_xor_add';
+throws_ok sub { $box->UpdateMulti($id, [5 => and_xor_add => 1]) }, qr/bad op <and_xor_add>/, 'bad and_xor_add';
+throws_ok sub { $box->UpdateMulti($id, [1, 2, 3]) }, qr/bad op/, 'bad op';
+throws_ok sub { $box->UpdateMulti($id, [1, 2]) }, qr/bad op/, 'bad op';
+throws_ok sub { $box->UpdateMulti($id, '') }, qr/bad op/, 'bad op';
+
+{
+ my @tuple = (14, 'aaa@test.mail.ru', 0, 0, 1, 1);
+
+ cleanup 14;
+ cleanup 15;
+ ok $box->Insert(@tuple), 'insert';
+
+ my @op = ([4 => num_add => 300], [5 => num_sub => 100], [5 => set => 1414], [5 => bit_set => 1 | 2], [5 => bit_clear => 2]);
+ ok $box->UpdateMulti($tuple[0], @op), 'update multi';
+ my @tuple_new = @tuple;
+ $tuple_new[4] += 300;
+ $tuple_new[5] -= 100;
+ $tuple_new[5] = 1414;
+ $tuple_new[5] |= 1 | 2;
+ $tuple_new[5] &= ~2;
+ is_deeply scalar $box->Select(14), \@tuple_new, 'update multi';
+
+ cleanup 14;
+ ok $box->Insert(@tuple), 'insert';
+ is_deeply scalar $box->UpdateMulti($tuple[0], @op, {want_result => 1}), \@tuple_new, 'update multi, want_result';
+
+ ok 0 == $box->UpdateMulti(15, [4 => num_add => 300], [5 => num_sub => 100], [5 => set => 1414]), 'update multi of nonexist';
+}
+
+
+## Select
+throws_ok sub { $box->Select(1) }, qr/void context/, 'select in void context';
+throws_ok sub { my $a = $box->Select(1,2,3) }, qr/too many keys in scalar context/, 'too many keys in scalar context';
+
+cleanup $tuple[0];
+ok $box->Insert(@tuple);
+is_deeply [$box->Select($tuple[0], $tuple[0])], [\@tuple, \@tuple], 'select in scalar context';
+is_deeply scalar $box->Select($tuple[0], $tuple[0], {want => 'arrayref'}), [\@tuple, \@tuple], 'select want => arrrayref';
+
+{
+ my $box = $CLASS->new(
+ { %{def_param()},
+ hashify => sub {
+ my ($namespace, $row) = @_;
+ my $i = 1;
+ foreach (@$row) {
+ my @tuple = @{$_};
+ $_ = {};
+ foreach my $k (@tuple) {
+ $_->{$i++} = $k;
+ }
+ }
+ },
+ }
+ );
+
+ my $hash = {};
+ my $i = 1;
+ $hash->{$i++} = $_ foreach @tuple;
+
+ is_deeply $box->Select($tuple[0]), $hash, 'select with hashify';
+}
+
+## Tree indexes
+sub def_param1 {
+ my $format = 'l&l';
+ return { servers => $server,
+ namespaces => [ {
+ indexes => [ {
+ index_name => 'primary_num1',
+ keys => [0],
+ }, {
+ index_name => 'secondary_str2',
+ keys => [1],
+ }, {
+ index_name => 'secondary_complex',
+ keys => [1, 2],
+ } ],
+ namespace => 26,
+ format => $format,
+ default_index => 'primary_num1',
+ } ],
+ %opts,
+ }
+}
+
+$box = $CLASS->new(def_param1);
+ok $box->isa($CLASS), 'connect';
+
+my @tuple1 = (13, 'mail.ru', 123);
+cleanup $tuple1[0];
+
+my @tuple2 = (14, 'mail.ru', 456);
+cleanup $tuple2[0];
+
+ok $box->Insert(@tuple1);
+
+is_deeply [$box->Select([[$tuple1[0]]])], [\@tuple1], 'select by primary_num1 index';
+is_deeply [$box->Select([[$tuple1[1]]], { use_index => 'secondary_str2' })], [\@tuple1], 'select by secondary_str2 index';
+is_deeply [$box->Select([[$tuple1[1], $tuple1[2]]], { use_index => 'secondary_complex' })], [\@tuple1], 'select by secondary_complex index';
+is_deeply [$box->Select([[$tuple1[1]]], { use_index => 'secondary_complex' })], [\@tuple1], 'select by secondary_complex index, partial key';
+
+ok $box->Insert(@tuple2);
+
+is_deeply [$box->Select([[$tuple2[0]]])], [\@tuple2], 'select by primary_num1 index';
+is_deeply [$box->Select([[$tuple1[1]]], { use_index => 'secondary_str2', limit => 2, offset => 0 })], [\@tuple1, \@tuple2], 'select by secondary_str2 index';
+is_deeply [$box->Select([[$tuple2[1], $tuple2[2]]], { use_index => 'secondary_complex' })], [\@tuple2], 'select by secondary_complex index';
+
+## Check index constrains
+sub def_param_bad {
+ my $format = 'l&&';
+ return { servers => $server,
+ spaces => [ {
+ indexes => [ {
+ index_name => 'primary_num1',
+ keys => [0],
+ }, {
+ index_name => 'secondary_str2',
+ keys => [1],
+ }, {
+ index_name => 'secondary_complex',
+ keys => [1, 2],
+ } ],
+ namespace => 26,
+ format => $format,
+ default_index => 'primary_num1',
+ } ],
+ %opts,
+ }
+}
+
+$box = $CLASS->new(def_param_bad);
+ok $box->isa($CLASS), 'connect';
+
+my @tuple_bad = (13, 'mail.ru', '123');
+cleanup $tuple_bad[0];
+throws_ok sub { $box->Insert(@tuple_bad) }, ILL_PARAM, "index_constains/bad_field_type";
+
+
+## Check unique tree index
+sub def_param_unique {
+ my $format = 'l&&&';
+ return { servers => $server,
+ namespaces => [ {
+ indexes => [ {
+ index_name => 'id',
+ keys => [0],
+ }, {
+ index_name => 'email',
+ keys => [1],
+ }, {
+ index_name => 'firstname',
+ keys => [2],
+ }, {
+ index_name => 'lastname',
+ keys => [3],
+ } , {
+ index_name => 'fullname',
+ keys => [2, 3]
+ } ],
+ space => 27,
+ format => $format,
+ default_index => 'id',
+ } ],
+ %opts,
+ }
+}
+
+$box = $CLASS->new(def_param_unique);
+ok $box->isa($CLASS), 'connect';
+
+my $tuples = [ [1, 'rtokarev@corp.mail.ru', 'Roman', 'Tokarev'],
+ [2, 'vostrikov@corp.mail.ru', 'Yuri', 'Vostrikov'],
+ [3, 'aleinikov@corp.mail.ru', 'Roman', 'Aleinikov'],
+ [4, 'roman.s.tokarev@gmail.com', 'Roman', 'Tokarev'],
+ [5, 'vostrikov@corp.mail.ru', 'delamon', 'delamon'] ];
+
+foreach my $tuple (@$tuples) {
+ cleanup $tuple->[0];
+}
+
+foreach my $tuple (@$tuples) {
+ if ($tuple == $tuples->[-1] || $tuple == $tuples->[-2]) {
+ throws_ok sub { $box->Insert(@$tuple) }, INDEX_VIOLATION, "unique_tree_index/insert \'$tuple->[0]\'";
+ } else {
+ ok $box->Insert(@$tuple), "unique_tree_index/insert \'$tuple->[0]\'";
+ }
+}
+
+
+my @res = $box->Select([map $_->[0], @$tuples], { limit => 100 });
+foreach my $r (@res) {
+ ok sub { return $r->[0] != $tuples->[-1] && $r->[0] != $tuples->[-2] },
+ 'invalid insert into unique index';
+}
+
+my $flds;
+my $lflds;
+BEGIN{ $flds = [qw/ f1 f2 f3 f4 LL /] }
+BEGIN{ $lflds = [qw/ l1 l2 l3 /] }
+ {
+ package TestBox;
+ use MR::Tarantool::Box::Singleton;
+ use base 'MR::Tarantool::Box::Singleton';
+
+ BEGIN {
+ __PACKAGE__->mkfields(@$flds);
+ __PACKAGE__->mklongfields(@$lflds);
+ }
+
+ sub SERVER { $server }
+ sub REPLICAS { '' }
+
+ sub SPACES {[{
+ space => 27,
+ indexes => [ {
+ index_name => 'primary_id',
+ keys => [TUPLE_f1],
+ } ],
+ format => 'l&$&(&$&)*',
+ default_index => 'primary_id',
+ }]}
+
+ }
+
+
+
+$box = 'TestBox';
+#$box = $CLASS->new(def_param_flds);
+#ok $box->isa($CLASS), 'connect';
+do {
+ my $tuples = [
+ [1, "asdasdasd1", "qqq\xD0\x8Eqqq1", "ww\xD0\x8Eww1", "la\xD0\x8Elalala11", "la\xD0\x8Elala11", "lala11"],
+ [2, "asdasdasd2", "qqq\xD0\x8Eqqq2", "ww\xD0\x8Eww2", "la\xD0\x8Elalala21", "la\xD0\x8Elala21", "lala21", "lalalala22", "lalala22", "lala22", "lalalala23", "lalala23", "lala23"],
+ [3, "asdasdasd3", "qqq\xD0\x8Eqqq3", "ww\xD0\x8Eww3", "la\xD0\x8Elalala31", "la\xD0\x8Elala31", "lala31", "lalalala32", "lalala32", "lala32"],
+ [4, "asdasdasd4", "qqq\xD0\x8Eqqq4", "ww\xD0\x8Eww4", "la\xD0\x8Elalala41", "la\xD0\x8Elala41", "lala41", "lalalala42", "lalala42", "lala42", "lalalala43", "lalala43", "lala43"],
+ [5, "asdasdasd5", "qqq\xD0\x8Eqqq5", "ww\xD0\x8Eww5", "la\xD0\x8Elalala51", "la\xD0\x8Elala51", "lala51"],
+ ];
+
+ my $check = [];
+ for my $tuple (@$tuples) {
+ my $i = 0;
+ Encode::_utf8_on($tuple->[2+$i*3]), ++$i while @$tuple > 1+$i*3;
+
+ my $t = { zip @{[@$flds[0..($#$flds-1)]]}, @{[@$tuple[0..($#$flds-1)]]} };
+ my $l = $t->{$flds->[-1]} = [];
+
+ $i = 1;
+ push(@$l, { zip @$lflds, @{[@$tuple[(1+$i*3)..(1+$i*3+2)]]} }), ++$i while @$tuple > 1+$i*3;
+
+ push @$check, $t;
+ }
+
+
+ foreach my $tuple (@$tuples) {
+ cleanup $tuple->[0];
+ }
+
+ foreach my $i (0 .. $#$tuples) {
+ is_deeply [$box->Insert(@{$tuples->[$i]}, {want_inserted_tuple => 1})], [$check->[$i]], "flds/insert \'$tuples->[$i]->[0]\'";
+ }
+
+ is_deeply [$box->Select([[$tuples->[0]->[0]]])], [$check->[0]], 'select by primary_num1 index';
+
+ my $res;
+ is_deeply [$res=$box->Select([map {$_->[0]} @$tuples],{want=>'arrayref'})], [$check], 'select all';
+ # print $res->[0]->{f3}, "\n";
+ # print $check->[0]->{f3}, "\n";
+ ok $res->[$_]->{f3} eq $check->[$_]->{f3}, "utf8chk" for 0..$#$tuples;
+ ok $res->[$_]->{LL}->[0]->{l2} eq $check->[$_]->{LL}->[0]->{l2}, "utf8chklong" for 0..$#$tuples;
+
+ is_deeply [$box->UpdateMulti($tuples->[2]->[0],[ $flds->[3] => set => $tuples->[2]->[3] ],{want_updated_tuple => 1})], [$check->[2]], 'update1';
+ ok $box->UpdateMulti($tuples->[2]->[0],[ $flds->[3] => set => $tuples->[2]->[3] ]), 'update2';
+ is_deeply [$box->UpdateMulti($tuples->[2]->[0],[ 3 => set => $tuples->[2]->[3] ],{want_updated_tuple => 1})], [$check->[2]], 'update3';
+ ok $box->UpdateMulti($tuples->[2]->[0],[ 3 => set => $tuples->[2]->[3] ]), 'update4';
+ is_deeply [$box->UpdateMulti($tuples->[2]->[0],[ 6 => set => $tuples->[2]->[6] ],{want_updated_tuple => 1})], [$check->[2]], 'update5';
+ ok $box->UpdateMulti($tuples->[2]->[0],[ 6 => set => $tuples->[2]->[6] ]), 'update6';
+ is_deeply [$box->UpdateMulti($tuples->[2]->[0],[ [0,2] => set => $tuples->[2]->[6] ],{want_updated_tuple => 1})], [$check->[2]], 'update7';
+ ok $box->UpdateMulti($tuples->[2]->[0],[ [0,2] => set => $tuples->[2]->[6] ]), 'update8';
+ is_deeply [$box->UpdateMulti($tuples->[2]->[0],[ [0,'l3'] => set => $tuples->[2]->[6] ],{want_updated_tuple => 1})], [$check->[2]], 'update9';
+ ok $box->UpdateMulti($tuples->[2]->[0],[ [0,'l3'] => set => $tuples->[2]->[6] ]), 'update10';
+
+ is_deeply [$box->Delete($tuples->[$_]->[0],{want_deleted_tuple => 1})], [$check->[$_]], "delete$_" for 0..$#$tuples;
+};
+
+
+
+## Check u64 index
+# note, that u64 keys are emulated via pack('ll') since default ubuntu perl doesn't support pack('q')
+sub def_param_u64 {
+ my $format = '&&&&';
+ return { servers => $server,
+ spaces => [ {
+ indexes => [ {
+ index_name => 'id',
+ keys => [0],
+ } ],
+ space => 20,
+ format => $format,
+ default_index => 'id',
+ } ],
+ %opts,
+ }
+}
+
+$box = $CLASS->new(def_param_u64);
+ok $box->isa($CLASS), 'connect';
+
+$_->[0] = pack('ll', $_->[0], 0) foreach @$tuples;
+
+foreach my $tuple (@$tuples) {
+ cleanup $tuple->[0];
+}
+
+foreach my $tuple (@$tuples) {
+ ok $box->Insert(@$tuple), "unique_tree_index/insert \'$tuple->[0]\'";
+}
+
+is_deeply($tuples, [$box->Select([map $_->[0], @$tuples])], 'Select tuples');
+
+
+__END__
+
diff --git a/connector/perl/t/data/box.t.cfg b/connector/perl/t/data/box.t.cfg
new file mode 100644
index 0000000000..11ec7225e9
--- /dev/null
+++ b/connector/perl/t/data/box.t.cfg
@@ -0,0 +1,61 @@
+space[0].enabled = 1
+space[0].index[0].type = "HASH"
+space[0].index[0].unique = 1
+space[0].index[0].key_field[0].fieldno = 0
+space[0].index[0].key_field[0].type = "NUM"
+space[0].index[1].type = "HASH"
+space[0].index[1].unique = 1
+space[0].index[1].key_field[0].fieldno = 1
+space[0].index[1].key_field[0].type = "STR"
+
+space[20].enabled = 1
+space[20].index[0].type = "HASH"
+space[20].index[0].unique = 1
+space[20].index[0].key_field[0].fieldno = 0
+space[20].index[0].key_field[0].type = "NUM64"
+
+
+space[26].enabled = 1
+space[26].index[0].type = "HASH"
+space[26].index[0].unique = 1
+space[26].index[0].key_field[0].fieldno = 0
+space[26].index[0].key_field[0].type = "NUM"
+space[26].index[1].type = "TREE"
+space[26].index[1].unique = 0
+space[26].index[1].key_field[0].fieldno = 1
+space[26].index[1].key_field[0].type = "STR"
+space[26].index[2].type = "TREE"
+space[26].index[2].unique = 0
+space[26].index[2].key_field[0].fieldno = 1
+space[26].index[2].key_field[0].type = "STR"
+space[26].index[2].key_field[1].fieldno = 2
+space[26].index[2].key_field[1].type = "NUM"
+
+
+
+space[27].enabled = 1
+space[27].index[0].type = "HASH"
+space[27].index[0].unique = 1
+space[27].index[0].key_field[0].fieldno = 0
+space[27].index[0].key_field[0].type = "NUM"
+space[27].index[1].type = "HASH"
+space[27].index[1].unique = 1
+space[27].index[1].key_field[0].fieldno = 1
+space[27].index[1].key_field[0].type = "STR"
+
+space[27].index[2].type = "TREE"
+space[27].index[2].unique = 1
+space[27].index[2].key_field[0].fieldno = 2
+space[27].index[2].key_field[0].type = "STR"
+
+space[27].index[2].type = "TREE"
+space[27].index[2].unique = 1
+space[27].index[2].key_field[0].fieldno = 3
+space[27].index[2].key_field[0].type = "STR"
+
+space[27].index[3].type = "TREE"
+space[27].index[3].unique = 1
+space[27].index[3].key_field[0].fieldno = 2
+space[27].index[3].key_field[0].type = "STR"
+space[27].index[3].key_field[1].fieldno = 3
+space[27].index[3].key_field[1].type = "STR"
diff --git a/connector/perl/t/data/init.lua b/connector/perl/t/data/init.lua
index d5335b60df..91b47ad977 100644
--- a/connector/perl/t/data/init.lua
+++ b/connector/perl/t/data/init.lua
@@ -1,5 +1,14 @@
+function tst_server_name()
+ local tuple = box.select( 0, 0, box.pack('i', 1) )
+ if tuple == nil then
+ return { 'unknown' }
+ else
+ return { tuple[1] }
+ end
+end
+
function tst_sleep( )
-
+
local tuple = box.select( 0, 0, box.pack('i', 1) )
if tuple == nil then
return { 'unknown', '0.0' }
@@ -19,3 +28,25 @@ end
function tst_rand_init()
math.randomseed( os.time() )
end
+
+
+function tst_sleep_force( first_delay, second_delay )
+
+ local tuple = box.select( 0, 0, box.pack('i', 1) )
+ local name = tuple[1]
+ local delay = 10.0
+
+ if name == 'first' then
+ delay = first_delay
+ else
+ if name == 'second' then
+ delay = second_delay
+ else
+ return { 'unknown', '0.0', first_delay, second_delay }
+ end
+ end
+
+ box.fiber.sleep(delay)
+
+ return { name, string.format('%f', delay), first_delay, second_delay }
+end
--
GitLab