libdr-tarantool-perl-0.44/0000755000000000000000000000000012633764734014213 5ustar rootrootlibdr-tarantool-perl-0.44/Tarantool.xs0000644000000000000000000002337712633764555016547 0ustar rootroot/* vim: set ft=c */ /* Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "tp.h" #include "msgpuck.h" extern void _mpack_item(SV *res, SV *o); extern const char *_munpack_item(const char *p, size_t len, SV **res, HV *ext, int utf); #define PREALLOC_SCALAR_SIZE 0 inline static void hash_ssave(HV *h, const char *k, const char *v) { hv_store( h, k, strlen(k), newSVpvn( v, strlen(v) ), 0 ); } inline static void hash_scsave(HV *h, const char *k, SV *sv) { hv_store( h, k, strlen(k), sv, 0); } inline static void hash_isave(HV *h, const char *k, uint32_t v) { hv_store( h, k, strlen(k), newSViv( v ), 0 ); } static char * sv_resizer(struct tp *p, size_t req, size_t *size) { SV *sv = p->obj; STRLEN new_len = tp_size(p) + req; char *new_str = SvGROW(sv, new_len); if (!new_str) croak("Cannot allocate memory"); // SvCUR_set(sv, new_len); *size = new_len; return new_str; } inline static void tp_av_tuple(struct tp *req, AV *tuple) { int i; tp_tuple(req); for (i = 0; i <= av_len(tuple); i++) { SV *field = *av_fetch(tuple, i, 0); char *fd; STRLEN fl; fd = SvPV(field, fl); tp_field(req, fd, fl); } } inline static int fetch_tuples( HV * ret, struct tp * rep ) { AV * tuples = newAV(); hv_store( ret, "tuples", 6, newRV_noinc( ( SV * ) tuples ), 0 ); int code; while ( (code = tp_next(rep)) ) { if (code < 0) return code; AV * t = newAV(); av_push( tuples, newRV_noinc( ( SV * ) t ) ); while((code = tp_nextfield(rep))) { if (code < 0) return code; SV * f = newSVpvn( tp_getfield(rep), tp_getfieldsize(rep) ); av_push( t, f ); } } return 0; } #define ALLOC_RET_SV(__name, __ptr, __len, __size) \ SV *__name = newSVpvn("", 0); \ RETVAL = __name; \ if (__size) SvGROW(__name, __size); \ STRLEN __len; \ char *__ptr = SvPV(__name, __len); MODULE = DR::Tarantool PACKAGE = DR::Tarantool PROTOTYPES: ENABLE SV * _pkt_select( req_id, ns, idx, offset, limit, keys ) unsigned req_id unsigned ns unsigned idx unsigned offset unsigned limit AV * keys CODE: ALLOC_RET_SV(ret, b, len, PREALLOC_SCALAR_SIZE); int k; struct tp req; tp_init(&req, b, PREALLOC_SCALAR_SIZE, sv_resizer, ret); tp_select(&req, ns, idx, offset, limit); for (k = 0; k <= av_len(keys); k++) { SV *t = *av_fetch(keys, k, 0); if (!SvROK(t) || (SvTYPE(SvRV(t)) != SVt_PVAV)) croak("keys must be ARRAYREF of ARRAYREF"); tp_av_tuple(&req, (AV *)SvRV(t)); } tp_reqid(&req, req_id); SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL SV * _pkt_ping( req_id ) unsigned req_id CODE: ALLOC_RET_SV(ret, b, len, 0); struct tp req; tp_init(&req, b, len, sv_resizer, ret); tp_ping(&req); tp_reqid(&req, req_id); SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL SV * _pkt_insert( req_id, ns, flags, tuple ) unsigned req_id unsigned ns unsigned flags AV * tuple CODE: ALLOC_RET_SV(ret, b, len, PREALLOC_SCALAR_SIZE); struct tp req; tp_init(&req, b, PREALLOC_SCALAR_SIZE, sv_resizer, ret); tp_insert(&req, ns, flags); tp_av_tuple(&req, tuple); tp_reqid(&req, req_id); SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL SV * _pkt_delete( req_id, ns, flags, tuple ) unsigned req_id unsigned ns unsigned flags AV *tuple CODE: ALLOC_RET_SV(ret, b, len, PREALLOC_SCALAR_SIZE); struct tp req; tp_init(&req, b, PREALLOC_SCALAR_SIZE, sv_resizer, ret); tp_delete(&req, ns, flags); tp_av_tuple(&req, tuple); tp_reqid(&req, req_id); SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL SV * _pkt_call_lua( req_id, flags, proc, tuple ) unsigned req_id unsigned flags SV *proc AV *tuple CODE: STRLEN name_len; char *name = SvPV(proc, name_len); ALLOC_RET_SV(ret, b, len, PREALLOC_SCALAR_SIZE); struct tp req; tp_init(&req, b, PREALLOC_SCALAR_SIZE, sv_resizer, ret); tp_call(&req, flags, name, name_len); tp_av_tuple(&req, tuple); tp_reqid(&req, req_id); SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL SV * _pkt_update( req_id, ns, flags, tuple, operations ) unsigned req_id unsigned ns unsigned flags AV *tuple AV *operations CODE: ALLOC_RET_SV(ret, b, len, PREALLOC_SCALAR_SIZE); struct tp req; int i; tp_init(&req, b, PREALLOC_SCALAR_SIZE, sv_resizer, ret); tp_update(&req, ns, flags); tp_reqid(&req, req_id); tp_av_tuple(&req, tuple); tp_updatebegin(&req); for (i = 0; i <= av_len( operations ); i++) { uint8_t opcode; SV *op = *av_fetch( operations, i, 0 ); if (!SvROK(op) || SvTYPE( SvRV(op) ) != SVt_PVAV) croak("Wrong update operation format"); AV *aop = (AV *)SvRV(op); int asize = av_len( aop ) + 1; if ( asize < 2 ) croak("Too short operation argument list"); unsigned fno = SvIV( *av_fetch( aop, 0, 0 ) ); STRLEN size; char *opname = SvPV( *av_fetch( aop, 1, 0 ), size ); /* delete */ if ( strcmp(opname, "delete") == 0 ) { tp_op(&req, fno, TP_OPDELETE, "", 0); continue; } if (asize < 3) croak("Too short operation argument list"); /* assign */ if ( strcmp(opname, "set") == 0 ) { char *data = SvPV( *av_fetch( aop, 2, 0 ), size ); tp_op(&req, fno, TP_OPSET, data, size); continue; } /* insert */ if ( strcmp(opname, "insert") == 0 ) { char *data = SvPV( *av_fetch( aop, 2, 0 ), size ); tp_op(&req, fno, TP_OPINSERT, data, size); continue; } /* arithmetic operations */ if ( strcmp(opname, "add") == 0 ) { opcode = TP_OPADD; goto ARITH; } if ( strcmp(opname, "and") == 0 ) { opcode = TP_OPAND; goto ARITH; } if ( strcmp(opname, "or") == 0 ) { opcode = TP_OPOR; goto ARITH; } if ( strcmp(opname, "xor") == 0 ) { opcode = TP_OPXOR; goto ARITH; } /* substr */ if ( strcmp(opname, "substr") == 0 ) { if (asize < 4) croak("Too short argument " "list for substr"); unsigned offset = SvIV( *av_fetch( aop, 2, 0 ) ); unsigned length = SvIV( *av_fetch( aop, 3, 0 ) ); char * data; if ( asize > 4 && SvOK( *av_fetch( aop, 4, 0 ) ) ) { data = SvPV( *av_fetch( aop, 4, 0 ), size ); } else { data = ""; size = 0; } tp_opsplice(&req, fno, offset, length, data, size); continue; } /* unknown command */ croak("unknown update operation: `%s'", opname); ARITH: { char *data = SvPV( *av_fetch( aop, 2, 0 ), size ); if (sizeof(unsigned long long) < size) size = sizeof(unsigned long long); tp_op(&req, fno, opcode, data, size); continue; } } SvCUR_set(ret, tp_used(&req)); OUTPUT: RETVAL HV * _pkt_parse_response( response ) SV *response INIT: RETVAL = newHV(); sv_2mortal((SV *)RETVAL); CODE: /* asm("break"); */ if ( !SvOK(response) ) croak( "response is undefined" ); STRLEN size; char *data = SvPV( response, size ); struct tp rep; tp_init(&rep, data, size, NULL, 0); // tp_use(&rep, size); ssize_t code = tp_reply(&rep); if (code == -1) { hash_ssave(RETVAL, "status", "buffer"); hash_ssave(RETVAL, "errstr", "Input data too short"); } else if (code >= 0) { uint32_t type = tp_replyop(&rep); hash_isave(RETVAL, "code", tp_replycode(&rep) ); hash_isave(RETVAL, "req_id", tp_getreqid(&rep) ); hash_isave(RETVAL, "type", type ); hash_isave(RETVAL, "count", tp_replycount(&rep) ); if (code == 0) { if (type != TP_PING) code = fetch_tuples(RETVAL, &rep); if (code != 0) { hash_ssave(RETVAL, "status", "buffer"); hash_ssave(RETVAL, "errstr", "Broken response"); } else { hash_ssave(RETVAL, "status", "ok"); } } else { hash_ssave(RETVAL, "status", "error"); size_t el = tp_replyerrorlen(&rep); SV *err; if (el) { char *s = tp_replyerror(&rep); if (s[el - 1] == 0) el--; err = newSVpvn(s, el); } else { err = newSVpvn("", 0); } hash_scsave(RETVAL, "errstr", err); } } OUTPUT: RETVAL unsigned TNT_PING() CODE: RETVAL = TP_PING; OUTPUT: RETVAL unsigned TNT_CALL() CODE: RETVAL = TP_CALL; OUTPUT: RETVAL unsigned TNT_INSERT() CODE: RETVAL = TP_INSERT; OUTPUT: RETVAL unsigned TNT_UPDATE() CODE: RETVAL = TP_UPDATE; OUTPUT: RETVAL unsigned TNT_DELETE() CODE: RETVAL = TP_DELETE; OUTPUT: RETVAL unsigned TNT_SELECT() CODE: RETVAL = TP_SELECT; OUTPUT: RETVAL unsigned TNT_FLAG_RETURN() CODE: RETVAL = TP_BOX_RETURN_TUPLE; OUTPUT: RETVAL unsigned TNT_FLAG_ADD() CODE: RETVAL = TP_BOX_ADD; OUTPUT: RETVAL unsigned TNT_FLAG_REPLACE() CODE: RETVAL = TP_BOX_REPLACE; OUTPUT: RETVAL SV * _msgpack(o) SV *o CODE: SV *res = newSVpvn("", 0); RETVAL = res; _mpack_item(res, o); OUTPUT: RETVAL SV * _msgunpack(str, utf) SV *str; SV *utf; PROTOTYPE: $$ CODE: SV *sv = 0; size_t len; const char *s = SvPV(str, len); if (items > 1) _munpack_item(s, len, &sv, (HV *)ST(1), SvIV(utf)); else _munpack_item(s, len, &sv, NULL, SvIV(utf)); RETVAL = sv; OUTPUT: RETVAL size_t _msgcheck(str) SV *str PROTOTYPE: $ CODE: size_t len; if (SvOK(str)) { const char *p = SvPV(str, len); if (len > 0) { const char *pe = p + len; const char *begin = p; if (mp_check(&p, pe) == 0) { RETVAL = p - begin; } else { RETVAL = 0; } } else { RETVAL = 0; } } else { RETVAL = 0; } OUTPUT: RETVAL libdr-tarantool-perl-0.44/t/0000775000000000000000000000000012414725705014450 5ustar rootrootlibdr-tarantool-perl-0.44/t/080-tarantool.t0000644000000000000000000001200012414721722017127 0ustar rootroot#!/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 constant PLAN => 33; use Encode qw(decode encode); BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':all'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::SyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'INT', }, { name => 'password', type => 'STR', }, { name => 'balance', type => 'MONEY', } ], indexes => { 0 => 'id', 1 => 'name', 2 => [ 'key', 'password' ], }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 9; } my $client = tarantool( port => $tnt->primary_port, spaces => $spaces ); isa_ok $client => 'DR::Tarantool::SyncClient'; ok $client->ping, '* tarantool ping'; my $t = $client->insert( first_space => [1, 'привет', 11, 'password', '1.23'], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->balance, '1.23', 'money(1.23)'; is $t->key, 11, 'key(11)'; $t = $client->update(first_space => 1 => [ [ balance => add => '1.12' ], [ key => add => 101 ], ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->balance, '2.35', 'money(2.35)'; is $t->key, 112, 'key(112)'; $t = $client->update(first_space => 1 => [ [ balance => add => '-3.17' ], [ key => add => -222 ], ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->balance, '-0.82', 'money(-0.82)'; is $t->key, -110, 'key(-110)'; # second key $t = $client->insert( first_space => [2, 'привет2', -121, 'password2', '-2.34'], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->key, '-121', 'key(-121)'; is $t->balance, '-2.34', 'money(-2.34)'; $t = $client->update(first_space => 2 => [ [ balance => add => '-1.12' ], [ key => add => -101 ], ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->key, '-222', 'key(-222)'; is $t->balance, '-3.46', 'money(-3.46)'; $t = $client->update(first_space => 2 => [ [ balance => add => '5.17' ], [ key => add => 777 ], ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple'; is $t->key, '555', 'key(555)'; is $t->balance, '1.71', 'money(1.71)'; # connect for my $cv (condvar AnyEvent) { DR::Tarantool::AsyncClient->connect( port => $tnt->primary_port, reconnect_period => 0.1, spaces => $spaces, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } unless ( isa_ok $client => 'DR::Tarantool::AsyncClient' ) { diag eval { decode utf8 => $client } || $client; last; } # ping for my $cv (condvar AnyEvent) { $client->ping( sub { my ($status) = @_; is $status, 'ok', '* async_tarantool ping'; $cv->send; } ); $cv->recv; } eval "require Coro"; skip "Coro isn't installed", 2 if $@; $client = coro_tarantool port => $tnt->primary_port, spaces => $spaces ; isa_ok $client => 'DR::Tarantool::CoroClient'; ok $client->ping, '* coro_tarantool ping'; } libdr-tarantool-perl-0.44/t/030-spaces.t0000644000000000000000000002734112347544137016423 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 149; use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::Spaces'; } use constant MODEL => 'DR::Tarantool::Spaces'; ok !eval { MODEL->new('abc') }, 'wrong arguments'; like $@, qr{HASHREF}, 'error message'; ok !eval { MODEL->new({a => 1}) }, 'wrong arguments'; like $@, qr{space number}, 'error message'; ok MODEL->new(), 'empty spaces'; my $s = MODEL->new({ 0 => { name => 'test', default_type => 'NUM', fields => [ qw(a b c), { type => 'UTF8STR', name => 'd' }, { type => 'NUM', name => 'a123', }, { type => 'STR', name => 'abcd', }, { type => 'INT', name => 'int', }, { type => 'MONEY', name => 'money', } ], indexes => { 0 => [ qw(a b) ], 1 => 'd', 2 => 'c', 3 => { name => 'abc', fields => [ qw(a b c) ] } } }, 1 => { name => 'json', fields => [ { name => 'f', type => 'JSON', } ], indexes => {} } }); is $s->family, 1, 'default family'; is $s->family(2), 2, 'change family'; is $s->space('test')->family, 2, 'space changed family'; is $s->family(1), 1, 'change again'; is $s->space('test')->family, 1, 'space changed family again'; is eval { $s->space('test')->index_number}, undef, 'index_number: undefined'; like $@, qr{name is undefined}, 'error string'; is eval { $s->space('test')->index_number('aaaaa') }, undef, 'index_number: not found'; like $@, qr{index.*is undefined}, 'error string'; is $s->space_number('test'), 0, 'space_number(test)'; is $s->space_number('json'), 1, 'space_number(json)'; is eval { $s->space_number; 1}, undef, 'space_number()'; like $@, qr{space name or number is not defined}, 'error string'; is $s->space('test')->index_number('i0'), 0, 'index_number: i0'; is $s->space('test')->index_number('abc'), 3, 'index_number: i3'; is $s->space('test')->index_name(0), 'i0', 'index_name: i0'; is $s->space('test')->index_name(3), 'abc', 'index_name: i3'; is $s->space('test')->field_number('a'), 0, 'field_number(a)'; is $s->space('test')->field_number('b'), 1, 'field_number(b)'; is $s->space('test')->field_number('c'), 2, 'field_number(c)'; is eval { $s->space('test')->field_number('unknown'); 1 }, undef, 'field_number(unknown)'; like $@, qr{Can't find field 'unknown' in this space}, 'error message'; is $s->space('test')->tail_index, 8, 'space0->tail_index'; is $s->space('json')->tail_index, 1, 'space1->tail_index'; my $class = $s->space('test')->tuple_class; can_ok $class, qw(a b c d a123 abcd int money); $class = $s->space('test')->tuple_class; can_ok $class, qw(a b c d a123 abcd int money); $class = $s->space('json')->tuple_class; can_ok $class, qw(f); $class = $s->space('json')->tuple_class; can_ok $class, qw(f); my $v = unpack "L$LE", $s->pack_field( test => a => '10' ); is $v, 10, 'pack_field NUM'; $v = unpack "L$LE", $s->pack_field( test => 0 => 11 ); is $v, 11, 'pack_field NUM'; $v = unpack "L$LE", $s->pack_field( 0 => 0 => 13 ); is $v, 13, 'pack_field NUM'; $v = unpack "L$LE", $s->pack_field( test => a123 => 13 ); is $v, 13, 'pack_field NUM64'; $v = $s->pack_field( test => d => 'test' ); is $v, 'test', 'pack_field STR'; $v = decode utf8 => $s->pack_field( test => d => 'привет' ); is $v, 'привет', 'pack_field STR'; $v = unpack "l$LE" => $s->pack_field( test => int => -10 ); is $v, -10, 'pack_field INT'; $v = decode utf8 => $s->pack_field( test => d => encode utf8 => 'привет' ); is $v, 'привет', 'pack_field STR'; # money $v = unpack "l$LE" => $s->pack_field( test => money => '123'); is $v, 12300, 'pack_field MONEY(123)'; $v = unpack "l$LE" => $s->pack_field( test => money => '-123'); is $v, -12300, 'pack_field MONEY(-123)'; $v = unpack "l$LE" => $s->pack_field( test => money => '.123'); is $v, 12, 'pack_field MONEY(.12)'; $v = unpack "l$LE" => $s->pack_field( test => money => '0'); is $v, 0, 'pack_field MONEY(0)'; $v = unpack "l$LE" => $s->pack_field( test => money => '12345.21'); is $v, 1234521, 'pack_field MONEY(12345.21)'; $v = unpack "l$LE" => $s->pack_field( test => money => '12345.2'); is $v, 1234520, 'pack_field MONEY(12345.20)'; $v = unpack "l$LE" => $s->pack_field( test => money => '-12345.21'); is $v, -1234521, 'pack_field MONEY(-12345.21)'; $v = $s->unpack_field( test => a => pack "L$LE" => 14); is $v, 14, 'unpack_field NUM'; $v = $s->unpack_field( test => int => pack "l$LE" => -14); is $v, -14, 'unpack_field INT'; $v = $s->unpack_field( test => 0 => pack "L$LE" => 14); is $v, 14, 'unpack_field NUM'; $v = $s->unpack_field( 0 => 0 => pack "L$LE" => 14); is $v, 14, 'unpack_field NUM'; $v = $s->unpack_field( 0 => 'abcd' => 'test'); is $v, 'test', 'unpack_field STR'; $v = $s->unpack_field( 0 => 'abcd' => 'привет'); is $v, encode(utf8 => 'привет'), 'unpack_field STR'; $v = $s->unpack_field( 0 => 'd' => 'привет'); is $v, 'привет', 'unpack_field STR'; $v = $s->unpack_field( test => money => pack "l$LE" => 12345); is $v, 123.45, 'unpack_field MONEY(123.45)'; $v = $s->unpack_field( test => money => pack "l$LE" => 0); is $v, '0.00', 'unpack_field MONEY(0)'; $v = $s->unpack_field( test => money => pack "l$LE" => -1234); is $v, '-12.34', 'unpack_field MONEY(-12.34)'; $v = $s->unpack_field( test => money => pack "l$LE" => 4); is $v, '0.04', 'unpack_field MONEY(0.04)'; my $tt = [0, 1, 2, 'медвед', 10, 'test']; my $t = $s->pack_tuple(test => $tt); isa_ok $t => 'ARRAY'; my $ut = $s->unpack_tuple(0 => $t); isa_ok $ut => 'ARRAY'; cmp_ok join(':', @$tt), 'eq', join(':', @$ut), 'unpacked packed tuple'; is unpack("L$LE", $t->[0]), 0, 'tuple[0]'; is unpack("L$LE", $t->[1]), 1, 'tuple[1]'; is unpack("L$LE", $t->[2]), 2, 'tuple[2]'; is $t->[3], encode(utf8 => 'медвед'), 'tuple[3]'; is unpack("L$LE", $t->[4]), 10, 'tuple[4]'; is $t->[5], 'test', 'tuple[5]'; # indexes { my $w; local $SIG{__WARN__} = sub { $w = $_[0] }; $t = $s->space('test')->pack_keys([1, 2], 'i0'); like $w => qr{Ambiguous keys list}, 'ambiguous keys warning'; cmp_ok join(':', @{ $t->[0] }), 'eq', join(':', pack("L$LE", 1), pack "L$LE", 2), 'pack_keys'; undef $w; $t = $s->space('test')->pack_keys([[2, 3]], 'i0'); cmp_ok join(':', @{ $t->[0] }), 'eq', join(':', pack("L$LE", 2), pack "L$LE", 3), 'pack_keys'; is $w, undef, 'there was no ambiguous warning'; } $t = eval { $s->space('test')->pack_keys([[1, 2, 3]], 'i0'); }; like $@, qr{must have 2}, 'error message'; is $t, undef, 'wrong elements count'; { my $w; local $SIG{__WARN__} = sub { $w = $_[0] }; $t = $s->space('test')->pack_keys([2, 3], 0); like $w => qr{Ambiguous keys list}, 'ambiguous keys warning'; cmp_ok join(':', @{ $t->[0] }), 'eq', join(':', pack("L$LE", 2), pack "L$LE", 3), 'pack_keys'; undef $w; $t = $s->space('test')->pack_keys([[2, 3]], 0); cmp_ok join(':', @{ $t->[0] }), 'eq', join(':', pack("L$LE", 2), pack "L$LE", 3), 'pack_keys'; is $w, undef, 'there was no ambiguous warning'; } $t = eval { $s->space('test')->pack_keys([[1,2,3]], 0); }; like $@, qr{must have 2}, 'error message'; is $t, undef, 'wrong elements count'; $t = $s->space('test')->pack_keys(4, 'i2'); is unpack("L$LE", $t->[0][0]), 4, 'pack_keys'; $t = $s->space('test')->pack_keys([5], 'i2'); is unpack("L$LE", $t->[0][0]), 5, 'pack_keys'; $t = $s->space('test')->pack_keys([[6]], 'i2'); is unpack("L$LE", $t->[0][0]), 6, 'pack_keys'; $t = $s->space('test')->pack_keys([7,8,9], 'i2'); is unpack("L$LE", $t->[0][0]), 7, 'pack_keys'; is unpack("L$LE", $t->[1][0]), 8, 'pack_keys'; is unpack("L$LE", $t->[2][0]), 9, 'pack_keys'; $t = eval { $s->space('test')->pack_keys([[7,8,9]], 'i2') }; like $@, qr{must have 1}, 'error message'; # pack_operation my $op = $s->space('test')->pack_operation([d => 'delete']); is $op->[0], 3, '* operation field'; is $op->[1], 'delete', 'operation name'; for (qw(insert add and or xor set)) { my $n = int rand 100000; $op = $s->space('test')->pack_operation([a123 => $_ => $n]); is $op->[0], 4, "operation field: $_"; is $op->[1], $_, 'operation name'; is unpack("L$LE", $op->[2]), $n, 'operation argument'; } $op = $s->space('test')->pack_operation([d => 'substr', 1, 2]); is $op->[0], 3, 'operation field: substr'; is $op->[1], 'substr', 'operation name'; is $op->[2], 1, 'operation argument 1'; is $op->[3], 2, 'operation argument 2'; is $op->[4], undef, 'operation argument 3'; $op = $s->space('test')->pack_operation([d => 'substr', 231, 232, 'привет']); is $op->[0], 3, 'operation field: substr'; is $op->[1], 'substr', 'operation name'; is $op->[2], 231, 'operation argument 1'; is $op->[3], 232, 'operation argument 2'; is $op->[4], 'привет', 'operation argument 3'; $op = $s->space('test')->pack_operations([ d => set => 'тест']); is $op->[0][0], 3, "operation field: set"; is $op->[0][1], 'set', 'operation name'; is decode(utf8 => $op->[0][2]), 'тест', 'operation argument'; $op = $s->space('test')->pack_operations([ [ d => set => 'тест'], [1 => insert => 500] ]); is $op->[0][0], 3, "operation field: set"; is $op->[0][1], 'set', 'operation name'; is decode(utf8 => $op->[0][2]), 'тест', 'operation argument'; is $op->[1][0], 1, "operation field: set"; is $op->[1][1], 'insert', 'operation name'; is unpack("L$LE", $op->[1][2]), 500, 'operation argument'; $op = $s->pack_field(json => f => undef); is $op, 'null', 'pack json: undef'; is $s->unpack_field(json => f => $op), undef, 'unpack json: undef'; $op = $s->pack_field(json => f => 123); is $op, '123', 'pack json: scalar'; is $s->unpack_field(json => f => $op), 123, 'unpack json: scalar'; $op = $s->pack_field(json => f => []); is $op, '[]', 'pack json: empty array'; isa_ok $s->unpack_field(json => f => $op) => 'ARRAY', 'unpack json: empty array'; $op = $s->pack_field(json => f => {}); is $op, '{}', 'pack json: empty hash'; isa_ok $s->unpack_field(json => f => $op) => 'HASH', 'unpack json: empty hash'; $op = $s->pack_field(json => f => [qw(hello world)]); is decode(utf8 => $op), '["hello","world"]', 'pack json: array'; $op = $s->unpack_field(json => f => $op); isa_ok $op => 'ARRAY', 'unpack json: array'; is $op->[0], 'hello', 'first element'; is $op->[1], 'world', 'second element'; $op = $s->pack_field(json => f => [qw(привет медвед)]); is decode(utf8 => $op), '["привет","медвед"]', 'pack json: array'; $op = $s->unpack_field(json => f => $op); isa_ok $op => 'ARRAY', 'unpack json: array'; is $op->[0], 'привет', 'first utf8 element'; is $op->[1], 'медвед', 'second utf8 element'; $op = $s->pack_field(json => f => {qw(hello world)}); is decode(utf8 => $op), '{"hello":"world"}', 'pack json: hash'; $op = $s->unpack_field(json => f => $op); isa_ok $op => 'HASH', 'unpack json: hash'; is $op->{hello}, 'world', 'key element'; $op = $s->pack_field(json => f => {qw(привет медвед)}); is decode(utf8 => $op), '{"привет":"медвед"}', 'pack json: hash'; $op = $s->unpack_field(json => f => $op); isa_ok $op => 'HASH', 'unpack json: hash'; is $op->{привет}, 'медвед', 'key utf8 element'; libdr-tarantool-perl-0.44/t/090-parallel-requests.t0000644000000000000000000001014212414722036020576 0ustar rootroot#!/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); BEGIN { use constant PLAN => 48; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::AsyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $script_dir = catfile dirname(__FILE__), 'test-data'; my $lua_file = catfile $script_dir, 'init.lua'; ok -d $script_dir, "-d $script_dir"; ok -r $lua_file, "-r $lua_file"; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg, script_dir => $script_dir ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', } ], indexes => { 0 => 'id', 1 => 'name', 2 => { name => 'tidx', fields => [ 'key', 'password' ] }, }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 11; } my $client; # connect for my $cv (condvar AnyEvent) { DR::Tarantool::AsyncClient->connect( port => $tnt->primary_port, reconnect_period => 0.1, spaces => $spaces, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } unless ( isa_ok $client => 'DR::Tarantool::AsyncClient' ) { diag eval { decode utf8 => $client } || $client; last; } for my $cv (AE::cv) { $cv->begin; $client->call_lua(test_parallel => [ 0.1, 151274 ], sub { my ($ok, $tuple, $error) = @_; diag $error unless is $ok, 'ok', "first call test_parallel: status"; is $tuple->raw(0), 151274, 'return value'; $cv->end; }); $cv->recv; } for my $cv (AE::cv) { my $started = AnyEvent::now; my $max = 0; for my $i ( 0 .. 10 ) { my $period = .8 * rand; $period = substr $period, 0, 5 unless length($period) < 5; $cv->begin; $client->call_lua(test_parallel => [ $period, $i ], sub { my ($ok, $tuple, $error) = @_; my $done_time = AnyEvent::now; $done_time -= $started; my $res = $tuple->raw(0); is $i, $res, 'id: ' . $res; cmp_ok $done_time, '>=', $period, 'delay minimum'; cmp_ok $done_time, '<', $period + .1, 'delay maximum'; $max = $done_time if $max < $done_time; $cv->end; }); } $cv->recv; my $total_time = AnyEvent::now() - $started; cmp_ok $max, '<=', $total_time, 'total time'; cmp_ok $total_time, '<=', 1, 'total time less than 1 second'; } } libdr-tarantool-perl-0.44/t/060-sync-client.t0000644000000000000000000001355312414721445017372 0ustar rootroot#!/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 constant PLAN => 57; use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::SyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', }, { name => 'json', type => 'JSON', } ], indexes => { 0 => 'id', 1 => 'name', 2 => [ 'key', 'password' ], }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 9; } my $client = DR::Tarantool::SyncClient->connect( port => $tnt->primary_port, spaces => $spaces ); isa_ok $client => 'DR::Tarantool::SyncClient'; is $client->last_code, undef, 'last_code'; is $client->last_error_string, undef, 'last_error_string'; ok $client->ping, '* ping'; my $t = $client->insert( first_space => [ 1, 'привет', 2, 'test' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', '* insert tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->insert( first_space => [ 2, 'медвед', 3, 'test2' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'insert tuple packed'; is $t->id, 2, 'id'; is $t->name, 'медвед', 'name'; is $t->key, 3, 'key'; is $t->password, 'test2', 'password'; $t = $client->call_lua('box.select' => [ 0, 0, pack "L$LE" => 1 ], 'first_space'); isa_ok $t => 'DR::Tarantool::Tuple', '* call tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 1); isa_ok $t => 'DR::Tarantool::Tuple', '* select tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 'привет', 'i1'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i1)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => [[2, 'test']], 'i2'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i2)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->update(first_space => 2 => [ name => set => 'привет1' ]); is $t, undef, '* update without flags'; $t = $client->update( first_space => 2 => [ name => set => 'привет медвед' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'update with flags'; is $t->name, 'привет медвед', '$t->name'; $t = $client->insert(first_space => [1, 2, 3, 4, undef], TNT_FLAG_RETURN); is $t->json, undef, 'JSON insert: undef'; $t = $client->insert(first_space => [1, 2, 3, 4, 22], TNT_FLAG_RETURN); is $t->json, 22, 'JSON insert: scalar'; $t = $client->insert(first_space => [1, 2, 3, 4, 'тест'], TNT_FLAG_RETURN); is $t->json, 'тест', 'JSON insert: utf8 scalar'; $t = $client->insert( first_space => [ 1, 2, 3, 4, { a => 'b' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{a}, 'b', 'JSON insert: hash value'; ok !eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'raise error'; like $@, qr{Duplicate key exists|Tuple already exists}, 'error message'; { local $client->{raise_error}; ok eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'no raise error'; like $client->last_error_string, qr{Duplicate key exists|Tuple already exists}, 'error message'; } $t = $client->insert( first_space => [ 1, 2, 3, 4, { привет => 'медвед' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{привет}, 'медвед', 'JSON insert: hash utf8 value'; } libdr-tarantool-perl-0.44/t/110-netsplit-readahead.t0000644000000000000000000001062012414722116020660 0ustar rootroot#!/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); BEGIN { use constant PLAN => 31; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::AsyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $script_dir = catfile dirname(__FILE__), 'test-data'; my $lua_file = catfile $script_dir, 'init.lua'; ok -d $script_dir, "-d $script_dir"; ok -r $lua_file, "-r $lua_file"; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg, script_dir => $script_dir, readahead => 1024000, ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', } ], indexes => { 0 => 'id', 1 => 'name', 2 => { name => 'tidx', fields => [ 'key', 'password' ] }, }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 11; } my $client; # connect for my $cv (condvar AnyEvent) { DR::Tarantool::AsyncClient->connect( port => $tnt->primary_port, reconnect_period => 0.1, spaces => $spaces, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } unless ( isa_ok $client => 'DR::Tarantool::AsyncClient' ) { diag eval { decode utf8 => $client } || $client; last; } for my $cv (AE::cv) { $cv->begin; $client->call_lua(test_parallel_big_tuple => [ 0.1, 151274 ], sub { my ($ok, $tuple, $error) = @_; diag $error unless is $ok, 'ok', "first call test_parallel: status"; is $tuple->raw(0), 151274, 'return value'; $cv->end; }); $cv->recv; } for my $cv (AE::cv) { my $started = AnyEvent::now; my $max = 0; for my $i ( 0 .. 3 ) { my $period = 0.5 * rand; $period = substr $period, 0, 5 unless length($period) < 5; $cv->begin; my @tuple = map { rand } 0 .. 2000 + int rand 300; my $tlen = 0; $tlen += length $_ for @tuple; $client->call_lua(test_parallel_big_tuple => [ $period, $i, @tuple ], sub { my ($ok, $tuple, $error) = @_; my $done_time = AnyEvent::now; $done_time -= $started; my $res = $tuple->raw(0); is $i, $res, 'id: ' . $res; cmp_ok $done_time, '>=', $period, 'delay minimum'; cmp_ok $done_time, '<', $period + .2, 'delay maximum'; $max = $done_time if $max < $done_time; is $tuple->raw(1), $tlen, 'Length of tuple'; $cv->end; }); } $cv->recv; my $total_time = AnyEvent::now() - $started; cmp_ok $max, '<=', $total_time, 'total time'; cmp_ok $total_time, '<=', 1, 'total time less than 1 second'; } } libdr-tarantool-perl-0.44/t/070-coro-client.t0000644000000000000000000001537012414721612017354 0ustar rootroot#!/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); my $LE = $] > 5.01 ? '<' : ''; use constant PLAN => 100; use Test::More; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { eval "use Coro"; plan skip_all => "Coro isn't installed" if $@; plan tests => PLAN; } } use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':constant'; use_ok 'DR::Tarantool::CoroClient'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'Coro'; use_ok 'AnyEvent'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', }, { name => 'json', type => 'JSON', } ], indexes => { 0 => 'id', 1 => 'name', 2 => [ 'key', 'password' ], }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 9; } my $client = DR::Tarantool::CoroClient->connect( port => $tnt->primary_port, spaces => $spaces ); isa_ok $client => 'DR::Tarantool::CoroClient'; is $client->last_code, undef, 'last_code'; is $client->last_error_string, undef, 'last_error_string'; ok $client->ping, '* ping'; my $t = $client->insert( first_space => [ 1, 'привет', 2, 'test' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', '* insert tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->insert( first_space => [ 2, 'медвед', 3, 'test2' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'insert tuple packed'; is $t->id, 2, 'id'; is $t->name, 'медвед', 'name'; is $t->key, 3, 'key'; is $t->password, 'test2', 'password'; $t = $client->call_lua('box.select' => [ 0, 0, pack "L$LE" => 1 ], 'first_space'); isa_ok $t => 'DR::Tarantool::Tuple', '* call tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 1); isa_ok $t => 'DR::Tarantool::Tuple', '* select tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 'привет', 'i1'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i1)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => [[2, 'test']], 'i2'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i2)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->update(first_space => 2 => [ name => set => 'привет1' ]); is $t, undef, '* update without flags'; $t = $client->update( first_space => 2 => [ name => set => 'привет медвед' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'update with flags'; is $t->name, 'привет медвед', '$t->name'; $t = $client->insert(first_space => [1, 2, 3, 4, undef], TNT_FLAG_RETURN); is $t->json, undef, 'JSON insert: undef'; $t = $client->insert(first_space => [1, 2, 3, 4, 22], TNT_FLAG_RETURN); is $t->json, 22, 'JSON insert: scalar'; $t = $client->insert(first_space => [1, 2, 3, 4, 'тест'], TNT_FLAG_RETURN); is $t->json, 'тест', 'JSON insert: utf8 scalar'; $t = $client->insert( first_space => [ 1, 2, 3, 4, { a => 'b' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{a}, 'b', 'JSON insert: hash value'; $t = $client->insert( first_space => [ 1, 2, 3, 4, { привет => 'медвед' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{привет}, 'медвед', 'JSON insert: hash utf8 value'; ok !eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'raise error'; like $@, qr{Duplicate key exists|Tuple already exists}, 'error message'; { local $client->{raise_error}; ok eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'no raise error'; like $client->last_error_string, qr{Duplicate key exists|Tuple already exists}, 'error message'; } my $start = AnyEvent::now; my (@fibers, %tuples); for my $n (123 .. 129) { push @fibers => async { Coro::AnyEvent::sleep(rand); $tuples{ $n } = $client->insert( 'first_space', [ $n, "тест $n", $n, "password $n" ], TNT_FLAG_RETURN ) ; }; } $_->join for @fibers; cmp_ok AnyEvent::now() - $start, '<', '2', 'all processes were done async'; for my $n (123 .. 129) { ok exists $tuples{$n}, 'result exists'; isa_ok $tuples{$n} => 'DR::Tarantool::Tuple'; is $tuples{$n}->id, $n, 'id'; is $tuples{$n}->name, "тест $n", 'name'; is $tuples{$n}->key, $n, 'key'; is $tuples{$n}->password, "password $n", 'password'; } } libdr-tarantool-perl-0.44/t/test-data/0000775000000000000000000000000012331722764016336 5ustar rootrootlibdr-tarantool-perl-0.44/t/test-data/00019-000-ok.bin0000644000000000000000000000005512123045772020377 0ustar rootroot!abcdeflibdr-tarantool-perl-0.44/t/test-data/llc-easy.cfg0000644000000000000000000000243612123045772020527 0ustar rootroot# # Limit of memory used to store tuples to 100MB # (0.1 GB) # This effectively limits the memory, used by # Tarantool. However, index and connection memory # is stored outside the slab allocator, hence # the effective memory usage can be higher (sometimes # twice as high). # slab_alloc_arena = 0.1 # # Read only and read-write port. primary_port = 33013 # Read-only port. secondary_port = 33014 # # The port for administrative commands. # admin_port = 33015 # # Each write ahead log contains this many rows. # When the limit is reached, Tarantool closes # the WAL and starts a new one. rows_per_wal = 50000 # Define a simple space with 1 HASH-based # primary key. 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 = "TREE" space[0].index[1].unique = 0 space[0].index[1].key_field[0].fieldno = 1 space[0].index[1].key_field[0].type = "STR" space[0].index[2].type = "TREE" space[0].index[2].unique = 0 space[0].index[2].key_field[0].fieldno = 2 space[0].index[2].key_field[0].type = "NUM" space[1].enabled = 1 space[1].index[0].type = "HASH" space[1].index[0].unique = 1 space[1].index[0].key_field[0].fieldno = 0 space[1].index[0].key_field[0].type = "STR" libdr-tarantool-perl-0.44/t/test-data/00013-14082-error.bin0000644000000000000000000000004512123045772021267 0ustar rootroot 7Tuple already existslibdr-tarantool-perl-0.44/t/test-data/init.lua0000644000000000000000000000101112331722764017773 0ustar rootrootfunction test_parallel(delay, id) box.fiber.sleep(delay) return id end function test_parallel_big_tuple(delay, id, ...) local args = { ... } local size = 0 for i, v in pairs(args) do size = size + string.len(v) end box.fiber.sleep(delay) return { id, tostring(size) } end function test_return_one() return { 'one' } end function test_return(...) return { ... } end function sleep_and_return(sleep, retval) box.fiber.sleep(tonumber(sleep)) return retval end libdr-tarantool-perl-0.44/t/test-data/00022-000-ok.bin0000644000000000000000000000005512123045772020371 0ustar rootroot!V abcdeflibdr-tarantool-perl-0.44/t/test-data/llc-easy2.cfg0000644000000000000000000000234112123045772020604 0ustar rootroot# # Limit of memory used to store tuples to 100MB # (0.1 GB) # This effectively limits the memory, used by # Tarantool. However, index and connection memory # is stored outside the slab allocator, hence # the effective memory usage can be higher (sometimes # twice as high). # slab_alloc_arena = 0.1 readahead = 1024 # # Read only and read-write port. primary_port = 33013 # Read-only port. secondary_port = 33014 # # The port for administrative commands. # admin_port = 33015 # # Each write ahead log contains this many rows. # When the limit is reached, Tarantool closes # the WAL and starts a new one. rows_per_wal = 50000 # Define a simple space with 1 HASH-based # primary key. 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 = "TREE" space[0].index[1].unique = 0 space[0].index[1].key_field[0].fieldno = 1 space[0].index[1].key_field[0].type = "STR" space[0].index[2].type = "TREE" space[0].index[2].unique = 0 space[0].index[2].key_field[0].fieldno = 2 space[0].index[2].key_field[0].type = "NUM" space[0].index[2].key_field[1].fieldno = 3 space[0].index[2].key_field[1].type = "STR" libdr-tarantool-perl-0.44/t/test-data/00017-000-ok.bin0000644000000000000000000000002412123045772020371 0ustar rootroot libdr-tarantool-perl-0.44/t/test-data/00013-000-ok.bin0000644000000000000000000000005212123045772020366 0ustar rootroot cdelibdr-tarantool-perl-0.44/t/test-data/00020-000-ok.bin0000644000000000000000000000002412123045772020363 0ustar rootrootlibdr-tarantool-perl-0.44/t/test-data/65280-000-ok.bin0000644000000000000000000000001412123045772020405 0ustar rootrootlibdr-tarantool-perl-0.44/t/test-data/empty_tuple.00022-000-ok.bin0000644000000000000000000000003412123045772022734 0ustar rootrootlibdr-tarantool-perl-0.44/t/005-connection.t0000644000000000000000000001154412347544137017304 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 56; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::AEConnection'; use_ok 'AnyEvent::Socket'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::StartTest'; } my $port = DR::Tarantool::StartTest::_find_free_port; ok $port => 'Port is generated ' . $port // 'undef'; my $fh; note 'connfail'; for my $cv (AE::cv) { $cv->begin; my $c = DR::Tarantool::AEConnection->new(port => $port); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; $c->on(connfail => sub { my ($self) = @_; isa_ok $self => 'DR::Tarantool::AEConnection'; is $self->state, 'connfail', 'error'; is $self->errno, 'ECONNREFUSED', 'errno'; $cv->end; }); $c->connect(); $cv->recv; } note 'connfail timeout'; for my $cv (AE::cv) { $cv->begin; my $c = DR::Tarantool::AEConnection->new(port => $port, timeout => 0); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; $c->on(connfail => sub { my ($self) = @_; isa_ok $self => 'DR::Tarantool::AEConnection'; is $self->state, 'connfail', 'error'; is $self->errno, 'ETIMEOUT', 'errno'; $cv->end; }); $c->connect(); $cv->recv; } note 'reconnect_always'; for my $cv (AE::cv) { $cv->begin for 1 .. 10; my $c = DR::Tarantool::AEConnection->new( port => $port, reconnect_always => 1, reconnect_period => .1 ); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; $c->on(connfail => sub { my ($self) = @_; isa_ok $self => 'DR::Tarantool::AEConnection'; is $self->state, 'connfail', 'error'; $cv->end; }); $c->connect(); $cv->recv; } note 'reconnect_period'; for my $cv (AE::cv) { $cv->begin for 1 .. 2; my $c = DR::Tarantool::AEConnection->new( port => $port, reconnect_period => .1, ); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; my $cnt = 0; my $tmr; $c->on(connfail => sub { my ($self) = @_; isa_ok $self => 'DR::Tarantool::AEConnection'; is $self->state, 'connfail', 'error'; undef $tmr unless is $cnt, 0, 'only one connfail'; $cnt++; $cv->end; }); $c->connect(); $tmr = AE::timer .6, 0, sub { ok $tmr => 'timeout exceeded'; $cv->end; }; $cv->recv; } note 'test server'; my $server; for my $cv (AE::cv) { $cv->begin; $server = tcp_server undef, $port, sub { syswrite $_[0], 'Hello, world'; }, sub { ok $_[0] => 'server is created'; $cv->end; } ; $cv->recv; } for my $cv (AE::cv) { $cv->begin; my $c = DR::Tarantool::AEConnection->new(port => $port); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; $c->on(connected => sub { my ($self) = @_; is $self->state, 'connected', 'connected'; { $cv->begin; my $io; $io = AE::io $self->fh, 0, sub { undef $io; sysread $self->fh, my $str, 4096; is $str => 'Hello, world', 'data received'; $cv->end; }; } $cv->end; }); $c->on(connfail => sub { my ($self) = @_; fail 'Connet to server'; $cv->end; }); $c->connect(); $cv->recv; } note 'read, set_error, reconnecting'; for my $cv (AE::cv) { $cv->begin; $cv->begin; # twice my $c = DR::Tarantool::AEConnection->new(port => $port, reconnect_period => .1); isa_ok $c => 'DR::Tarantool::AEConnection'; is $c->state, 'init', 'state'; my $count = 0; $c->on(connected => sub { my ($self) = @_; is $self->state, 'connected', 'connected'; { $cv->begin; my $io; $io = AE::io $self->fh, 0, sub { undef $io; sysread $self->fh, my $str, 4096; is $str => 'Hello, world', 'data received'; $self->set_error('User error'); cmp_ok $count, '<', 2, 'reconnects'; $count++; $cv->end; }; } $cv->end; }); $c->on(connfail => sub { my ($self) = @_; fail 'Connet to server'; $cv->end; }); $c->connect(); $cv->recv; } libdr-tarantool-perl-0.44/t/010-xs.t0000644000000000000000000002114212331722764015563 0ustar rootroot#!/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}; # Pack an integer into an , per the Tarantool binary protocol. sub pack_varint { my $num = shift; my $out = pack 'C', ($num & 0x7f); $num >>= 7; while ($num) { $out .= pack 'C', (($num & 0x7f) | 0x80); $num >>= 7; } return scalar reverse $out; } # Pack arbitrary data into a trivial , per the Tarantool binary # protocol. sub pack_fq_tuple { my $body = shift; my $len = length $body; # ::= # ::= + # ::= my $len_varint = pack_varint($len); return pack 'LLa*a*', 4 * length($len_varint) + $len, 1, $len_varint, $body ; } for (1 .. 30) { my $body = join '', map { chr int rand 256 } 1 .. (300 + int rand 300); my $pkt = pack 'LLLLLa*', TNT_SELECT, 8 + length $body, int rand 500, 0, 1, pack_fq_tuple($body) ; $res = DR::Tarantool::_pkt_parse_response( $pkt ); diag explain $res unless is $res->{status}, 'buffer', "Broken package $_"; $pkt = pack 'LLLLLa*', TNT_SELECT, 8 + 10 + length $body, int rand 500, 0, 1, pack_fq_tuple($body) ; $res = DR::Tarantool::_pkt_parse_response( $pkt ); diag explain $res unless is $res->{status}, 'buffer', "Broken package $_, too long body"; $pkt = pack 'LLLLLa*', TNT_SELECT, 8 - 10 + length $body, int rand 500, 0, 1, pack_fq_tuple($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, 5 + int rand 500, 5 + int rand 500, 0, '' ; my $pkth = join '', map { sprintf '.%02x', ord $_ } split //, $pkt; $res = DR::Tarantool::_pkt_parse_response( $pkt ); diag explain [ $res, $pkth, TNT_SELECT ] unless is $res->{status}, 'buffer', "Broken package $_, zero length body"; } } libdr-tarantool-perl-0.44/t/025-ll_synclient.t0000644000000000000000000001357312414721645017646 0ustar rootroot#!/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); BEGIN { use constant PLAN => 63; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLSyncClient'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname'; use_ok 'DR::Tarantool', ':constant'; } my $LE = $] > 5.01 ? '<' : ''; my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 7; } my $client = DR::Tarantool::LLSyncClient->connect( port => $tnt->primary_port, reconnect_period => 0.1 ); note 'ping'; ok $client->ping, 'ping'; close $client->{fh}; ok !$client->ping, 'ping disconnected'; note 'call_lua'; { my $res = $client->call_lua('box.dostring', [ 'return "123", "abc"' ]); isa_ok $res => 'HASH'; is $res->{status}, 'ok', 'status'; is_deeply $res->{tuples}, [[123],['abc']], 'tuples'; is $res->{code}, 0, 'code'; is $client->last_code, $res->{code}, 'code'; is $client->last_error_string, '', 'error'; is $res->{count}, 2, '2 tuples'; is $res->{type}, TNT_CALL, 'type'; } { my $res = eval { $client->call_lua('box.dostring', [ 'error("abc")' ]); ## LINE1 }; like $@, qr{Lua error}, 'Error'; } note 'insert'; { for (1 .. 2) { my $res = $client->insert(0, [ pack("L$LE", 1), 'abc', pack "L$LE", $_ ], TNT_FLAG_RETURN ); isa_ok $res => 'HASH'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_INSERT, 'type'; is $res->{count}, 1, 'count'; is_deeply $res->{tuples}, [[pack("L$LE", 1), 'abc', pack "L$LE", $_]], 'tuples'; } my $res = eval { $client->insert(0, [ pack("L$LE", 1), 'abc', pack "L$LE", 1234 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); }; is $res, undef, 'no results'; like $@, qr{Duplicate key exists}, 'Error message'; ok $client->last_code, 'last_code'; like $client->last_error_string, qr{Duplicate key exists}, 'Error message'; } note 'select'; { my $res = $client->select(0, 0, [[ pack("L$LE", 1) ]], 2, 0); isa_ok $res => 'HASH'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_SELECT, 'type'; is $res->{count}, 1, 'count'; is_deeply $res->{tuples}, [[pack("L$LE", 1), 'abc', pack "L$LE", 2]], 'tuples'; } { my $res = $client->select(0, 0, [[ pack("L$LE", 2) ]], 2, 0); isa_ok $res => 'HASH'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_SELECT, 'type'; is $res->{count}, 0, 'count'; is_deeply $res->{tuples}, [], 'tuples'; } note 'update'; { my $res = $client->update( 0, # ns [ pack "L$LE", 1 ], # keys [ [ 1 => set => 'abcdef' ], [ 1 => substr => 2, 2, ], [ 1 => substr => 100, 1, 'tail' ], [ 2 => 'delete' ], [ 2 => insert => pack "L$LE" => 123 ], [ 3 => insert => 'third' ], [ 4 => insert => 'fourth' ], ], TNT_FLAG_RETURN, # flags ); is $res->{code}, 0, '* update reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_UPDATE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr} // '', 'operation errstr'; is $res->{tuples}[0][1], 'abeftail', 'updated tuple 1'; is $res->{tuples}[0][2], (pack "L$LE", 123), 'updated tuple 2'; is $res->{tuples}[0][3], 'third', 'updated tuple 3'; is $res->{tuples}[0][4], 'fourth', 'updated tuple 4'; $res = $client->update( 0, [ pack "L$LE", 1 ], [ [ 1 => set => '123' ] ] ); is $res->{code}, 0, 'update reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_UPDATE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr} // '', 'operation errstr'; is $res->{count}, 1, 'count'; is_deeply $res->{tuples}, [], 'no tuples'; } note 'delete'; { my $res = $client->delete( 0, # ns [ pack "L$LE", 1 ], # keys TNT_FLAG_RETURN, # flags ); is $res->{code}, 0, '* delete reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_DELETE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr} // '', 'operation errstr'; is $res->{tuples}[0][1], '123', 'deleted tuple[1]'; } } libdr-tarantool-perl-0.44/t/033-iterator.t0000644000000000000000000001165312123045772016771 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 53; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::Iterator'; } use constant MODEL => 'DR::Tarantool::Iterator'; is eval { MODEL->new }, undef, 'empty constructor'; like $@, qr{usage:}, 'error message'; my $iter = MODEL->new([1, 2, 3]); ok $iter, 'constructor'; isa_ok $iter => MODEL; is $iter->count, 3, '$iter->count'; is $iter->item(0), 1, '$iter->item(0)'; is $iter->item(1), 2, '$iter->item(1)'; is $iter->item(2), 3, '$iter->item(2)'; is $iter->item(-1), 3, '$iter->item(-1)'; is $iter->item(-2), 2, '$iter->item(-2)'; is $iter->item(-3), 1, '$iter->item(-3)'; is eval { $iter->item(3) }, undef, '$iter->item(3) (out of bound)'; like $@, qr{wrong item number: 3}, 'error message'; is eval { $iter->item(-4) }, undef, '$iter->item(-4) (out of bound)'; like $@, qr{wrong item number: -4}, 'error message'; is eval { $iter->item('abc') }, undef, '$iter->item("abc")'; like $@, qr{wrong item number format: abc}, 'error message'; is eval { $iter->item(undef) }, undef, '$iter->item(undef)'; like $@, qr{wrong item number format: undef}, 'error message'; my @res; while(my $o = $iter->next) { push @res => $o } is_deeply \@res, [ 1, 2, 3 ], '$iter->next'; is $iter->next, 1, '$iter->next (first)'; is $iter->reset, 0, '$iter->reset returns old iterator position'; @res = (); while(my $o = $iter->next) { push @res => $o } is_deeply \@res, [ 1, 2, 3 ], '$iter->next'; $iter->reset; is_deeply scalar $iter->all, [ 1, 2, 3 ], '$iter->all'; $iter->next; is_deeply scalar $iter->all, [ 1, 2, 3 ], '$iter->all (after next)'; @res = (); while(my $o = $iter->next) { push @res => $o } is_deeply \@res, [ 2, 3 ], '$iter->next after $iter->all'; is_deeply scalar $iter->all(sub { $_[0] + 1 }), [ 2, 3, 4 ], '$iter->all(sub { .. })'; is_deeply scalar $iter->all(sub { $_[0] + 1 }, sub { $_[0] + 2 }), [ [ 2, 3 ], [ 3, 4 ], [ 4, 5 ] ], '$iter->all(sub { ... }, sub { ... })'; $iter->item_class('Test::Iterator::Class'); $iter->item_constructor('constructor'); my $item = $iter->item(2); isa_ok $item => 'Test::Iterator::Class'; is eval { $item->value }, 3, '$item->value'; $iter->reset; $iter->item_constructor(undef); $item = $iter->next; isa_ok $item => 'Test::Iterator::Class'; is $$item, 1, 'blessed (not constructed)'; $item = $iter->next; isa_ok $item => 'Test::Iterator::Class'; is $$item, 2, 'blessed (not constructed)'; $iter->item_class(undef); $item = $iter->next; is $item, 3, 'unblessed item'; $iter = MODEL->new([3, 4, 5], item_class => [ 'Test::Iterator::Class', 'constructor' ] ); isa_ok $iter->next, 'Test::Iterator::Class'; is eval { $iter->next->value }, 4, '$iter->item(1)->value'; $iter = MODEL->new([ 5, 6, 7 ], item_class => 'Test::Iterator::Class', item_constructor => 'constructor' ); isa_ok $iter->next, 'Test::Iterator::Class'; is eval { $iter->next->value }, 6, '$iter->item(1)->value'; $iter = MODEL->new( [ 8, 9, 10 ], item_class => 'Test::Iterator::Class', data => { 1 => [ 2, 3] } ); isa_ok $iter->next, 'Test::Iterator::Class'; is eval { ${ $iter->next } }, 9, '$iter->item(1) usually blessed'; is_deeply $iter->data, { 1 => [ 2, 3] }, '$iter->data (get)'; is_deeply $iter->data([ 4, { 5 => 6} ]), [ 4, { 5 => 6 } ], '$iter->data (set)'; is_deeply $iter->data, [ 4, { 5 => 6 } ], '$iter->data (get)'; $iter = MODEL->new([3, 2, 1, 102, 0, -10]); my $iter2 = $iter->clone(1); my $iter3 = $iter->clone; $iter->raw_sort(sub { $_[0] <=> $_[1] }); is_deeply [ $iter->all ], [ -10, 0, 1, 2, 3, 102 ], 'raw_sort'; is_deeply [ $iter3->all ], [ $iter->all ], '->clone(0)->raw_sort'; is_deeply [ $iter2->all ], [ 3, 2, 1, 102, 0, -10 ], '->clone(1)->raw_sort'; $iter->item_class('Test::Iterator::Class', 'constructor'); $iter->sort(sub { $_[1]->value <=> $_[0]->value }); $iter->item_class(undef, undef); is_deeply scalar $iter->all, [ 102, 3, 2, 1, 0, -10 ], '->sort'; $iter2 = $iter->grep(sub { $_[0] > 2 }); is_deeply scalar $iter2->all, [ 102, 3 ], '->grep'; $iter2 = $iter->grep(sub { $_[0] > 200 }); is_deeply scalar $iter2->all, [ ], '->grep'; $iter->item_class('Test::Iterator::Class', 'constructor'); $iter->data(\123); $iter2 = $iter->grep(sub { $_[0]->value < 10 }); $iter3 = $iter->raw_grep(sub { $_[0] < 10 }); $iter2->item_class(undef, undef); $iter3->item_class(undef, undef); is_deeply scalar $iter2->all, [ 3, 2, 1, 0, -10 ], '->grep'; is_deeply scalar $iter2->all, scalar $iter3->all, 'raw_grep'; package Test::Iterator::Class; use Test::More; sub constructor { my ($class, $v) = @_; return bless { value => $v } => ref($class) || $class; } sub value { my ($self) = @_; return $self->{value}; } libdr-tarantool-perl-0.44/t/000-use.t0000644000000000000000000000141112123045772015715 0ustar rootroot#!/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 => 10; 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'; use_ok 'DR::Tarantool'; use_ok 'DR::Tarantool', ':all'; use_ok 'DR::Tarantool', ':constant'; use_ok 'DR::Tarantool::AsyncClient'; use_ok 'DR::Tarantool::LLClient'; use_ok 'DR::Tarantool::Spaces'; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool::SyncClient'; use_ok 'DR::Tarantool::Tuple'; } libdr-tarantool-perl-0.44/t/120-sessionid.t0000644000000000000000000000546112414722001017123 0ustar rootroot#!/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); my $LE = $] > 5.01 ? '<' : ''; use constant PLAN => 17; use Test::More; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { eval "use Coro"; plan skip_all => "Coro isn't installed" if $@; plan tests => PLAN; } } use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':constant'; use_ok 'DR::Tarantool::CoroClient'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'Coro'; use_ok 'AnyEvent'; use_ok 'Coro::AnyEvent'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); SKIP: { skip "tarantool isn't installed", PLAN - 10 unless $tnt->started; my $c1 = DR::Tarantool::CoroClient->connect( port => $tnt->primary_port, spaces => {} ); my $c2 = DR::Tarantool::CoroClient->connect( port => $tnt->primary_port, spaces => {} ); ok $c1->ping, 'ping'; ok $c2->ping, 'ping'; my $sid1 = $c1->call_lua( 'box.dostring', [ 'return tostring(box.session.id())' ] )->raw(0); my $sid2 = $c1->call_lua( 'box.dostring', [ 'return tostring(box.session.id())' ] )->raw(0); my $sid3 = $c2->call_lua( 'box.dostring', [ 'return tostring(box.session.id())' ] )->raw(0); my $sid4 = $c2->call_lua( 'box.dostring', [ 'return tostring(box.session.id())' ] )->raw(0); is $sid1, $sid2, 'sids are equal'; is $sid3, $sid4, 'sids are equal'; isnt $sid1, $sid3, 'sids are not equal'; $c1->call_lua('box.dostring', [ q[ sessions = {} box.session.on_disconnect( function() table.insert(sessions, tostring(box.session.id())) end ) ] ] ); $c2->_llc->disconnect; $c2->_llc->connect; Coro::AnyEvent::sleep 0.5; my $dsid = $c1->call_lua('box.dostring', [ 'return sessions' ])->raw(0); is $sid3, $dsid, 'disconnect sid'; isnt $sid1, $dsid, 'disconnect sid'; } libdr-tarantool-perl-0.44/t/920-critic.xt0000644000000000000000000000022312123045772016601 0ustar rootrootuse strict; use Test::More; eval q{ use Test::Perl::Critic }; plan skip_all => "Test::Perl::Critic is not installed." if $@; all_critic_ok("lib"); libdr-tarantool-perl-0.44/t/1.6/0000775000000000000000000000000012414725445014755 5ustar rootrootlibdr-tarantool-perl-0.44/t/1.6/data/0000775000000000000000000000000012347544137015670 5ustar rootrootlibdr-tarantool-perl-0.44/t/1.6/data/ll.lua0000644000000000000000000000001512347544137016774 0ustar rootrootbox.cfg { } libdr-tarantool-perl-0.44/t/1.6/data/ll-grant.lua0000644000000000000000000000016012347544137020106 0ustar rootroot box.cfg{ } box.schema.user.create('test_user') box.schema.user.grant('test_user', 'read,write', 'universe') libdr-tarantool-perl-0.44/t/1.6/017-msgpack-proto.t0000644000000000000000000001573612347544137020251 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); use Test::More tests => 25; use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::MsgPack::Proto', qw(call_lua response insert replace del update select auth); } note 'call'; { my ($p) = response call_lua(121, 'test'); is_deeply $p => { CODE => 'CALL', FUNCTION_NAME => 'test', SYNC => 121, TUPLE => [] }, 'Call request'; } { my ($p) = response call_lua(121, 'test', 1, [2, 3], 4); is_deeply $p => { CODE => 'CALL', FUNCTION_NAME => 'test', SYNC => 121, TUPLE => [1, [2, 3], 4] }, 'Call request'; } note 'insert'; { my ($p) = response insert(10, 20, [1,2,3]); is_deeply $p => { CODE => 'INSERT', SYNC => 10, TUPLE => [1, 2, 3], SPACE_ID => 20, }, 'Insert request with space number'; } { my ($p) = response insert(17, 20, 'scalar'); is_deeply $p => { CODE => 'INSERT', SYNC => 17, TUPLE => ['scalar'], SPACE_ID => 20, }, 'Insert request with space number'; } { my ($p) = response insert(19, 'space_name', [1,2,3]); is_deeply $p => { CODE => 'CALL', SYNC => 19, TUPLE => [1, 2, 3], FUNCTION_NAME => 'box.space.space_name:insert', }, 'Insert request with space name'; } note 'replace'; { my ($p) = response replace(10, 20, [1,2,3]); is_deeply $p => { CODE => 'REPLACE', SYNC => 10, TUPLE => [1, 2, 3], SPACE_ID => 20, }, 'Replace request with space number'; } { my ($p) = response replace(17, 20, 'scalar'); is_deeply $p => { CODE => 'REPLACE', SYNC => 17, TUPLE => ['scalar'], SPACE_ID => 20, }, 'Replace request with space number'; } { my ($p) = response replace(19, 'space_name', [1,2,3]); is_deeply $p => { CODE => 'CALL', SYNC => 19, TUPLE => [1, 2, 3], FUNCTION_NAME => 'box.space.space_name:replace', }, 'Replace request with space name'; } note 'del'; { my ($p) = response del(10, 27, [1,2,3]); is_deeply $p => { CODE => 'DELETE', SYNC => 10, KEY => [1, 2, 3], SPACE_ID => 27, }, 'Delete request with space number'; } { my ($p) = response del(17, 20, 'scalar'); is_deeply $p => { CODE => 'DELETE', SYNC => 17, KEY => ['scalar'], SPACE_ID => 20, }, 'Delete request with space number'; } { my ($p) = response del(19, 'space_name', [1,2,3]); is_deeply $p => { CODE => 'CALL', SYNC => 19, TUPLE => [1, 2, 3], FUNCTION_NAME => 'box.space.space_name:delete', }, 'Delete request with space name'; } note 'update'; { my ($p) = response update(10, 27, [1,2,3], [['+', 1, 2]]); is_deeply $p => { CODE => 'UPDATE', SYNC => 10, KEY => [1, 2, 3], TUPLE => [['+', 1, 2]], SPACE_ID => 27, }, 'Update request with space number'; } { my ($p) = response update(10, 27, 'test', [['+', 1, 2]]); is_deeply $p => { CODE => 'UPDATE', SYNC => 10, KEY => ['test'], TUPLE => [['+', 1, 2]], SPACE_ID => 27, }, 'Update request with space number'; } { my ($p) = response update(10, 'space_name', 'test', [['+', 1, 2]]); is_deeply $p => { CODE => 'CALL', SYNC => 10, TUPLE => [['test'], [['+', 1, 2]]], FUNCTION_NAME => 'box.space.space_name:update', }, 'Update request with space name'; } note 'select'; { my ($p) = response select(10, 27, 30, [1,2,3]); is_deeply $p => { CODE => 'SELECT', SYNC => 10, OFFSET => 0, LIMIT => 0xFFFF_FFFF, KEY => [1, 2, 3], SPACE_ID => 27, INDEX_ID => 30, ITERATOR => 'EQ', }, 'Select request with space & index numbers'; } { my ($p) = response select(10, 27, 30, [1,2,3], 300); is_deeply $p => { CODE => 'SELECT', SYNC => 10, OFFSET => 0, LIMIT => 300, KEY => [1, 2, 3], SPACE_ID => 27, INDEX_ID => 30, ITERATOR => 'EQ', }, 'Select request with space & index numbers'; } { my ($p) = response select(10, 27, 30, [1,2,3], 300, 400, 'LE'); is_deeply $p => { CODE => 'SELECT', SYNC => 10, OFFSET => 400, LIMIT => 300, KEY => [1, 2, 3], SPACE_ID => 27, INDEX_ID => 30, ITERATOR => 'LE', }, 'Select request with space & index numbers'; } { my ($p) = response select('10', '27', '30', [1,2,3]); is_deeply $p => { CODE => 'SELECT', SYNC => 10, OFFSET => 0, LIMIT => 0xFFFF_FFFF, KEY => [1, 2, 3], SPACE_ID => 27, INDEX_ID => 30, ITERATOR => 'EQ', }, 'Select request with space & index numbers'; } { my ($p) = response select('10', 'space_name', 'index_name', [1], 5, 1, 'GT'); is_deeply $p => { CODE => 'CALL', SYNC => 10, FUNCTION_NAME => 'box.space.space_name.index.index_name:select', TUPLE => [ [1], { limit => 5, offset => 1, iterator => 6, } ] }, 'Select request with space & index numbers'; } note 'auth'; { local $DR::Tarantool::MsgPack::Proto::DECODE_UTF8 = 0; my ($p) = response auth 19, 'user', 'password', '1234'; isa_ok $p => 'HASH'; my $tuple = delete $p->{TUPLE}; is_deeply $p => { CODE => 'AUTH', SYNC => 19, USER_NAME => 'user', }, 'Auth request'; isa_ok $tuple => 'ARRAY'; is $tuple->[0] => 'chap-sha1', 'chap-sha1'; is length $tuple->[1] => 20, 'length of sha'; } libdr-tarantool-perl-0.44/t/1.6/050-msgpack-coro.t0000644000000000000000000000617612347544137020043 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); BEGIN { use constant PLAN => 20; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.6', 2)) { plan skip_all => 'tarantool 1.6 is not found'; } else { plan tests => PLAN; } } use File::Spec::Functions 'catfile', 'rel2abs'; use File::Basename 'dirname'; use Encode qw(decode encode); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::MsgPack::CoroClient'; use_ok 'AnyEvent'; } my $cfg = catfile dirname(__FILE__), 'data', 'll.lua'; my $cfgg = catfile dirname(__FILE__), 'data', 'll-grant.lua'; ok -r $cfg, "-r config file ($cfg)"; ok -r $cfgg, "-r config file ($cfgg)"; my $t = DR::Tarantool::StartTest->run( family => 2, cfg => $cfg, ); ok $t->started, 'tarantool was started'; $t->admin(q[ box.schema.user.create('user1', { password = 'password' }) ]); $t->admin(q[ box.schema.user.grant('user1', 'read,write,execute', 'universe')]); $t->admin(q[ box.schema.create_space('test', { id = 7 }).n]); $t->admin(q[ box.space.test:create_index('pk', { type = 'tree' })]); my $tnt = DR::Tarantool::MsgPack::CoroClient->connect( port => $t->primary_port, user => 'user1', password => 'password', spaces => { 7 => { name => 'name_in_script', fields => [ 'id', 'name', 'age' ], indexes => { 0 => { name => 'id', fields => [ 'id' ] } } }, }, ); isa_ok $tnt => 'DR::Tarantool::MsgPack::CoroClient', 'client is created'; ok $tnt->ping, 'ping'; is_deeply $tnt->insert('name_in_script', [ 1, 'вася', 21 ])->raw, [ 1, 'вася', 21 ], 'insert'; is eval { $tnt->insert('name_in_script', [ 1, 'вася', 21 ]) }, undef, 'repeat'; like $@ => qr{Duplicate key exists}, 'error message'; isnt $tnt->last_code, 0, 'last_code'; like $tnt->last_error_string => qr{Duplicate key}, 'last_error_string'; is_deeply $tnt->replace('name_in_script', [ 1, 'вася', 23 ])->raw, [ 1, 'вася', 23 ], 'insert'; is_deeply $tnt->replace('name_in_script', [ 2, 'петя', 23 ])->raw, [ 2, 'петя', 23 ], 'insert'; is $tnt->select('name_in_script', 0, [1], iterator => 'ALL')->iter->count, 2, 'select with iterator ALL'; is_deeply $tnt->delete('name_in_script', 1)->raw, [ 1, 'вася', 23 ], 'delete'; is_deeply $tnt->select('name_in_script', 0, 1), undef, 'select'; is_deeply $tnt->select('name_in_script', 0, 2)->raw, [ 2, 'петя', 23 ], 'select'; is_deeply $tnt->call_lua('box.space.test.index.pk:select', 2)->raw, [2, 'петя', 23], 'call_lua'; is $tnt->last_code, 0, 'last code'; libdr-tarantool-perl-0.44/t/1.6/040-msgpack-sync.t0000644000000000000000000000600712347544137020045 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); BEGIN { use constant PLAN => 19; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.6', 2)) { plan skip_all => 'tarantool 1.6 is not found'; } else { plan tests => PLAN; } } use File::Spec::Functions 'catfile', 'rel2abs'; use File::Basename 'dirname'; use Encode qw(decode encode); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::MsgPack::SyncClient'; use_ok 'AnyEvent'; } my $cfg = catfile dirname(__FILE__), 'data', 'll.lua'; my $cfgg = catfile dirname(__FILE__), 'data', 'll-grant.lua'; ok -r $cfg, "-r config file ($cfg)"; ok -r $cfgg, "-r config file ($cfgg)"; my $t = DR::Tarantool::StartTest->run( family => 2, cfg => $cfg, ); ok $t->started, 'tarantool was started'; $t->admin(q[ box.schema.user.create('user1', { password = 'password' }) ]); $t->admin(q[ box.schema.user.grant('user1', 'read,write,execute', 'universe')]); $t->admin(q[ box.schema.create_space('test', { id = 7 }).n]); $t->admin(q[ box.space.test:create_index('pk', { type = 'tree' })]); my $tnt = DR::Tarantool::MsgPack::SyncClient->connect( port => $t->primary_port, user => 'user1', password => 'password', spaces => { 7 => { name => 'name_in_script', fields => [ 'id', 'name', 'age' ], indexes => { 0 => { name => 'id', fields => [ 'id' ] } } }, }, ); isa_ok $tnt => 'DR::Tarantool::MsgPack::SyncClient', 'client is created'; ok $tnt->ping, 'ping'; is_deeply $tnt->insert('name_in_script', [ 1, 'вася', 21 ])->raw, [ 1, 'вася', 21 ], 'insert'; is eval { $tnt->insert('name_in_script', [ 1, 'вася', 21 ]) }, undef, 'repeat'; like $@ => qr{Duplicate key exists}, 'error message'; isnt $tnt->last_code, 0, 'last_code'; like $tnt->last_error_string => qr{Duplicate key}, 'last_error_string'; is_deeply $tnt->replace('name_in_script', [ 1, 'вася', 23 ])->raw, [ 1, 'вася', 23 ], 'insert'; is_deeply $tnt->replace('name_in_script', [ 2, 'петя', 23 ])->raw, [ 2, 'петя', 23 ], 'insert'; is_deeply $tnt->delete('name_in_script', 1)->raw, [ 1, 'вася', 23 ], 'delete'; is_deeply $tnt->select('name_in_script', 0, 1), undef, 'select'; is_deeply $tnt->select('name_in_script', 0, 2)->raw, [ 2, 'петя', 23 ], 'select'; is_deeply $tnt->call_lua('box.space.test.index.pk:select', 2)->raw, [2, 'петя', 23], 'call_lua'; is $tnt->last_code, 0, 'last code'; libdr-tarantool-perl-0.44/t/1.6/030-msgpack-async.t0000644000000000000000000001455112347544137020210 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); BEGIN { use constant PLAN => 62; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.6', 2)) { plan skip_all => 'tarantool 1.6 is not found'; } else { plan tests => PLAN; } } use File::Spec::Functions 'catfile', 'rel2abs'; use File::Basename 'dirname'; use Encode qw(decode encode); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::MsgPack::AsyncClient'; use_ok 'AnyEvent'; } my $cfg = catfile dirname(__FILE__), 'data', 'll.lua'; my $cfgg = catfile dirname(__FILE__), 'data', 'll-grant.lua'; ok -r $cfg, "-r config file ($cfg)"; ok -r $cfgg, "-r config file ($cfgg)"; my $t = DR::Tarantool::StartTest->run( family => 2, cfg => $cfg, ); ok $t->started, 'tarantool was started'; $t->admin(q[ box.schema.user.create('user1', { password = 'password' }) ]); $t->admin(q[ box.schema.user.grant('user1', 'read,write,execute', 'universe')]); $t->admin(q[ box.schema.create_space('test', { id = 7 }).n]); $t->admin(q[ box.space.test:create_index('pk', { type = 'tree' })]); my $tnt; sub wait_cv_ok($;$) { my ($cv, $timeout) = @_; $timeout ||= .5; my $tmr; $tmr = AE::timer $timeout, 0, sub { undef $tmr; undef $timeout; $cv->end; }; $cv->recv; ok $timeout, 'timeout not exceeded'; undef $tmr; } for my $cv (AE::cv) { $cv->begin; DR::Tarantool::MsgPack::AsyncClient->connect( port => $t->primary_port, user => 'user1', password => 'password', spaces => { 7 => { name => 'name_in_script', fields => [ 'id', 'name', 'age' ], indexes => { 0 => { name => 'id', fields => [ 'id' ] } } }, }, sub { ($tnt) = @_; $cv->end; } ); wait_cv_ok $cv; ok $tnt => 'connection established'; } note 'ping'; for my $cv (AE::cv) { $cv->begin; $tnt->ping(sub { $cv->end; is $_[0] => 'ok', 'status'; is $_[1] => undef, 'no tuples'; is $_[2] => 0, 'code'; }); wait_cv_ok $cv; } note 'insert'; for my $cv (AE::cv) { $cv->begin; $tnt->insert(7, [1,'вася',3], sub { is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [1, 'вася', 3], 'tuples'; is $_[2] => 0, 'code'; $cv->end; }); $cv->begin; $tnt->insert('name_in_script', [2,'петя',3], sub { is $_[0] => 'ok', 'status'; isa_ok $_[1] => 'DR::Tarantool::Tuple'; is_deeply $_[1]->raw => [2,'петя',3], 'tuple'; is $_[2] => 0, 'code'; $cv->end; }); wait_cv_ok $cv; } note 'replace'; for my $cv (AE::cv) { $cv->begin; $tnt->replace(7, [1,'васяня',31], sub { is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [1, 'васяня', 31], 'tuples'; is $_[2] => 0, 'code'; $cv->end; }); $cv->begin; $tnt->replace('name_in_script', [2,'петюня',32], sub { is $_[0] => 'ok', 'status'; isa_ok $_[1] => 'DR::Tarantool::Tuple'; is_deeply $_[1]->raw => [2,'петюня',32], 'tuple'; is $_[2] => 0, 'code'; is $_[1]->id => 2, 'id'; is $_[1]->name => 'петюня', 'name'; is $_[1]->age => 32, 'age'; $cv->end; }); $cv->begin; $tnt->replace('name_in_script', [3,'масяня',32], sub { is $_[0] => 'ok', 'status'; isa_ok $_[1] => 'DR::Tarantool::Tuple'; is_deeply $_[1]->raw => [3,'масяня',32], 'tuple'; is $_[2] => 0, 'code'; $cv->end; }); wait_cv_ok $cv; } note 'delete'; for my $cv (AE::cv) { $cv->begin; $tnt->delete('name_in_script' => 11, sub { $cv->end; is $_[0] => 'ok', 'status'; is $_[1] => undef, 'not exists tuple'; }); $cv->begin; $tnt->delete('name_in_script' => 1, sub { $cv->end; is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [1, 'васяня', 31], 'exists tuple'; }); wait_cv_ok $cv; } for my $cv (AE::cv) { $cv->begin; $tnt->delete('name_in_script' => 1, sub { $cv->end; is $_[0] => 'ok', 'status'; is $_[1] => undef, 'really removed'; }); wait_cv_ok $cv; } note 'select'; for my $cv (AE::cv) { $cv->begin; $tnt->select('name_in_script', 'id', 1, sub { is $_[0] => 'ok', 'status'; is $_[1] => undef, 'tuple (deleted)'; is $_[2] => 0, 'code'; $cv->end; }); $tnt->select('name_in_script', 'id', 2, sub { is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [2, 'петюня', 32], 'tuple'; is $_[1]->iter->count, 1, 'count of tuples'; is $_[2] => 0, 'code'; $cv->end; }); $tnt->select('name_in_script', 'id', 2, limit => 20, iterator => 'GE', sub { is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [2, 'петюня', 32], 'tuple (deleted)'; SKIP: { skip 'tarantool has bug #273', 1; is $_[1]->iter->count, 2, 'count of tuples'; }; is $_[2] => 0, 'code'; $cv->end; }); wait_cv_ok $cv; } note 'update'; for my $cv (AE::cv) { $cv->begin; $tnt->update( 'name_in_script', 2, [ [ '+' => 2, 2 ] ], sub { $cv->end; is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [2, 'петюня', 34], 'tuple'; is $_[2] => 0, 'code'; } ); wait_cv_ok $cv; } for my $cv (AE::cv) { $cv->begin; $tnt->update( 'name_in_script', 2, [ [ '+' => 'age', 2 ] ], sub { $cv->end; is $_[0] => 'ok', 'status'; is_deeply $_[1]->raw => [2, 'петюня', 36], 'tuple'; is $_[2] => 0, 'code'; } ); wait_cv_ok $cv; } libdr-tarantool-perl-0.44/t/1.6/015-msgpack-xs.t0000644000000000000000000002006112347544137017521 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); use Test::More tests => 73; 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::MsgPack', 'msgpack', 'msgunpack', 'msgcheck'; } note '===================== pack ==============================='; note 'string'; { my $res = DR::Tarantool::_msgpack('test'); like $res, qr{test$}, 'text'; my $type = unpack 'C', $res; is $type, 0xA4, 'type'; $res = DR::Tarantool::_msgpack('test' x 20); like $res, qr{test$}, 'text'; $type = unpack 'C', $res; is $type, 0xD9, 'str 8'; $res = DR::Tarantool::_msgpack('test' x 200); like $res, qr{test$}, 'text'; $type = unpack 'C', $res; is $type, 0xDA, 'str 16'; $res = DR::Tarantool::_msgpack('test' x 20000); like $res, qr{test$}, 'text'; $type = unpack 'C', $res; is $type, 0xDb, 'str 32'; } note 'numbers'; { my $res = DR::Tarantool::_msgpack(10); my $type = unpack 'C', $res; is $type, 10, 'fixint'; $res = DR::Tarantool::_msgpack(-10); $type = unpack 'c', $res; is $type, -10, 'negative fixint'; $res = DR::Tarantool::_msgpack(140); $type = unpack 'C', $res; is $type, 0xCC, 'positive uint8'; $res = DR::Tarantool::_msgpack(-105); $type = unpack 'C', $res; is $type, 0xD0, 'negative int8'; $res = DR::Tarantool::_msgpack(1400); $type = unpack 'C', $res; is $type, 0xCD, 'positive uint16'; $res = DR::Tarantool::_msgpack(-1400); $type = unpack 'C', $res; is $type, 0xD1, 'negative int16'; $res = DR::Tarantool::_msgpack(67000); $type = unpack 'C', $res; is $type, 0xCE, 'positive uint32'; $res = DR::Tarantool::_msgpack(-68123); $type = unpack 'C', $res; is $type, 0xD2, 'negative int32'; $res = DR::Tarantool::_msgpack(67000000000); $type = unpack 'C', $res; is $type, 0xCF, 'positive uint64'; $res = DR::Tarantool::_msgpack(-68123456789); $type = unpack 'C', $res; is $type, 0xD3, 'negative int64'; } note 'float'; { my $res = DR::Tarantool::_msgpack(10.0); my $type = unpack 'C', $res; is $type, 10, 'double as fixint'; $res = DR::Tarantool::_msgpack(-10.0); $type = unpack 'c', $res; is $type, -10, 'double as fixint'; $res = DR::Tarantool::_msgpack(10.1); $type = unpack 'C', $res; is $type, 0xCB, 'double'; } note 'nil'; { my $res = DR::Tarantool::_msgpack(undef); my $type = unpack 'C', $res; is $type, 0xC0, 'nil'; } note 'array'; { my $res = DR::Tarantool::_msgpack([]); my $type = unpack 'C', $res; is $type, 0x90, 'fixed empty array'; is length($res), 1, 'array_len'; } { my $res = DR::Tarantool::_msgpack([1, 2, 3]); my ($type, $v1, $v2, $v3) = unpack 'C*', $res; is $type, 0x93, 'fixed array'; is length($res), 1 + 3, 'array_len'; is_deeply [$v1, $v2, $v3], [1,2,3], 'values'; } note 'hash'; { my $res = DR::Tarantool::_msgpack({}); my $type = unpack 'C', $res; is $type, 0x80, 'fixed empty hash'; is length($res), 1, 'pack_len'; } { my $res = DR::Tarantool::_msgpack({ 1 => 2 }); my ($type, $v1, $v2, $v3) = unpack 'C*', $res; is $type, 0x81, 'fixed hash'; is length($res), 3, 'hash len'; diag explain [ $v1, $v2, $v3 ] unless is_deeply [ $v1, $v2 ], [ 1,2 ], 'values'; } { my $res = DR::Tarantool::_msgpack({ 'a' => 2 }); my ($type, $v1, $v2, $v3) = unpack 'C*', $res; is $type, 0x81, 'fixed hash'; is length($res), 4, 'hash len'; diag explain [ $v1, $v2, $v3 ] unless is_deeply [ $v1, chr($v2), $v3 ], [ 0xA1, 'a',2 ], 'values'; } note 'bless'; { my $res = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::Bool->new(0)); is length $res, 1, 'package length'; is $res, pack('C', 0xC2), 'false'; $res = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::FALSE); is length $res, 1, 'package length'; is $res, pack('C', 0xC2), 'false'; $res = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::Bool->new(1)); is length $res, 1, 'package length'; is $res, pack('C', 0xC3), 'true'; $res = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::TRUE); is length $res, 1, 'package length'; is $res, pack('C', 0xC3), 'false'; { package BTest; } my $tp = bless {} => 'BTest'; $res = eval { DR::Tarantool::_msgpack($tp) }; like $@, qr{msgpack}, 'error message for broken package'; } note '==================== unpack =============================='; note 'string'; { my $p = DR::Tarantool::_msgpack('test'); is DR::Tarantool::_msgunpack($p, 1), 'test', 'fixed string'; $p = DR::Tarantool::_msgpack('test' x 20); is DR::Tarantool::_msgunpack($p, 1), 'test' x 20, 'string 8'; $p = DR::Tarantool::_msgpack('test' x 200); is DR::Tarantool::_msgunpack($p, 1), 'test' x 200, 'string 16'; $p = DR::Tarantool::_msgpack('test' x 20000); is DR::Tarantool::_msgunpack($p, 1), 'test' x 20000, 'string 32'; } note 'numbers'; { my $p = DR::Tarantool::_msgpack(10); is DR::Tarantool::_msgunpack($p, 1), 10, 'fixed int'; $p = DR::Tarantool::_msgpack(-10); is DR::Tarantool::_msgunpack($p, 1), -10, 'fixed negative'; $p = DR::Tarantool::_msgpack(-100); is DR::Tarantool::_msgunpack($p, 1), -100, 'negative int8'; $p = DR::Tarantool::_msgpack(10000); is DR::Tarantool::_msgunpack($p, 1), 10000, 'uint16'; $p = DR::Tarantool::_msgpack(123333939393939); is DR::Tarantool::_msgunpack($p, 1), 123333939393939, 'uint64'; } note 'nil'; { my $p = DR::Tarantool::_msgpack(undef); is DR::Tarantool::_msgunpack($p, 1), undef, 'undef'; } note 'bool'; { my $p = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::TRUE); ok DR::Tarantool::_msgunpack($p, 1), 'true'; $p = DR::Tarantool::_msgpack(DR::Tarantool::MsgPack::FALSE); ok !DR::Tarantool::_msgunpack($p, 1), 'false'; } note 'hash'; { my $p = DR::Tarantool::_msgpack({}); is_deeply DR::Tarantool::_msgunpack($p, 1), {}, 'empty hash'; } { my $p = DR::Tarantool::_msgpack({ a => 'b' }); is_deeply DR::Tarantool::_msgunpack($p, 1), {a => 'b'}, 'non-empty hash'; } { my $p = DR::Tarantool::_msgpack({ a => 'b', c => 'd' }); is_deeply DR::Tarantool::_msgunpack($p, 1), {a => 'b', c => 'd'}, 'non-empty hash'; } { my $p = DR::Tarantool::_msgpack({ a => 'b', c => undef }); is_deeply DR::Tarantool::_msgunpack($p, 1), {a => 'b', c => undef}, 'non-empty hash'; } note 'arrays'; { my $p = DR::Tarantool::_msgpack([]); diag explain DR::Tarantool::_msgunpack($p, 1) unless is_deeply DR::Tarantool::_msgunpack($p, 1), [], 'empty array'; } { my $p = DR::Tarantool::_msgpack([ a => 'b' ]); diag explain DR::Tarantool::_msgunpack($p, 1) unless is_deeply DR::Tarantool::_msgunpack($p, 1), [a => 'b'], 'non-empty array'; } { my $p = DR::Tarantool::_msgpack([ a => 'b', c => 'd', undef ]); ok DR::Tarantool::_msgcheck($p), 'non broken msgpack'; is DR::Tarantool::_msgcheck($p), DR::Tarantool::_msgcheck($p . 'aaa'), 'msgcheck return length'; is DR::Tarantool::_msgcheck($p), length($p), 'length is valid'; diag explain DR::Tarantool::_msgunpack($p, 1) unless is_deeply DR::Tarantool::_msgunpack($p, 1), [ a => 'b', c => 'd', undef ], 'non-empty array'; } note 'unpack errors'; { my $p = substr DR::Tarantool::_msgpack([1,2,3,4,5, 6, 7, 5000]), 0, 8; is DR::Tarantool::_msgcheck($p), 0, 'broken msgpack'; ok !eval { DR::Tarantool::_msgunpack($p, 1); 1 }, '_msgpack(broken)'; like $@ => qr{Unexpected EOF}, 'message error'; } note 'utf8'; { my $p = DR::Tarantool::_msgpack(['привет']); ok $p => 'encode msgpack'; is_deeply DR::Tarantool::_msgunpack($p, 1), ['привет'], 'decode msgpack'; is_deeply DR::Tarantool::_msgunpack($p, 0), [encode utf8 => 'привет'], 'decode msgpack'; } libdr-tarantool-perl-0.44/t/1.6/022-msgpack-llclient.t0000644000000000000000000003536512414725445020706 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib ../../lib); use lib qw(blib/lib blib/arch ../blib/lib ../blib/arch ../../blib/lib ../../blib/arch); BEGIN { use constant PLAN => 128; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.6', 2)) { plan skip_all => 'tarantool 1.6 is not found'; } else { plan tests => PLAN; } } use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::MsgPack::LLClient'; } my $cfg = catfile dirname(__FILE__), 'data', 'll.lua'; my $cfgg = catfile dirname(__FILE__), 'data', 'll-grant.lua'; ok -r $cfg, "-r config file ($cfg)"; ok -r $cfgg, "-r config file ($cfgg)"; my $t = DR::Tarantool::StartTest->run( family => 2, cfg => $cfg, ); ok $t->started, 'tarantool was started'; my $tnt; note 'connect'; for my $cv (AE::cv) { $cv->begin; DR::Tarantool::MsgPack::LLClient->connect( host => '127.0.0.1', port => $t->primary_port, cb => sub { ($tnt) = @_; ok $tnt, 'connect callback'; $cv->end; } ); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; ok $tnt => 'connector was saved 1'; } unless ( isa_ok $tnt => 'DR::Tarantool::MsgPack::LLClient' ) { diag eval { decode utf8 => $tnt } || $tnt; note $t->log; exit; } note 'ping'; for my $cv (AE::cv) { $cv->begin; $tnt->ping(sub { my ($r) = @_; isa_ok $r => 'HASH', 'ping response'; ok exists $r->{CODE}, 'ping code'; ok exists $r->{SYNC}, 'ping sync'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'call'; for my $cv (AE::cv) { $cv->begin; $tnt->call_lua('box.session.id', [], sub { my ($r) = @_; isa_ok $r => 'HASH', 'call response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok exists $r->{ERROR}, 'exists error'; like $r->{ERROR} => qr[Execute access denied], 'error text'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'auth'; for my $cv (AE::cv) { $cv->begin; $tnt->auth('user1', 'password1', sub { my ($r) = @_; isa_ok $r => 'HASH', 'auth response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok exists $r->{ERROR}, 'exists error'; like $r->{ERROR} => qr[User.*is not found], 'error text'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note $t->admin(q[ box.schema.user.create('user1', { password = 'password1' }) ]); for my $cv (AE::cv) { $cv->begin; $tnt->auth('user1', 'password2', sub { my ($r) = @_; isa_ok $r => 'HASH', 'auth response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok exists $r->{ERROR}, 'exists error'; like $r->{ERROR} => qr[Incorrect password supplied], 'error text'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note $t->admin(q[ box.schema.user.grant('user1', 'read,write,execute', 'universe') ]); for my $cv (AE::cv) { $cv->begin; $tnt->auth('user1', 'password1', sub { my ($r) = @_; isa_ok $r => 'HASH', 'auth response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok !exists $r->{ERROR}, "existn't error"; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'call again'; for my $cv (AE::cv) { $cv->begin; $tnt->call_lua('box.session.id', [], sub { my ($r) = @_; isa_ok $r => 'HASH', 'call response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok !exists $r->{ERROR}, 'exists not error'; isa_ok $r->{DATA} => 'ARRAY', 'extsts data'; is scalar @{ $r->{DATA} }, 1, 'count of tuples'; cmp_ok $r->{DATA}[0], '>', 0, 'box.session.id'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } my $sid; for my $cv (AE::cv) { $cv->begin; $tnt->call_lua('box.session.id', sub { my ($r) = @_; isa_ok $r => 'HASH', 'call response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok !exists $r->{ERROR}, 'exists not error'; isa_ok $r->{DATA} => 'ARRAY', 'extsts data'; is scalar @{ $r->{DATA} }, 1, 'count of tuples'; cmp_ok $r->{DATA}[0], '>', 0, 'box.session.id'; $sid = $r->{DATA}[0]; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'autologin'; { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; for my $cv (AE::cv) { my $tnt; $cv->begin; DR::Tarantool::MsgPack::LLClient->connect( host => '127.0.0.1', port => $t->primary_port, user => 'user1', password => 'password2', cb => sub { ($tnt) = @_; ok $tnt, 'connect callback'; $cv->end; } ); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; ok $tnt => 'connector was saved'; } is scalar @warns, 1, 'One warning'; like $warns[0] => qr{Incorrect password}, 'text of warning'; } for my $cv (AE::cv) { my $tnt; $cv->begin; DR::Tarantool::MsgPack::LLClient->connect( host => '127.0.0.1', port => $t->primary_port, user => 'user1', password => 'password1', cb => sub { ($tnt) = @_; ok $tnt, 'connect callback'; $cv->end; } ); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; ok $tnt => 'connector was saved'; for my $cv (AE::cv) { $cv->begin; $tnt->call_lua('box.session.id', sub { my ($r) = @_; isa_ok $r => 'HASH', 'call response'; ok exists $r->{CODE}, 'exists code'; ok exists $r->{SYNC}, 'exists sync'; ok !exists $r->{ERROR}, 'exists not error'; isa_ok $r->{DATA} => 'ARRAY', 'extsts data'; is scalar @{ $r->{DATA} }, 1, 'count of tuples'; cmp_ok $r->{DATA}[0], '>', 0, 'box.session.id'; isnt $r->{DATA}[0], $sid, 'the other session.id'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } } { my @warns; local $SIG{__WARN__} = sub { push @warns => $_[0] }; for my $cv (AE::cv) { my $tnt; $cv->begin; DR::Tarantool::MsgPack::LLClient->connect( host => '127.0.0.1', port => $t->primary_port, user => 'user1', password => 'password2', reconnect_period => 1, reconnect_always => 1, cb => sub { ($tnt) = @_; ok $tnt, 'connect callback'; $cv->end; } ); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } is scalar @warns, 1, 'One warning'; like $warns[0] => qr{Incorrect password}, 'text of warning'; } note 'select'; $t->admin(q[box.schema.create_space('test', { id = 7 }).n]); $t->admin(q[box.space.test:create_index('pk', { type = 'tree' })]); $t->admin(q[box.space.test:insert({1,2,3})]); $t->admin(q[box.space.test:insert({2,2,3})]); { for my $cv (AE::cv) { $cv->begin; $tnt->select(6, 0, 1, sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; ok $res->{CODE}, 'code != 0'; like $res->{ERROR} => qr{Space '\#\d+' does not exist}, 'error str'; $cv->end; }); $cv->begin; $tnt->select(7, 0, 1, sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; is $res->{CODE}, 0, 'code == 0'; is_deeply $res->{DATA}, [[1, 2, 3]], 'tuple'; $cv->end; }); $cv->begin; $tnt->select(7, 0, 2, sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; is $res->{CODE}, 0, 'code == 0'; is_deeply $res->{DATA}, [[2, 2, 3]], 'tuple'; $cv->end; }); $cv->begin; $tnt->select('test', 'pk', [1], 3, 0, 'GT', sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; is $res->{CODE}, 0, 'code == 0'; is_deeply $res->{DATA}, [[2, 2, 3]], 'tuple'; $cv->end; }); $cv->begin; $tnt->select(7, 0, 3, sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; is $res->{CODE}, 0, 'code == 0'; is_deeply $res->{DATA}, [], 'tuple'; $cv->end; }); $cv->begin; $tnt->select(7, 11, 1, sub { my ($res) = @_; isa_ok $res => 'HASH', 'select response'; ok $res->{CODE}, 'code != 0'; like $res->{ERROR} => qr{No index.*is defined in space 'test'}, 'error str'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } } note 'insert'; for my $cv (AE::cv) { $cv->begin; $tnt->insert(6, [ 3, 4, 5 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; ok $res->{CODE}, 'CODE is not 0'; like $res->{ERROR} => qr{Space '\#6' does not exist}, 'error message'; $cv->end; }); $cv->begin; $tnt->insert(7, [ 3, 4, 5 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [[3, 4, 5]], 'tuple was inserted'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $cv->end; }); $cv->begin; $tnt->insert(7, [ 1, 2, 3 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; ok $res->{CODE}, 'code'; like $res->{ERROR} => qr{Duplicate key}, 'error message'; is $res->{status}, 'error', 'status'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'replace'; for my $cv (AE::cv) { $cv->begin; $tnt->replace(6, [ 3, 4, 5 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; ok $res->{CODE}, 'CODE is not 0'; like $res->{ERROR} => qr{Space '\#6' does not exist}, 'error message'; $cv->end; }); $cv->begin; $tnt->replace(7, [ 4, 5 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [[4, 5]], 'tuple was inserted'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $cv->end; }); $cv->begin; $tnt->replace(7, [ 1, 4, 5 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [[1, 4, 5]], 'tuple was replaced'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'delete'; for my $cv (AE::cv) { $cv->begin; $tnt->delete(6, [ 3 ], sub { my ($res) = shift; isa_ok $res => 'HASH'; ok $res->{CODE}, 'CODE is not 0'; like $res->{ERROR} => qr{Space '\#6' does not exist}, 'error message'; $cv->end; }); $cv->begin; $tnt->delete(7, 55, sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [], 'tuple was not found'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $cv->end; }); $cv->begin; $tnt->select(7, 0, 4, sub { my ($res) = @_; is_deeply $res->{DATA} => [[4,5]], 'tuple exists'; $tnt->delete(7, [4], sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [[4,5]], 'tuple was removed'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $tnt->select(7, 0, 4, sub { my ($res) = @_; is_deeply $res->{DATA} => [], 'tuple was removed really'; $cv->end; }); }); }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } note 'update'; for my $cv (AE::cv) { $cv->begin; $tnt->update(6, 1, [ ], sub { my ($res) = shift; isa_ok $res => 'HASH'; ok $res->{CODE}, 'CODE is not 0'; like $res->{ERROR} => qr{Space '\#6' does not exist}, 'error message'; $cv->end; }); $cv->begin; $tnt->update(7, 55, [['+', 1, 1]], sub { my ($res) = shift; isa_ok $res => 'HASH'; is_deeply $res->{DATA} => [], 'tuple was not found'; is $res->{CODE}, 0, 'code'; is $res->{status}, 'ok', 'status'; $cv->end; }); $cv->begin; $tnt->select(7, 0, 1, sub { my ($res) = @_; is_deeply $res->{DATA}, [[1,4,5]], 'data in db'; $tnt->update(7, 1, [['+', 1, 1], ['-', 2, 1], ['-', 2, 2]], sub { my ($res) = @_; ok $res->{CODE}, 'code != 0'; like $res->{ERROR} => qr{double update of the same field}, 'error msg'; $cv->end; }); }); $cv->begin; $tnt->update(7, 1, [['+', 1, 1], ['-', 2, 3]], sub { my ($res) = @_; is_deeply $res->{DATA}, [[1,5,2]], 'data after update'; $cv->end; }); my $timer; $timer = AE::timer 1.5, 0, sub { $cv->end }; $cv->recv; undef $timer; } libdr-tarantool-perl-0.44/t/100-transform.t0000644000000000000000000000712512414722067017147 0ustar rootroot#!/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); BEGIN { use constant PLAN => 17; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool', 'tarantool'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile', 'rel2abs'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::AsyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy.cfg'; ok -r $tcfg, $tcfg; my $script_dir = catfile dirname(__FILE__), 'test-data'; my $lua_file = catfile $script_dir, 'init.lua'; ok -d $script_dir, "-d $script_dir"; ok -r $lua_file, "-r $lua_file"; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg, script_dir => $script_dir ); my $spaces = { 1 => { name => 'test_space', fields => [ { name => 'id', type => 'STR', }, ], indexes => { 0 => 'id', }, }, }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 11; } my $client = tarantool port => $tnt->primary_port, spaces => $spaces; ok $client, 'Connected'; $client->insert(test_space => [ 1 .. 10 ]); my $tuple = $client->select(test_space => 1); is_deeply $tuple->raw, [ 1 .. 10 ], 'tuple was written'; $tuple = $client->call_lua('box.dostring', [ "return box.select(1, 0, '1')" ] => 'test_space' ); is_deeply $tuple->raw, [ 1 .. 10 ], 'tuple was read by dostring'; $tuple = $client->call_lua('box.dostring', [ "local tuple = box.select(1, 0, '1'); return tuple" ] => 'test_space' ); is_deeply [$tuple->raw], [[ 1 .. 10 ]], 'tuple was read by dostring'; $tuple = $client->call_lua('box.dostring', [ q^ local tuple = box.select(1, 0, '1') tuple = tuple:transform( #tuple, 0, ... ) tuple = tuple:transform( 1, 1 ) return { tuple:unpack() } ^, 11, 12, 13, 14 ] => 'test_space' ); diag explain $tuple->raw unless is_deeply [$tuple->raw], [[ 1, 3 .. 14 ]], 'tuple was read by dostring'; $tuple = eval { $client->call_lua('box.dostring', [ q^ local tuple = box.select(1, 0, '1') tuple = tuple:transform( #tuple, 0, ... ) tuple = tuple:transform( 1, 1 ) return tuple ^, 11, 12, 13, 14 ] => 'test_space' ); }; diag explain eval { $tuple->raw } unless is_deeply [eval { $tuple->raw }], [[ 1, 3 .. 14 ]], 'tuple was read'; ok !$tnt->is_dead, 'Tarantool is still working'; } libdr-tarantool-perl-0.44/t/050-async-client.t0000644000000000000000000002664012414721401017523 0ustar rootroot#!/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 constant PLAN => 80; use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::AsyncClient'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', } ], indexes => { 0 => 'id', 1 => 'name', 2 => { name => 'tidx', fields => [ 'key', 'password' ] }, }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 9; } my $client; # connect for my $cv (condvar AnyEvent) { DR::Tarantool::AsyncClient->connect( port => $tnt->primary_port, reconnect_period => 0.1, spaces => $spaces, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } unless ( isa_ok $client => 'DR::Tarantool::AsyncClient' ) { diag eval { decode utf8 => $client } || $client; last; } # ping for my $cv (condvar AnyEvent) { $client->ping( sub { my ($status) = @_; is $status, 'ok', '* ping'; $cv->send; } ); $cv->recv; } # insert for my $cv (condvar AnyEvent) { $cv->begin; $client->insert( 'first_space', [ 10, 'user', 11, 'password' ], TNT_FLAG_RETURN, sub { my ($status, $res) = @_; is $status, 'ok', '* insert status'; is $res->id, 10, 'id'; is $res->name, 'user', 'name'; is $res->key, 11, 'key'; is $res->password, 'password', 'password'; $cv->end; } ); $cv->begin; $client->insert( 'first_space', [ 111, 'user2', 13, 'password2' ], TNT_FLAG_RETURN, sub { my ($status, $res) = @_; is $status, 'ok', '* insert status'; is $res->id, 111, 'id'; is $res->name, 'user2', 'name'; is $res->key, 13, 'key'; is $res->password, 'password2', 'password'; $cv->end; } ); $cv->begin; $client->insert( 'first_space', [ 10, 'user', 11, 'password' ], TNT_FLAG_RETURN | TNT_FLAG_ADD, sub { my ($status, $code, $error) = @_; is $status, 'error', 'status'; ok $code, 'code'; like $error, qr{exists}, 'tuple already exists'; $cv->end; } ); $cv->recv; } # call lua for my $cv (condvar AnyEvent) { $cv->begin; $client->call_lua( 'box.select' => [ 0, 0, 10 ], fields => [ { type => 'NUM', name => 'a' }, 'b', { type => 'NUM', name => 'c'}, 'd' ], args => [ 's', 'i', { type => 'NUM' } ], sub { my ($status, $tuple) = @_; is $status, 'ok', '* call status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple packed'; is $tuple->a, 10, 'id'; is $tuple->b, 'user', 'name'; is $tuple->c, 11, 'key'; $cv->end; } ); $cv->begin; $client->call_lua( 'box.select' => [ 0, 0, 10 ], space => 'first_space', args => [ 's', 'i', { type => 'NUM' } ], sub { my ($status, $tuple) = @_; is $status, 'ok', 'status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple packed'; is $tuple->id, 10, 'id'; is $tuple->name, 'user', 'name'; is $tuple->key, 11, 'key'; is $tuple->password, 'password', 'password'; $cv->end; } ); $cv->begin; $client->call_lua( 'box.select' => [ 0, 0, 10 ], args => [ 's', 'i', { type => 'NUM' } ], sub { my ($status, $tuple) = @_; is $status, 'ok', 'status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple packed'; SKIP: { skip 'there is no tuple', 4 unless $tuple; is unpack("L$LE", $tuple->raw(0)), 10, 'id'; is $tuple->raw(1), 'user', 'name'; is unpack("L$LE", $tuple->raw(2)), 11, 'key'; is $tuple->raw(3), 'password', 'password'; } $cv->end; } ); $cv->begin; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE" => 10 ], 'first_space', sub { my ($status, $tuple) = @_; is $status, 'ok', 'status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple packed'; is $tuple->id, 10, 'id'; is $tuple->name, 'user', 'name'; is $tuple->key, 11, 'key'; is $tuple->password, 'password', 'password'; $cv->end; } ); $cv->begin; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE" => 11 ], 'first_space', sub { my ($status, $tuple) = @_; is $status, 'ok', 'status'; is $tuple, undef, 'there is no tuple'; $cv->end; } ); $cv->begin; $client->call_lua( 'unknown_function_name' => [ ], 'first_space', sub { my ($status, $code, $errstr) = @_; is $status, 'error', 'status'; cmp_ok $code, '>', 0, 'code'; like $errstr, qr{Procedure .* is not defined}, 'errstr'; $cv->end; } ); $cv->recv; } # select for my $cv (condvar AnyEvent) { $cv->begin; $client->select(first_space => [[10], [11], [111]], 'i0', sub { my ($status, $tuple) = @_; is $status, 'ok', '* select status'; my $iter = $tuple->iter; is $iter->count, 2, 'count of elements'; is $tuple->id, 10, 'tuple(0)->id'; is $iter->next->id, 10, 'tuple(0)->id'; is $tuple->next->id, 111, 'tuple(1}->id'; is $iter->next->id, 111, 'tuple(1)->id'; $cv->end; }); $cv->begin; $client->select( first_space => [[10], [11], [111]], limit => 1, index => 'i0', sub { my ($status, $tuple) = @_; is $status, 'ok', 'select (limit) status'; my $iter = $tuple->iter; is $iter->count, 1, 'count of elements'; is $tuple->id, 10, 'tuple(0)->id'; is $iter->next->id, 10, 'tuple(0)->id'; $cv->end; } ); $cv->begin; $client->select( first_space => [[10], [11], [111]], limit => 1, offset => 1, index => 'i0', sub { my ($status, $tuple) = @_; is $status, 'ok', 'select (limit) status'; my $iter = $tuple->iter; is $iter->count, 1, 'count of elements'; is $tuple->id, 111, 'tuple(0)->id'; is $iter->next->id, 111, 'tuple(0)->id'; $cv->end; } ); $cv->begin; $client->select(first_space => [[11, 'password']], 'tidx', sub { my ($status, $tuple) = @_; is $status, 'ok', 'select status (not primary index)'; my $iter = $tuple->iter; is $iter->count, 1, 'count of elements'; is $tuple->id, 10, 'tuple(0)->id'; $cv->end; }); $cv->recv; } # delete for my $cv (condvar AnyEvent) { $cv->begin; $client->delete(first_space => 10, sub { my ($status, $tuple) = @_; is $status, 'ok', '* delete status'; $cv->end; }); $cv->begin; $client->select(first_space => 10, sub { my ($status, $tuple) = @_; is $status, 'ok', 'select deleted status'; is $tuple, undef, 'there is no tuple'; $cv->end; }); $cv->recv; } # update for my $cv (condvar AnyEvent) { $cv->begin; $client->update(first_space => 111, [ name => set => 'привет1' ], sub { my ($status, $tuple) = @_; is $status, 'ok', '* update status'; is $tuple, undef, 'tuple'; $cv->end; }); $cv->begin; $client->update(first_space => 111, [ name => set => 'привет' ], TNT_FLAG_RETURN, sub { my ($status, $tuple) = @_; is $status, 'ok', '* update status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple was selected'; is $tuple->name, 'привет', 'field was updated'; $cv->end; }); $cv->begin; $client->select(first_space => 111, sub { my ($status, $tuple) = @_; is $status, 'ok', 'select deleted status'; isa_ok $tuple => 'DR::Tarantool::Tuple', 'tuple was selected'; is $tuple->name, 'привет', 'field was updated'; $cv->end; }); $cv->recv; } } libdr-tarantool-perl-0.44/t/020-low_level_client.t0000644000000000000000000003754412414721274020472 0ustar rootroot#!/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); BEGIN { use constant PLAN => 100; use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 7; } my $client; # connect for my $cv (condvar AnyEvent) { DR::Tarantool::LLClient->connect( port => $tnt->primary_port, reconnect_period => 0.1, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } unless ( isa_ok $client => 'DR::Tarantool::LLClient' ) { diag eval { decode utf8 => $client } || $client; last; } # ping for my $cv (condvar AnyEvent) { $client->ping( sub { my ($res) = @_; is $res->{code}, 0, '* ping reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_PING, 'type'; is $client->last_code, 0, 'operation code'; is $client->last_error_string, undef, 'operation errstr'; $cv->send; } ); $cv->recv; } # insert for my $cv (condvar AnyEvent) { my $cnt = 3; $client->insert( 0, [ pack("L$LE", 1), 'abc', pack "L$LE", 1234 ], TNT_FLAG_RETURN, sub { my ($res) = @_; is $res->{code}, 0, '* insert reply code'; is $res->{status}, 'ok', 'status'; is $client->last_code, 0, 'operation code'; is $client->last_error_string, undef, 'operation errstr'; is $res->{type}, TNT_INSERT, 'type'; is $res->{tuples}[0][0], pack("L$LE", 1), 'key'; is $res->{tuples}[0][1], 'abc', 'f1'; $cv->send if --$cnt == 0; } ); $client->insert( 0, [ pack("L$LE", 2), 'cde', pack "L$LE", 4567 ], TNT_FLAG_RETURN, sub { my ($res) = @_; is $res->{code}, 0, 'insert reply code'; is $client->last_code, 0, 'operation code'; is $client->last_error_string, undef, 'operation code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_INSERT, 'type'; is $res->{tuples}[0][0], pack("L$LE", 2), 'key'; is $res->{tuples}[0][1], 'cde', 'f1'; $cv->send if --$cnt == 0; } ); $client->insert( 0, [ pack("L$LE", 1), 'aaa', pack "L$LE", 1234 ], TNT_FLAG_RETURN | TNT_FLAG_ADD, sub { my ($res) = @_; is $res->{code} & 0x00002002, 0x00002002, 'insert reply code (already exists)'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; is $res->{status}, 'error', 'status'; is $res->{type}, TNT_INSERT, 'type'; like $res->{errstr}, qr{Duplicate key exists|Tuple already exists}, 'errstr'; $cv->send if --$cnt == 0; } ); $cv->recv; } # select for my $cv (condvar AnyEvent) { my $cnt = 2; $client->select( 0, # ns 0, # idx [ [ pack "L$LE", 1 ], [ pack "L$LE", 2 ] ], 2, # limit 0, # offset sub { my ($res) = @_; is $res->{code}, 0, '* select reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_SELECT, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; is scalar(grep { $_->[1] and $_->[1] eq 'abc' } @{ $res->{tuples} }), 1, 'first tuple' ; is scalar(grep { $_->[1] and $_->[1] eq 'cde' } @{ $res->{tuples} }), 1, 'second tuple' ; $cv->send if --$cnt == 0; } ); $client->select( 0, #ns 0, #idx [ [ pack "L$LE", 3 ], [ pack "L$LE", 4 ] ], sub { my ($res) = @_; is $res->{code}, 0, 'select reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_SELECT, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; ok !@{ $res->{tuples} }, 'empty response'; $cv->send if --$cnt == 0; } ); $cv->recv; } # update for my $cv (condvar AnyEvent) { my $cnt = 2; $client->update( 0, # ns [ pack "L$LE", 1 ], # keys [ [ 1 => set => 'abcdef' ], [ 1 => substr => 2, 2, ], [ 1 => substr => 100, 1, 'tail' ], [ 2 => 'delete' ], [ 2 => insert => pack "L$LE" => 123 ], [ 3 => insert => 'third' ], [ 4 => insert => 'fourth' ], ], TNT_FLAG_RETURN, # flags sub { my ($res) = @_; is $res->{code}, 0, '* update reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_UPDATE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; is $res->{tuples}[0][1], 'abeftail', 'updated tuple 1'; is $res->{tuples}[0][2], (pack "L$LE", 123), 'updated tuple 2'; is $res->{tuples}[0][3], 'third', 'updated tuple 3'; is $res->{tuples}[0][4], 'fourth', 'updated tuple 4'; $cv->send if --$cnt == 0; } ); $client->update( 0, # ns [ pack "L$LE", 2 ], # keys [ [ 1 => set => 'abcdef' ], [ 2 => or => pack "L$LE", 23 ], [ 2 => and => pack "L$LE", 345 ], [ 2 => xor => pack "L$LE", 744 ], ], TNT_FLAG_RETURN, # flags sub { my ($res) = @_; is $res->{code}, 0, '* update reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_UPDATE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; is $res->{tuples}[0][1], 'abcdef', 'updated tuple 1'; is $res->{tuples}[0][2], (pack "L$LE", ( (4567 | 23) & 345 ) ^ 744 ), 'updated tuple 2' ; $cv->send if --$cnt == 0; } ); $cv->recv; } # delete for my $cv (condvar AnyEvent) { my $cnt = 2; $client->delete( 0, # ns [ pack "L$LE", 1 ], # keys TNT_FLAG_RETURN, # flags sub { my ($res) = @_; is $res->{code}, 0, '* delete reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_DELETE, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; SKIP: { skip 'Old version of delete', 4 unless TNT_DELETE == 21; is $res->{tuples}[0][1], 'abeftail', 'deleted tuple 1'; is $res->{tuples}[0][2], (pack "L$LE", 123), 'deleted tuple 2'; is $res->{tuples}[0][3], 'third', 'deleted tuple 3'; is $res->{tuples}[0][4], 'fourth', 'deleted tuple 4'; } $cv->send if --$cnt == 0; } ); $client->select( 0, # ns 0, # idx [ [ pack "L$LE", 1 ], [ pack "L$LE", 1 ] ], sub { my ($res) = @_; is $res->{code}, 0, '* select reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_SELECT, 'type'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; ok !@{ $res->{tuples} }, 'really removed'; $cv->send if --$cnt == 0; } ); $cv->recv; } # call for my $cv (condvar AnyEvent) { my $cnt = 1; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE", 2 ], 0, sub { my ($res) = @_; is $res->{code}, 0, '* call reply code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_CALL, 'type'; is $res->{tuples}[0][1], 'abcdef', 'updated tuple 1'; is $client->last_code, $res->{code}, 'operation code'; is $client->last_error_string, $res->{errstr}, 'operation errstr'; is $res->{tuples}[0][2], (pack "L$LE", ( (4567 | 23) & 345 ) ^ 744 ), 'updated tuple 2' ; $cv->send if --$cnt == 0; } ); $cv->recv; } # memory leak (You have touse external tool to watch memory) if ($ENV{LEAK_TEST}) { for my $cv (condvar AnyEvent) { my $cnt = 1000000; my $tmr; $tmr = AE::timer 0.0001, 0.0001 => sub { $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE", 2 ], 0, sub { if (--$cnt == 0) { $cv->send; undef $tmr; } } ); DR::Tarantool::LLClient->connect( port => $tnt->primary_port, reconnect_period => 100, cb => sub { if (--$cnt == 0) { $cv->send; undef $tmr; } } ); }; $cv->recv; } } $client->_fatal_error('abc'); ok !$client->is_connected, 'disconnected'; for my $cv (condvar AnyEvent) { my $tmr; $tmr = AE::timer 0.5, 0, sub { undef $tmr; $cv->send }; $cv->recv; } ok $client->is_connected, 'reconnected'; # call after reconnect for my $cv (condvar AnyEvent) { my $cnt = 1; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE", 2 ], 0, sub { my ($res) = @_; is $res->{code}, 0, '* call after reconnect code'; is $res->{status}, 'ok', 'status'; is $res->{type}, TNT_CALL, 'type'; is $res->{tuples}[0][1], 'abcdef', 'tuple 1'; $cv->send if --$cnt == 0; } ); $cv->recv; } for my $cv (condvar AnyEvent) { my $timer; $timer = AE::timer 0, .5, sub { undef $timer; $cv->send; }; $cv->recv; } $tnt->kill; # socket error for my $cv (condvar AnyEvent) { my $cnt = 1; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE", 2 ], 0, sub { my ($res) = @_; is $res->{status}, 'fatal', '* fatal status'; like $res->{errstr} => qr{Socket error}, 'Error string'; is $res->{errstr}, $client->last_error_string, 'last_error_string'; ok $client->last_code, 'last_code'; $cv->send if --$cnt == 0; } ); $cv->recv; } $tnt->restart; for my $cv (condvar AnyEvent) { my $cnt = 1; $client->call_lua( 'box.select' => [ 0, 0, pack "L$LE", 2 ], 0, sub { my ($res) = @_; is $res->{status}, 'ok', 'request after reconnect was ok'; is $res->{tuples}[0][1], 'abcdef', 'tuple 1'; is $client->last_code, 0, 'last_code'; $cv->send if --$cnt == 0; } ); $cv->recv; } $tnt->kill; # connect to shotdowned tarantool for my $cv (condvar AnyEvent) { DR::Tarantool::LLClient->connect( port => $tnt->primary_port, reconnect_period => 0, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } ok !ref $client, 'First unsuccessful connect'; for my $cv (condvar AnyEvent) { DR::Tarantool::LLClient->connect( port => $tnt->primary_port, reconnect_period => 100, cb => sub { $client = shift; $cv->send; } ); $cv->recv; } ok !ref $client, 'First unsuccessful connect without repeats'; { my $done_reconnect = 0; for my $cv (condvar AnyEvent) { DR::Tarantool::LLClient->connect( port => $tnt->primary_port, reconnect_period => .1, reconnect_always => 1, cb => sub { $done_reconnect++; } ); my $timer; $timer = AE::timer .5, 0 => sub { undef $timer; $cv->send; }; $cv->recv; } ok !$done_reconnect, 'reconnect_always option'; } # note $tnt->log; } libdr-tarantool-perl-0.44/t/130-reconnect.t0000644000000000000000000000375512414725705017126 0ustar rootroot#!/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 constant PLAN => 17; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2', 1)) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } use Encode qw(decode encode); BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool::SyncClient'; use_ok 'File::Spec::Functions'; use_ok 'File::Basename', 'dirname'; use_ok 'AnyEvent'; } sub pause($) { my $t = shift; my $cv = AE::cv; my $tmr; $tmr = AE::timer $t, 0, sub { undef $tmr; $cv->send; }; $cv->recv; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg ); ok $tnt->started, 'tarantool is started'; my $client = DR::Tarantool::SyncClient->connect( port => $tnt->primary_port, spaces => {} ); my $client2 = DR::Tarantool::SyncClient->connect( port => $tnt->primary_port, spaces => {}, reconnect_period => .1, reconnect_always => 1, ); ok $client->ping, 'ping'; ok $client2->ping, 'client2->ping'; $tnt->kill(-9); ok !$tnt->started, 'tarantool is not started'; ok !$client->ping, 'does not ping'; ok !$client->ping, 'does not ping'; ok !$client2->ping, 'does not client2->ping'; ok !$client2->ping, 'does not client2->ping'; $tnt->restart; ok $tnt->started, 'tarantool is started'; pause .3; ok $client2->ping, 'does not client2->ping'; libdr-tarantool-perl-0.44/t/910-pod.t0000644000000000000000000000020112123045772015711 0ustar rootrootuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); libdr-tarantool-perl-0.44/t/065-realsync-client.t0000644000000000000000000001456612414721504020244 0ustar rootroot#!/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 constant PLAN => 62; use Encode qw(decode encode); my $LE = $] > 5.01 ? '<' : ''; BEGIN { use Test::More; use DR::Tarantool::StartTest; unless (DR::Tarantool::StartTest::is_version('1.5.2')) { plan skip_all => 'Incorrect tarantool version'; } else { plan tests => PLAN; } } BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::LLClient', 'tnt_connect'; use_ok 'DR::Tarantool::StartTest'; use_ok 'DR::Tarantool', ':constant'; use_ok 'File::Spec::Functions', 'catfile'; use_ok 'File::Basename', 'dirname', 'basename'; use_ok 'AnyEvent'; use_ok 'DR::Tarantool::RealSyncClient'; use_ok 'Time::HiRes'; } my $cfg_dir = catfile dirname(__FILE__), 'test-data'; ok -d $cfg_dir, 'directory with test data'; my $tcfg = catfile $cfg_dir, 'llc-easy2.cfg'; ok -r $tcfg, $tcfg; my $tnt = run DR::Tarantool::StartTest( cfg => $tcfg, script_dir => catfile(dirname(__FILE__), 'test-data') ); my $spaces = { 0 => { name => 'first_space', fields => [ { name => 'id', type => 'NUM', }, { name => 'name', type => 'UTF8STR', }, { name => 'key', type => 'NUM', }, { name => 'password', type => 'STR', }, { name => 'json', type => 'JSON', } ], indexes => { 0 => 'id', 1 => 'name', 2 => [ 'key', 'password' ], }, } }; SKIP: { unless ($tnt->started and !$ENV{SKIP_TNT}) { diag $tnt->log unless $ENV{SKIP_TNT}; skip "tarantool isn't started", PLAN - 9; } my $client = DR::Tarantool::RealSyncClient->connect( port => $tnt->primary_port, spaces => $spaces ); isa_ok $client => 'DR::Tarantool::RealSyncClient'; is $client->last_code, undef, 'last_code'; is $client->last_error_string, undef, 'last_error_string'; ok $client->ping, '* ping'; my $t = $client->insert( first_space => [ 1, 'привет', 2, 'test' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', '* insert tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->insert( first_space => [ 2, 'медвед', 3, 'test2' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'insert tuple packed'; is $t->id, 2, 'id'; is $t->name, 'медвед', 'name'; is $t->key, 3, 'key'; is $t->password, 'test2', 'password'; $t = $client->call_lua('box.select' => [ 0, 0, pack "L$LE" => 1 ], 'first_space'); isa_ok $t => 'DR::Tarantool::Tuple', '* call tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 1); isa_ok $t => 'DR::Tarantool::Tuple', '* select tuple packed'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => 'привет', 'i1'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i1)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->select(first_space => [[2, 'test']], 'i2'); isa_ok $t => 'DR::Tarantool::Tuple', 'select tuple packed (i2)'; is $t->id, 1, 'id'; is $t->name, 'привет', 'name'; is $t->key, 2, 'key'; is $t->password, 'test', 'password'; $t = $client->update(first_space => 2 => [ name => set => 'привет1' ]); is $t, undef, '* update without flags'; $t = $client->update( first_space => 2 => [ name => set => 'привет медвед' ], TNT_FLAG_RETURN ); isa_ok $t => 'DR::Tarantool::Tuple', 'update with flags'; is $t->name, 'привет медвед', '$t->name'; $t = $client->insert(first_space => [1, 2, 3, 4, undef], TNT_FLAG_RETURN); is $t->json, undef, 'JSON insert: undef'; $t = $client->insert(first_space => [1, 2, 3, 4, 22], TNT_FLAG_RETURN); is $t->json, 22, 'JSON insert: scalar'; $t = $client->insert(first_space => [1, 2, 3, 4, 'тест'], TNT_FLAG_RETURN); is $t->json, 'тест', 'JSON insert: utf8 scalar'; $t = $client->insert( first_space => [ 1, 2, 3, 4, { a => 'b' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{a}, 'b', 'JSON insert: hash value'; ok !eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'raise error'; like $@, qr{Duplicate key exists|Tuple already exists}, 'error message'; { local $client->{llc}{raise_error}; ok eval { $client->insert( first_space => [ 1 .. 10 ], TNT_FLAG_RETURN | TNT_FLAG_ADD ); 1 }, 'no raise error'; like $client->last_error_string, qr{Duplicate key exists|Tuple already exists}, 'error message'; } $t = $client->insert( first_space => [ 1, 2, 3, 4, { привет => 'медвед' } ], TNT_FLAG_RETURN ); isa_ok $t->json => 'HASH', 'JSON insert: hash'; is $t->json->{привет}, 'медвед', 'JSON insert: hash utf8 value'; ok $t = $client->delete(first_space => [ 1 ], TNT_FLAG_RETURN), 'delete'; is $t->json->{привет}, 'медвед', 'JSON delete: hash utf8 value'; note 'EINTR'; { $SIG{ALRM} = sub { ok 1 , 'SIG{ALRM} received' }; Time::HiRes::alarm .5; is_deeply $client->call_lua('sleep_and_return', [2, 'rv'])->raw, ['rv'], 'response received'; } } libdr-tarantool-perl-0.44/t/040-tuple.t0000644000000000000000000001206012123045772016260 0ustar rootroot#!/usr/bin/perl use warnings; use strict; use utf8; use open qw(:std :utf8); use lib qw(lib ../lib); use Test::More tests => 67; use Encode qw(decode encode); use Carp; my $LE = $] > 5.01 ? '<' : ''; BEGIN { # Подготовка объекта тестирования для работы с utf8 my $builder = Test::More->builder; binmode $builder->output, ":utf8"; binmode $builder->failure_output, ":utf8"; binmode $builder->todo_output, ":utf8"; use_ok 'DR::Tarantool::Spaces'; use_ok 'DR::Tarantool::Tuple'; } my $s = DR::Tarantool::Spaces->new({ 0 => { name => 'test', default_type => 'NUM', fields => [ qw(a b c), { type => 'UTF8STR', name => 'd' }, { type => 'NUM64', name => 'a123', }, { type => 'STR', name => 'abcd', } ], indexes => { 0 => [ qw(a b) ], 1 => 'd' } } }); my $tp = new DR::Tarantool::Tuple( [ 'aa', 'bb', 'cc' ], $s->space('test') ); isa_ok $tp => 'DR::Tarantool::Tuple'; is $tp->raw(0), 'aa', 'raw(0)'; is $tp->a, 'aa', 'raw(0)'; is $tp->raw(1), 'bb', 'raw(1)'; is $tp->b, 'bb', 'raw(1)'; is $tp->raw(2), 'cc', 'raw(2)'; is $tp->c, 'cc', 'raw(2)'; cmp_ok join(':', @{ $tp->raw }), 'eq', 'aa:bb:cc', 'raw'; is $tp->raw(3), undef, 'raw(3)'; is $tp->d, undef, 'raw(3)'; ok !eval { $tp->unknown; 1 }, 'unknown'; my $tp2 = $tp->next(['dd', 'ee']); my $tp3 = $tp->next(['ff', 'gg']); isa_ok $tp2 => 'DR::Tarantool::Tuple'; isa_ok $tp3 => 'DR::Tarantool::Tuple'; is $tp2->raw(0), 'dd', 'tp2->raw(0)'; is $tp2->raw(1), 'ee', 'tp2->raw(1)'; is $tp3->raw(0), 'ff', 'tp3->raw(0)'; is $tp3->raw(1), 'gg', 'tp3->raw(1)'; my $it = $tp->iter; isa_ok $it => 'DR::Tarantool::Iterator'; is $it->count, 3, 'count'; $tp = $it->next; is $tp->raw(0), 'aa', 'raw(0)'; is $tp->raw(1), 'bb', 'raw(1)'; $tp = $it->next; is $tp->raw(0), 'dd', 'raw(0)'; is $tp->raw(1), 'ee', 'raw(1)'; $tp = $it->next; is $tp->raw(0), 'ff', 'raw(0)'; is $tp->raw(1), 'gg', 'raw(1)'; $tp = $it->next; is $tp, undef, 'iterator finished'; my @tlist = $it->all; is scalar(@tlist), 3, '3 items by ->all'; is $tlist[0]->a, 'aa', 'item[0].raw(0)'; is $tlist[0]->b, 'bb', 'item[0].raw(1)'; is $tlist[1]->a, 'dd', 'item[1].raw(0)'; is $tlist[1]->b, 'ee', 'item[1].raw(1)'; is $tlist[2]->a, 'ff', 'item[2].raw(0)'; is $tlist[2]->b, 'gg', 'item[2].raw(1)'; @tlist = $it->all('a'); is scalar @tlist, 3, '3 items by ->all("a")'; cmp_ok join(':', @tlist), 'eq', 'aa:dd:ff', 'items were fetched properly'; while( my $t = $it->next ) { isa_ok $t => 'DR::Tarantool::Tuple'; } while( my $t = $it->next ) { isa_ok $t => 'DR::Tarantool::Tuple'; } $tp = new DR::Tarantool::Tuple( [ [ 'aa' ], [ 'bb' ], [ 'cc' ] ], $s->space('test') ); is $tp->raw(0), 'aa', 'tuple[0]'; is $tp->next->raw(0), 'bb', 'tuple[0]'; is $tp->next->next->raw(0), 'cc', 'tuple[0]'; $tp = DR::Tarantool::Tuple->unpack( [ pack("L$LE", 10), pack("L$LE", 20) ], $s->space('test') ); isa_ok $tp => 'DR::Tarantool::Tuple'; is $tp->raw(0), 10, 'raw(0)'; is $tp->raw(1), 20, 'raw(1)'; $tp = new DR::Tarantool::Tuple( [ [ 'aa' ], [ 'bb' ], ], $s->space('test') ); isa_ok $tp => 'DR::Tarantool::Tuple'; is $tp->iter->count, 2, 'create tuple list'; my $iter = $tp->iter; isa_ok $iter => 'DR::Tarantool::Iterator', 'iterator'; isa_ok $iter->next => 'DR::Tarantool::Tuple', 'no iterator class'; $iter = $tp->iter('TestItem', 'new1'); isa_ok $iter => 'DR::Tarantool::Iterator', 'iterator with TestItem'; $tp = $iter->next; isa_ok $tp => 'TestItem'; isa_ok $tp->{tuple} => 'DR::Tarantool::Tuple'; is $tp->{tuple}->raw(0), 'aa', 'tuple(0).raw(0)'; is $iter->next->{tuple}->raw(0), 'bb', 'tuple(1).raw(0)'; $tp = DR::Tarantool::Tuple->new([ [ 'aa' ], [ 'bb' ], ], $s->space('test')); $iter = $tp->iter; undef $tp; is $iter->count, 2, 'iterator saves tuple ref'; # You have to use external tool to watch memory while($ENV{LEAK_TEST}) { $tp = DR::Tarantool::Tuple->new([ [ 'aa' ], [ 'bb' ], ], $s->space('test')); $tp = $tp->iter('TestItem', 'new1')->next; } $tp = DR::Tarantool::Tuple->new([ [ 'bb' ], [ 'cc' ], ], $s->space('test')); $iter = $tp->iter('TestItem'); is_deeply $iter->next, bless([ 'bb' ] => 'TestItem'), 'iter without constructor name'; is_deeply $iter->next, bless([ 'cc' ] => 'TestItem'), 'iter without constructor name'; is_deeply $iter->item(1), bless([ 'cc' ] => 'TestItem'), 'iter without constructor name'; is_deeply $iter->item(-1), bless([ 'cc' ] => 'TestItem'), 'iter without constructor name'; isa_ok $iter->{items}[0] => 'ARRAY', "item[0] isn't blessed"; isa_ok $iter->{items}[1] => 'ARRAY', "item[1] isn't blessed"; $tp = DR::Tarantool::Tuple->new([ qw(a b c d e f g h i) ], $s->space('test')); is_deeply $tp->raw, [ qw(a b c d e f g h i) ], 'tuple->raw'; is_deeply $tp->tail, [ qw(g h i) ], 'tuple->tail'; package TestItem; sub new1 { my ($class, $tuple) = @_; return bless { tuple => $tuple } => $class; } libdr-tarantool-perl-0.44/t/900-podspell.t0000644000000000000000000000070112347544137016764 0ustar rootrootuse Test::More; eval q{ use Test::Spelling }; plan skip_all => "Test::Spelling is not installed." if $@; add_stopwords(); set_spell_cmd("aspell -l en list"); all_pod_files_spelling_ok('lib'); __DATA__ VCS tuple tuples tarantool github repo NUM async cb errstr lua JSON STR UTF coro errorstr destructor ok cfg utf happenned ator autoloads iter itemlist LLClient Destructor Tuple API BIGMONEY TODO deserialized iproto multi unicode msgpack auth libdr-tarantool-perl-0.44/st/0000775000000000000000000000000012123045772014627 5ustar rootrootlibdr-tarantool-perl-0.44/st/Check/0000775000000000000000000000000012123045772015644 5ustar rootrootlibdr-tarantool-perl-0.44/st/Check/Ping.pm0000644000000000000000000000123612123045772017077 0ustar rootrootuse utf8; use strict; use warnings; package Check::Ping; use constant ITERATIONS => cfg 'check.ping.iterations'; sub start { my $done_time = 0; my $total = 0; while(1) { my $started = now(); for (my $i = 0; $i < ITERATIONS; $i++) { die "Can't ping tarantool\n" unless tnt->ping; } my $period = now() - $started; $done_time += $period; $total += ITERATIONS; df "done %d pings in %3.2f seconds", $total, $done_time ; df "%d r/s, %3.5f s/r", $total / $done_time, $done_time / $total ; } } 1; libdr-tarantool-perl-0.44/st/Check/Order.pm0000644000000000000000000000417312123045772017260 0ustar rootrootuse utf8; use strict; use warnings; package Check::Order; use constant ITERATIONS => cfg 'check.order.iterations'; use DR::Tarantool ':constant'; sub start { my $done_time = 0; my $total = 0; my $errors = 0; while(1) { my $started = now(); my $sid = uuid; my $pid = uuid; my @orders; for (my $i = 0; $i < ITERATIONS; $i++) { push @orders => tnt->call_lua(order_add => [ uuid, $pid, uuid, now(), 'request', $sid, uuid, '', '' ] => 'orders'); } for (@orders) { $_ = [ $_, tnt->call_lua(order_add => [ $_->oid, $_->pid, $_->oid_in_pid, now(), ( ( int rand 100 < 50 ) ? 'request' : 'confirm' ), $_->sid, $_->did, '', '' ] => 'orders') ]; $errors++ if error(( !$_->[1] or !(@{ $_->[1]->raw } - 1 == @{ $_->[0]->raw }) ), 'update' ); } for (@orders) { my $o = tnt->delete(orders => $_->[0]->oid, TNT_FLAG_RETURN); $errors++ if error(( !$_->[-1] or !$o or !(@{ $_->[-1]->raw } ~~ @{ $o->raw }) ), 'delete' ); } my $period = now() - $started; $done_time += $period; $total += ITERATIONS; df "done %d iterations in %3.2f seconds (%d errors)", $total, $done_time, $errors ; df "%d r/s, %3.5f s/r, %3.5f errors/s", $total / $done_time, $done_time / $total, $errors / $done_time ; } } 1; libdr-tarantool-perl-0.44/st/Check/OneTree.pm0000644000000000000000000000337212123045772017546 0ustar rootrootuse utf8; use strict; use warnings; package Check::OneTree; use AnyEvent; use Coro; use Coro::AnyEvent; use DR::Tarantool ':constant'; use constant ITERATIONS => cfg 'check.onetree.iterations'; sub start { my $done_time = 0; my $total = 0; my @fields; my $total_errors = 0; while(1) { my $started = now(); my $errors = 0; for (my $i = 0; $i < ITERATIONS; $i++) { push @fields => tnt->insert( one_tree => [ uuid, uuid ], TNT_FLAG_RETURN); } for (@fields) { my $f = tnt->select(one_tree => [ $_->id ]); if ($f) { next if $f->id ~~ $_->id; next if $f->value ~~ $_->value; } error 1, 'select exists tuple'; $errors++; } for (@fields) { my $f = tnt->delete(one_tree => [ $_->id ], TNT_FLAG_RETURN); if ($f) { next if $f->id ~~ $_->id; next if $f->value ~~ $_->value; } error 1, 'delete exists tuple'; $errors++; } for (@fields) { next if !defined tnt->select(one_tree => [ $_->id ]); $errors++; error 1, 'select unexists tuple'; } @fields = (); my $period = now() - $started; $done_time += $period; $total += ITERATIONS; $total_errors += $errors; df '%d iterations in %3.3f seconds (%d errors)', $total, $done_time, $total_errors ; df "%d r/s, %3.5f s/r, %3.5f err/s", $total / $done_time, $done_time / $total, $total_errors / $done_time ; } } 1; libdr-tarantool-perl-0.44/st/Check/OneHash.pm0000644000000000000000000000337212123045772017532 0ustar rootrootuse utf8; use strict; use warnings; package Check::OneHash; use AnyEvent; use Coro; use Coro::AnyEvent; use DR::Tarantool ':constant'; use constant ITERATIONS => cfg 'check.onehash.iterations'; sub start { my $done_time = 0; my $total = 0; my @fields; my $total_errors = 0; while(1) { my $started = now(); my $errors = 0; for (my $i = 0; $i < ITERATIONS; $i++) { push @fields => tnt->insert( one_hash => [ uuid, uuid ], TNT_FLAG_RETURN); } for (@fields) { my $f = tnt->select(one_hash => [ $_->id ]); if ($f) { next if $f->id ~~ $_->id; next if $f->value ~~ $_->value; } error 1, 'select exists tuple'; $errors++; } for (@fields) { my $f = tnt->delete(one_hash => [ $_->id ], TNT_FLAG_RETURN); if ($f) { next if $f->id ~~ $_->id; next if $f->value ~~ $_->value; } error 1, 'delete exists tuple'; $errors++; } for (@fields) { next if !defined tnt->select(one_hash => [ $_->id ]); error 1, 'select unexists tuple'; $errors++; } @fields = (); my $period = now() - $started; $done_time += $period; $total += ITERATIONS; $total_errors += $errors; df '%d iterations in %3.3f seconds (%d errors)', $total, $done_time, $total_errors ; df "%d r/s, %3.5f s/r, %3.5f err/s", $total / $done_time, $done_time / $total, $total_errors / $done_time ; } } 1; libdr-tarantool-perl-0.44/st/Check/XlogCleanup.pm0000644000000000000000000000261212123045772020422 0ustar rootrootuse utf8; use strict; use warnings; package Check::XlogCleanup; use Coro::AnyEvent; use File::Spec::Functions 'catfile'; use AnyEvent::Socket; use AnyEvent; use Encode 'decode_utf8'; use Coro; sub start { my (undef, $tarantool, $primary_pid) = @_; Coro::schedule unless $primary_pid == $$; my $csocket; my $watcher; my $c = tcp_connect '127.0.0.1', $tarantool->admin_port, sub { my ($fh) = @_; $csocket = $fh; $watcher = AE::io $fh, 0, sub { my $data; undef $watcher unless defined sysread $fh, $data, 1024; }; }; while(1) { Coro::AnyEvent::sleep 20; next unless $tarantool; df 'Cleanup *.xlog files in: %s', $tarantool->temp_dir; my @xlogs = sort glob catfile $tarantool->temp_dir, '*.xlog'; while(@xlogs > cfg 'check.xlogcleanup.keep_xlogs') { my $name = shift @xlogs; df 'unlink %s', $name; unlink $name; } my @snaps = sort glob catfile $tarantool->temp_dir, '*.snapshot'; while(@snaps > cfg 'check.xlogcleanup.keep_snapshots') { my $name = shift @snaps; df 'unlink %s', $name; unlink $name; } if ($csocket) { df 'create new snapshot'; die decode_utf8 $! unless defined syswrite $csocket, "save snapshot\n"; } } }; 1; libdr-tarantool-perl-0.44/st/init.lua0000644000000000000000000000177012123045772016300 0ustar rootrootfunction order_add(oid, pid, oid_in_pid, time, status, sid, did, driver_xml, xml, if_status) local order = box.select(5, 1, pid, oid_in_pid) -- если заказ есть в БД и его статус не соответствует ожидаемому ничего -- не делаем if if_status ~= nil and order ~= nil and order[4] ~= if_status then return end if order == nil then order = box.insert(5, oid, pid, oid_in_pid, time, status, sid, did, '', '', driver_xml, xml) return order end if status == 'confirm' and order[4] == 'request' then return box.update( 5, order[0], '!p=p=p=p=p', 10, xml, 5, sid, 6, did, 9, driver_xml, 4, status ) end return box.update( 5, order[0], '!p', 10, xml ) end libdr-tarantool-perl-0.44/st/stress.pl0000644000000000000000000002024312123045772016506 0ustar rootroot#!/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 lib qw(st); use Coro; use DR::Tarantool::StartTest; use DR::Tarantool; use Carp; use File::Spec::Functions 'catfile', 'rel2abs'; use File::Basename 'dirname', 'basename'; use POSIX; use UUID; use Scalar::Util; use FindBin; use Coro::AnyEvent; use AnyEvent; use Encode qw(decode_utf8); use feature 'state'; use Data::Dumper; use Getopt::Long; use Pod::Usage; our $tarantool; our $errors = 0; my $verbose; sub cfg($) { state $cfg; state %cache; unless ($cfg) { my $name = rel2abs catfile $FindBin::Bin, 'stress.cfg'; die "File $name is not found\n" unless -r $name; $cfg = do $name; die if $@; } my $path = shift; return $cache{$path} if exists $cache{$path}; my @spath = split /\./, $path; my $o = $cfg; for (@spath) { croak "Path $path is not found in config file" unless exists $o->{ $_ }; $o = $o->{ $_ }; } return $cache{$path} = $o; } sub df($;@) { return unless $verbose; my ($fmt, @args) = @_; $fmt =~ s/\s*$/\n/; unshift @args => $$; unshift @args => POSIX::strftime '%d/%m %H:%M:%S' => localtime; return printf '%s (%s) ' . $fmt, @args; } sub uuid() { UUID::generate my $uuid; $uuid =~ s/./sprintf '%02x', ord $&/ge; return $uuid; } sub tnt() { state (@process, $tnt); unless($tnt) { if (@process) { push @process => $Coro::current; Coro::schedule; } else { push @process => $Coro::current; $tnt = coro_tarantool host => '127.0.0.1', port => $tarantool->primary_port, spaces => { 0 => { name => 'one_hash', default_type => 'STR', fields => [ 'id', 'value', ], indexes => { 0 => { name => 'id', fields => [ 'id' ], } } }, 1 => { name => 'one_tree', default_type => 'STR', fields => [ 'id', 'value', ], indexes => { 0 => { name => 'id', fields => [ 'id' ], } } }, 5 => { name => 'orders', default_type => 'UTF8STR', fields => [ 'oid', 'pid', 'oid_in_pid', 'time', 'status', 'sid', 'did', 'rating', 'feedback', 'driver_xml', 'xml', ], indexes => { 0 => { name => 'oid', fields => 'oid', }, 1 => { name => 'parent', fields => [ 'pid', 'oid_in_pid' ], }, 2 => { name => 'time', fields => 'time' }, 3 => { name => 'status', fields => [ 'status', 'sid' ] }, 4 => { name => 'driver', fields => [ 'did', 'status' ] }, } }, } ; while(my $coro = shift @process) { next if $coro == $Coro::current; $coro->ready; } } } return $tnt; } sub error($$;@) { my ($cond, $name, @args) = @_; return $cond unless $cond; $errors++; df 'Error ' . $name, @args; return $cond; } pod2usage() unless GetOptions 'help|h' => \my $help, 'verbose|v' => \$verbose, 'timeout|t=i' => \my $timeout, 'forks|f=i' => \my $forks, ; pod2usage(-verbose => 2) if $help; $timeout ||= 120; my $primary_pid = $$; { my $cfg = rel2abs catfile $FindBin::Bin, 'stress.tarantool.cfg'; $tarantool = DR::Tarantool::StartTest->run( cfg => $cfg, script_dir => rel2abs $FindBin::Bin, ); unless ($tarantool->started) { df "Can't start tarantool\n%s", $tarantool->log; exit -1; } } my @child; df 'Started main process %s', $primary_pid; $SIG{CHLD} = 'none'; for (1 .. $forks // cfg 'forks') { my $pid = fork; unless ($pid) { @child = (); last; } push @child => $pid; } my $coro = $Coro::current; $SIG{INT} = $SIG{TERM} = $SIG{__DIE__} = sub { if ($$ == $primary_pid) { $tarantool->kill('KILL') if $tarantool; df 'Exit loop'; df '%s', $tarantool->log if $tarantool; kill TERM => $_ for @child; } error 1, 'Signal or exception was caught'; $coro->ready; $coro->cede_to; }; my @checks = glob catfile 'st', 'Check', '*.pm'; die "Can't find any check in st/Check" unless @checks; for (@checks) { my $cname = basename $_ => '.pm'; my $name = "Check::$cname"; df 'try to init module %s', $name; unless (cfg sprintf 'check.%s.enabled', lc $cname) { df ' -- %s is disabled by config, skipping...', $cname; next; } { no strict 'refs'; if (cfg sprintf 'check.%s.verbose', lc $cname) { *{ $name . '::df' } = sub ($;@) { my $fmt = shift; $fmt = "$cname: $fmt"; unshift @_ => $fmt; goto \&df; }; } else { *{ $name . '::df' } = sub { }; } *{ $name . '::error' } = sub { my ($cond, $name, @args) = @_; return error $cond, "%s $name", $cname, @args; }; *{ $name . '::uuid' } = \&uuid; *{ $name . '::tnt' } = \&tnt; *{ $name . '::cfg' } = \&cfg; *{ $name . '::now' } = \&AnyEvent::now; } eval "require $name;"; die if $@; die "There is no finction $name\->start" unless $name->can('start'); df "starting check process $name\->start"; async { eval { $name->start($tarantool, $primary_pid) }; df 'Unexpected process "%s" shutdown: %s', $name, decode_utf8($@ // 'no errors'); kill INT => $$; }; } async { Coro::AnyEvent::sleep $timeout; $coro->ready; }; Coro::schedule; for (@child) { waitpid $_, 0; error $?, 'Child %s returns non-zero code: %s', $_, $?; } $tarantool->kill('KILL') if $$ ~~ $primary_pid; df 'There were %s errors total', $errors; exit($errors && 1); =head1 NAME stress.pl - stress test for L =head1 SYNOPSIS perl stress.pl [ OPTIONS ] =head2 OPTIONS =over =item -h | --help Display helpscreen =item -v | --verbose Enable verbose while running =item -t | --timeout SECONDS How long the test must be started. Default: 120 seconds. =back =cut libdr-tarantool-perl-0.44/st/stress.cfg0000644000000000000000000000134012123045772016627 0ustar rootroot# vim: set ft=perl : { check => { onehash => { iterations => 1000, verbose => 1, enabled => 1, }, ping => { iterations => 5000, verbose => 1, enabled => 1, }, onetree => { iterations => 1000, verbose => 1, enabled => 1, }, order => { iterations => 1000, verbose => 1, enabled => 1, }, xlogcleanup => { verbose => 1, keep_xlogs => 10, keep_snapshots => 2, enabled => 1, }, }, forks => 3, } libdr-tarantool-perl-0.44/st/stress.tarantool.cfg0000644000000000000000000000272712123045772020643 0ustar rootrootrows_per_wal = 50000 readahead = 10240000 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 = "STR" space[1].enabled = 1 space[1].index[0].type = "TREE" space[1].index[0].unique = 1 space[1].index[0].key_field[0].fieldno = 0 space[1].index[0].key_field[0].type = "STR" space[5].enabled = 1 space[5].index[0].type = "HASH" space[5].index[0].unique = 1 space[5].index[0].key_field[0].fieldno = 0 space[5].index[0].key_field[0].type = "STR" space[5].index[1].type = "TREE" space[5].index[1].unique = 1 space[5].index[1].key_field[0].fieldno = 1 space[5].index[1].key_field[0].type = "STR" space[5].index[1].key_field[1].fieldno = 2 space[5].index[1].key_field[1].type = "STR" space[5].index[2].type = "TREE" space[5].index[2].unique = 0 space[5].index[2].key_field[0].fieldno = 3 space[5].index[2].key_field[0].type = "STR" space[5].index[2].key_field[1].fieldno = 4 space[5].index[2].key_field[1].type = "STR" space[5].index[3].type = "TREE" space[5].index[3].unique = 0 space[5].index[3].key_field[0].fieldno = 4 space[5].index[3].key_field[0].type = "STR" space[5].index[3].key_field[1].fieldno = 5 space[5].index[3].key_field[1].type = "STR" space[5].index[4].type = "TREE" space[5].index[4].unique = 0 space[5].index[4].key_field[0].fieldno = 6 space[5].index[4].key_field[0].type = "STR" space[5].index[4].key_field[1].fieldno = 4 space[5].index[4].key_field[1].type = "STR" libdr-tarantool-perl-0.44/msgpack.c0000644000000000000000000001122212414721033015760 0ustar rootroot#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #define MP_SOURCE 1 #include "msgpuck.h" void _mpack_item(SV *res, SV *o) { size_t len, res_len, new_len; char *s, *res_s; res_s = SvPVbyte(res, res_len); unsigned i; if (!SvOK(o)) { new_len = res_len + mp_sizeof_nil(); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_nil(res_s + res_len); return; } if (SvROK(o)) { o = SvRV(o); if (SvOBJECT(o)) { SvGETMAGIC(o); HV *stash = SvSTASH(o); GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0); if (!mtd) croak("Object has no method 'msgpack'"); dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash)); PUTBACK; call_sv((SV *)GvCV(mtd), G_SCALAR); SPAGAIN; SV *pkt = POPs; if (!SvOK(pkt)) croak("O->msgpack returned undef"); s = SvPV(pkt, len); new_len = res_len + len; res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); memcpy(res_s + res_len, s, len); PUTBACK; FREETMPS; LEAVE; return; } switch(SvTYPE(o)) { case SVt_PVAV: { AV *a = (AV *)o; len = av_len(a) + 1; new_len = res_len + mp_sizeof_array(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_array(res_s + res_len, len); for (i = 0; i < len; i++) { SV **item = av_fetch(a, i, 0); if (!item) _mpack_item(res, 0); else _mpack_item(res, *item); } break; } case SVt_PVHV: { HV *h = (HV *)o; len = hv_iterinit(h); new_len = res_len + mp_sizeof_map(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_map(res_s + res_len, len); for (;;) { HE * iter = hv_iternext(h); if (!iter) break; SV *k = hv_iterkeysv(iter); SV *v = HeVAL(iter); _mpack_item(res, k); _mpack_item(res, v); } break; } default: croak("Can't serialize reference"); } return; } switch(SvTYPE(o)) { case SVt_PV: case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: case SVt_REGEXP: if (!looks_like_number(o)) { s = SvPV(o, len); new_len = res_len + mp_sizeof_str(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_str(res_s + res_len, s, len); break; } case SVt_NV: { NV v = SvNV(o); IV iv = (IV)v; if (v != iv) { new_len = res_len + mp_sizeof_double(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_double(res_s + res_len, v); break; } } case SVt_IV: { IV v = SvIV(o); if (v >= 0) { new_len = res_len + mp_sizeof_uint(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_uint(res_s + res_len, v); } else { new_len = res_len + mp_sizeof_int(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_int(res_s + res_len, v); } break; } default: croak("Internal msgpack error %d", SvTYPE(o)); } } const char * _munpack_item(const char *p, size_t len, SV **res, HV *ext, int utf) { if (!len || !p) croak("Internal error: out of pointer"); const char *pe = p + len; switch(mp_typeof(*p)) { case MP_UINT: *res = newSViv( mp_decode_uint(&p) ); break; case MP_INT: *res = newSViv( mp_decode_int(&p) ); break; case MP_FLOAT: *res = newSVnv( mp_decode_float(&p) ); break; case MP_DOUBLE: *res = newSVnv( mp_decode_double(&p) ); break; case MP_STR: { const char *s; uint32_t len; s = mp_decode_str(&p, &len); *res = newSVpvn_flags(s, len, utf ? SVf_UTF8 : 0); break; } case MP_NIL: { mp_decode_nil(&p); *res = newSV(0); break; } case MP_BOOL: if (mp_decode_bool(&p)) { *res = newSViv(1); } else { *res = newSViv(0); } break; case MP_MAP: { uint32_t l, i; l = mp_decode_map(&p); HV * h = newHV(); sv_2mortal((SV *)h); for (i = 0; i < l; i++) { SV *k = 0; SV *v = 0; if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &k, ext, utf); sv_2mortal(k); if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &v, ext, utf); hv_store_ent(h, k, v, 0); } *res = newRV((SV *)h); break; } case MP_ARRAY: { uint32_t l, i; l = mp_decode_array(&p); AV *a = newAV(); sv_2mortal((SV *)a); for (i = 0; i < l; i++) { SV *item = 0; if (p >= pe) croak("Unexpected EOF msgunpack str"); p = _munpack_item(p, pe - p, &item, ext, utf); av_push(a, item); } *res = newRV((SV *)a); break; } case MP_EXT: { croak("Isn't defined yet"); } default: croak("Unexpected symbol 0x%02x", 0xFF & (int)(*p)); } return p; } libdr-tarantool-perl-0.44/Makefile.PL0000644000000000000000000000317112347544137016162 0ustar rootrootuse 5.008008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'DR::Tarantool', VERSION_FROM => 'lib/DR/Tarantool.pm', # finds $VERSION PREREQ_PM => { 'Carp' => 0, 'File::Temp' => 0, 'File::Path' => 0, 'File::Spec::Functions' => 0, 'Cwd' => 0, 'IO::Socket::INET' => 0, 'AnyEvent' => 0, 'Devel::GlobalDestruction' => 0, 'JSON::XS' => 0, 'List::MoreUtils' => 0, }, # e.g., Module::Name => 1.1 META_MERGE => { resources => { homepage => 'https://github.com/dr-co/dr-tarantool', repository => 'https://github.com/dr-co/dr-tarantool', bugtracker => 'https://github.com/dr-co/dr-tarantool/issues', } }, ABSTRACT_FROM => 'lib/DR/Tarantool.pm', # retrieve abstract from module AUTHOR => 'Dmitry E. Oboukhov ', LIBS => [], # e.g., '-lm' DEFINE => '', # e.g., '-DHAVE_SOMETHING' INC => '-I.', # e.g., '-I. -I/usr/include/other' # Un-comment this if you add C files to link with later: OBJECT => '$(O_FILES)', # link all the C files too LICENSE => 'artistic', ); # if (open my $fh, '>>', 'Makefile') { # print $fh "\n\nTEST_VERBOSE=1\n"; # } libdr-tarantool-perl-0.44/Changes0000777000000000000000000000000012207410067020557 2debian/changelogustar rootrootlibdr-tarantool-perl-0.44/rpm/0000775000000000000000000000000012633763417015010 5ustar rootrootlibdr-tarantool-perl-0.44/rpm/perl-DR-Tarantool.spec0000644000000000000000000000444312633763417021075 0ustar rootrootName: perl-DR-Tarantool Version: 0.38 Release: 1 Summary: A Perl driver for Tarantool Group: Development/Libraries License: Artistic URL: http://search.cpan.org/~unera/DR-Tarantool-0.38/ Source0: http://search.cpan.org/CPAN/authors/id/U/UN/UNERA/DR-Tarantool-0.38.tar.gz Source1: filter-requires-dr-tarantool.sh BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) %define __perl_requires %{SOURCE1} %description This module provides a synchronous and asynchronous driver for Tarantool. The driver does not have external dependencies, but includes the official light-weight Tarantool C client (a single C header which implements all protocol formatting) for packing requests and unpacking server responses. This driver implements "iproto" protocol described in https://github.com/mailru/tarantool/blob/master/doc/box-protocol.txt It is built on top of AnyEvent - an asynchronous event framework, and is therefore easiest to integrate into a program which is already based on AnyEvent. A synchronous version of the driver exists as well, it starts AnyEvent event machine for every request. %prep %setup -q -n DR-Tarantool-%{version} %build CFLAGS="$RPM_OPT_FLAGS" %{__perl} Makefile.PL INSTALLDIRS=vendor make %{?_smp_mflags} OPTIMIZE="$RPM_OPT_FLAGS" %install rm -rf $RPM_BUILD_ROOT make pure_install PERL_INSTALL_ROOT=$RPM_BUILD_ROOT find $RPM_BUILD_ROOT -type f -name .packlist -exec rm -f {} ';' find $RPM_BUILD_ROOT -type f -name '*.bs' -empty -exec rm -f {} ';' find $RPM_BUILD_ROOT -type d -depth -exec rmdir {} 2>/dev/null ';' %check || : mv t/010-xs.t t/010-xs.t.disabled make test %clean rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root,-) %doc README.pod %{perl_vendorarch}/DR/ %{perl_vendorarch}/auto/DR/Tarantool/Tarantool.so /usr/share/man/man3/DR::README.3pm.gz /usr/share/man/man3/DR::Tarantool.3pm.gz /usr/share/man/man3/DR::Tarantool::AsyncClient.3pm.gz /usr/share/man/man3/DR::Tarantool::CoroClient.3pm.gz /usr/share/man/man3/DR::Tarantool::Iterator.3pm.gz /usr/share/man/man3/DR::Tarantool::LLClient.3pm.gz /usr/share/man/man3/DR::Tarantool::Spaces.3pm.gz /usr/share/man/man3/DR::Tarantool::StartTest.3pm.gz /usr/share/man/man3/DR::Tarantool::SyncClient.3pm.gz /usr/share/man/man3/DR::Tarantool::Tuple.3pm.gz libdr-tarantool-perl-0.44/rpm/SOURCES/0000775000000000000000000000000012165537670016133 5ustar rootrootlibdr-tarantool-perl-0.44/rpm/SOURCES/filter-requires-dr-tarantool.sh0000755000000000000000000000030512165274113024202 0ustar rootroot#!/bin/sh /usr/lib/rpm/find-requires $* | grep -v 'perl(Coro)' | grep -v 'perl(base)' | \ grep -v 'perl(strict)' | grep -v 'perl(utf8)' | grep -v 'perl(warnings)' | \ grep -v 'perl(DR::Tarantool)' libdr-tarantool-perl-0.44/tmp/0000775000000000000000000000000012021616213014770 5ustar rootrootlibdr-tarantool-perl-0.44/msgpuck.h0000644000000000000000000016234612347544137016044 0ustar rootroot#ifndef MSGPUCK_H_INCLUDED #define MSGPUCK_H_INCLUDED /* * Copyright (c) 2013 MsgPuck Authors * All rights reserved. * * Redistribution and use in source and binary forms, with or * without modification, are permitted provided that the following * conditions are met: * * 1. Redistributions of source code must retain the above * copyright notice, this list of conditions and the * following disclaimer. * * 2. Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials * provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ /** * \file msgpuck.h * MsgPuck * \brief MsgPuck is a simple and efficient MsgPack encoder/decoder * library in a single self-contained file. * * Usage example: * \code * // Encode * char buf[1024]; * char *w = buf; * w = mp_encode_array(w, 4) * w = mp_encode_uint(w, 10); * w = mp_encode_str(w, "hello world", strlen("hello world")); * w = mp_encode_bool(w, true); * w = mp_encode_double(w, 3.1415); * * // Validate * const char *b = buf; * int r = mp_check(&b); * assert(!r) * assert(b == w); * * // Decode * uint32_t size; * uint64_t ival; * const char *sval; * uint32_t sval_len; * bool bval; * double dval; * * const char *r = buf; * * size = mp_decode_array(&r); * // size is 4 * * ival = mp_decode_uint(&r); * // ival is 10; * * sval = mp_decode_str(&r, &sval_len); * // sval is "hello world", sval_len is strlen("hello world") * * bval = mp_decode_bool(&r); * // bval is true * * dval = mp_decode_double(&r); * // dval is 3.1415 * * assert(r == w); * \endcode * * \note Supported compilers. * The implementation requires a C99+ or C++03+ compatible compiler. * * \note Inline functions. * The implementation is compatible with both C99 and GNU inline functions. * Please define MP_SOURCE 1 before \#include in a single * compilation unit. This module will be used to store non-inlined versions of * functions and global tables. */ #if defined(__cplusplus) && !defined(__STDC_CONSTANT_MACROS) #define __STDC_CONSTANT_MACROS 1 /* make С++ to be happy */ #endif #if defined(__cplusplus) && !defined(__STDC_LIMIT_MACROS) #define __STDC_LIMIT_MACROS 1 /* make С++ to be happy */ #endif #include #include #include #include #include #include #if defined(__cplusplus) extern "C" { #endif /* defined(__cplusplus) */ /* * {{{ Platform-specific definitions */ /** \cond 0 **/ #if defined(__GNUC__) && !defined(__GNUC_STDC_INLINE__) #if !defined(MP_SOURCE) #define MP_PROTO extern inline #define MP_IMPL extern inline #else /* defined(MP_SOURCE) */ #define MP_PROTO #define MP_IMPL #endif #define MP_ALWAYSINLINE #else /* C99 inline */ #if !defined(MP_SOURCE) #define MP_PROTO inline #define MP_IMPL inline #else /* defined(MP_SOURCE) */ #define MP_PROTO extern inline #define MP_IMPL inline #endif #define MP_ALWAYSINLINE __attribute__((always_inline)) #endif /* GNU inline or C99 inline */ #if !defined __GNUC_MINOR__ || defined __INTEL_COMPILER || \ defined __SUNPRO_C || defined __SUNPRO_CC #define MP_GCC_VERSION(major, minor) 0 #else #define MP_GCC_VERSION(major, minor) (__GNUC__ > (major) || \ (__GNUC__ == (major) && __GNUC_MINOR__ >= (minor))) #endif #if !defined(__has_builtin) #define __has_builtin(x) 0 /* clang */ #endif #if MP_GCC_VERSION(2, 9) || __has_builtin(__builtin_expect) #define mp_likely(x) __builtin_expect((x), 1) #define mp_unlikely(x) __builtin_expect((x), 0) #else #define mp_likely(x) (x) #define mp_unlikely(x) (x) #endif #if MP_GCC_VERSION(4, 5) || __has_builtin(__builtin_unreachable) #define mp_unreachable() (assert(0), __builtin_unreachable()) #else MP_PROTO void mp_unreachable(void) __attribute__((noreturn)); MP_PROTO void mp_unreachable(void) { assert(0); abort(); } #define mp_unreachable() (assert(0)) #endif #if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__ #if MP_GCC_VERSION(4, 8) || __has_builtin(__builtin_bswap16) #define mp_bswap_u16(x) __builtin_bswap16(x) #else /* !MP_GCC_VERSION(4, 8) */ #define mp_bswap_u16(x) ( \ (((x) << 8) & 0xff00) | \ (((x) >> 8) & 0x00ff) ) #endif #if MP_GCC_VERSION(4, 3) || __has_builtin(__builtin_bswap32) #define mp_bswap_u32(x) __builtin_bswap32(x) #else /* !MP_GCC_VERSION(4, 3) */ #define mp_bswap_u32(x) ( \ (((x) << 24) & UINT32_C(0xff000000)) | \ (((x) << 8) & UINT32_C(0x00ff0000)) | \ (((x) >> 8) & UINT32_C(0x0000ff00)) | \ (((x) >> 24) & UINT32_C(0x000000ff)) ) #endif #if MP_GCC_VERSION(4, 3) || __has_builtin(__builtin_bswap64) #define mp_bswap_u64(x) __builtin_bswap64(x) #else /* !MP_GCC_VERSION(4, 3) */ #define mp_bswap_u64(x) (\ (((x) << 56) & UINT64_C(0xff00000000000000)) | \ (((x) << 40) & UINT64_C(0x00ff000000000000)) | \ (((x) << 24) & UINT64_C(0x0000ff0000000000)) | \ (((x) << 8) & UINT64_C(0x000000ff00000000)) | \ (((x) >> 8) & UINT64_C(0x00000000ff000000)) | \ (((x) >> 24) & UINT64_C(0x0000000000ff0000)) | \ (((x) >> 40) & UINT64_C(0x000000000000ff00)) | \ (((x) >> 56) & UINT64_C(0x00000000000000ff)) ) #endif #elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__ #define mp_bswap_u16(x) (x) #define mp_bswap_u32(x) (x) #define mp_bswap_u64(x) (x) #else #error Unsupported __BYTE_ORDER__ #endif #if !defined(__FLOAT_WORD_ORDER__) #define __FLOAT_WORD_ORDER__ __BYTE_ORDER__ #endif /* defined(__FLOAT_WORD_ORDER__) */ #if __FLOAT_WORD_ORDER__ == __ORDER_LITTLE_ENDIAN__ MP_PROTO float mp_bswap_float(float f); MP_PROTO double mp_bswap_double(double d); MP_IMPL float mp_bswap_float(float f) { union { float f; uint32_t n; } cast; cast.f = f; cast.n = mp_bswap_u32(cast.n); return cast.f; } MP_IMPL double mp_bswap_double(double d) { union { double d; uint64_t n; } cast; cast.d = d; cast.n = mp_bswap_u64(cast.n); return cast.d; } #elif __FLOAT_WORD_ORDER__ == __ORDER_BIG_ENDIAN__ #define mp_bswap_float(x) (x) #define mp_bswap_double(x) (x) #else #error Unsupported __FLOAT_WORD_ORDER__ #endif /** \endcond */ /* * }}} */ /* * {{{ API definition */ /** * \brief MsgPack data types */ enum mp_type { MP_NIL = 0, MP_UINT, MP_INT, MP_STR, MP_BIN, MP_ARRAY, MP_MAP, MP_BOOL, MP_FLOAT, MP_DOUBLE, MP_EXT }; /** * \brief Determine MsgPack type by a first byte \a c of encoded data. * * Example usage: * \code * assert(MP_ARRAY == mp_typeof(0x90)); * \endcode * * \param c - a first byte of encoded data * \return MsgPack type */ MP_PROTO __attribute__((pure)) enum mp_type mp_typeof(const char c); /** * \brief Calculate exact buffer size needed to store an array header of * \a size elements. Maximum return value is 5. For performance reasons you * can preallocate buffer for maximum size without calling the function. * \param size - a number of elements * \return buffer size in bytes (max is 5) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_array(uint32_t size); /** * \brief Encode an array header of \a size elements. * * All array members must be encoded after the header. * * Example usage: * \code * // Encode * char buf[1024]; * char *w = buf; * w = mp_encode_array(w, 2) * w = mp_encode_uint(w, 10); * w = mp_encode_uint(w, 15); * * // Decode * const char *r = buf; * uint32_t size = mp_decode_array(&r); * for (uint32_t i = 0; i < size; i++) { * uint64_t val = mp_decode_uint(&r); * } * assert (r == w); * \endcode * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param size - a number of elements * \return \a data + \link mp_sizeof_array() mp_sizeof_array(size) \endlink * \sa mp_sizeof_array */ MP_PROTO char * mp_encode_array(char *data, uint32_t size); /** * \brief Check that \a cur buffer has enough bytes to decode an array header * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_ARRAY */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_array(const char *cur, const char *end); /** * \brief Decode an array header from MsgPack \a data. * * All array members must be decoded after the header. * \param data - the pointer to a buffer * \return the number of elements in an array * \post *data = *data + mp_sizeof_array(retval) * \sa \link mp_encode_array() An usage example \endlink */ MP_PROTO uint32_t mp_decode_array(const char **data); /** * \brief Calculate exact buffer size needed to store a map header of * \a size elements. Maximum return value is 5. For performance reasons you * can preallocate buffer for maximum size without calling the function. * \param size - a number of elements * \return buffer size in bytes (max is 5) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_map(uint32_t size); /** * \brief Encode a map header of \a size elements. * * All map key-value pairs must be encoded after the header. * * Example usage: * \code * char buf[1024]; * * // Encode * char *w = buf; * w = mp_encode_map(b, 2); * w = mp_encode_str(b, "key1", 4); * w = mp_encode_str(b, "value1", 6); * w = mp_encode_str(b, "key2", 4); * w = mp_encode_str(b, "value2", 6); * * // Decode * const char *r = buf; * uint32_t size = mp_decode_map(&r); * for (uint32_t i = 0; i < size; i++) { * // Use switch(mp_typeof(**r)) to support more types * uint32_t key_len, val_len; * const char *key = mp_decode_str(&r, key_len); * const char *val = mp_decode_str(&r, val_len); * } * assert (r == w); * \endcode * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param size - a number of key/value pairs * \return \a data + \link mp_sizeof_map() mp_sizeof_map(size)\endlink * \sa mp_sizeof_map */ MP_PROTO char * mp_encode_map(char *data, uint32_t size); /** * \brief Check that \a cur buffer has enough bytes to decode a map header * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_MAP */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_map(const char *cur, const char *end); /** * \brief Decode a map header from MsgPack \a data. * * All map key-value pairs must be decoded after the header. * \param data - the pointer to a buffer * \return the number of key/value pairs in a map * \post *data = *data + mp_sizeof_array(retval) * \sa \link mp_encode_map() An usage example \endlink */ MP_PROTO uint32_t mp_decode_map(const char **data); /** * \brief Calculate exact buffer size needed to store an integer \a num. * Maximum return value is 9. For performance reasons you can preallocate * buffer for maximum size without calling the function. * Example usage: * \code * char **data = ...; * char *end = *data; * my_buffer_ensure(mp_sizeof_uint(x), &end); * // my_buffer_ensure(9, &end); * mp_encode_uint(buffer, x); * \endcode * \param num - a number * \return buffer size in bytes (max is 9) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_uint(uint64_t num); /** * \brief Calculate exact buffer size needed to store an integer \a num. * Maximum return value is 9. For performance reasons you can preallocate * buffer for maximum size without calling the function. * \param num - a number * \return buffer size in bytes (max is 9) * \pre \a num < 0 */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_int(int64_t num); /** * \brief Encode an unsigned integer \a num. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param num - a number * \return \a data + mp_sizeof_uint(\a num) * \sa \link mp_encode_array() An usage example \endlink * \sa mp_sizeof_uint() */ MP_PROTO char * mp_encode_uint(char *data, uint64_t num); /** * \brief Encode a signed integer \a num. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param num - a number * \return \a data + mp_sizeof_int(\a num) * \sa \link mp_encode_array() An usage example \endlink * \sa mp_sizeof_int() * \pre \a num < 0 */ MP_PROTO char * mp_encode_int(char *data, int64_t num); /** * \brief Check that \a cur buffer has enough bytes to decode an uint * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_UINT */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_uint(const char *cur, const char *end); /** * \brief Check that \a cur buffer has enough bytes to decode an int * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_INT */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_int(const char *cur, const char *end); /** * \brief Decode an unsigned integer from MsgPack \a data * \param data - the pointer to a buffer * \return an unsigned number * \post *data = *data + mp_sizeof_uint(retval) */ MP_PROTO uint64_t mp_decode_uint(const char **data); /** * \brief Decode a signed integer from MsgPack \a data * \param data - the pointer to a buffer * \return an unsigned number * \post *data = *data + mp_sizeof_int(retval) */ MP_PROTO int64_t mp_decode_int(const char **data); /** * \brief Compare two packed unsigned integers. * * The function is faster than two mp_decode_uint() calls. * \param data_a unsigned int a * \param data_b unsigned int b * \retval < 0 when \a a < \a b * \retval 0 when \a a == \a b * \retval > 0 when \a a > \a b */ MP_PROTO __attribute__((pure)) int mp_compare_uint(const char *data_a, const char *data_b); /** * \brief Calculate exact buffer size needed to store a float \a num. * The return value is always 5. The function was added to provide integrity of * the library. * \param num - a float * \return buffer size in bytes (always 5) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_float(float num); /** * \brief Calculate exact buffer size needed to store a double \a num. * The return value is either 5 or 9. The function was added to provide * integrity of the library. For performance reasons you can preallocate buffer * for maximum size without calling the function. * \param num - a double * \return buffer size in bytes (5 or 9) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_double(double num); /** * \brief Encode a float \a num. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param num - a float * \return \a data + mp_sizeof_float(\a num) * \sa mp_sizeof_float() * \sa \link mp_encode_array() An usage example \endlink */ MP_PROTO char * mp_encode_float(char *data, float num); /** * \brief Encode a double \a num. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param num - a float * \return \a data + mp_sizeof_double(\a num) * \sa \link mp_encode_array() An usage example \endlink * \sa mp_sizeof_double() */ MP_PROTO char * mp_encode_double(char *data, double num); /** * \brief Check that \a cur buffer has enough bytes to decode a float * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_FLOAT */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_float(const char *cur, const char *end); /** * \brief Check that \a cur buffer has enough bytes to decode a double * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_DOUBLE */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_double(const char *cur, const char *end); /** * \brief Decode a float from MsgPack \a data * \param data - the pointer to a buffer * \return a float * \post *data = *data + mp_sizeof_float(retval) */ MP_PROTO float mp_decode_float(const char **data); /** * \brief Decode a double from MsgPack \a data * \param data - the pointer to a buffer * \return a double * \post *data = *data + mp_sizeof_double(retval) */ MP_PROTO double mp_decode_double(const char **data); /** * \brief Calculate exact buffer size needed to store a string header of * length \a num. Maximum return value is 5. For performance reasons you can * preallocate buffer for maximum size without calling the function. * \param len - a string length * \return size in chars (max is 5) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_strl(uint32_t len); /** * \brief Equivalent to mp_sizeof_strl(\a len) + \a len. * \param len - a string length * \return size in chars (max is 5 + \a len) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_str(uint32_t len); /** * \brief Calculate exact buffer size needed to store a binstring header of * length \a num. Maximum return value is 5. For performance reasons you can * preallocate buffer for maximum size without calling the function. * \param len - a string length * \return size in chars (max is 5) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_binl(uint32_t len); /** * \brief Equivalent to mp_sizeof_binl(\a len) + \a len. * \param len - a string length * \return size in chars (max is 5 + \a len) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_bin(uint32_t len); /** * \brief Encode a string header of length \a len. * * The function encodes MsgPack header (\em only header) for a string of * length \a len. You should append actual string data to the buffer manually * after encoding the header (exactly \a len bytes without trailing '\0'). * * This approach is very useful for cases when the total length of the string * is known in advance, but the string data is not stored in a single * continuous buffer (e.g. network packets). * * It is your responsibility to ensure that \a data has enough space. * Usage example: * \code * char buffer[1024]; * char *b = buffer; * b = mp_encode_strl(b, hdr.total_len); * char *s = b; * memcpy(b, pkt1.data, pkt1.len) * b += pkt1.len; * // get next packet * memcpy(b, pkt2.data, pkt2.len) * b += pkt2.len; * // get next packet * memcpy(b, pkt1.data, pkt3.len) * b += pkt3.len; * * // Check that all data was received * assert(hdr.total_len == (uint32_t) (b - s)) * \endcode * Hint: you can dynamically reallocate the buffer during the process. * \param data - a buffer * \param len - a string length * \return \a data + mp_sizeof_strl(len) * \sa mp_sizeof_strl() */ MP_PROTO char * mp_encode_strl(char *data, uint32_t len); /** * \brief Encode a string of length \a len. * The function is equivalent to mp_encode_strl() + memcpy. * \param data - a buffer * \param str - a pointer to string data * \param len - a string length * \return \a data + mp_sizeof_str(len) == * data + mp_sizeof_strl(len) + len * \sa mp_encode_strl */ MP_PROTO char * mp_encode_str(char *data, const char *str, uint32_t len); /** * \brief Encode a binstring header of length \a len. * See mp_encode_strl() for more details. * \param data - a bufer * \param len - a string length * \return data + mp_sizeof_binl(\a len) * \sa mp_encode_strl */ MP_PROTO char * mp_encode_binl(char *data, uint32_t len); /** * \brief Encode a binstring of length \a len. * The function is equivalent to mp_encode_binl() + memcpy. * \param data - a buffer * \param str - a pointer to binstring data * \param len - a binstring length * \return \a data + mp_sizeof_bin(\a len) == * data + mp_sizeof_binl(\a len) + \a len * \sa mp_encode_strl */ MP_PROTO char * mp_encode_bin(char *data, const char *str, uint32_t len); /** * \brief Check that \a cur buffer has enough bytes to decode a string header * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_STR */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_strl(const char *cur, const char *end); /** * \brief Check that \a cur buffer has enough bytes to decode a binstring header * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_BIN */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_binl(const char *cur, const char *end); /** * \brief Decode a length of a string from MsgPack \a data * \param data - the pointer to a buffer * \return a length of astring * \post *data = *data + mp_sizeof_strl(retval) * \sa mp_encode_strl */ MP_PROTO uint32_t mp_decode_strl(const char **data); /** * \brief Decode a string from MsgPack \a data * \param data - the pointer to a buffer * \param len - the pointer to save a string length * \return a pointer to a decoded string * \post *data = *data + mp_sizeof_str(*len) * \sa mp_encode_binl */ MP_PROTO const char * mp_decode_str(const char **data, uint32_t *len); /** * \brief Decode a length of a binstring from MsgPack \a data * \param data - the pointer to a buffer * \return a length of a binstring * \post *data = *data + mp_sizeof_binl(retval) * \sa mp_encode_binl */ MP_PROTO uint32_t mp_decode_binl(const char **data); /** * \brief Decode a binstring from MsgPack \a data * \param data - the pointer to a buffer * \param len - the pointer to save a binstring length * \return a pointer to a decoded binstring * \post *data = *data + mp_sizeof_str(*len) * \sa mp_encode_binl */ MP_PROTO const char * mp_decode_bin(const char **data, uint32_t *len); /** * \brief Calculate exact buffer size needed to store the nil value. * The return value is always 1. The function was added to provide integrity of * the library. * \return buffer size in bytes (always 1) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_nil(void); /** * \brief Encode the nil value. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \return \a data + mp_sizeof_nil() * \sa \link mp_encode_array() An usage example \endlink * \sa mp_sizeof_nil() */ MP_PROTO char * mp_encode_nil(char *data); /** * \brief Check that \a cur buffer has enough bytes to decode nil * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_NIL */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_nil(const char *cur, const char *end); /** * \brief Decode the nil value from MsgPack \a data * \param data - the pointer to a buffer * \post *data = *data + mp_sizeof_nil() */ MP_PROTO void mp_decode_nil(const char **data); /** * \brief Calculate exact buffer size needed to store a boolean value. * The return value is always 1. The function was added to provide integrity of * the library. * \return buffer size in bytes (always 1) */ MP_PROTO __attribute__((const)) uint32_t mp_sizeof_bool(bool val); /** * \brief Encode a bool value \a val. * It is your responsibility to ensure that \a data has enough space. * \param data - a buffer * \param val - a bool * \return \a data + mp_sizeof_bool(val) * \sa \link mp_encode_array() An usage example \endlink * \sa mp_sizeof_bool() */ MP_PROTO char * mp_encode_bool(char *data, bool val); /** * \brief Check that \a cur buffer has enough bytes to decode a bool value * \param cur buffer * \param end end of the buffer * \retval 0 - buffer has enough bytes * \retval > 0 - the number of remaining bytes to read * \pre cur < end * \pre mp_typeof(*cur) == MP_BOOL */ MP_PROTO __attribute__((pure)) ptrdiff_t mp_check_bool(const char *cur, const char *end); /** * \brief Decode a bool value from MsgPack \a data * \param data - the pointer to a buffer * \return a decoded bool value * \post *data = *data + mp_sizeof_bool(retval) */ MP_PROTO bool mp_decode_bool(const char **data); /** * \brief Skip one element in a packed \a data. * * The function is faster than mp_typeof + mp_decode_XXX() combination. * For arrays and maps the function also skips all members. * For strings and binstrings the function also skips the string data. * * Usage example: * \code * char buf[1024]; * * char *w = buf; * // First MsgPack object * w = mp_encode_uint(w, 10); * * // Second MsgPack object * w = mp_encode_array(w, 4); * w = mp_encode_array(w, 2); * // Begin of an inner array * w = mp_encode_str(w, "second inner 1", 14); * w = mp_encode_str(w, "second inner 2", 14); * // End of an inner array * w = mp_encode_str(w, "second", 6); * w = mp_encode_uint(w, 20); * w = mp_encode_bool(w, true); * * // Third MsgPack object * w = mp_encode_str(w, "third", 5); * // EOF * * const char *r = buf; * * // First MsgPack object * assert(mp_typeof(**r) == MP_UINT); * mp_next(&r); // skip the first object * * // Second MsgPack object * assert(mp_typeof(**r) == MP_ARRAY); * mp_decode_array(&r); * assert(mp_typeof(**r) == MP_ARRAY); // inner array * mp_next(&r); // -->> skip the entire inner array (with all members) * assert(mp_typeof(**r) == MP_STR); // second * mp_next(&r); * assert(mp_typeof(**r) == MP_UINT); // 20 * mp_next(&r); * assert(mp_typeof(**r) == MP_BOOL); // true * mp_next(&r); * * // Third MsgPack object * assert(mp_typeof(**r) == MP_STR); // third * mp_next(&r); * * assert(r == w); // EOF * * \endcode * \param data - the pointer to a buffer * \post *data = *data + mp_sizeof_TYPE() where TYPE is mp_typeof(**data) */ MP_PROTO void mp_next(const char **data); /** * \brief Equivalent to mp_next() but also validates MsgPack in \a data. * \param data - the pointer to a buffer * \param end - the end of a buffer * \retval 0 when MsgPack in \a data is valid. * \retval != 0 when MsgPack in \a data is not valid. * \post *data = *data + mp_sizeof_TYPE() where TYPE is mp_typeof(**data) * \post *data is not defined if MsgPack is not valid * \sa mp_next() */ MP_PROTO int mp_check(const char **data, const char *end); /* * }}} */ /* * {{{ Implementation */ /** \cond 0 */ extern const enum mp_type mp_type_hint[]; extern const int8_t mp_parser_hint[]; MP_IMPL MP_ALWAYSINLINE enum mp_type mp_typeof(const char c) { return mp_type_hint[(unsigned char) c]; } MP_IMPL uint32_t mp_sizeof_array(uint32_t size) { if (size <= 15) { return 1; } else if (size <= UINT16_MAX) { return 1 + sizeof(uint16_t); } else { return 1 + sizeof(uint32_t); } } MP_IMPL char * mp_encode_array(char *data, uint32_t size) { if (size <= 15) { *(unsigned char *) (data++) = 0x90 | size; return data; } else if (size <= UINT16_MAX) { *(data++) = 0xdc; *(uint16_t *) data = mp_bswap_u16(size); return data + sizeof(uint16_t); } else { *(data++) = 0xdd; *(uint32_t *) data = mp_bswap_u32(size); return data + sizeof(uint32_t); } } MP_IMPL ptrdiff_t mp_check_array(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_ARRAY); unsigned char c = *(unsigned char *) cur; if (mp_likely(!(c & 0x40))) return 1 - (end - cur); assert(c >= 0xdc && c <= 0xdd); /* must be checked above by mp_typeof */ uint32_t hsize = 2U << (c & 0x1); /* 0xdc->2, 0xdd->4 */ return 1 + hsize - (end - cur); } MP_PROTO uint32_t mp_decode_array_slowpath(unsigned char c, const char **data); MP_IMPL uint32_t mp_decode_array_slowpath(unsigned char c, const char **data) { uint32_t size; switch (c & 0x1) { case 0xdc & 0x1: size = mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); return size; case 0xdd & 0x1: size = mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); return size; default: mp_unreachable(); } } MP_IMPL MP_ALWAYSINLINE uint32_t mp_decode_array(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; if (mp_likely(!(c & 0x40))) return (c & 0xf); return mp_decode_array_slowpath(c, data); } MP_IMPL uint32_t mp_sizeof_map(uint32_t size) { if (size <= 15) { return 1; } else if (size <= UINT16_MAX) { return 1 + sizeof(uint16_t); } else { return 1 + sizeof(uint32_t); } } MP_IMPL char * mp_encode_map(char *data, uint32_t size) { if (size <= 15) { *(data++) = 0x80 | (char) size; return data; } else if (size <= UINT16_MAX) { *(data++) = 0xde; *(uint16_t *) data = mp_bswap_u16(size); return data + sizeof(uint16_t); } else { *(data++) = 0xdf; *(uint32_t *) data = mp_bswap_u32(size); return data + sizeof(uint32_t); } } MP_IMPL ptrdiff_t mp_check_map(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_MAP); unsigned char c = *(unsigned char *) cur; if (mp_likely((c & ~0xfU) == 0x80)) return 1 - (end - cur); assert(c >= 0xde && c <= 0xdf); /* must be checked above by mp_typeof */ uint32_t hsize = 2U << (c & 0x1); /* 0xde->2, 0xdf->4 */ return 1 + hsize - (end - cur); } MP_IMPL uint32_t mp_decode_map(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; uint32_t size; switch (c) { case 0x80 ... 0x8f: return c & 0xf; case 0xde: size = mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); return size; case 0xdf: size = mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); return size; default: mp_unreachable(); } } MP_IMPL uint32_t mp_sizeof_uint(uint64_t num) { if (num <= 0x7f) { return 1; } else if (num <= UINT8_MAX) { return 1 + sizeof(uint8_t); } else if (num <= UINT16_MAX) { return 1 + sizeof(uint16_t); } else if (num <= UINT32_MAX) { return 1 + sizeof(uint32_t); } else { return 1 + sizeof(uint64_t); } } MP_IMPL uint32_t mp_sizeof_int(int64_t num) { assert(num < 0); if (num >= -0x20) { return 1; } else if (num >= INT8_MIN && num <= INT8_MAX) { return 1 + sizeof(int8_t); } else if (num >= INT16_MIN && num <= UINT16_MAX) { return 1 + sizeof(int16_t); } else if (num >= INT32_MIN && num <= UINT32_MAX) { return 1 + sizeof(int32_t); } else { return 1 + sizeof(int64_t); } } MP_IMPL ptrdiff_t mp_check_uint(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_UINT); return 1 + mp_parser_hint[*(unsigned char *) cur] - (end - cur); } MP_IMPL ptrdiff_t mp_check_int(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_INT); return 1 + mp_parser_hint[*(unsigned char *) cur] - (end - cur); } MP_IMPL char * mp_encode_uint(char *data, uint64_t num) { if (num <= 0x7f) { *data = num; return data + 1; } else if (num <= UINT8_MAX) { *data = 0xcc; data++; *(uint8_t *) data = num; return data + sizeof(uint8_t); } else if (num <= UINT16_MAX) { *data = 0xcd; data++; *(uint16_t *) data = mp_bswap_u16(num); return data + sizeof(uint16_t); } else if (num <= UINT32_MAX) { *data = 0xce; data++; *(uint32_t *) data = mp_bswap_u32(num); return data + sizeof(uint32_t); } else { *data = 0xcf; data++; *(uint64_t *) data = mp_bswap_u64(num); return data + sizeof(uint64_t); } } MP_IMPL char * mp_encode_int(char *data, int64_t num) { assert(num < 0); if (num >= -0x20) { *data = (0xe0 | num); return data + 1; } else if (num >= INT8_MIN) { *data = 0xd0; data++; *(int8_t *) data = num; return data + sizeof(int8_t); } else if (num >= INT16_MIN) { *data = 0xd1; data++; *(int16_t *) data = mp_bswap_u16(num); return data + sizeof(int16_t); } else if (num >= INT32_MIN) { *data = 0xd2; data++; *(int32_t *) data = mp_bswap_u32(num); return data + sizeof(int32_t); } else { *data = 0xd3; data++; *(int64_t *) data = mp_bswap_u64(num); return data + sizeof(int64_t); } } MP_IMPL uint64_t mp_decode_uint(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; uint64_t val; switch (c) { case 0x00 ... 0x7f: return c; case 0xcc: val = *(uint8_t *) *data; *data += sizeof(uint8_t); return val; case 0xcd: val = mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); return val; case 0xce: val = mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); return val; case 0xcf: val = mp_bswap_u64(*(uint64_t *) *data); *data += sizeof(uint64_t); return val; default: mp_unreachable(); } } MP_IMPL int mp_compare_uint(const char *data_a, const char *data_b) { unsigned char ca = (unsigned char) *data_a; unsigned char cb = (unsigned char) *data_b; int r = ca - cb; if (r != 0) return r; if (ca <= 0x7f) return 0; ++data_a; ++data_b; uint64_t a, b; switch (ca & 0x3) { case 0xcc & 0x3: a = *(uint8_t *) data_a; b = *(uint8_t *) data_b; break; case 0xcd & 0x3: a = mp_bswap_u16(*(uint16_t *) data_a); b = mp_bswap_u16(*(uint16_t *) data_b); break; case 0xce & 0x3: a = mp_bswap_u32(*(uint32_t *) data_a); b = mp_bswap_u32(*(uint32_t *) data_b); break; case 0xcf & 0x3: a = mp_bswap_u64(*(uint64_t *) data_a); b = mp_bswap_u64(*(uint64_t *) data_b); return a < b ? -1 : a > b; break; default: mp_unreachable(); } int64_t v = (a - b); return (v > 0) - (v < 0); } MP_IMPL int64_t mp_decode_int(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; int64_t val; switch (c) { case 0xe0 ... 0xff: return (int8_t) (c); case 0xd0: val = *(int8_t *) *data; *data += sizeof(uint8_t); return (int8_t) val; case 0xd1: val = mp_bswap_u16(*(int16_t *) *data); *data += sizeof(uint16_t); return (int16_t) val; case 0xd2: val = mp_bswap_u32(*(int32_t *) *data); *data += sizeof(uint32_t); return (int32_t) val; case 0xd3: val = mp_bswap_u64(*(int64_t *) *data); *data += sizeof(int64_t); return val; default: mp_unreachable(); } } MP_IMPL uint32_t mp_sizeof_float(float num) { (void) num; return 1 + sizeof(float); } MP_IMPL uint32_t mp_sizeof_double(double num) { (void) num; return 1 + sizeof(double); } MP_IMPL ptrdiff_t mp_check_float(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_FLOAT); return 1 + sizeof(float) - (end - cur); } MP_IMPL ptrdiff_t mp_check_double(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_DOUBLE); return 1 + sizeof(double) - (end - cur); } MP_IMPL char * mp_encode_float(char *data, float num) { *data = 0xca; data++; *(float *) data = mp_bswap_float(num); return data + sizeof(float); } MP_IMPL char * mp_encode_double(char *data, double num) { *data = 0xcb; data++; *(double *) data = mp_bswap_double(num); return data + sizeof(double); } MP_IMPL float mp_decode_float(const char **data) { unsigned char c = (unsigned char) **data; assert(c == 0xca); (void) c; *data += 1; float val = mp_bswap_float(*(float *) *data); *data += sizeof(float); return val; } MP_IMPL double mp_decode_double(const char **data) { unsigned char c = (unsigned char) **data; assert(c == 0xcb); (void) c; *data += 1; double val = mp_bswap_double(*(double *) *data); *data += sizeof(double); return val; } MP_IMPL uint32_t mp_sizeof_strl(uint32_t len) { if (len <= 31) { return 1; } else if (len <= UINT8_MAX) { return 1 + sizeof(uint8_t); } else if (len <= UINT16_MAX) { return 1 + sizeof(uint16_t); } else { return 1 + sizeof(uint32_t); } } MP_IMPL uint32_t mp_sizeof_str(uint32_t len) { return mp_sizeof_strl(len) + len; } MP_IMPL uint32_t mp_sizeof_binl(uint32_t len) { if (len <= UINT8_MAX) { return 1 + sizeof(uint8_t); } else if (len <= UINT16_MAX) { return 1 + sizeof(uint16_t); } else { return 1 + sizeof(uint32_t); } } MP_IMPL uint32_t mp_sizeof_bin(uint32_t len) { return mp_sizeof_binl(len) + len; } MP_IMPL char * mp_encode_strl(char *data, uint32_t len) { if (len <= 31) { *data = 0xa0 | (unsigned char) len; data += 1; } else if (len <= UINT8_MAX) { *data = 0xd9; data += 1; *(uint8_t *) data = len; data += sizeof(uint8_t); } else if (len <= UINT16_MAX) { *data = 0xda; data += 1; *(uint16_t *) data = mp_bswap_u16(len); data += sizeof(uint16_t); } else { *data = 0xdb; data += 1; *(uint32_t *) data = mp_bswap_u32(len); data += sizeof(uint32_t); } return data; } MP_IMPL char * mp_encode_str(char *data, const char *str, uint32_t len) { data = mp_encode_strl(data, len); memcpy(data, str, len); return data + len; } MP_IMPL char * mp_encode_binl(char *data, uint32_t len) { if (len <= UINT8_MAX) { *data = 0xc4; data += 1; *(uint8_t *) data = len; data += sizeof(uint8_t); } else if (len <= UINT16_MAX) { *data = 0xc5; data += 1; *(uint16_t *) data = mp_bswap_u16(len); data += sizeof(uint16_t); } else { *data = 0xc6; data += 1; *(uint32_t *) data = mp_bswap_u32(len); data += sizeof(uint32_t); } return data; } MP_IMPL char * mp_encode_bin(char *data, const char *str, uint32_t len) { data = mp_encode_binl(data, len); memcpy(data, str, len); return data + len; } MP_IMPL ptrdiff_t mp_check_strl(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_STR); unsigned char c = *(unsigned char *) cur; if (mp_likely(c & ~0x1f) == 0xa0) return 1 - (end - cur); assert(c >= 0xd9 && c <= 0xdb); /* must be checked above by mp_typeof */ uint32_t hsize = 1U << (c & 0x3) >> 1; /* 0xd9->1, 0xda->2, 0xdb->4 */ return 1 + hsize - (end - cur); } MP_IMPL ptrdiff_t mp_check_binl(const char *cur, const char *end) { unsigned char c = *(unsigned char *) cur; assert(cur < end); assert(mp_typeof(c) == MP_BIN); assert(c >= 0xc4 && c <= 0xc6); /* must be checked above by mp_typeof */ uint32_t hsize = 1U << (c & 0x3); /* 0xc4->1, 0xc5->2, 0xc6->4 */ return 1 + hsize - (end - cur); } MP_IMPL uint32_t mp_decode_strl(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; uint32_t len; switch (c) { case 0xa0 ... 0xbf: len = c & 0x1f; return len; case 0xd9: len = *(uint8_t *) *data; *data += sizeof(uint8_t); return len; case 0xda: len = mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); return len; case 0xdb: len = mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); return len; default: mp_unreachable(); } } MP_IMPL const char * mp_decode_str(const char **data, uint32_t *len) { assert(len != NULL); *len = mp_decode_strl(data); const char *str = *data; *data += *len; return str; } MP_IMPL uint32_t mp_decode_binl(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; uint32_t len; switch (c) { case 0xc4: len = *(uint8_t *) *data; *data += sizeof(uint8_t); return len; case 0xc5: len = mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); return len; case 0xc6: len = mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); return len; default: mp_unreachable(); } } MP_IMPL const char * mp_decode_bin(const char **data, uint32_t *len) { assert(len != NULL); *len = mp_decode_binl(data); const char *str = *data; *data += *len; return str; } MP_IMPL uint32_t mp_sizeof_nil() { return 1; } MP_IMPL char * mp_encode_nil(char *data) { *data = 0xc0; return data + 1; } MP_IMPL ptrdiff_t mp_check_nil(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_NIL); return 1 - (end - cur); } MP_IMPL void mp_decode_nil(const char **data) { unsigned char c = (unsigned char) **data; assert(c == 0xc0); (void) c; *data += 1; } MP_IMPL uint32_t mp_sizeof_bool(bool val) { (void) val; return 1; } MP_IMPL char * mp_encode_bool(char *data, bool val) { *data = 0xc2 | (val & 1); return data + 1; } MP_IMPL ptrdiff_t mp_check_bool(const char *cur, const char *end) { assert(cur < end); assert(mp_typeof(*cur) == MP_BOOL); return 1 - (end - cur); } MP_IMPL bool mp_decode_bool(const char **data) { unsigned char c = (unsigned char) **data; *data += 1; switch (c) { case 0xc3: return true; case 0xc2: return false; default: mp_unreachable(); } } /** See mp_parser_hint */ enum { MP_HINT = -32, MP_HINT_STR_8 = MP_HINT, MP_HINT_STR_16 = MP_HINT - 1, MP_HINT_STR_32 = MP_HINT - 2, MP_HINT_ARRAY_16 = MP_HINT - 3, MP_HINT_ARRAY_32 = MP_HINT - 4, MP_HINT_MAP_16 = MP_HINT - 5, MP_HINT_MAP_32 = MP_HINT - 6, MP_HINT_EXT_8 = MP_HINT - 7, MP_HINT_EXT_16 = MP_HINT - 8, MP_HINT_EXT_32 = MP_HINT - 9 }; MP_PROTO void mp_next_slowpath(const char **data, int k); MP_IMPL void mp_next_slowpath(const char **data, int k) { for (; k > 0; k--) { unsigned char c = (unsigned char) **data; int l = mp_parser_hint[c]; if (mp_likely(l >= 0)) { *data += l + 1; continue; } else if (mp_likely(l > MP_HINT)) { k -= l; *data += 1; continue; } *data += 1; switch (l) { case MP_HINT_STR_8: /* MP_STR (8) */ *data += *(uint8_t *) *data + sizeof(uint8_t); break; case MP_HINT_STR_16: /* MP_STR (16) */ *data += mp_bswap_u16(*(uint16_t *) *data) + sizeof(uint16_t); break; case MP_HINT_STR_32: /* MP_STR (32) */ *data += mp_bswap_u32(*(uint32_t *) *data) + sizeof(uint32_t); break; case MP_HINT_ARRAY_16: /* MP_ARRAY (16) */ k += mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); break; case MP_HINT_ARRAY_32: /* MP_ARRAY (32) */ k += mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); break; case MP_HINT_MAP_16: /* MP_MAP (16) */ k += 2 * mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); break; case MP_HINT_MAP_32: /* MP_MAP (32) */ k += 2 * mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); break; case MP_HINT_EXT_8: /* MP_EXT (8) */ *data += *(uint8_t *) *data + sizeof(uint8_t) + 1; break; case MP_HINT_EXT_16: /* MP_EXT (16) */ *data += mp_bswap_u16(*(uint16_t *) *data) + sizeof(uint16_t) + 1; break; case MP_HINT_EXT_32: /* MP_EXT (32) */ *data += mp_bswap_u32(*(uint32_t *) *data) + sizeof(uint32_t) + 1; break; default: mp_unreachable(); } } } MP_IMPL void mp_next(const char **data) { int k = 1; for (; k > 0; k--) { unsigned char c = (unsigned char) **data; int l = mp_parser_hint[c]; if (mp_likely(l >= 0)) { *data += l + 1; continue; } else if (mp_likely(c == 0xd9)){ /* MP_STR (8) */ *data += 1; *data += *(uint8_t *) *data + sizeof(uint8_t); continue; } else if (l > MP_HINT) { k -= l; *data += 1; continue; } else { return mp_next_slowpath(data, k); } } } MP_IMPL int mp_check(const char **data, const char *end) { int k; for (k = 1; k > 0; k--) { if (mp_unlikely(*data >= end)) return 1; unsigned char c = (unsigned char) **data; *data += 1; int l = mp_parser_hint[c]; if (mp_likely(l >= 0)) { *data += l; continue; } else if (mp_likely(l > MP_HINT)) { k -= l; continue; } switch (l) { case MP_HINT_STR_8: /* MP_STR (8) */ if (mp_unlikely(*data + sizeof(uint8_t) > end)) return 1; *data += *(uint8_t *) *data + sizeof(uint8_t); break; case MP_HINT_STR_16: /* MP_STR (16) */ if (mp_unlikely(*data + sizeof(uint16_t) > end)) return 1; *data += mp_bswap_u16(*(uint16_t *) *data) + sizeof(uint16_t); break; case MP_HINT_STR_32: /* MP_STR (32) */ if (mp_unlikely(*data + sizeof(uint32_t) > end)) return 1; *data += mp_bswap_u32(*(uint32_t *) *data) + sizeof(uint32_t); break; case MP_HINT_ARRAY_16: /* MP_ARRAY (16) */ if (mp_unlikely(*data + sizeof(uint16_t) > end)) return 1; k += mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); break; case MP_HINT_ARRAY_32: /* MP_ARRAY (32) */ if (mp_unlikely(*data + sizeof(uint32_t) > end)) return 1; k += mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); break; case MP_HINT_MAP_16: /* MP_MAP (16) */ if (mp_unlikely(*data + sizeof(uint16_t) > end)) return false; k += 2 * mp_bswap_u16(*(uint16_t *) *data); *data += sizeof(uint16_t); break; case MP_HINT_MAP_32: /* MP_MAP (32) */ if (mp_unlikely(*data + sizeof(uint32_t) > end)) return 1; k += 2 * mp_bswap_u32(*(uint32_t *) *data); *data += sizeof(uint32_t); break; case MP_HINT_EXT_8: /* MP_EXT (8) */ if (mp_unlikely(*data + sizeof(uint8_t) + 1 > end)) return 1; *data += *(uint8_t *) *data + sizeof(uint8_t); break; case MP_HINT_EXT_16: /* MP_EXT (16) */ if (mp_unlikely(*data + sizeof(uint16_t) + 1 > end)) return 1; *data += mp_bswap_u16(*(uint16_t *) *data) + sizeof(uint16_t) + 1; break; case MP_HINT_EXT_32: /* MP_EXT (32) */ if (mp_unlikely(*data + sizeof(uint32_t) + 1 > end)) return 1; *data += mp_bswap_u32(*(uint32_t *) *data) + sizeof(uint32_t) + 1; break; default: mp_unreachable(); } } if (mp_unlikely(*data > end)) return 1; return 0; } /** \endcond */ /* * }}} */ /* * {{{ Implementation: parser tables */ /** \cond 0 */ #if defined(MP_SOURCE) /** * This lookup table used by mp_sizeof() to determine enum mp_type by the first * byte of MsgPack element. */ const enum mp_type mp_type_hint[256]= { /* {{{ MP_UINT (fixed) */ /* 0x00 */ MP_UINT, /* 0x01 */ MP_UINT, /* 0x02 */ MP_UINT, /* 0x03 */ MP_UINT, /* 0x04 */ MP_UINT, /* 0x05 */ MP_UINT, /* 0x06 */ MP_UINT, /* 0x07 */ MP_UINT, /* 0x08 */ MP_UINT, /* 0x09 */ MP_UINT, /* 0x0a */ MP_UINT, /* 0x0b */ MP_UINT, /* 0x0c */ MP_UINT, /* 0x0d */ MP_UINT, /* 0x0e */ MP_UINT, /* 0x0f */ MP_UINT, /* 0x10 */ MP_UINT, /* 0x11 */ MP_UINT, /* 0x12 */ MP_UINT, /* 0x13 */ MP_UINT, /* 0x14 */ MP_UINT, /* 0x15 */ MP_UINT, /* 0x16 */ MP_UINT, /* 0x17 */ MP_UINT, /* 0x18 */ MP_UINT, /* 0x19 */ MP_UINT, /* 0x1a */ MP_UINT, /* 0x1b */ MP_UINT, /* 0x1c */ MP_UINT, /* 0x1d */ MP_UINT, /* 0x1e */ MP_UINT, /* 0x1f */ MP_UINT, /* 0x20 */ MP_UINT, /* 0x21 */ MP_UINT, /* 0x22 */ MP_UINT, /* 0x23 */ MP_UINT, /* 0x24 */ MP_UINT, /* 0x25 */ MP_UINT, /* 0x26 */ MP_UINT, /* 0x27 */ MP_UINT, /* 0x28 */ MP_UINT, /* 0x29 */ MP_UINT, /* 0x2a */ MP_UINT, /* 0x2b */ MP_UINT, /* 0x2c */ MP_UINT, /* 0x2d */ MP_UINT, /* 0x2e */ MP_UINT, /* 0x2f */ MP_UINT, /* 0x30 */ MP_UINT, /* 0x31 */ MP_UINT, /* 0x32 */ MP_UINT, /* 0x33 */ MP_UINT, /* 0x34 */ MP_UINT, /* 0x35 */ MP_UINT, /* 0x36 */ MP_UINT, /* 0x37 */ MP_UINT, /* 0x38 */ MP_UINT, /* 0x39 */ MP_UINT, /* 0x3a */ MP_UINT, /* 0x3b */ MP_UINT, /* 0x3c */ MP_UINT, /* 0x3d */ MP_UINT, /* 0x3e */ MP_UINT, /* 0x3f */ MP_UINT, /* 0x40 */ MP_UINT, /* 0x41 */ MP_UINT, /* 0x42 */ MP_UINT, /* 0x43 */ MP_UINT, /* 0x44 */ MP_UINT, /* 0x45 */ MP_UINT, /* 0x46 */ MP_UINT, /* 0x47 */ MP_UINT, /* 0x48 */ MP_UINT, /* 0x49 */ MP_UINT, /* 0x4a */ MP_UINT, /* 0x4b */ MP_UINT, /* 0x4c */ MP_UINT, /* 0x4d */ MP_UINT, /* 0x4e */ MP_UINT, /* 0x4f */ MP_UINT, /* 0x50 */ MP_UINT, /* 0x51 */ MP_UINT, /* 0x52 */ MP_UINT, /* 0x53 */ MP_UINT, /* 0x54 */ MP_UINT, /* 0x55 */ MP_UINT, /* 0x56 */ MP_UINT, /* 0x57 */ MP_UINT, /* 0x58 */ MP_UINT, /* 0x59 */ MP_UINT, /* 0x5a */ MP_UINT, /* 0x5b */ MP_UINT, /* 0x5c */ MP_UINT, /* 0x5d */ MP_UINT, /* 0x5e */ MP_UINT, /* 0x5f */ MP_UINT, /* 0x60 */ MP_UINT, /* 0x61 */ MP_UINT, /* 0x62 */ MP_UINT, /* 0x63 */ MP_UINT, /* 0x64 */ MP_UINT, /* 0x65 */ MP_UINT, /* 0x66 */ MP_UINT, /* 0x67 */ MP_UINT, /* 0x68 */ MP_UINT, /* 0x69 */ MP_UINT, /* 0x6a */ MP_UINT, /* 0x6b */ MP_UINT, /* 0x6c */ MP_UINT, /* 0x6d */ MP_UINT, /* 0x6e */ MP_UINT, /* 0x6f */ MP_UINT, /* 0x70 */ MP_UINT, /* 0x71 */ MP_UINT, /* 0x72 */ MP_UINT, /* 0x73 */ MP_UINT, /* 0x74 */ MP_UINT, /* 0x75 */ MP_UINT, /* 0x76 */ MP_UINT, /* 0x77 */ MP_UINT, /* 0x78 */ MP_UINT, /* 0x79 */ MP_UINT, /* 0x7a */ MP_UINT, /* 0x7b */ MP_UINT, /* 0x7c */ MP_UINT, /* 0x7d */ MP_UINT, /* 0x7e */ MP_UINT, /* 0x7f */ MP_UINT, /* }}} */ /* {{{ MP_MAP (fixed) */ /* 0x80 */ MP_MAP, /* 0x81 */ MP_MAP, /* 0x82 */ MP_MAP, /* 0x83 */ MP_MAP, /* 0x84 */ MP_MAP, /* 0x85 */ MP_MAP, /* 0x86 */ MP_MAP, /* 0x87 */ MP_MAP, /* 0x88 */ MP_MAP, /* 0x89 */ MP_MAP, /* 0x8a */ MP_MAP, /* 0x8b */ MP_MAP, /* 0x8c */ MP_MAP, /* 0x8d */ MP_MAP, /* 0x8e */ MP_MAP, /* 0x8f */ MP_MAP, /* }}} */ /* {{{ MP_ARRAY (fixed) */ /* 0x90 */ MP_ARRAY, /* 0x91 */ MP_ARRAY, /* 0x92 */ MP_ARRAY, /* 0x93 */ MP_ARRAY, /* 0x94 */ MP_ARRAY, /* 0x95 */ MP_ARRAY, /* 0x96 */ MP_ARRAY, /* 0x97 */ MP_ARRAY, /* 0x98 */ MP_ARRAY, /* 0x99 */ MP_ARRAY, /* 0x9a */ MP_ARRAY, /* 0x9b */ MP_ARRAY, /* 0x9c */ MP_ARRAY, /* 0x9d */ MP_ARRAY, /* 0x9e */ MP_ARRAY, /* 0x9f */ MP_ARRAY, /* }}} */ /* {{{ MP_STR (fixed) */ /* 0xa0 */ MP_STR, /* 0xa1 */ MP_STR, /* 0xa2 */ MP_STR, /* 0xa3 */ MP_STR, /* 0xa4 */ MP_STR, /* 0xa5 */ MP_STR, /* 0xa6 */ MP_STR, /* 0xa7 */ MP_STR, /* 0xa8 */ MP_STR, /* 0xa9 */ MP_STR, /* 0xaa */ MP_STR, /* 0xab */ MP_STR, /* 0xac */ MP_STR, /* 0xad */ MP_STR, /* 0xae */ MP_STR, /* 0xaf */ MP_STR, /* 0xb0 */ MP_STR, /* 0xb1 */ MP_STR, /* 0xb2 */ MP_STR, /* 0xb3 */ MP_STR, /* 0xb4 */ MP_STR, /* 0xb5 */ MP_STR, /* 0xb6 */ MP_STR, /* 0xb7 */ MP_STR, /* 0xb8 */ MP_STR, /* 0xb9 */ MP_STR, /* 0xba */ MP_STR, /* 0xbb */ MP_STR, /* 0xbc */ MP_STR, /* 0xbd */ MP_STR, /* 0xbe */ MP_STR, /* 0xbf */ MP_STR, /* }}} */ /* {{{ MP_NIL, MP_BOOL */ /* 0xc0 */ MP_NIL, /* 0xc1 */ MP_EXT, /* never used */ /* 0xc2 */ MP_BOOL, /* 0xc3 */ MP_BOOL, /* }}} */ /* {{{ MP_BIN */ /* 0xc4 */ MP_BIN, /* MP_BIN(8) */ /* 0xc5 */ MP_BIN, /* MP_BIN(16) */ /* 0xc6 */ MP_BIN, /* MP_BIN(32) */ /* }}} */ /* {{{ MP_EXT */ /* 0xc7 */ MP_EXT, /* 0xc8 */ MP_EXT, /* 0xc9 */ MP_EXT, /* }}} */ /* {{{ MP_FLOAT, MP_DOUBLE */ /* 0xca */ MP_FLOAT, /* 0xcb */ MP_DOUBLE, /* }}} */ /* {{{ MP_UINT */ /* 0xcc */ MP_UINT, /* 0xcd */ MP_UINT, /* 0xce */ MP_UINT, /* 0xcf */ MP_UINT, /* }}} */ /* {{{ MP_INT */ /* 0xd0 */ MP_INT, /* MP_INT (8) */ /* 0xd1 */ MP_INT, /* MP_INT (16) */ /* 0xd2 */ MP_INT, /* MP_INT (32) */ /* 0xd3 */ MP_INT, /* MP_INT (64) */ /* }}} */ /* {{{ MP_EXT */ /* 0xd4 */ MP_EXT, /* MP_INT (8) */ /* 0xd5 */ MP_EXT, /* MP_INT (16) */ /* 0xd6 */ MP_EXT, /* MP_INT (32) */ /* 0xd7 */ MP_EXT, /* MP_INT (64) */ /* 0xd8 */ MP_EXT, /* MP_INT (127) */ /* }}} */ /* {{{ MP_STR */ /* 0xd9 */ MP_STR, /* MP_STR(8) */ /* 0xda */ MP_STR, /* MP_STR(16) */ /* 0xdb */ MP_STR, /* MP_STR(32) */ /* }}} */ /* {{{ MP_ARRAY */ /* 0xdc */ MP_ARRAY, /* MP_ARRAY(16) */ /* 0xdd */ MP_ARRAY, /* MP_ARRAY(32) */ /* }}} */ /* {{{ MP_MAP */ /* 0xde */ MP_MAP, /* MP_MAP (16) */ /* 0xdf */ MP_MAP, /* MP_MAP (32) */ /* }}} */ /* {{{ MP_INT */ /* 0xe0 */ MP_INT, /* 0xe1 */ MP_INT, /* 0xe2 */ MP_INT, /* 0xe3 */ MP_INT, /* 0xe4 */ MP_INT, /* 0xe5 */ MP_INT, /* 0xe6 */ MP_INT, /* 0xe7 */ MP_INT, /* 0xe8 */ MP_INT, /* 0xe9 */ MP_INT, /* 0xea */ MP_INT, /* 0xeb */ MP_INT, /* 0xec */ MP_INT, /* 0xed */ MP_INT, /* 0xee */ MP_INT, /* 0xef */ MP_INT, /* 0xf0 */ MP_INT, /* 0xf1 */ MP_INT, /* 0xf2 */ MP_INT, /* 0xf3 */ MP_INT, /* 0xf4 */ MP_INT, /* 0xf5 */ MP_INT, /* 0xf6 */ MP_INT, /* 0xf7 */ MP_INT, /* 0xf8 */ MP_INT, /* 0xf9 */ MP_INT, /* 0xfa */ MP_INT, /* 0xfb */ MP_INT, /* 0xfc */ MP_INT, /* 0xfd */ MP_INT, /* 0xfe */ MP_INT, /* 0xff */ MP_INT /* }}} */ }; /** * This lookup table used by mp_next() and mp_check() to determine * size of MsgPack element by its first byte. * A positive value contains size of the element (excluding the first byte). * A negative value means the element is compound (e.g. array or map) * of size (-n). * MP_HINT_* values used for special cases handled by switch() statement. */ const int8_t mp_parser_hint[256] = { /* {{{ MP_UINT(fixed) **/ /* 0x00 */ 0, /* 0x01 */ 0, /* 0x02 */ 0, /* 0x03 */ 0, /* 0x04 */ 0, /* 0x05 */ 0, /* 0x06 */ 0, /* 0x07 */ 0, /* 0x08 */ 0, /* 0x09 */ 0, /* 0x0a */ 0, /* 0x0b */ 0, /* 0x0c */ 0, /* 0x0d */ 0, /* 0x0e */ 0, /* 0x0f */ 0, /* 0x10 */ 0, /* 0x11 */ 0, /* 0x12 */ 0, /* 0x13 */ 0, /* 0x14 */ 0, /* 0x15 */ 0, /* 0x16 */ 0, /* 0x17 */ 0, /* 0x18 */ 0, /* 0x19 */ 0, /* 0x1a */ 0, /* 0x1b */ 0, /* 0x1c */ 0, /* 0x1d */ 0, /* 0x1e */ 0, /* 0x1f */ 0, /* 0x20 */ 0, /* 0x21 */ 0, /* 0x22 */ 0, /* 0x23 */ 0, /* 0x24 */ 0, /* 0x25 */ 0, /* 0x26 */ 0, /* 0x27 */ 0, /* 0x28 */ 0, /* 0x29 */ 0, /* 0x2a */ 0, /* 0x2b */ 0, /* 0x2c */ 0, /* 0x2d */ 0, /* 0x2e */ 0, /* 0x2f */ 0, /* 0x30 */ 0, /* 0x31 */ 0, /* 0x32 */ 0, /* 0x33 */ 0, /* 0x34 */ 0, /* 0x35 */ 0, /* 0x36 */ 0, /* 0x37 */ 0, /* 0x38 */ 0, /* 0x39 */ 0, /* 0x3a */ 0, /* 0x3b */ 0, /* 0x3c */ 0, /* 0x3d */ 0, /* 0x3e */ 0, /* 0x3f */ 0, /* 0x40 */ 0, /* 0x41 */ 0, /* 0x42 */ 0, /* 0x43 */ 0, /* 0x44 */ 0, /* 0x45 */ 0, /* 0x46 */ 0, /* 0x47 */ 0, /* 0x48 */ 0, /* 0x49 */ 0, /* 0x4a */ 0, /* 0x4b */ 0, /* 0x4c */ 0, /* 0x4d */ 0, /* 0x4e */ 0, /* 0x4f */ 0, /* 0x50 */ 0, /* 0x51 */ 0, /* 0x52 */ 0, /* 0x53 */ 0, /* 0x54 */ 0, /* 0x55 */ 0, /* 0x56 */ 0, /* 0x57 */ 0, /* 0x58 */ 0, /* 0x59 */ 0, /* 0x5a */ 0, /* 0x5b */ 0, /* 0x5c */ 0, /* 0x5d */ 0, /* 0x5e */ 0, /* 0x5f */ 0, /* 0x60 */ 0, /* 0x61 */ 0, /* 0x62 */ 0, /* 0x63 */ 0, /* 0x64 */ 0, /* 0x65 */ 0, /* 0x66 */ 0, /* 0x67 */ 0, /* 0x68 */ 0, /* 0x69 */ 0, /* 0x6a */ 0, /* 0x6b */ 0, /* 0x6c */ 0, /* 0x6d */ 0, /* 0x6e */ 0, /* 0x6f */ 0, /* 0x70 */ 0, /* 0x71 */ 0, /* 0x72 */ 0, /* 0x73 */ 0, /* 0x74 */ 0, /* 0x75 */ 0, /* 0x76 */ 0, /* 0x77 */ 0, /* 0x78 */ 0, /* 0x79 */ 0, /* 0x7a */ 0, /* 0x7b */ 0, /* 0x7c */ 0, /* 0x7d */ 0, /* 0x7e */ 0, /* 0x7f */ 0, /* }}} */ /* {{{ MP_MAP (fixed) */ /* 0x80 */ 0, /* empty map - just skip one byte */ /* 0x81 */ -2, /* 2 elements follow */ /* 0x82 */ -4, /* 0x83 */ -6, /* 0x84 */ -8, /* 0x85 */ -10, /* 0x86 */ -12, /* 0x87 */ -14, /* 0x88 */ -16, /* 0x89 */ -18, /* 0x8a */ -20, /* 0x8b */ -22, /* 0x8c */ -24, /* 0x8d */ -26, /* 0x8e */ -28, /* 0x8f */ -30, /* }}} */ /* {{{ MP_ARRAY (fixed) */ /* 0x90 */ 0, /* empty array - just skip one byte */ /* 0x91 */ -1, /* 1 element follows */ /* 0x92 */ -2, /* 0x93 */ -3, /* 0x94 */ -4, /* 0x95 */ -5, /* 0x96 */ -6, /* 0x97 */ -7, /* 0x98 */ -8, /* 0x99 */ -9, /* 0x9a */ -10, /* 0x9b */ -11, /* 0x9c */ -12, /* 0x9d */ -13, /* 0x9e */ -14, /* 0x9f */ -15, /* }}} */ /* {{{ MP_STR (fixed) */ /* 0xa0 */ 0, /* 0xa1 */ 1, /* 0xa2 */ 2, /* 0xa3 */ 3, /* 0xa4 */ 4, /* 0xa5 */ 5, /* 0xa6 */ 6, /* 0xa7 */ 7, /* 0xa8 */ 8, /* 0xa9 */ 9, /* 0xaa */ 10, /* 0xab */ 11, /* 0xac */ 12, /* 0xad */ 13, /* 0xae */ 14, /* 0xaf */ 15, /* 0xb0 */ 16, /* 0xb1 */ 17, /* 0xb2 */ 18, /* 0xb3 */ 19, /* 0xb4 */ 20, /* 0xb5 */ 21, /* 0xb6 */ 22, /* 0xb7 */ 23, /* 0xb8 */ 24, /* 0xb9 */ 25, /* 0xba */ 26, /* 0xbb */ 27, /* 0xbc */ 28, /* 0xbd */ 29, /* 0xbe */ 30, /* 0xbf */ 31, /* }}} */ /* {{{ MP_NIL, MP_BOOL */ /* 0xc0 */ 0, /* MP_NIL */ /* 0xc1 */ 0, /* never used */ /* 0xc2 */ 0, /* MP_BOOL*/ /* 0xc3 */ 0, /* MP_BOOL*/ /* }}} */ /* {{{ MP_BIN */ /* 0xc4 */ MP_HINT_STR_8, /* MP_BIN (8) */ /* 0xc5 */ MP_HINT_STR_16, /* MP_BIN (16) */ /* 0xc6 */ MP_HINT_STR_32, /* MP_BIN (32) */ /* }}} */ /* {{{ MP_EXT */ /* 0xc7 */ MP_HINT_EXT_8, /* MP_EXT (8) */ /* 0xc8 */ MP_HINT_EXT_16, /* MP_EXT (16) */ /* 0xc9 */ MP_HINT_EXT_32, /* MP_EXT (32) */ /* }}} */ /* {{{ MP_FLOAT, MP_DOUBLE */ /* 0xca */ sizeof(float), /* MP_FLOAT */ /* 0xcb */ sizeof(double), /* MP_DOUBLE */ /* }}} */ /* {{{ MP_UINT */ /* 0xcc */ sizeof(uint8_t), /* MP_UINT (8) */ /* 0xcd */ sizeof(uint16_t), /* MP_UINT (16) */ /* 0xce */ sizeof(uint32_t), /* MP_UINT (32) */ /* 0xcf */ sizeof(uint64_t), /* MP_UINT (64) */ /* }}} */ /* {{{ MP_INT */ /* 0xd0 */ sizeof(uint8_t), /* MP_INT (8) */ /* 0xd1 */ sizeof(uint16_t), /* MP_INT (8) */ /* 0xd2 */ sizeof(uint32_t), /* MP_INT (8) */ /* 0xd3 */ sizeof(uint64_t), /* MP_INT (8) */ /* }}} */ /* {{{ MP_EXT (fixext) */ /* 0xd4 */ 2, /* MP_EXT (fixext 8) */ /* 0xd5 */ 3, /* MP_EXT (fixext 16) */ /* 0xd6 */ 5, /* MP_EXT (fixext 32) */ /* 0xd7 */ 9, /* MP_EXT (fixext 64) */ /* 0xd8 */ 17, /* MP_EXT (fixext 128) */ /* }}} */ /* {{{ MP_STR */ /* 0xd9 */ MP_HINT_STR_8, /* MP_STR (8) */ /* 0xda */ MP_HINT_STR_16, /* MP_STR (16) */ /* 0xdb */ MP_HINT_STR_32, /* MP_STR (32) */ /* }}} */ /* {{{ MP_ARRAY */ /* 0xdc */ MP_HINT_ARRAY_16, /* MP_ARRAY (16) */ /* 0xdd */ MP_HINT_ARRAY_32, /* MP_ARRAY (32) */ /* }}} */ /* {{{ MP_MAP */ /* 0xde */ MP_HINT_MAP_16, /* MP_MAP (16) */ /* 0xdf */ MP_HINT_MAP_32, /* MP_MAP (32) */ /* }}} */ /* {{{ MP_INT (fixed) */ /* 0xe0 */ 0, /* 0xe1 */ 0, /* 0xe2 */ 0, /* 0xe3 */ 0, /* 0xe4 */ 0, /* 0xe5 */ 0, /* 0xe6 */ 0, /* 0xe7 */ 0, /* 0xe8 */ 0, /* 0xe9 */ 0, /* 0xea */ 0, /* 0xeb */ 0, /* 0xec */ 0, /* 0xed */ 0, /* 0xee */ 0, /* 0xef */ 0, /* 0xf0 */ 0, /* 0xf1 */ 0, /* 0xf2 */ 0, /* 0xf3 */ 0, /* 0xf4 */ 0, /* 0xf5 */ 0, /* 0xf6 */ 0, /* 0xf7 */ 0, /* 0xf8 */ 0, /* 0xf9 */ 0, /* 0xfa */ 0, /* 0xfb */ 0, /* 0xfc */ 0, /* 0xfd */ 0, /* 0xfe */ 0, /* 0xff */ 0 /* }}} */ }; #endif /* defined(MP_SOURCE) */ /** \endcond */ /* * }}} */ #if defined(__cplusplus) } /* extern "C" */ #endif /* defined(__cplusplus) */ #undef MP_SOURCE #undef MP_PROTO #undef MP_IMPL #undef MP_ALWAYSINLINE #undef MP_GCC_VERSION #endif /* MSGPUCK_H_INCLUDED */ libdr-tarantool-perl-0.44/tp.h0000644000000000000000000007061012210112423014760 0ustar rootroot#ifndef TP_H_INCLUDED #define TP_H_INCLUDED /* * TP - Tarantool Protocol library. * (http://tarantool.org) * * protocol description: * https://github.com/tarantool/tarantool/blob/master/doc/box-protocol.txt * ------------------- * * TP - a C library designed to create requests and process * replies to or from a Tarantool server. * * The library is designed to be used by a C/C++ application which * requires sophisticated memory control and/or performance. * * The library does not support network operations. All operations * are done in a user supplied buffer and with help of * a user-supplied allocator. * * The primary purpose of the library was to spare implementors * of Tarantool drivers in other languages, such as Perl, * Ruby, Python, etc, from the details of the binary protocol, and * also to make it possible to avoid double-buffering by writing * directly to/from language objects from/to a serialized binary * packet stream. This paradigm makes data transfer from domain * language types (such as strings, scalars, numbers, etc) to * the network format direct, and, therefore, most efficient. * * As a side effect, the library is usable in any kind of * networking environment: synchronous with buffered sockets, or * asynchronous event-based, as well as with cooperative * multitasking. * * Before using the library, please get acquainted with * Tarnatool binary protocol, documented at * https://github.com/tarantool/tarantool/blob/master/doc/box-protocol.txt * * BASIC REQUEST STRUCTURE * ----------------------- * * Any request in Tarantool consists of a 12-byte header, * containing request type, id and length, and an optional tuple * or tuples. Similarly, a response carries back the same request * type and id, and then a tuple or tuples. * * Below is a step-by-step tutorial for creating requests * and unpacking responses. * * TO ASSEMBLE A REQUEST * --------------------- * * (1) initialize an instance of struct tp with tp_init(). * Provide tp_init() with a buffer and an (optional) allocator * function. * * (2) construct requests by sequentially calling necessary * operations, such as tp_insert(), tp_delete(), tp_update(), * tp_call(). Note: these operations only append to the buffer * a request header, a body of the request, which is usually * a tuple, must be appended to the buffer with a separate call. * Each next call of tp_*() API appends request data to * the tail of the buffer. If the buffer becomes too small to * contain the binary stream, the reallocation function is * invoked to enlarge the buffer. * A buffer can contain multiple requests: Tarantool * handles them all asynchronously, sending responses * back as soon as they are ready. The request id can be then * used to associate responses with requests. * * For example: * * char buf[256]; * struct tp req; * // initialize request buffer * tp_init(&req, buf, sizeof(buf), NULL, NULL); * // append INSERT packet header to the buffer * // request flags are empty, request id is 0 * tp_insert(&req, 0, 0); * // begin appending a tuple to the request * tp_tuple(&req); * // append one tuple field * tp_sz(&req, "key"); * // one more tuple field * tp_sz(&req, "value"); * * (3) the buffer can be used right after all requests are * appended to it. tp_used() can be used to get the current * buffer size: * * write(1, buf, tp_used(&req)); // write the buffer to stdout * * (4) When no longer needed, the buffer must be freed manually. * * For additional examples, please read the documentation for * buffer operations. * * PROCESSING A REPLY * ------------------ * * (1) tp_init() must be called with a pointer to a buffer which * already stores or will eventually receive the server response. * Functions tp_reqbuf() and tp_req() can be then used to examine * if a network buffer contains a full reply or not. * * Following is an example of tp_req() usage (reading from stdin * and parsing it until a response is completely read): * * struct tp rep; * tp_init(&rep, NULL, 0, tp_realloc, NULL); * * while (1) { * ssize_t to_read = tp_req(&rep); * printf("to_read: %zu\n", to_read); * if (to_read <= 0) * break; * ssize_t new_size = tp_ensure(&rep, to_read); * printf("new_size: %zu\n", new_size); * if (new_size == -1) * return -1; * int rc = fread(rep.p, to_read, 1, stdin); * if (rc != 1) * return 1; * // discard processed data and make space available * // for new input: * tp_use(&rep, to_read); * } * * (2) tp_reply() function can be used to find out if the request * is executed successfully or not: * server_code = tp_reply(&reply); * * if (server_code != 0) { * printf("error: %-.*s\n", tp_replyerrorlen(&rep), * tp_replyerror(&rep)); * } * * Note: the library itself doesn't contain #defines for server * error codes. They are defined in * https://github.com/tarantool/tarantool/blob/master/include/errcode.h * * A server failure can be either transient or persistent. For * example, a failure to allocate memory is transient: as soon as * some data is deleted, the request can be executed again, this * time successfully. A constraint violation is a non-transient * error: it persists regardless of how many times a request * is re-executed. Server error codes can be analyzed to better * handle an error. * * (3) The server usually responds to any kind of request with a * tuple. Tuple data can be accessed via tp_next(), tp_nextfield(), * tp_gettuple(), tp_getfield(). * * See the docs for tp_reply() and tp_next()/tp_nextfield() for an * example. * * API RETURN VALUE CONVENTION * --------------------------- * * API functions return 0 on success, -1 on error. * If a function appends data to struct tp, it returns the * size appended on success, or -1 on error. * * SEE ALSO * -------- * * TP is used by Tarantool Perl driver: * https://github.com/dr-co/dr-tarantool/blob/master/Tarantool.xs */ /* * Copyright (c) 2012-2013 Tarantool AUTHORS * (https://github.com/tarantool/tarantool/blob/master/AUTHORS) * * Redistribution and use in source and binary forms, with or * without modification, are permitted provided that the following * conditions are met: * * 1. Redistributions of source code must retain the above * copyright notice, this list of conditions and the * following disclaimer. * * 2. Redistributions in binary form must reproduce the above * copyright notice, this list of conditions and the following * disclaimer in the documentation and/or other materials * provided with the distribution. * * THIS SOFTWARE IS PROVIDED BY ``AS IS'' AND * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, * INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF * THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #ifdef __cplusplus extern "C" { #endif #include #include #include #include #define tp_function_unused __attribute__((unused)) #define tp_packed __attribute__((packed)) #define tp_inline __attribute__((forceinline)) #define tp_noinline __attribute__((noinline)) #if defined(__GNUC__) #if (__GNUC__ > 4) || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3) #define tp_hot __attribute__((hot)) #endif #endif #if !defined(tp_hot) #define tp_hot #endif #define tp_likely(expr) __builtin_expect(!! (expr), 1) #define tp_unlikely(expr) __builtin_expect(!! (expr), 0) struct tp; /* Reallocation function, can be customized for own use */ typedef char *(*tp_reserve)(struct tp *p, size_t req, size_t *size); /* request types. */ #define TP_PING 65280 #define TP_INSERT 13 #define TP_SELECT 17 #define TP_UPDATE 19 #define TP_DELETE 21 #define TP_CALL 22 /* requests flags */ #define TP_BOX_RETURN_TUPLE 1 #define TP_BOX_ADD 2 #define TP_BOX_REPLACE 4 /* update operation codes */ #define TP_OPSET 0 #define TP_OPADD 1 #define TP_OPAND 2 #define TP_OPXOR 3 #define TP_OPOR 4 #define TP_OPSPLICE 5 #define TP_OPDELETE 6 #define TP_OPINSERT 7 /* internal protocol headers */ struct tp_h { uint32_t type, len, reqid; } tp_packed; struct tp_hinsert { uint32_t space, flags; } tp_packed; struct tp_hdelete { uint32_t space, flags; } tp_packed; struct tp_hupdate { uint32_t space, flags; } tp_packed; struct tp_hcall { uint32_t flags; } tp_packed; struct tp_hselect { uint32_t space, index; uint32_t offset; uint32_t limit; uint32_t keyc; } tp_packed; /* * Main tp object - points either to a request buffer, or to * a response. * * All fields except tp->p should not be accessed directly. * Appropriate accessors should be used instead. */ struct tp { struct tp_h *h; /* current request header */ char *s, *p, *e; /* start, pos, end */ char *t, *f, *u; /* tuple, tuple field, update operation */ char *c; /* reply parsing position */ uint32_t tsz, fsz, tc; /* tuple size, field size, tuple count */ uint32_t code; /* reply server code */ uint32_t cnt; /* reply tuple count */ tp_reserve reserve; /* realloc function pointer */ void *obj; /* reallocation context pointer */ }; /* Get the size of the allocated buffer */ static inline size_t tp_size(struct tp *p) { return p->e - p->s; } /* Get the size of data in the buffer */ static inline size_t tp_used(struct tp *p) { return p->p - p->s; } /* Get the size available for write */ static inline size_t tp_unused(struct tp *p) { return p->e - p->p; } /* A common reallocation function, can be used * for 'reserve' param in tp_init(). * Resizes the buffer twice the previous size using realloc(). * * struct tp req; * tp_init(&req, NULL, tp_realloc, NULL); * tp_ping(&req); // will call the reallocator * * data must be manually freed when the buffer is no longer * needed. * (eg. free(p->s)); * if realloc will return NULL, then you must destroy previous memory. * (eg. * if (tp_realloc(p, ..) == NULL) { * free(p->s) * return NULL; * } */ tp_function_unused static char* tp_realloc(struct tp *p, size_t required, size_t *size) { size_t toalloc = tp_size(p) * 2; if (tp_unlikely(toalloc < required)) toalloc = tp_size(p) + required; *size = toalloc; return realloc(p->s, toalloc); } /* Free function for use in a pair with tp_realloc */ static inline void tp_free(struct tp *p) { free(p->s); } /* Get currently allocated buffer pointer */ static inline char* tp_buf(struct tp *p) { return p->s; } /* Main initialization function. * * reserve - reallocation function, may be NULL * obj - pointer to be passed to the reallocation function as * context * buf - current buffer, may be NULL * size - current buffer size * * Either a buffer pointer or a reserve function must be * provided. */ static inline void tp_init(struct tp *p, char *buf, size_t size, tp_reserve reserve, void *obj) { p->s = buf; p->p = p->s; p->e = p->s + size; p->t = NULL; p->f = NULL; p->u = NULL; p->c = NULL; p->h = NULL; p->tsz = 0; p->fsz = 0; p->cnt = 0; p->code = 0; p->reserve = reserve; p->obj = obj; } /* Ensure that buffer has enough space to fill size bytes, resize * buffer if needed. */ static tp_noinline ssize_t tp_ensure(struct tp *p, size_t size) { if (tp_likely(tp_unused(p) >= size)) return 0; if (tp_unlikely(p->reserve == NULL)) return -1; size_t sz; register char *np = p->reserve(p, size, &sz); if (tp_unlikely(np == NULL)) return -1; p->p = np + (p->p - p->s); if (tp_likely(p->h)) p->h = (struct tp_h*)(np + (((char*)p->h) - p->s)); if (tp_likely(p->t)) p->t = np + (p->t - p->s); if (tp_unlikely(p->f)) p->f = (np + (p->f - p->s)); if (tp_unlikely(p->u)) p->u = (np + (p->u - p->s)); p->s = np; p->e = np + sz; return sz; } /* Mark size bytes as used. * Can be used to tell the buffer that a chunk has been read * from the network into it. */ static inline ssize_t tp_use(struct tp *p, size_t size) { p->p += size; return tp_used(p); } /* Append data to the buffer. * Mostly unnecessary, but can be used to add any raw * iproto-format data to the buffer. * Normally tp_tuple(), tp_field() and tp_sz() should be used * instead. */ static inline ssize_t tp_append(struct tp *p, const void *data, size_t size) { if (tp_unlikely(tp_ensure(p, size) == -1)) return -1; memcpy(p->p, data, size); return tp_use(p, size); } /* Set the current request id. * * tp_ping(&req); * tp_reqid(&req, 777); */ static inline void tp_reqid(struct tp *p, uint32_t reqid) { assert(p->h != NULL); p->h->reqid = reqid; } /* Return the current request id */ static inline uint32_t tp_getreqid(struct tp *p) { assert(p->h != NULL); return p->h->reqid; } /* Get tuple count */ static inline uint32_t tp_tuplecount(struct tp *p) { assert(p->t != NULL); return *(uint32_t*)(p->t); } /* Write a tuple header */ static inline ssize_t tp_tuple(struct tp *p) { assert(p->h != NULL); if (tp_unlikely(tp_ensure(p, sizeof(uint32_t)) == -1)) return -1; *(uint32_t*)(p->t = p->p) = 0; p->p += sizeof(uint32_t); p->h->len += sizeof(uint32_t); if (p->h->type == TP_SELECT) { ((struct tp_hselect*) ((char*)p->h + sizeof(struct tp_h)))->keyc++; } return tp_used(p); } /* Leb128 calculation functions, internally used by the library */ static inline size_t tp_leb128sizeof(uint32_t value) { return ( tp_likely(value < (1 << 7))) ? 1 : ( tp_likely(value < (1 << 14))) ? 2 : (tp_unlikely(value < (1 << 21))) ? 3 : (tp_unlikely(value < (1 << 28))) ? 4 : 5; } static tp_noinline void tp_hot tp_leb128save_slowpath(struct tp *p, uint32_t value) { if (tp_unlikely(value >= (1 << 21))) { if (tp_unlikely(value >= (1 << 28))) *(p->p++) = (value >> 28) | 0x80; *(p->p++) = (value >> 21) | 0x80; } p->p[0] = ((value >> 14) | 0x80); p->p[1] = ((value >> 7) | 0x80); p->p[2] = value & 0x7F; p->p += 3; } static inline void tp_hot tp_leb128save(struct tp *p, uint32_t value) { if (tp_unlikely(value >= (1 << 14))) { tp_leb128save_slowpath(p, value); return; } if (tp_likely(value >= (1 << 7))) *(p->p++) = ((value >> 7) | 0x80); *(p->p++) = ((value) & 0x7F); } static tp_noinline int tp_hot tp_leb128load_slowpath(struct tp *p, uint32_t *value) { if (tp_likely(! (p->f[2] & 0x80))) { *value = (p->f[0] & 0x7f) << 14 | (p->f[1] & 0x7f) << 7 | (p->f[2] & 0x7f); p->f += 3; } else if (! (p->f[3] & 0x80)) { *value = (p->f[0] & 0x7f) << 21 | (p->f[1] & 0x7f) << 14 | (p->f[2] & 0x7f) << 7 | (p->f[3] & 0x7f); p->f += 4; } else if (! (p->f[4] & 0x80)) { *value = (p->f[0] & 0x7f) << 28 | (p->f[1] & 0x7f) << 21 | (p->f[2] & 0x7f) << 14 | (p->f[3] & 0x7f) << 7 | (p->f[4] & 0x7f); p->f += 5; } else return -1; return 0; } static inline int tp_hot tp_leb128load(struct tp *p, uint32_t *value) { if (tp_likely(! (p->f[0] & 0x80))) { *value = *(p->f++) & 0x7f; } else if (tp_likely(! (p->f[1] & 0x80))) { *value = (p->f[0] & 0x7f) << 7 | (p->f[1] & 0x7f); p->f += 2; } else return tp_leb128load_slowpath(p, value); return 0; } /* Write a tuple field * Note: the tuple must be started prior to calling * this function with tp_tuple() call. */ static inline ssize_t tp_field(struct tp *p, const char *data, size_t size) { assert(p->h != NULL); assert(p->t != NULL); register int esz = tp_leb128sizeof(size); if (tp_unlikely(tp_ensure(p, esz + size) == -1)) return -1; tp_leb128save(p, size); memcpy(p->p, data, size); p->p += size; (*(uint32_t*)p->t)++; p->h->len += esz + size; return tp_used(p); } /* Set the current request. * Note: this is an internal helper function, not part of the * tp.h API. */ static inline void tp_setreq(struct tp *p) { p->h = (struct tp_h*)p->p; p->t = NULL; p->u = NULL; } /* Set current request and append data to the buffer. * Note: this is an internal helper function, not part of the * tp.h API. tp_ping(), tp_update() and other functions * which directly create a request header should be used * instead. */ static inline ssize_t tp_appendreq(struct tp *p, void *h, size_t size) { int isallocated = p->p != NULL; tp_setreq(p); ssize_t rc = tp_append(p, h, size); if (tp_unlikely(rc == -1)) return -1; if (!isallocated) p->h = (struct tp_h*)p->s; return rc; } /* Create a ping request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * tp_ping(&req); */ static inline ssize_t tp_ping(struct tp *p) { struct tp_h h = { TP_PING, 0, 0 }; return tp_appendreq(p, &h, sizeof(h)); } /* Create an insert request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * tp_insert(&req, 0, TP_FRET); * tp_tuple(&req); * tp_sz(&req, "key"); * tp_sz(&req, "value"); */ static inline ssize_t tp_insert(struct tp *p, uint32_t space, uint32_t flags) { struct { struct tp_h h; struct tp_hinsert i; } h; h.h.type = TP_INSERT; h.h.len = sizeof(struct tp_hinsert); h.h.reqid = 0; h.i.space = space; h.i.flags = flags; return tp_appendreq(p, &h, sizeof(h)); } /* Create a delete request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * tp_delete(&req, 0, 0); * tp_tuple(&req); * tp_sz(&req, "key"); */ static inline ssize_t tp_delete(struct tp *p, uint32_t space, uint32_t flags) { struct { struct tp_h h; struct tp_hdelete d; } h; h.h.type = TP_DELETE; h.h.len = sizeof(struct tp_hdelete); h.h.reqid = 0; h.d.space = space; h.d.flags = flags; return tp_appendreq(p, &h, sizeof(h)); } /* Create a call request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * * char proc[] = "hello_proc"; * tp_call(&req, 0, proc, sizeof(proc) - 1); * tp_tuple(&req); * tp_sz(&req, "arg1"); * tp_sz(&req, "arg2"); */ static inline ssize_t tp_call(struct tp *p, uint32_t flags, const char *name, size_t name_len) { struct { struct tp_h h; struct tp_hcall c; } h; size_t sz = tp_leb128sizeof(name_len); h.h.type = TP_CALL; h.h.len = sizeof(struct tp_hcall) + sz + name_len; h.h.reqid = 0; h.c.flags = flags; if (tp_unlikely(tp_ensure(p, sizeof(h) + sz + name_len) == -1)) return -1; tp_setreq(p); memcpy(p->p, &h, sizeof(h)); p->p += sizeof(h); tp_leb128save(p, name_len); memcpy(p->p, name, name_len); p->p += name_len; return tp_used(p); } /* Append a select request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * tp_select(&req, 0, 0, 0, 100); * tp_tuple(&req); * tp_sz(&req, "key"); */ static inline ssize_t tp_select(struct tp *p, uint32_t space, uint32_t index, uint32_t offset, uint32_t limit) { struct { struct tp_h h; struct tp_hselect s; } h; h.h.type = TP_SELECT; h.h.len = sizeof(struct tp_hselect); h.h.reqid = 0; h.s.space = space; h.s.index = index; h.s.offset = offset; h.s.limit = limit; h.s.keyc = 0; return tp_appendreq(p, &h, sizeof(h)); } /* Create an update request. * * char buf[64]; * struct tp req; * tp_init(&req, buf, sizeof(buf), NULL, NULL); * tp_update(&req, 0, 0); * tp_tuple(&req); * tp_sz(&req, "key"); * tp_updatebegin(&req); * tp_op(&req, 1, TP_OPSET, "VALUE", 5); */ static inline ssize_t tp_update(struct tp *p, uint32_t space, uint32_t flags) { struct { struct tp_h h; struct tp_hupdate u; } h; h.h.type = TP_UPDATE; h.h.len = sizeof(struct tp_hupdate); h.h.reqid = 0; h.u.space = space; h.u.flags = flags; return tp_appendreq(p, &h, sizeof(h)); } /* Append the number of operations the update request * is going to contain. * Must be called right after appending the key which * identifies the tuple which must be updated. Since * the key can be multipart, tp_tuple() must be used to * append it. * * In other words, this call sequence creates a proper * UPDATE request: * tp_init(...) * tp_update() * tp_tuple() * tp_sz(), tp_sz(), ... * tp_updatebegin() * tp_op(), tp_op(), ... */ static inline ssize_t tp_updatebegin(struct tp *p) { assert(p->h != NULL); assert(p->h->type == TP_UPDATE); if (tp_unlikely(tp_ensure(p, sizeof(uint32_t)) == -1)) return -1; *(uint32_t*)(p->u = p->p) = 0; p->p += sizeof(uint32_t); p->h->len += sizeof(uint32_t); return tp_used(p); } /* Append a single UPDATE operation. * * May be called after tp_updatebegin(). * Can be used to create TP_OPSET, TP_OPADD, TP_OPAND, * TP_OPXOR, TP_OPOR operations. * * See: tp_update() for example. */ static inline ssize_t tp_op(struct tp *p, uint32_t field, uint8_t op, const char *data, size_t size) { assert(p->h != NULL); assert(p->u != NULL); assert(p->h->type == TP_UPDATE); size_t sz = 4 + 1 + tp_leb128sizeof(size) + size; if (tp_unlikely(tp_ensure(p, sz)) == -1) return -1; /* field */ *(uint32_t*)(p->p) = field; p->p += sizeof(uint32_t); /* operation */ *(uint8_t*)(p->p) = op; p->p += sizeof(uint8_t); /* data */ tp_leb128save(p, size); if (tp_likely(data)) memcpy(p->p, data, size); p->p += size; /* update offset and count */ p->h->len += sz; (*(uint32_t*)p->u)++; return tp_used(p); } /* Append a SPLICE operation. This operation is unlike any other, * since it takes three arguments instead of one. */ static inline ssize_t tp_opsplice(struct tp *p, uint32_t field, uint32_t offset, uint32_t cut, const char *paste, size_t paste_len) { uint32_t olen = tp_leb128sizeof(sizeof(offset)), clen = tp_leb128sizeof(sizeof(cut)), plen = tp_leb128sizeof(paste_len); uint32_t sz = olen + sizeof(offset) + clen + sizeof(cut) + plen + paste_len; ssize_t rc = tp_op(p, field, TP_OPSPLICE, NULL, sz); if (tp_unlikely(rc == -1)) return -1; p->p -= sz; tp_leb128save(p, sizeof(offset)); memcpy(p->p, &offset, sizeof(offset)); p->p += sizeof(offset); tp_leb128save(p, sizeof(cut)); memcpy(p->p, &cut, sizeof(cut)); p->p += sizeof(cut); tp_leb128save(p, paste_len); memcpy(p->p, paste, paste_len); p->p += paste_len; return rc; } /* Append a '\0' terminated string as a tuple field. */ static inline ssize_t tp_sz(struct tp *p, const char *sz) { return tp_field(p, sz, strlen(sz)); } /* * Returns the number of bytes which are required to fully * store a reply in the buffer. * The return value can be negative, which indicates that * there is a complete reply in the buffer which is not parsed * and discarded yet. */ static inline ssize_t tp_reqbuf(const char *buf, size_t size) { if (tp_unlikely(size < sizeof(struct tp_h))) return sizeof(struct tp_h) - size; register int sz = ((struct tp_h*)buf)->len + sizeof(struct tp_h); return (tp_likely(size < sz)) ? sz - size : -(size - sz); } /* Same as tp_reqbuf(), but works on the buffer in struct tp. */ static inline ssize_t tp_req(struct tp *p) { return tp_reqbuf(p->s, tp_size(p)); } /* Get the size of a yet unprocessed reply data. * * This is not part of the API. */ static inline size_t tp_unfetched(struct tp *p) { return p->p - p->c; } /* Advance the reply processed pointer. * * This is not part of the API, tp_use() is a higher level * function. */ static inline void* tp_fetch(struct tp *p, int inc) { assert(tp_unfetched(p) >= inc); register char *po = p->c; p->c += inc; return po; } static inline int tp_can_fetch(struct tp *p, int inc) { if (tp_unfetched(p) >= inc) return 1; return 0; } /* Get the last server error. */ static inline char* tp_replyerror(struct tp *p) { return p->c; } /* Get the length of the last error message. */ static inline int tp_replyerrorlen(struct tp *p) { return tp_unfetched(p); } /* Get the tuple count in the response (there must be * no error). */ static inline uint32_t tp_replycount(struct tp *p) { return p->cnt; } /* Get the current response return code. */ static inline uint32_t tp_replycode(struct tp *p) { return p->code; } /* Get the current response operation code. */ static inline uint32_t tp_replyop(struct tp *p) { return p->h->type; } /* * Initialize the buffer with a fully read server response. * The response is parsed. * * struct tp rep; * tp_init(&rep, reply_buf, reply_size, NULL, NULL); * * ssize_t server_code = tp_reply(&rep); * * printf("op: %d\n", tp_replyop(&rep)); * printf("count: %d\n", tp_replycount(&rep)); * printf("code: %zu\n", server_code); * * if (server_code != 0) { * printf("error: %-.*s\n", tp_replyerrorlen(&rep), * tp_replyerror(&rep)); * } * */ tp_function_unused static ssize_t tp_reply(struct tp *p) { ssize_t used = tp_req(p); if (tp_unlikely(used > 0)) return -1; /* this is end of packet in continious buffer */ p->p = p->e + used; /* end - used */ p->c = p->s; if (!tp_can_fetch(p, sizeof(struct tp_h))) return -1; p->h = tp_fetch(p, sizeof(struct tp_h)); p->t = p->f = p->u = NULL; p->cnt = 0; p->code = 0; if (tp_unlikely(p->h->type == TP_PING)) return 0; if (tp_unlikely(p->h->type != TP_UPDATE && p->h->type != TP_INSERT && p->h->type != TP_DELETE && p->h->type != TP_SELECT && p->h->type != TP_CALL)) return -1; if (!tp_can_fetch(p, sizeof(uint32_t))) return -1; p->code = *(uint32_t*)tp_fetch(p, sizeof(uint32_t)); if (p->code != 0) return p->code; /* BOX_QUIET */ if (tp_unlikely(tp_unfetched(p) == 0)) return p->code; if (!tp_can_fetch(p, sizeof(uint32_t))) return -1; p->cnt = *(uint32_t*)tp_fetch(p, sizeof(uint32_t)); return p->code; } /* Example: iteration over returned tuples. * * while (tp_next(&rep)) { * printf("tuple fields: %d\n", tp_tuplecount(&rep)); * printf("tuple size: %d\n", tp_tuplesize(&rep)); * printf("["); * while (tp_nextfield(&rep)) { * printf("%-.*s", tp_getfieldsize(rep), tp_getfield(&rep)); * if (tp_hasnextfield(&rep)) * printf(", "); * } * printf("]\n"); * } */ /* Rewind iteration to the first tuple. */ static inline void tp_rewind(struct tp *p) { p->t = NULL; p->f = NULL; } /* Rewind iteration to the first tuple field of the current tuple. */ static inline void tp_rewindfield(struct tp *p) { p->f = NULL; } /* Get the current tuple data, all fields. */ static inline char* tp_gettuple(struct tp *p) { return p->t; } /* Get the current tuple size. */ static inline uint32_t tp_tuplesize(struct tp *p) { return p->tsz; } /* Get the current field. */ static inline char* tp_getfield(struct tp *p) { return p->f; } /* Get the current field size. */ static inline uint32_t tp_getfieldsize(struct tp *p) { return p->fsz; } /* Get a pointer to the end of the current tuple. */ static inline char* tp_tupleend(struct tp *p) { /* tuple_size + p->t + cardinaltiy_size + * fields_size */ return p->t + 4 + p->tsz; } /* Check if the response has a tuple. * Automatically checked during tp_next() iteration. */ static inline int tp_hasdata(struct tp *p) { return tp_replyop(p) != TP_PING && tp_unfetched(p) > 0; } /* Check if there is a one more tuple. */ static inline int tp_hasnext(struct tp *p) { assert(p->t != NULL); return (p->p - tp_tupleend(p)) >= 4; } /* Check if the current tuple has a one more field. */ static inline int tp_hasnextfield(struct tp *p) { assert(p->t != NULL); register char *f = p->f + p->fsz; if (tp_unlikely(p->f == NULL)) f = p->t + 4; return (tp_tupleend(p) - f) >= 1; } /* Skip to the next tuple. * Tuple can be accessed using: * tp_tuplecount(), tp_tuplesize(), tp_gettuple(). */ static inline int tp_next(struct tp *p) { if (tp_unlikely(p->t == NULL)) { if (tp_unlikely(! tp_hasdata(p))) return 0; p->t = p->c + 4; goto fetch; } if (tp_unlikely(! tp_hasnext(p))) return 0; p->t = tp_tupleend(p) + 4; fetch: p->tsz = *(uint32_t*)(p->t - 4); if (tp_unlikely((p->t + p->tsz) > p->e)) return -1; p->f = NULL; return 1; } /* Skip to the next field. * Data can be accessed using: tp_getfieldsize(), tp_getfield(). */ static inline int tp_nextfield(struct tp *p) { assert(p->t != NULL); if (tp_unlikely(p->f == NULL)) { if (tp_unlikely(! tp_hasnextfield(p))) return 0; p->f = p->t + 4; goto fetch; } if (tp_unlikely(! tp_hasnextfield(p))) return 0; p->f += p->fsz; fetch:; register int rc = tp_leb128load(p, &p->fsz); if (tp_unlikely(rc == -1)) return -1; if (tp_unlikely((p->f + p->fsz) > p->e)) return -1; return 1; } #ifdef __cplusplus } /* extern "C" */ #endif #endif /* TP_H_INCLUDED */ libdr-tarantool-perl-0.44/MANIFEST0000664000000000000000000000366212414722151015335 0ustar rootrootChanges debian/changelog debian/compat debian/control debian/copyright debian/rules debian/source/format debian/watch lib/DR/Tarantool.pm lib/DR/Tarantool/AEConnection.pm lib/DR/Tarantool/AsyncClient.pm lib/DR/Tarantool/CoroClient.pm lib/DR/Tarantool/Iterator.pm lib/DR/Tarantool/LLClient.pm lib/DR/Tarantool/LLSyncClient.pm lib/DR/Tarantool/MsgPack.pm lib/DR/Tarantool/MsgPack/AsyncClient.pm lib/DR/Tarantool/MsgPack/CoroClient.pm lib/DR/Tarantool/MsgPack/LLClient.pm lib/DR/Tarantool/MsgPack/Proto.pm lib/DR/Tarantool/MsgPack/SyncClient.pm lib/DR/Tarantool/RealSyncClient.pm lib/DR/Tarantool/Spaces.pm lib/DR/Tarantool/StartTest.pm lib/DR/Tarantool/SyncClient.pm lib/DR/Tarantool/Tuple.pm lib/DR/Tarantool/Tuple/MsgPack.pm Makefile.PL MANIFEST msgpack.c msgpack.o msgpuck.h rpm/perl-DR-Tarantool.spec rpm/SOURCES/filter-requires-dr-tarantool.sh st/Check/OneHash.pm st/Check/OneTree.pm st/Check/Order.pm st/Check/Ping.pm st/Check/XlogCleanup.pm st/init.lua st/stress.cfg st/stress.pl st/stress.tarantool.cfg t/000-use.t t/005-connection.t t/010-xs.t t/020-low_level_client.t t/025-ll_synclient.t t/030-spaces.t t/033-iterator.t t/040-tuple.t t/050-async-client.t t/060-sync-client.t t/065-realsync-client.t t/070-coro-client.t t/080-tarantool.t t/090-parallel-requests.t t/1.6/015-msgpack-xs.t t/1.6/017-msgpack-proto.t t/1.6/022-msgpack-llclient.t t/1.6/030-msgpack-async.t t/1.6/040-msgpack-sync.t t/1.6/050-msgpack-coro.t t/1.6/data/ll-grant.lua t/1.6/data/ll.lua t/100-transform.t t/110-netsplit-readahead.t t/120-sessionid.t t/130-reconnect.t t/900-podspell.t t/910-pod.t t/920-critic.xt t/test-data/00013-000-ok.bin t/test-data/00013-14082-error.bin t/test-data/00017-000-ok.bin t/test-data/00019-000-ok.bin t/test-data/00020-000-ok.bin t/test-data/00022-000-ok.bin t/test-data/65280-000-ok.bin t/test-data/empty_tuple.00022-000-ok.bin t/test-data/init.lua t/test-data/llc-easy.cfg t/test-data/llc-easy2.cfg Tarantool.bs Tarantool.c Tarantool.o Tarantool.xs tp.h libdr-tarantool-perl-0.44/lib/0000775000000000000000000000000012077477367014770 5ustar rootrootlibdr-tarantool-perl-0.44/lib/DR/0000775000000000000000000000000012414725745015264 5ustar rootrootlibdr-tarantool-perl-0.44/lib/DR/Tarantool/0000775000000000000000000000000012414725153017220 5ustar rootrootlibdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/0000775000000000000000000000000012347544137020553 5ustar rootrootlibdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/LLClient.pm0000644000000000000000000001421012347544137022553 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::MsgPack::LLClient; use Carp; use base qw(DR::Tarantool::LLClient); use DR::Tarantool::MsgPack::Proto; use Data::Dumper; sub connect { my $class = shift; my (%opts, $cb); if (@_ % 2) { $cb = pop; %opts = @_; } else { %opts = @_; $cb = delete $opts{cb}; } $cb ||= sub { }; $class->_check_cb( $cb ); my $user = delete $opts{user}; my $password = delete $opts{password}; $class->SUPER::connect( %opts, cb => sub { my ($tnt) = @_; if (ref $tnt) { if (defined $user and defined $password) { $tnt->{user} = $user; $tnt->{password} = $password; } $tnt->{_connect_cb} = $cb; return; } $cb->( $tnt ); } ); } sub _reconnected { my ($self) = @_; $self->{handshake} = 1; delete $self->{tnt_salt}; } sub _check_rbuf { my ($self) = @_; if ($self->{handshake}) { return unless length $self->{rbuf} >= 128; my $handshake = substr $self->{rbuf}, 0, 128, ''; eval { ($self->{tnt_version}, $self->{tnt_salt}) = DR::Tarantool::MsgPack::Proto::handshake($handshake) }; if ($@) { if (my $cb = delete $self->{_connect_cb}) { $cb->('Broken handshake'); } else { $self->_fatal_error('Broken handshake'); } return; } $self->{handshake} = 0; if (my $cb = delete $self->{_connect_cb}) {{ unless (defined $self->{user} and defined $self->{password}) { $cb->($self); last; } $self->auth(sub { my ($r) = @_; if ('HASH' eq ref $r) { warn $r->{ERROR} unless $r->{CODE} == 0; $cb->($self); } else { $cb->($r); } }); }} } # usual receive while(1) { my ($resp, $tail) = eval { DR::Tarantool::MsgPack::Proto::response $self->{rbuf}; }; if ($@) { $self->_fatal_error('Broken response'); return; } return unless $resp; $self->{rbuf} = $tail; $self->{last_code} = $resp->{CODE}; $self->{last_error_string} = $resp->{ERROR}; my $id = $resp->{SYNC}; my $cb = delete $self->{ wait }{ $id }; if ('CODE' eq ref $cb) { $cb->( $resp ); } else { warn "Unexpected reply from tarantool with id = $id"; } } } sub _fatal_error { my ($self, $msg, $raw) = @_; $self->{last_code} ||= -1; $self->{last_error_string} ||= $msg; my $wait = delete $self->{wait}; $self->{wait} = {}; for (keys %$wait) { my $cb = delete $wait->{$_}; $cb->({ status => 'fatal', ERROR => $msg, SYNC => $_ }, $raw); } $self->set_error($msg) if $self->state ne 'error'; } sub ping { my ($self, $cb) = @_; $self->_check_cb( $cb ); my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::ping($id); $self->_request($id, $pkt, $cb); return; } sub call_lua { my $self = shift; my $proc = shift; $self->_check_cb( my $cb = pop ); my $tuple; if (@_) { $self->_check_tuple($tuple = shift); } else { $tuple = []; } my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::call_lua($id, $proc, $tuple); $self->_request($id, $pkt, $cb); return; } sub auth { my $self = shift; my $cb = pop; ($self->{user}, $self->{password}) = @_ if @_ == 2; $self->_check_cb($cb); croak "user and password must be defined" unless defined $self->{user} and defined $self->{password}; croak "salt is not received yet" unless $self->{tnt_salt}; my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::auth( $id, $self->{user}, $self->{password}, $self->{tnt_salt}); $self->_request($id, $pkt, $cb); return; } sub _request { my ($self, $id, $pkt, $cb) = @_; return $self->SUPER::_request($id, $pkt, sub { unless (exists $_[0]{status}) { if ($_[0]{CODE} == 0) { $_[0]{status} = 'ok'; } else { $_[0]{status} = 'error'; } } &$cb; }); } sub select { my $self = shift; my $space = shift; my $index = shift; my $key = shift; my $cb = pop; my $limit = shift; my $offset = shift; my $iterator = shift; $self->_check_cb( $cb ); my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::select( $id, $space, $index, $key, $limit, $offset, $iterator); $self->_request($id, $pkt, $cb); return; } sub insert { my $self = shift; my $space = shift; my $tuple = shift; my $cb = pop; $self->_check_tuple( $tuple ); $self->_check_cb( $cb ); my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::insert($id, $space, $tuple); $self->_request($id, $pkt, $cb); return; } sub replace { my $self = shift; my $space = shift; my $tuple = shift; my $cb = pop; $self->_check_tuple( $tuple ); $self->_check_cb( $cb ); my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::replace($id, $space, $tuple); $self->_request($id, $pkt, $cb); return; } sub delete:method { my $self = shift; my $cb = pop; $self->_check_cb($cb); my $space = shift; my $key = shift; my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::del($id, $space, $key); $self->_request($id, $pkt, $cb); return; } sub update { my $self = shift; my $cb = pop; $self->_check_cb($cb); my $space = shift; my $key = shift; my $ops = shift; my $id = $self->_req_id; my $pkt = DR::Tarantool::MsgPack::Proto::update($id, $space, $key, $ops); $self->_request($id, $pkt, $cb); return; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/AsyncClient.pm0000644000000000000000000002135712347544137023333 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::MsgPack::AsyncClient; =head1 NAME DR::Tarantool::MsgPack::AsyncClient - async client for tarantool. =head1 SYNOPSIS use DR::Tarantool::MsgPack::AsyncClient; DR::Tarantool::MsgPack::AsyncClient->connect( host => '127.0.0.1', port => 12345, spaces => $spaces, sub { my ($client) = @_; } ); $client->insert('space_name', [1,2,3], sub { ... }); =head1 Class methods =head2 connect Connect to , returns (by callback) an object which can be used to make requests. =head3 Arguments =over =item host & port & user & password Address and auth information of remote tarantool. =item space A hash with space description or a L reference. =item reconnect_period An interval to wait before trying to reconnect after a fatal error or unsuccessful connect. If the field is defined and is greater than 0, the driver tries to reconnect to the server after this interval. Important: the driver does not reconnect after the first unsuccessful connection. It calls callback instead. =item reconnect_always Try to reconnect even after the first unsuccessful connection. =back =cut use DR::Tarantool::MsgPack::LLClient; use DR::Tarantool::Spaces; use DR::Tarantool::Tuple; use Carp; $Carp::Internal{ (__PACKAGE__) }++; use Scalar::Util (); use Data::Dumper; sub connect { my $class = shift; my ($cb, %opts); if ( @_ % 2 ) { $cb = pop; %opts = @_; } else { %opts = @_; $cb = delete $opts{cb}; } $class->_llc->_check_cb( $cb ); my $host = $opts{host} || 'localhost'; my $port = $opts{port} or croak "port isn't defined"; my $user = delete $opts{user}; my $password = delete $opts{password}; my $spaces = Scalar::Util::blessed($opts{spaces}) ? $opts{spaces} : DR::Tarantool::Spaces->new($opts{spaces}); $spaces->family(2); my $reconnect_period = $opts{reconnect_period} || 0; my $reconnect_always = $opts{reconnect_always} || 0; DR::Tarantool::MsgPack::LLClient->connect( host => $host, port => $port, user => $user, password => $password, reconnect_period => $reconnect_period, reconnect_always => $reconnect_always, sub { my ($client) = @_; my $self; if (ref $client) { $self = bless { llc => $client, spaces => $spaces, } => ref($class) || $class; } else { $self = $client; } $cb->( $self ); } ); return; } sub _llc { return $_[0]{llc} if ref $_[0]; 'DR::Tarantool::MsgPack::LLClient' } sub _cb_default { my ($res, $s, $cb) = @_; if ($res->{status} ne 'ok') { $cb->($res->{status} => $res->{CODE}, $res->{ERROR}); return; } if ($s) { $cb->(ok => $s->tuple_class->unpack( $res->{DATA}, $s ), $res->{CODE}); return; } unless ('ARRAY' eq ref $res->{DATA}) { $cb->(ok => $res->{DATA}, $res->{CODE}); return; } unless (@{ $res->{DATA} }) { $cb->(ok => undef, $res->{CODE}); return; } $cb->(ok => DR::Tarantool::Tuple->new($res->{DATA}), $res->{CODE}); return; } =head1 Worker methods All methods accept callbacks which are invoked with the following arguments: =over =item status On success, this field has value 'ok'. The value of this parameter determines the contents of the rest of the callback arguments. =item a tuple or tuples or an error code On success, the second argument contains tuple(s) produced by the request. On error, it contains the server error code. =item errorstr Error string in case of an error. sub { if ($_[0] eq 'ok') { my ($status, $tuples) = @_; ... } else { my ($status, $code, $errstr) = @_; ... } } =back =head2 ping Ping the server. $client->ping(sub { ... }); =head2 insert, replace Insert/replace a tuple into a space. $client->insert('space', [ 1, 'Vasya', 20 ], sub { ... }); $client->replace('space', [ 2, 'Petya', 22 ], sub { ... }); =head2 call_lua Call Lua function. $client->call_lua(foo => ['arg1', 'arg2'], sub { }); =head2 select Select a tuple (or tuples) from a space by index. $client->select('space_name', 'index_name', [ 'key' ], %opts, sub { .. }); Options can be: =over =item limit =item offset =item iterator An iterator for index. Can be: =over =item ALL Returns all tuples in space. =item EQ, GE, LE, GT, LT =back =back =head2 delete Delete a tuple. $client->delete('space_name', [ 'key' ], sub { ... }); =head2 update Update a tuple. $client->update('space', [ 'key' ], \@ops, sub { ... }); C<@ops> is array of operations to update. Each operation is array of elements: =over =item code Code of operation: C<=>, C<+>, C<->, C<&>, C<|>, etc =item field Field number or name. =item arguments =back =cut sub ping { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); $self->_llc->ping(sub { _cb_default($_[0], undef, $cb) }); } sub insert { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $space = shift; my $tuple = shift; $self->_llc->_check_tuple( $tuple ); my $sno; my $s; if (Scalar::Util::looks_like_number $space) { $sno = $space; } else { $s = $self->{spaces}->space($space); $sno = $s->number, $tuple = $s->pack_tuple( $tuple ); } $self->_llc->insert( $sno, $tuple, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); return; } sub replace { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $space = shift; my $tuple = shift; $self->_llc->_check_tuple( $tuple ); my $sno; my $s; if (Scalar::Util::looks_like_number $space) { $sno = $space; } else { $s = $self->{spaces}->space($space); $sno = $s->number, $tuple = $s->pack_tuple( $tuple ); } $self->_llc->replace( $sno, $tuple, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); return; } sub delete :method { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $space = shift; my $key = shift; my $sno; my $s; if (Scalar::Util::looks_like_number $space) { $sno = $space; } else { $s = $self->{spaces}->space($space); $sno = $s->number; } $self->_llc->delete( $sno, $key, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); return; } sub select :method { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $space = shift; my $index = shift; my $key = shift; my %opts = @_; my $sno; my $ino; my $s; if (Scalar::Util::looks_like_number $space) { $sno = $space; croak 'If space is number, index must be number too' unless Scalar::Util::looks_like_number $index; $ino = $index; } else { $s = $self->{spaces}->space($space); $sno = $s->number; $ino = $s->_index( $index )->{no}; } $self->_llc->select( $sno, $ino, $key, $opts{limit}, $opts{offset}, $opts{iterator}, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); } sub update :method { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $space = shift; my $key = shift; my $ops = shift; my $sno; my $s; if (Scalar::Util::looks_like_number $space) { $sno = $space; } else { $s = $self->{spaces}->space($space); $sno = $s->number; $ops = $s->pack_operations($ops); } $self->_llc->update( $sno, $key, $ops, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); } sub call_lua { my $self = shift; my $cb = pop; $self->_llc->_check_cb( $cb ); my $proc = shift; my $tuple = shift; $tuple = [ $tuple ] unless ref $tuple; $self->_llc->_check_tuple( $tuple ); $self->_llc->call_lua( $proc, $tuple, sub { my ($res) = @_; _cb_default($res, undef, $cb); } ); return; } sub last_code { $_[0]->_llc->last_code } sub last_error_string { $_[0]->_llc->last_error_string } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/CoroClient.pm0000644000000000000000000000225512347544137023154 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::MsgPack::CoroClient; use base qw(DR::Tarantool::MsgPack::AsyncClient); use AnyEvent; use Carp; use Data::Dumper; use Coro; sub connect { my ($class, %opts) = @_; my $cv = AE::cv; $opts{raise_error} = 1 unless exists $opts{raise_error}; $class->SUPER::connect(%opts, sub { $cv->send(@_) }); my ($self) = $cv->recv; croak $self unless ref $self; $self->{raise_error} = $opts{raise_error}; return $self; } sub ping { my ($self) = @_; $self->SUPER::ping( Coro::rouse_cb ); my ($status, $tuple, $code) = Coro::rouse_wait; return 1 if $status and $status eq 'ok'; return 0; } for my $method (qw(insert replace select update delete call_lua)) { no strict 'refs'; *{ __PACKAGE__ . "::$method" } = sub { my ($self, @args) = @_; my $m = "SUPER::$method"; $self->$m(@args, Coro::rouse_cb); my @res = Coro::rouse_wait; return $res[1] if $res[0] eq 'ok'; return undef unless $self->{raise_error}; croak sprintf "%s: %s", defined($res[1])? $res[1] : 'unknown', $res[2] ; }; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/Proto.pm0000644000000000000000000002200212347544137022206 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::MsgPack::Proto; use DR::Tarantool::MsgPack qw(msgpack msgunpack msgcheck); use base qw(Exporter); our @EXPORT_OK = qw(call_lua response insert replace del update select auth handshake ping); use Carp; use Scalar::Util 'looks_like_number'; use Digest::SHA 'sha1'; use MIME::Base64; our $DECODE_UTF8 = 1; my (%resolve, %tresolve); my %iter = ( EQ => 0, REQ => 1, ALL => 2, LT => 3, LE => 4, GE => 5, GT => 6, BITS_ALL_SET => 7, BITS_ANY_SET => 8, BITS_ALL_NOT_SET => 9 ); my %riter = reverse %iter; BEGIN { my %types = ( IPROTO_SELECT => 1, IPROTO_INSERT => 2, IPROTO_REPLACE => 3, IPROTO_UPDATE => 4, IPROTO_DELETE => 5, IPROTO_CALL => 6, IPROTO_AUTH => 7, IPROTO_DML_REQUEST_MAX => 8, IPROTO_PING => 64, IPROTO_SUBSCRIBE => 66, ); my %attrs = ( IPROTO_CODE => 0x00, IPROTO_SYNC => 0x01, IPROTO_SERVER_ID => 0x02, IPROTO_LSN => 0x03, IPROTO_TIMESTAMP => 0x04, IPROTO_SPACE_ID => 0x10, IPROTO_INDEX_ID => 0x11, IPROTO_LIMIT => 0x12, IPROTO_OFFSET => 0x13, IPROTO_ITERATOR => 0x14, IPROTO_KEY => 0x20, IPROTO_TUPLE => 0x21, IPROTO_FUNCTION_NAME => 0x22, IPROTO_USER_NAME => 0x23, IPROTO_DATA => 0x30, IPROTO_ERROR => 0x31, ); use constant; while (my ($n, $v) = each %types) { constant->import($n => $v); $n =~ s/^IPROTO_//; $tresolve{$v} = $n; } while (my ($n, $v) = each %attrs) { constant->import($n => $v); $n =~ s/^IPROTO_//; $resolve{$v} = $n; } } sub raw_response($) { my ($response) = @_; my $len; { return unless defined $response; my $lenheader = length $response > 10 ? substr $response, 0, 10 : $response; return unless my $lenlen = msgcheck($lenheader); $len = msgunpack $lenheader, $DECODE_UTF8; croak 'Unexpected msgpack object ' . ref($len) if ref $len; $len += $lenlen; } return if length $response < $len; my @r; my $off = 0; for (1 .. 3) { my $sp = $off ? substr $response, $off : $response; my $len_item = msgcheck $sp; croak 'Broken response' unless $len_item and $len_item + $off <= length $response; push @r => msgunpack $sp, $DECODE_UTF8; $off += $len_item; if ($_ eq 2 and $off == length $response) { push @r => {}; last; } } croak 'Broken response header' unless 'HASH' eq ref $r[1]; croak 'Broken response body' unless 'HASH' eq ref $r[2]; return [ $r[1], $r[2] ], substr $response, $off; } sub response($) { my ($resp, $tail) = raw_response($_[0]); return unless $resp; my ($h, $b) = @$resp; my $res = {}; while(my ($k, $v) = each %$h) { my $name = $resolve{$k}; $name = $k unless defined $name; $res->{$name} = $v; } while(my ($k, $v) = each %$b) { my $name = $resolve{$k}; $name = $k unless defined $name; $res->{$name} = $v; } if (defined $res->{CODE}) { my $n = $tresolve{ $res->{CODE} }; $res->{CODE} = $n if defined $n; } if (defined $res->{ITERATOR}) { my $n = $riter{ $res->{ITERATOR} }; $res->{ITERATOR} = $n if defined $n; } return $res, $tail; } sub request($$) { my ($header, $body) = @_; my $pkt = msgpack($header) . msgpack($body); return msgpack(length $pkt) . $pkt; } sub _call_lua($$$) { my ($sync, $proc, $tuple) = @_; request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_CALL, }, { IPROTO_FUNCTION_NAME, $proc, IPROTO_TUPLE, $tuple, } ; } sub call_lua($$@) { my ($sync, $proc, @args) = @_; return _call_lua($sync, $proc, \@args); } sub insert($$$) { my ($sync, $space, $tuple) = @_; $tuple = [ $tuple ] unless ref $tuple; croak "Cant convert HashRef to tuple" if 'HASH' eq ref $tuple; if (looks_like_number $space) { return request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_INSERT, }, { IPROTO_SPACE_ID, $space, IPROTO_TUPLE, $tuple, } ; } # HACK _call_lua($sync, "box.space.$space:insert", $tuple); } sub replace($$$) { my ($sync, $space, $tuple) = @_; $tuple = [ $tuple ] unless ref $tuple; croak "Cant convert HashRef to tuple" if 'HASH' eq ref $tuple; if (looks_like_number $space) { return request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_REPLACE, }, { IPROTO_SPACE_ID, $space, IPROTO_TUPLE, $tuple, } ; } # HACK _call_lua($sync, "box.space.$space:replace", $tuple); } sub del($$$) { my ($sync, $space, $key) = @_; $key = [ $key ] unless ref $key; croak "Cant convert HashRef to key" if 'HASH' eq ref $key; if (looks_like_number $space) { return request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_DELETE, }, { IPROTO_SPACE_ID, $space, IPROTO_KEY, $key, } ; } # HACK _call_lua($sync, "box.space.$space:delete", $key); } sub update($$$$) { my ($sync, $space, $key, $ops) = @_; croak 'Oplist must be Arrayref' unless 'ARRAY' eq ref $ops; $key = [ $key ] unless ref $key; croak "Cant convert HashRef to key" if 'HASH' eq ref $key; if (looks_like_number $space) { return request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_UPDATE, }, { IPROTO_SPACE_ID, $space, IPROTO_KEY, $key, IPROTO_TUPLE, $ops, } ; } # HACK _call_lua($sync, "box.space.$space:update", [ $key, $ops ]); } sub select($$$$;$$$) { my ($sync, $space, $index, $key, $limit, $offset, $iterator) = @_; $iterator = 'EQ' unless defined $iterator; $offset ||= 0; $limit = 0xFFFF_FFFF unless defined $limit; $key = [ $key ] unless ref $key; croak "Cant convert HashRef to key" if 'HASH' eq ref $key; unless(looks_like_number $iterator) { my $i = $iter{$iterator}; croak "Wrong iterator type: $iterator" unless defined $i; $iterator = $i; } if (looks_like_number $space and looks_like_number $index) { return request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_SELECT, }, { IPROTO_KEY, $key, IPROTO_SPACE_ID, $space, IPROTO_OFFSET, $offset, IPROTO_INDEX_ID, $index, IPROTO_LIMIT, $limit, IPROTO_ITERATOR, $iterator, } ; } # HACK _call_lua($sync, "box.space.$space.index.$index:select", [ $key, { offset => $offset, limit => $limit, iterator => $iterator } ] ); } sub ping($) { my ($sync) = @_; request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_PING, }, { } ; } sub strxor($$) { my ($x, $y) = @_; my @x = unpack 'C*', $x; my @y = unpack 'C*', $y; $x[$_] ^= $y[$_] for 0 .. $#x; return pack 'C*', @x; } sub auth($$$$) { my ($sync, $user, $password, $salt) = @_; my $hpasswd = sha1 $password; my $hhpasswd = sha1 $hpasswd; my $scramble = sha1 $salt . $hhpasswd; my $hash = strxor $hpasswd, $scramble; request { IPROTO_SYNC, $sync, IPROTO_CODE, IPROTO_AUTH, }, { IPROTO_USER_NAME, $user, IPROTO_TUPLE, [ 'chap-sha1', $hash ], } ; } sub handshake($) { my ($h) = @_; croak 'Wrong handshake length' unless length $h == 128; my $version = substr $h, 0, 64; my $salt = substr MIME::Base64::decode_base64(substr $h, 64), 0, 20; for ($version) { s/\0.*//; s/^tarantool:?\s*//i; } return $version, $salt; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack/SyncClient.pm0000644000000000000000000000232112347544137023160 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::MsgPack::SyncClient; use base qw(DR::Tarantool::MsgPack::AsyncClient); use AnyEvent; use Carp; use Data::Dumper; sub connect { my ($class, %opts) = @_; my $cv = AE::cv; $opts{raise_error} = 1 unless exists $opts{raise_error}; $class->SUPER::connect(%opts, sub { $cv->send(@_) }); my ($self) = $cv->recv; croak $self unless ref $self; $self->{raise_error} = $opts{raise_error}; return $self; } sub ping { my ($self) = @_; my $cv = AE::cv; $self->SUPER::ping( sub { $cv->send(@_) } ); my ($status, $tuple, $code) = $cv->recv; return 1 if $status and $status eq 'ok'; return 0; } for my $method (qw(insert replace select update delete call_lua)) { no strict 'refs'; *{ __PACKAGE__ . "::$method" } = sub { my ($self, @args) = @_; my $cv = AE::cv; my $m = "SUPER::$method"; $self->$m(@args, sub { $cv->send(@_) }); my @res = $cv->recv; return $res[1] if $res[0] eq 'ok'; return undef unless $self->{raise_error}; croak sprintf "%s: %s", defined($res[1])? $res[1] : 'unknown', $res[2] ; }; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/Tuple.pm0000644000000000000000000001275312241152046020646 0ustar rootrootuse utf8; use strict; use warnings; =head1 NAME DR::Tarantool::Tuple - a tuple container for L =head1 SYNOPSIS my $tuple = new DR::Tarantool::Tuple([ 1, 2, 3]); my $tuple = new DR::Tarantool::Tuple([ 1, 2, 3], $space); my $tuple = unpack DR::Tarantool::Tuple([ 1, 2, 3], $space); $tuple->next( $other_tuple ); $f = $tuple->raw(0); $f = $tuple->name_field; =head1 DESCRIPTION A tuple contains normalized (unpacked) fields. You can access the fields by their indexes (see L function) or by their names (if they are described in the space). Each tuple can contain references to L tuple and Lator, so that if the server returns more than one tuple, all of them can be accessed. =head1 METHODS =cut package DR::Tarantool::Tuple; use DR::Tarantool::Iterator; use Scalar::Util 'weaken', 'blessed'; use Carp; $Carp::Internal{ (__PACKAGE__) }++; =head2 new A constructor. my $t = DR::Tarantool::Tuple->new([1, 2, 3]); my $t = DR::Tarantool::Tuple->new([1, 2, 3], $space); =cut sub new :method { my ($class, $tuple, $space) = @_; $class = ref $class if ref $class; # hack to replace default autoload $class = $space->tuple_class if $space and $class eq __PACKAGE__; croak 'wrong space' if defined $space and !blessed $space; croak 'tuple must be ARRAYREF [of ARRAYREF]' unless 'ARRAY' eq ref $tuple; croak "tuple can't be empty" unless @$tuple; $tuple = [ $tuple ] unless 'ARRAY' eq ref $tuple->[0]; my $iterator = DR::Tarantool::Iterator->new( $tuple, data => $space, item_class => ref($class) || $class, item_constructor => '_new' ); return bless { idx => 0, iterator => $iterator, } => ref($class) || $class; } sub _new { my ($class, $item, $idx, $iterator) = @_; return bless { idx => $idx, iterator => $iterator, } => ref($class) || $class; } =head2 unpack Another way to construct a tuple. my $t = DR::Tarantool::Tuple->unpack([1, 2, 3], $space); =cut sub unpack :method { my ($class, $tuple, $space) = @_; croak 'wrong space' unless blessed $space; return undef unless defined $tuple; croak 'tuple must be ARRAYREF [of ARRAYREF]' unless 'ARRAY' eq ref $tuple; return undef unless @$tuple; if ('ARRAY' eq ref $tuple->[0]) { my @tu; push @tu => $space->unpack_tuple($_) for @$tuple; return $class->new(\@tu, $space); } return $class->new($space->unpack_tuple($tuple), $space); } =head2 raw Return raw data from the tuple. my $array = $tuple->raw; my $field = $tuple->raw(0); =cut sub raw :method { my ($self, $fno) = @_; my $item = $self->{iterator}->raw_item( $self->{idx} ); return $item unless defined $fno; croak 'wrong field number' unless $fno =~ /^-?\d+$/; return undef if $fno < -@$item; return undef if $fno >= @$item; return $item->[ $fno ]; } =head2 next Append or return the next tuple, provided there is more than one tuple in the result set. my $next_tuple = $tuple->next; =cut sub next :method { my ($self, $tuple) = @_; my $iterator = $self->{iterator}; my $idx = $self->{idx} + 1; # if tuple is exists next works like 'iterator->push' if ('ARRAY' eq ref $tuple) { $iterator->push( $tuple ); $idx = $iterator->count - 1; } return undef unless $idx < $iterator->count; my $next = bless { idx => $idx, iterator => $iterator, } => ref($self); return $next; } =head2 iter Return an iterator object associated with the tuple. my $iterator = $tuple->iter; my $iterator = $tuple->iter('MyTupleClass', 'new'); while(my $t = $iterator->next) { # the first value of $t and $tuple are the same ... } =head3 Arguments =over =item package (optional) =item method (optional) If 'package' and 'method' are present, $iterator->L method constructs objects using C<< $package->$method( $next_tuple ) >> If 'method' is not present and 'package' is present, the iterator blesses the raw array with 'package'. =back =cut sub iter :method { my ($self, $class, $method) = @_; my $iterator = $self->{iterator}; if ($class) { return $self->{iterator}->clone( item_class => $class, item_constructor => sub { my ($c, $item, $idx) = @_; if ($method) { my $bitem = bless { idx => $idx, iterator => $iterator, } => ref($self); return $c->$method( $bitem ); } return bless [ @$item ] => ref($c) || $c; } ); } return $self->{iterator}; } =head2 tail Return the tail of the tuple (array of unnamed fields). The function always returns B (as L). =cut sub tail { my ($self) = @_; my $space = $self->{iterator}->data; my $raw = $self->raw; return [ @$raw[ $space->tail_index .. $#$raw ] ] if $space; return $raw; } sub DESTROY { } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/LLClient.pm0000644000000000000000000004304012347544137021231 0ustar rootrootuse utf8; use strict; use warnings; =head1 NAME DR::Tarantool::LLClient - a low level async client for L =head1 SYNOPSIS DR::Tarantool::LLClient->connect( host => '127.0.0.1', port => '33033', cb => { my ($tnt) = @_; ... } ); $tnt->ping( sub { .. } ); $tnt->insert(0, [ 1, 2, 3 ], sub { ... }); $tnt->select(1, 0, [ [ 1, 2 ], [ 3, 4 ] ], sub { ... }); $tnt->update(0, [ 1 ], [ [ 1 => add pack 'L<', 1 ] ], sub { ... }); $tnt->call_lua( 'box.select', [ 0, 1, 2 ], sub { ... }); =head1 DESCRIPTION This module provides a low-level interface to L. =head1 METHODS All methods receive B as the last argument. The callback receives B value with the following fields: =over =item status Done status: =over =item fatal A fatal error occurred. The server closed the connection or returned a broken package. =item buffer An internal driver error. =item error The request wasn't executed: the server returned an error. =item ok Request was executed OK. =back =item errstr If an error occurred, contains error description. =item code Contains reply code. =item req_id Contains request id. (see L) =item type Contains request type (see L) =item count Contains the count of returned tuples. =item tuples Returned tuples (B of B). =back If you use B or B field types, values for these fields need to be packed before they are sent to the server, and unpacked when received in a response. This is a low-level driver :) =cut package DR::Tarantool::LLClient; use base qw(DR::Tarantool::AEConnection); use AnyEvent; use AnyEvent::Socket; use Carp; use Devel::GlobalDestruction; use File::Spec::Functions 'catfile'; $Carp::Internal{ (__PACKAGE__) }++; use Scalar::Util 'weaken'; require DR::Tarantool; use Data::Dumper; use Time::HiRes (); my $LE = $] > 5.01 ? '<' : ''; =head2 connect Creates a connection to L DR::Tarantool::LLClient->connect( host => '127.0.0.1', port => '33033', cb => { my ($tnt) = @_; ... } ); =head3 Arguments =over =item host & port Host and port to connect to. =item reconnect_period An interval to wait before trying to reconnect after a fatal error or unsuccessful connect. If the field is defined and is greater than 0, the driver tries to reconnect to the server after this interval. B: the driver does not reconnect after B unsuccessful connection. It calls B instead. =item reconnect_always Try to reconnect even after the first unsuccessful connection. =item cb Done callback. The callback receives a connection handle connected to the server or an error string. =back =cut sub connect { my $class = shift; my (%opts, $cb); if (@_ % 2) { $cb = pop; %opts = @_; } else { %opts = @_; $cb = delete $opts{cb}; } $cb ||= sub { }; $class->_check_cb( $cb ); return $class->SUPER::connect if ref $class; my $host = $opts{host} || 'localhost'; my $port = $opts{port} or croak "port is undefined"; my $reconnect_period = $opts{reconnect_period} || 0; my $reconnect_always = $opts{reconnect_always} || 0; my $self = $class->SUPER::new( host => $host, port => $port, reconnect_period => $reconnect_period, reconnect_always => $reconnect_always, ); $self->on(connected => sub { my ($self) = @_; $self->on(connected => $self->on_connected); $self->on_connected->($self); $cb->($self); }); $self->on(connfail => sub { my ($self) = @_; $self->on(connfail => undef); unless($self->reconnect_always) { $self->on(connected => undef); $cb->($self->error); } }); $self->on(error => sub { my ($self) = @_; $self->_fatal_error($self->error); }); $self->SUPER::connect; unless (defined wantarray) { my $cbb = $cb; $cb = sub { &$cbb; undef $self; }; return; } return $self; } sub _reconnected { } sub on_connected { sub { my ($self) = @_; $self->_reconnected; $self->{guard}{read} = AE::io $self->fh, 0, $self->on_read; } } sub disconnect { my ($self, $cb) = @_; $cb ||= sub { }; $self->_check_cb( $cb ); $self->SUPER::disconnect; $cb->( 'ok' ); } sub DESTROY { return if in_global_destruction; my ($self) = @_; $self->disconnect; } =head2 is_connected B if this connection is established. =cut sub is_connected { my ($self) = @_; $self->state eq 'connected'; } =head2 connection_status Contains a string with the status of connection. Return value can be: =over =item ok Connection is established. =item not_connected Connection isn't established yet, or was lost. =item connecting The driver is connecting to the server. =item fatal An attempt to connect was made, but ended up with an error. If the event loop is running, and B option is set, the driver continues to try to reconnect and update its status. =back =cut sub connection_status { my ($self) = @_; return 'ok' if $self->state eq 'connected'; return 'connecting' if $self->state eq 'connecting'; return 'fatal' if $self->state eq 'error'; return 'not_connected'; } =head2 ping Ping the server. $tnt->ping( sub { .. } ); =head3 Arguments =over =item a callback =back =cut sub ping :method { my ($self, $cb) = @_; my $id = $self->_req_id; $self->_check_cb( $cb ); my $pkt = DR::Tarantool::_pkt_ping( $id ); if ($self->is_connected) { $self->_request( $id, $pkt, $cb ); return; } unless($self->reconnect_period) { $cb->({ status => 'fatal', req_id => $id, errstr => "Connection isn't established (yet)" } ); return; } my $this = $self; weaken $this; my $tmr; $tmr = AE::timer $self->reconnect_period, 0, sub { undef $tmr; if ($this and $this->is_connected) { $this->_request( $id, $pkt, $cb ); return; } $cb->({ status => 'fatal', req_id => $id, errstr => "Connection isn't established (yet)" } ); }; } =head2 insert Insert a tuple. $tnt->insert(0, [ 1, 2, 3 ], sub { ... }); $tnt->insert(0, [ 4, 5, 6 ], $flags, sub { .. }); =head3 Arguments =over =item space =item tuple =item flags (optional) =item callback =back =cut sub insert :method { my $self = shift; $self->_check_number( my $space = shift ); $self->_check_tuple( my $tuple = shift ); $self->_check_cb( my $cb = pop ); $self->_check_number( my $flags = pop || 0 ); croak "insert: tuple must be ARRAYREF" unless ref $tuple eq 'ARRAY'; $flags ||= 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_insert( $id, $space, $flags, $tuple ); $self->_request( $id, $pkt, $cb ); return; } =head2 select Select a tuple or tuples. $tnt->select(1, 0, [ [ 1, 2 ], [ 3, 4 ] ], sub { ... }); $tnt->select(1, 0, [ [ 1, 2 ], [ 3, 4 ] ], 1, sub { ... }); $tnt->select(1, 0, [ [ 1, 2 ], [ 3, 4 ] ], 1, 2, sub { ... }); =head3 Arguments =over =item space =item index =item tuple_keys =item limit (optional) If the limit isn't set or is zero, select extracts all records without a limit. =item offset (optional) Default value is B<0>. =item callback for results =back =cut sub select :method { my $self = shift; $self->_check_number( my $ns = shift ); $self->_check_number( my $idx = shift ); $self->_check_tuple_list( my $keys = shift ); $self->_check_cb( my $cb = pop ); $self->_check_number( my $limit = shift || 0x7FFFFFFF ); $self->_check_number( my $offset = shift || 0 ); my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_select($id, $ns, $idx, $offset, $limit, $keys); $self->_request( $id, $pkt, $cb ); return; } =head2 update Update a tuple. $tnt->update(0, [ 1 ], [ [ 1 => add 1 ] ], sub { ... }); $tnt->update( 0, # space [ 1 ], # key [ [ 1 => add 1 ], [ 2 => add => 1 ], # operations $flags, # flags sub { ... } # callback ); $tnt->update(0, [ 1 ], [ [ 1 => add 1 ] ], $flags, sub { ... }); =head3 Arguments =over =item space =item tuple_key =item operations list =item flags (optional) =item callback for results =back =cut sub update :method { my $self = shift; $self->_check_number( my $ns = shift ); $self->_check_tuple( my $key = shift ); $self->_check_operations( my $operations = shift ); $self->_check_cb( my $cb = pop ); $self->_check_number( my $flags = pop || 0 ); my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_update($id, $ns, $flags, $key, $operations); $self->_request( $id, $pkt, $cb ); return; } =head2 delete Delete a tuple. $tnt->delete( 0, [ 1 ], sub { ... }); $tnt->delete( 0, [ 1 ], $flags, sub { ... }); =head3 Arguments =over =item space =item tuple_key =item flags (optional) =item callback for results =back =cut sub delete :method { my $self = shift; my $ns = shift; my $key = shift; $self->_check_tuple( $key ); my $cb = pop; $self->_check_cb( $cb ); my $flags = pop || 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_delete($id, $ns, $flags, $key); $self->_request( $id, $pkt, $cb ); return; } =head2 call_lua Calls a lua procedure. $tnt->call_lua( 'box.select', [ 0, 1, 2 ], sub { ... }); $tnt->call_lua( 'box.select', [ 0, 1, 2 ], $flags, sub { ... }); =head3 Arguments =over =item name of the procedure =item tuple_key =item flags (optional) =item callback to call when the request is ready =back =cut sub call_lua :method { my $self = shift; my $proc = shift; my $tuple = shift; $self->_check_tuple( $tuple ); my $cb = pop; $self->_check_cb( $cb ); my $flags = pop || 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_call_lua($id, $flags, $proc, $tuple); $self->_request( $id, $pkt, $cb ); return; } =head2 last_code Return code of the last request or B if there was no request. =cut sub last_code { my ($self) = @_; return $self->{last_code} if exists $self->{last_code}; return undef; } =head2 last_error_string An error string if the last request ended up with an error, or B otherwise. =cut sub last_error_string { my ($self) = @_; return $self->{last_error_string} if exists $self->{last_error_string}; return undef; } =head1 Logging The module can log requests/responses. Logging can be turned ON by setting these environment variables: =over =item TNT_LOG_DIR Instructs LLClient to record all requests/responses into this directory. =item TNT_LOG_ERRDIR Instructs LLClient to record all requests/responses which ended up with an error into this directory. =back =cut sub _log_transaction { my ($self, $id, $pkt, $response, $res_pkt) = @_; my $logdir = $ENV{TNT_LOG_DIR}; goto DOLOG if $logdir; $logdir = $ENV{TNT_LOG_ERRDIR}; goto DOLOG if $logdir and $response->{status} ne 'ok'; return; DOLOG: eval { die "Directory $logdir was not found, transaction wasn't logged\n" unless -d $logdir; my $now = Time::HiRes::time; my $logdirname = catfile $logdir, sprintf '%s-%s', $now, $response->{status}; die "Object $logdirname is already exists, transaction wasn't logged\n" if -e $logdirname or -d $logdirname; die $! unless mkdir $logdirname; my $rrname = catfile $logdirname, sprintf 'rawrequest-%04d.bin', $id; open my $fh, '>:raw', $rrname or die "Can't open $rrname: $!\n"; print $fh $pkt; close $fh; my $respname = catfile $logdirname, sprintf 'dumpresponse-%04d.txt', $id; open $fh, '>:raw', $respname or die "Can't open $respname: $!\n"; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; local $Data::Dumper::Useqq = 1; local $Data::Dumper::Deepcopy = 1; local $Data::Dumper::Maxdepth = 0; print $fh Dumper($response); close $fh; if (defined $res_pkt) { $respname = catfile $logdirname, sprintf 'rawresponse-%04d.bin', $id; open $fh, '>:raw', $respname or die "Can't open $respname: $!\n"; print $fh $res_pkt; close $fh; } }; warn $@ if $@; } sub _request { my ($self, $id, $pkt, $cb ) = @_; # Scalar::Util::weaken $self; my $cbres = $cb; $cbres = sub { $self->_log_transaction($id, $pkt, @_); &$cb } if $ENV{TNT_LOG_ERRDIR} or $ENV{TNT_LOG_DIR}; $self->{ wait }{ $id } = $cbres; $self->push_write($pkt); } sub _req_id { my ($self) = @_; for (my $id = $self->{req_id} || 0;; $id++) { $id = 0 unless $id < 0x7FFF_FFFF; next if exists $self->{wait}{$id}; $self->{req_id} = $id + 1; return $id; } } sub _fatal_error { my ($self, $msg, $raw) = @_; $self->{last_code} ||= -1; $self->{last_error_string} ||= $msg; delete $self->{fh}; $self->{wbuf} = ''; my $wait = delete $self->{wait}; $self->{wait} = {}; for (keys %$wait) { my $cb = delete $wait->{$_}; $cb->({ status => 'fatal', errstr => $msg, req_id => $_ }, $raw); } $self->set_error($msg) if $self->state ne 'error'; } sub _check_rbuf {{ my ($self) = @_; return unless length $self->{rbuf} >= 12; my (undef, $blen) = unpack "L$LE L$LE", $self->{rbuf}; return unless length $self->{rbuf} >= 12 + $blen; my $pkt = substr $self->{rbuf}, 0, 12 + $blen, ''; my $res = DR::Tarantool::_pkt_parse_response( $pkt ); $self->{last_code} = $res->{code}; if (exists $res->{errstr}) { $self->{last_error_string} = $res->{errstr}; } else { delete $self->{last_error_string}; } if ($res->{status} =~ /^(fatal|buffer)$/) { $self->_fatal_error( $res->{errstr}, $pkt ); return; } my $id = $res->{req_id}; my $cb = delete $self->{ wait }{ $id }; if ('CODE' eq ref $cb) { $cb->( $res, $pkt ); } else { warn "Unexpected reply from tarantool with id = $id"; } redo; }} sub on_read { my $self = shift; sub { my $rd = sysread $self->fh, my $buf, 4096; unless(defined $rd) { return if $!{EINTR}; $self->_fatal_error("Socket error: $!"); return; } unless($rd) { $self->_fatal_error("Socket error: Server closed connection"); return; } $self->{rbuf} .= $buf; $self->_check_rbuf; } # write responses as binfile for tests # { # my ($type, $blen, $id, $code, $body) = # unpack 'L< L< L< L< A*', $hdr . $data; # my $sname = sprintf 't/test-data/%05d-%03d-%s.bin', # $type || 0, $code, $code ? 'fail' : 'ok'; # open my $fh, '>:raw', $sname; # print $fh $hdr; # print $fh $data; # warn "$sname saved (body length: $blen)"; # } } sub _check_cb { my ($self, $cb) = @_; croak 'Callback must be CODEREF' unless 'CODE' eq ref $cb; } sub _check_tuple { my ($self, $tuple) = @_; croak 'Tuple must be ARRAYREF' unless 'ARRAY' eq ref $tuple; } sub _check_tuple_list { my ($self, $list) = @_; croak 'Tuplelist must be ARRAYREF of ARRAYREF' unless 'ARRAY' eq ref $list; croak 'Tuplelist is empty' unless @$list; $self->_check_tuple($_) for @$list; } sub _check_number { my ($self, $number) = @_; croak "argument must be number" unless defined $number and $number =~ /^\d+$/; } sub _check_operation { my ($self, $op) = @_; croak 'Operation must be ARRAYREF' unless 'ARRAY' eq ref $op; croak 'Wrong update operation: too short arglist' unless @$op >= 2; croak "Wrong operation: $op->[1]" unless $op->[1] and $op->[1] =~ /^(delete|set|insert|add|and|or|xor|substr)$/; $self->_check_number($op->[0]); } sub _check_operations { my ($self, $list) = @_; croak 'Operations list must be ARRAYREF of ARRAYREF' unless 'ARRAY' eq ref $list; croak 'Operations list is empty' unless @$list; $self->_check_operation( $_ ) for @$list; } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/StartTest.pm0000644000000000000000000002342012414725153021512 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::StartTest; use Carp; use File::Temp qw(tempfile tempdir); use File::Path 'rmtree'; use File::Spec::Functions qw(catfile rel2abs); use Cwd; use IO::Socket::INET; use POSIX (); use List::MoreUtils 'any'; =head1 NAME DR::Tarantool::StartTest - finds and starts Tarantool on free port. =head1 SYNOPSIS my $t = run DR::Tarantool::StartTest ( cfg => $file_spaces_cfg ); =head1 DESCRIPTION The module tries to find and then to start B. The module is used inside tests. =head1 METHODS =head2 run Constructor. Receives the following arguments: =over =item cfg path to tarantool.cfg =back =cut sub compare_versions($$) { my ($v1, $v2) = @_; my @v1 = split /\./, $v1; my @v2 = split /\./, $v2; for (0 .. (@v1 < @v2 ? $#v1 : $#v2)) { return 'gt' if $v1[$_] > $v2[$_]; return 'lt' if $v1[$_] < $v2[$_]; } return 'gt' if @v1 > @v2; return 'lt' if @v1 < @v2; return 'eq'; } =head2 is_version(VERSION[, FAMILY]) return true if tarantool_box is found and its version is more than L. FAMILY can be: =over =item B<1> (default) For tarantool < 1.6. =item B<2> For tarantool >= 1.6. =back =cut sub is_version($;$) { my ($version, $family) = @_; my $box; $family ||= 1; croak "Unknown family: $family" unless any { $family == $_ } 1, 2; if ($family == 1) { $box = $ENV{TARANTOOL_BOX} || 'tarantool_box'; } else { $box = $ENV{TARANTOOL_BOX} || 'tarantool'; } my $str; { local $SIG{__WARN__} = sub { }; $str = `$box -V`; } return 0 unless $str; return 0 if $str =~ /^tarantool client, version/; my ($vt) = $str =~ /^Tarantool:?\s+(\d(?:\.\d+)+).*\s*$/s; return 0 unless $vt; my $res = compare_versions $version, $vt; return 0 unless any { $_ eq $res } 'eq', 'lt'; return 1; } sub run { my ($module, %opts) = @_; my $cfg_file = delete $opts{cfg} or croak "config file not defined"; croak "File not found" unless -r $cfg_file; open my $fh, '<:encoding(UTF-8)', $cfg_file or die "$@\n"; local $/; my $cfg = <$fh>; my $family = $opts{family} || 1; croak "Unknown family: $family" unless any { $family == $_ } 1, 2; my %self = ( admin_port => $module->_find_free_port, primary_port => $module->_find_free_port, secondary_port => $module->_find_free_port, cfg_data => $cfg, master => $$, cwd => getcwd, add_opts => \%opts, family => $family, ); $opts{script_dir} = rel2abs $opts{script_dir} if $opts{script_dir}; my $self = bless \%self => $module; $self->_start_tarantool; $self; } sub family { my ($self) = @_; return $self->{family}; } =head2 started Return true if Tarantool is found and started =cut sub started { my ($self) = @_; return $self->{started}; } =head2 log Return Tarantool logs =cut sub log { my ($self) = @_; return '' unless $self->{log} and -r $self->{log}; open my $fh, '{log}; local $/; my $l = <$fh>; return $l; } sub admin { my ($self, @cmd) = @_; $cmd[-1] =~ s/\s*$/\n/; my $cmd = join ' ' => @cmd; my $s = IO::Socket::INET->new( PeerHost => '127.0.0.1', PeerPort => $self->admin_port, Proto => 'tcp', (($^O eq 'MSWin32') ? () : (ReuseAddr => 1)), ); croak "Can't connect to admin port: $!" unless $s; print $s $cmd; my @lines; while(<$s>) { s/\s*$//; next if $_ eq '---'; last if $_ eq '...'; push @lines => $_; } close $s; return @lines; } sub _start_tarantool { my ($self) = @_; if ($ENV{TARANTOOL_TEMPDIR}) { $self->{temp} = $ENV{TARANTOOL_TEMPDIR}; $self->{dont_unlink_temp} = 1; rmtree $self->{temp} if -d $self->{temp}; mkdir $self->{temp}; } else { $self->{temp} = tempdir; } if ($self->family) { $self->{cfg} = catfile $self->{temp}, 'tarantool.cfg'; } else { $self->{cfg} = catfile $self->{temp}, 'box.lua'; } $self->{log} = catfile $self->{temp}, 'tarantool.log'; $self->{pid} = catfile $self->{temp}, 'tarantool.pid'; $self->{core} = catfile $self->{temp}, 'core'; if ($self->family == 1) { croak "Available tarantool is not valid (is_version '1.4.0')" unless is_version '1.4.0', $self->family; } else { croak "Available tarantool is not valid (is_version '1.4.0')" unless is_version '1.6.0', $self->family; } $self->{config_body} = $self->{cfg_data}; if ($self->family == 1) { $self->{config_body} .= "\n\n"; $self->{config_body} .= "slab_alloc_arena = 1.1\n"; $self->{config_body} .= sprintf "pid_file = %s\n", $self->{pid}; $self->{box} = $ENV{TARANTOOL_BOX} || 'tarantool_box'; $self->{config_body} .= sprintf "%s = %s\n", $_, $self->{$_} for (qw(admin_port primary_port secondary_port)); $self->{config_body} .= sprintf qq{logger = "cat >> %s"\n}, $self->{log}; for (keys %{ $self->{add_opts} }) { my $v = $self->{add_opts}{ $_ }; if ($v =~ /^\d+$/) { $self->{config_body} .= sprintf qq{%s = %s\n}, $_, $v; } else { $self->{config_body} .= sprintf qq{%s = "%s"\n}, $_, $v; } } } else { $self->{box} = $ENV{TARANTOOL_BOX} || 'tarantool'; for ($self->{config_body}) { if (/primary_port\s*=/) { s{listen\s*=\s*['"]?\d+['"]} /listen = @{[$self->primary_port]}/; } else { s /$& listen = '127.0.0.1:@{[$self->primary_port]}',/; } $_ .= "\n\nrequire('console')". ".listen('127.0.0.1:@{[$self->admin_port]}')"; } } return unless open my $fh, '>:encoding(UTF-8)', $self->{cfg}; print $fh $self->{config_body}; close $fh; chdir $self->{temp}; if ($self->family == 1) { system "$self->{box} -c $self->{cfg} ". "--check-config >> $self->{log} 2>&1"; goto EXIT if $?; system "$self->{box} -c $self->{cfg} --init-storage ". ">> $self->{log} 2>&1"; goto EXIT if $?; } $self->_restart; EXIT: chdir $self->{cwd}; } sub _restart { my ($self) = @_; unless ($self->{child} = fork) { chdir $self->{temp}; die "Can't fork: $!" unless defined $self->{child}; POSIX::setsid(); if ($self->family == 1) { exec "ulimit -c unlimited; ". "exec $self->{box} -c $self->{cfg} >> $self->{log} 2>&1"; } else { exec "ulimit -c unlimited; ". "exec $self->{box} $self->{cfg} >> $self->{log} 2>&1"; } die "Can't start $self->{box}: $!\n"; } $self->{started} = 1; # wait for starting Tarantool for (my $i = 0; $i < 100; $i++) { last if IO::Socket::INET->new( PeerAddr => '127.0.0.1', PeerPort => $self->primary_port ); sleep 0.01; } for (my $i = 0; $i < 100; $i++) { last if $self->log =~ /entering event loop/; sleep 0.01; } sleep 1 unless $self->log =~ /entering event loop/; } sub restart { my ($self) = @_; $self->kill('KILL'); $self->_restart; } =head2 primary_port Return Tarantool primary port =cut sub primary_port { return $_[0]->{primary_port} } =head2 admin_port Return Tarantool admin port =cut sub admin_port { return $_[0]->{admin_port} } =head2 tarantool_pid Return B =cut sub tarantool_pid { return $_[0]->{child} } =head2 kill Kills Tarantool =cut sub kill :method { my ($self, $signame) = @_; $signame ||= 'TERM'; if ($self->{child}) { kill $signame => $self->{child}; waitpid $self->{child}, 0; delete $self->{child}; } $self->{started} = 0; } =head2 is_dead Return true if child Tarantool process is dead. =cut sub is_dead { my ($self) = @_; return 1 unless $self->{child}; return 0 if 0 < kill 0 => $self->{child}; return 1; } =head2 DESTROY Destructor. Kills tarantool, removes temporary files. =cut sub DESTROY { my ($self) = @_; local $?; chdir $self->{cwd}; return unless $self->{master} == $$; if (-r $self->{core}) { warn "Tarantool was coredumped\n" if -r $self->{core}; system "echo bt|gdb $self->{box} $self->{core}"; } $self->kill; rmtree $self->{temp} if $self->{temp} and !$self->{dont_unlink_temp}; } sub temp_dir { my ($self) = @_; return $self->{temp}; } sub clean_xlogs { my ($self) = @_; return unless $self->{temp}; my @xlogs = glob catfile $self->{temp}, '*.xlog'; unlink for @xlogs; } { my %busy_ports; sub _find_free_port { while( 1 ) { my $port = 10000 + int rand 30000; next if exists $busy_ports{ $port }; next unless IO::Socket::INET->new( Listen => 5, LocalAddr => '127.0.0.1', LocalPort => $port, Proto => 'tcp', (($^O eq 'MSWin32') ? () : (ReuseAddr => 1)), ); return $busy_ports{ $port } = $port; } } } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/MsgPack.pm0000644000000000000000000000364012347544137021112 0ustar rootrootuse utf8; use strict; use warnings; =head1 NAME DR::Tarantool::MsgPack - msgpack encoder/decoder. =head1 SYNOPSIS use DR::Tarantool::MsgPack 'msgpack', 'msgunpack', 'msgcheck'; # encode object my $pkt = msgpack({ a => 'b' }); # decode object my $object = msgunpack($pkt); # decode object with utf8-strings my $object = msgunpack($pkt, 1); # check if $string is valid msgpack $object = msgunpack($str, 1) if msgcheck($str); =head1 METHODS =head2 msgpack($OBJECT) Encode perl object (scalar, hash, array) to octets. =head2 msgunpack($OCTETS[, $UTF8]) Decide octets to perl object. Return perl object and tail of input string. If C<$UTF8> is true, L will decode utf8-strings. =cut package DR::Tarantool::MsgPack; use Carp; require DR::Tarantool; use base qw(Exporter); our @EXPORT_OK = qw(msgpack msgunpack msgcheck); sub msgpack($) { DR::Tarantool::_msgpack($_[0]) } sub msgunpack($;$) { my ($pkt, $utf8) = @_; $utf8 ||= 0; $utf8 &&= 1; DR::Tarantool::_msgunpack($pkt, $utf8) } sub msgcheck($) { DR::Tarantool::_msgcheck($_[0]) } sub TRUE() { DR::Tarantool::MsgPack::Bool->new(1) }; sub FALSE() { DR::Tarantool::MsgPack::Bool->new(0) }; =head2 true and false Protocol supports C and C statements. L unpacks them to C<1> and C<0>. If You want to pack C You can use B: use DR::Tarantool::MsgPack 'msgpack'; my $to_pack = { a => DR::Tarantool::MsgPack::Bool->new(0) }; my $pkt = msgpack($to_pack); =cut package DR::Tarantool::MsgPack::Bool; use Carp; use overload 'int' => sub { ${ $_[0] } }, '""' => sub { ${ $_[0] } }, 'bool' => sub { ${ $_[0] } } ; sub new { my ($class, $v) = @_; my $bv = $v ? 1 : 0; return bless \$v => ref($class) || $class; } sub msgpack :method { my ($self) = @_; return scalar pack 'C', ($$self ? 0xC3 : 0xC2); } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/Tuple/0000775000000000000000000000000012347544137020317 5ustar rootrootlibdr-tarantool-perl-0.44/lib/DR/Tarantool/Tuple/MsgPack.pm0000644000000000000000000000521212347544137022200 0ustar rootrootuse utf8; use strict; use warnings; =head1 NAME DR::Tarantool::Tuple::MsgPack - a tuple container for L (v >= 1.6) =head1 SYNOPSIS my $tuple = new DR::Tarantool::Tuple::MsgPack::MsgPack([ 1, 2, 3]); my $tuple = new DR::Tarantool::Tuple::MsgPack::MsgPack([ 1, 2, 3], $space); my $tuple = unpack DR::Tarantool::Tuple::MsgPack::MsgPack([ 1, 2, 3], $space); $tuple->next( $other_tuple ); $f = $tuple->raw(0); $f = $tuple->name_field; =head1 DESCRIPTION A tuple contains normalized (unpacked) fields. You can access the fields by their indexes (see L function) or by their names (if they are described in the space). Each tuple can contain references to L tuple and Lator, so that if the server returns more than one tuple, all of them can be accessed. =head1 METHODS =cut package DR::Tarantool::Tuple::MsgPack; use base qw(DR::Tarantool::Tuple); $Carp::Internal{ (__PACKAGE__) }++; =head2 new A constructor. my $t = DR::Tarantool::Tuple::MsgPack->new([1, 2, 3]); my $t = DR::Tarantool::Tuple::MsgPack->new([1, 2, 3], $space); =cut # sub new { # my ($class, @args) = @_; # return $class->SUPER::new(@args); # } =head2 unpack Another way to construct a tuple. my $t = DR::Tarantool::Tuple::MsgPack->unpack([1, 2, 3], $space); =cut =head2 raw Return raw data from the tuple. my $array = $tuple->raw; my $field = $tuple->raw(0); =cut =head2 next Append or return the next tuple, provided there is more than one tuple in the result set. my $next_tuple = $tuple->next; =cut =head2 iter Return an iterator object associated with the tuple. my $iterator = $tuple->iter; my $iterator = $tuple->iter('MyTupleClass', 'new'); while(my $t = $iterator->next) { # the first value of $t and $tuple are the same ... } =head3 Arguments =over =item package (optional) =item method (optional) If 'package' and 'method' are present, $iterator->L method constructs objects using C<< $package->$method( $next_tuple ) >> If 'method' is not present and 'package' is present, the iterator blesses the raw array with 'package'. =back =cut =head2 tail Return the tail of the tuple (array of unnamed fields). The function always returns B (as L). =cut =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/Spaces.pm0000644000000000000000000004223112347544137021002 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::Spaces; use Carp; $Carp::Internal{ (__PACKAGE__) }++; my $LE = $] > 5.01 ? '<' : ''; =head1 NAME DR::Tarantool::Spaces - Tarantool schema description =head1 SYNOPSIS use DR::Tarantool::Spaces; my $s = new DR::Tarantool::Spaces({ 1 => { name => 'users', # space name default_type => 'STR', # undescribed fields fields => [ qw(login password role), { name => 'counter', type => 'NUM' }, { name => 'something', type => 'UTF8STR', }, { name => 'opts', type => 'JSON', } ], indexes => { 0 => 'login', 1 => [ qw(login password) ], 2 => { name => 'my_idx', fields => 'login', }, 3 => { name => 'my_idx2', fields => [ 'counter', 'something' ] } } }, 0 => { ... } }); my $f = $s->pack_field('users', 'counter', 10); my $f = $s->pack_field('users', 3, 10); # the same my $f = $s->pack_field(1, 3, 10); # the same my $ts = $s->pack_keys([1,2,3] => 'my_idx'); my $t = $s->pack_primary_key([1,2,3]); =head1 DESCRIPTION The package describes all spaces used in an application. It supports the following field types: =over =item NUM, NUM64, STR The standard L types. =item UTF8STR The same as B, but the string is utf8-decoded after it's received from the server. =item INT & INT64 The same as B and B, but contain signed values. =item JSON The field is encoded with L when putting into a database, and decoded after is received back from the server. =back =head1 METHODS =head2 new my $spaces = DR::Tarantool::Spaces->new( $spaces ); =cut sub new { my ($class, $spaces, %opts) = @_; $opts{family} ||= 1; $spaces = {} unless defined $spaces; croak 'spaces must be a HASHREF' unless 'HASH' eq ref $spaces; my (%spaces, %fast); for (keys %$spaces) { my $s = new DR::Tarantool::Space($_ => $spaces->{ $_ }, %opts); $spaces{ $s->name } = $s; $fast{ $_ } = $s->name; } return bless { spaces => \%spaces, fast => \%fast, family => $opts{family}, } => ref($class) || $class; } sub family { my ($self, $family) = @_; return $self->{family} if @_ == 1; $self->{family} = $family; $_->family($family) for values %{ $self->{spaces} }; return $self->{family}; } =head2 space Return space object by number or name. my $space = $spaces->space('name'); my $space = $spaces->space(0); =cut sub space { my ($self, $space) = @_; croak 'space name or number is not defined' unless defined $space; if ($space =~ /^\d+$/) { croak "space '$space' is not defined" unless exists $self->{fast}{$space}; return $self->{spaces}{ $self->{fast}{$space} }; } croak "space '$space' is not defined" unless exists $self->{spaces}{$space}; return $self->{spaces}{$space}; } =head2 space_number Return space number by its name. =cut sub space_number { my ($self, $space) = @_; return $self->space($space)->number; } =head2 pack_field Packs one field into a format suitable for making a database request: my $field = $spaces->pack_field('space', 'field', $data); =cut sub pack_field { my ($self, $space, $field, $value) = @_; croak q{Usage: $spaces->pack_field('space', 'field', $value)} unless @_ == 4; return $self->space($space)->pack_field($field => $value); } =head2 unpack_field Unpack one field after getting it from the server: my $field = $spaces->unpack_field('space', 'field', $data); =cut sub unpack_field { my ($self, $space, $field, $value) = @_; croak q{Usage: $spaces->unpack_field('space', 'field', $value)} unless @_ == 4; return $self->space($space)->unpack_field($field => $value); } =head2 pack_tuple Pack a tuple before making database request. my $t = $spaces->pack_tuple('space', [ 1, 2, 3 ]); =cut sub pack_tuple { my ($self, $space, $tuple) = @_; croak q{Usage: $spaces->pack_tuple('space', $tuple)} unless @_ == 3; return $self->space($space)->pack_tuple( $tuple ); } =head2 unpack_tuple Unpack a tuple after getting it from the database: my $t = $spaces->unpack_tuple('space', \@fields); =cut sub unpack_tuple { my ($self, $space, $tuple) = @_; croak q{Usage: $spaces->unpack_tuple('space', $tuple)} unless @_ == 3; return $self->space($space)->unpack_tuple( $tuple ); } package DR::Tarantool::Space; use Carp; $Carp::Internal{ (__PACKAGE__) }++; use JSON::XS (); use Digest::MD5 (); =head1 SPACES methods =head2 new constructor use DR::Tarantool::Spaces; my $space = DR::Tarantool::Space->new($no, $space); =cut sub new { my ($class, $no, $space, %opts) = @_; $opts{family} ||= 1; croak 'space number must conform the regexp qr{^\d+}' unless defined $no and $no =~ /^\d+$/; croak "'fields' not defined in space hash" unless 'ARRAY' eq ref $space->{fields}; croak "wrong 'indexes' hash" if !$space->{indexes} or 'HASH' ne ref $space->{indexes}; my $name = $space->{name}; croak 'wrong space name: ' . (defined($name) ? $name : 'undef') unless $name and $name =~ /^[a-z_]\w*$/i; my $fqr = qr{^(?:STR|NUM|NUM64|INT|INT64|UTF8STR|JSON|MONEY|BIGMONEY)$}; my (@fields, %fast, $default_type); $default_type = $space->{default_type} || 'STR'; croak "wrong 'default_type'" unless $default_type =~ $fqr; for (my $no = 0; $no < @{ $space->{fields} }; $no++) { my $f = $space->{ fields }[ $no ]; if (ref $f eq 'HASH') { push @fields => { name => $f->{name} || "f$no", idx => $no, type => $f->{type} }; } elsif(ref $f) { croak 'wrong field name or description'; } else { push @fields => { name => $f, idx => $no, type => $default_type, } } my $s = $fields[ -1 ]; croak 'unknown field type: ' . (defined($s->{type}) ? $s->{type} : 'undef') unless $s->{type} and $s->{type} =~ $fqr; croak 'wrong field name: ' . (defined($s->{name}) ? $s->{name} : 'undef') unless $s->{name} and $s->{name} =~ /^[a-z_]\w*$/i; croak "Duplicate field name: $s->{name}" if exists $fast{ $s->{name} }; $fast{ $s->{name} } = $no; } my %indexes; if ($space->{indexes}) { for my $no (keys %{ $space->{indexes} }) { my $l = $space->{indexes}{ $no }; croak "wrong index number: $no" unless $no =~ /^\d+$/; my ($name, $fields); if ('ARRAY' eq ref $l) { $name = "i$no"; $fields = $l; } elsif ('HASH' eq ref $l) { $name = $l->{name} || "i$no"; $fields = [ ref($l->{fields}) ? @{ $l->{fields} } : $l->{fields} ]; } else { $name = "i$no"; $fields = [ $l ]; } croak "wrong index name: $name" unless $name =~ /^[a-z_]\w*$/i; for (@$fields) { croak "field '$_' is presend in index but isn't in fields" unless exists $fast{ $_ }; } $indexes{ $name } = { no => $no, name => $name, fields => $fields }; } } my $tuple_class = 'DR::Tarantool::Tuple::Instance' . Digest::MD5::md5_hex( join "\0", sort keys %fast ); bless { fields => \@fields, fast => \%fast, name => $name, number => $no, default_type => $default_type, indexes => \%indexes, tuple_class => $tuple_class, family => $opts{family}, } => ref($class) || $class; } sub family { my ($self, $family) = @_; return $self->{family} if @_ == 1; return $self->{family} = $family; } =head2 tuple_class Create (or return) a class to hold tuple data. The class is a descendant of L. Returns a unique class (package) name. If a package with such name is already exists, the method doesn't recreate it. =cut sub tuple_class { my ($self) = @_; my $class = $self->{tuple_class}; no strict 'refs'; return $class if ${ $class . '::CREATED' }; die unless eval "package $class; use base 'DR::Tarantool::Tuple'; 1"; for my $fname (keys %{ $self->{fast} }) { my $fnumber = $self->{fast}{$fname}; *{ $class . '::' . $fname } = eval "sub { \$_[0]->raw($fnumber) }"; } ${ $class . '::CREATED' } = time; return $class; } =head2 name Get a space name. =cut sub name { $_[0]{name} } =head2 number Get a space number. =cut sub number { $_[0]{number} } sub _field { my ($self, $field) = @_; croak 'field name or number is not defined' unless defined $field; if ($field =~ /^\d+$/) { return $self->{fields}[ $field ] if $field < @{ $self->{fields} }; return undef; } croak "field with name '$field' is not defined in this space" unless exists $self->{fast}{$field}; return $self->{fields}[ $self->{fast}{$field} ]; } =head2 field_number Return field index by field name. =cut sub field_number { my ($self, $field) = @_; croak 'field name or number is not defined' unless defined $field; return $self->{fast}{$field} if exists $self->{fast}{$field}; croak "Can't find field '$field' in this space"; } =head2 tail_index Return index of the first element that is not described in the space. =cut sub tail_index { my ($self) = @_; return scalar @{ $self->{fields} }; } =head2 pack_field Pack a field before making a database request. =cut sub pack_field { my ($self, $field, $value) = @_; croak q{Usage: $space->pack_field('field', $value)} unless @_ == 3; my $f = $self->_field($field); my $type = $f ? $f->{type} : $self->{default_type}; if ($type eq 'JSON') { my $v = eval { JSON::XS->new->allow_nonref->utf8->encode( $value ) }; croak "Can't pack json: $@" if $@; return $v; } my $v = $value; utf8::encode( $v ) if utf8::is_utf8( $v ); return $v if $type eq 'STR' or $type eq 'UTF8STR'; return pack "L$LE" => $v if $type eq 'NUM'; return pack "l$LE" => $v if $type eq 'INT'; return pack "Q$LE" => $v if $type eq 'NUM64'; return pack "q$LE" => $v if $type eq 'INT64'; if ($type eq 'MONEY' or $type eq 'BIGMONEY') { my ($r, $k) = split /\./, $v; for ($k) { $_ = '.00' unless defined $_; s/^\.//; $_ .= '0' if length $_ < 2; $_ = substr $_, 0, 2; } $r ||= 0; if ($r < 0) { $v = $r * 100 - $k; } else { $v = $r * 100 + $k; } return pack "l$LE", $v if $type eq 'MONEY'; return pack "q$LE", $v; } croak 'Unknown field type:' . $type; } =head2 unpack_field Unpack a single field in a server response. =cut sub unpack_field { my ($self, $field, $value) = @_; croak q{Usage: $space->pack_field('field', $value)} unless @_ == 3; my $f = $self->_field($field); my $type = $f ? $f->{type} : $self->{default_type}; my $v = $value; utf8::encode( $v ) if utf8::is_utf8( $v ); if ($type eq 'JSON') { $v = JSON::XS->new->allow_nonref->utf8->decode( $v ); croak "Can't unpack json: $@" if $@; return $v; } $v = unpack "L$LE" => $v if $type eq 'NUM'; $v = unpack "l$LE" => $v if $type eq 'INT'; $v = unpack "Q$LE" => $v if $type eq 'NUM64'; $v = unpack "q$LE" => $v if $type eq 'INT64'; utf8::decode( $v ) if $type eq 'UTF8STR'; if ($type eq 'MONEY' or $type eq 'BIGMONEY') { $v = unpack "l$LE" => $v if $type eq 'MONEY'; $v = unpack "q$LE" => $v if $type eq 'BIGMONEY'; my $s = ''; if ($v < 0) { $v = -$v; $s = '-'; } my $k = $v % 100; my $r = ($v - $k) / 100; $v = sprintf '%s%d.%02d', $s, $r, $k; } return $v; } =head2 pack_tuple Pack a tuple to the binary protocol format: =cut sub pack_tuple { my ($self, $tuple) = @_; croak 'tuple must be ARRAYREF' unless 'ARRAY' eq ref $tuple; my @res; if ($self->family == 1) { for (my $i = 0; $i < @$tuple; $i++) { push @res => $self->pack_field($i, $tuple->[ $i ]); } } else { @res = @$tuple; } return \@res; } =head2 unpack_tuple Unpack a tuple in a server response. =cut sub unpack_tuple { my ($self, $tuple) = @_; croak 'tuple must be ARRAYREF' unless 'ARRAY' eq ref $tuple; my @res; if ($self->family == 1) { for (my $i = 0; $i < @$tuple; $i++) { push @res => $self->unpack_field($i, $tuple->[ $i ]); } } else { @res = @$tuple; } return \@res; } sub _index { my ($self, $index) = @_; if ($index =~ /^\d+$/) { for (values %{ $self->{indexes} }) { return $_ if $_->{no} == $index; } croak "index $index is undefined"; } return $self->{indexes}{$index} if exists $self->{indexes}{$index}; croak "index `$index' is undefined"; } =head2 index_number returns index number by its name. =cut sub index_number { my ($self, $idx) = @_; croak "index name is undefined" unless defined $idx; return $self->_index( $idx )->{no}; } =head2 index_name returns index name by its number. =cut sub index_name { my ($self, $idx) = @_; croak "index number is undefined" unless defined $idx; return $self->_index( $idx )->{name}; } sub pack_keys { my ($self, $keys, $idx, $disable_warn) = @_; $idx = $self->_index($idx); my $ksize = @{ $idx->{fields} }; $keys = [[ $keys ]] unless 'ARRAY' eq ref $keys; unless('ARRAY' eq ref $keys->[0]) { if ($ksize == @$keys) { $keys = [ $keys ]; carp "Ambiguous keys list (it was used as ONE key), ". "Use brackets to solve the trouble." if $ksize > 1 and !$disable_warn; } else { $keys = [ map { [ $_ ] } @$keys ]; } } my @res; for my $k (@$keys) { croak "key must have $ksize elements" unless $ksize >= @$k; my @packed; for (my $i = 0; $i < @$k; $i++) { my $f = $self->_field($idx->{fields}[$i]); push @packed => $self->pack_field($f->{name}, $k->[$i]) } push @res => \@packed; } return \@res; } sub pack_primary_key { my ($self, $key) = @_; croak 'wrong key format' if 'ARRAY' eq ref $key and 'ARRAY' eq ref $key->[0]; my $t = $self->pack_keys($key, 0, 1); return $t->[0]; } sub pack_operation { my ($self, $op) = @_; croak 'wrong operation' unless 'ARRAY' eq ref $op and @$op > 1; if ($self->family == 1) { my $fno = $op->[0]; my $opname = $op->[1]; my $f = $self->_field($fno); if ($opname eq 'delete') { croak 'wrong operation' unless @$op == 2; return [ $f->{idx} => $opname ]; } if ($opname =~ /^(?:set|insert|add|and|or|xor)$/) { croak 'wrong operation' unless @$op == 3; return [ $f->{idx} => $opname, $self->pack_field($fno, $op->[2]) ]; } if ($opname eq 'substr') { croak 'wrong operation11' unless @$op >= 4; croak 'wrong offset in substr operation' unless $op->[2] =~ /^\d+$/; croak 'wrong length in substr operation' unless $op->[3] =~ /^\d+$/; return [ $f->{idx}, $opname, $op->[2], $op->[3], $op->[4] ]; } croak "unknown operation: $opname"; } my $fno = $op->[1]; my $f = $self->_field($fno); my @res = @$op; splice @res, 1, 1, $f->{idx}; return \@res; } sub pack_operations { my ($self, $ops) = @_; croak 'wrong operation' unless 'ARRAY' eq ref $ops and @$ops >= 1; $ops = [ $ops ] unless 'ARRAY' eq ref $ops->[ 0 ]; my @res; push @res => $self->pack_operation( $_ ) for @$ops; return \@res; } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/AEConnection.pm0000644000000000000000000001076012347544137022073 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::AEConnection; use AnyEvent; use AnyEvent::Socket (); use Carp; use List::MoreUtils (); use Scalar::Util (); sub _errno() { while (my ($k, $v) = each(%!)) { return $k if $v; } return $!; } sub new { my ($class, %opts) = @_; $opts{state} = 'init'; $opts{host} ||= '127.0.0.1'; croak 'port is undefined' unless $opts{port}; $opts{on}{connected} ||= sub { }; $opts{on}{connfail} ||= sub { }; $opts{on}{disconnect} ||= sub { }; $opts{on}{error} ||= sub { }; $opts{on}{reconnecting} ||= sub { }; $opts{success_connects} = 0; $opts{wbuf} = ''; $opts{read} = { any => [] }; bless \%opts => ref($class) || $class; } sub on { my ($self, $name, $cb) = @_; croak "wrong event name: $name" unless exists $self->{on}{$name}; $self->{on}{$name} = $cb || sub { }; $self; } sub fh { $_[0]->{fh} } sub state { $_[0]->{state} } sub host { $_[0]->{host} } sub port { $_[0]->{port} } sub error { $_[0]->{error} } sub errno { $_[0]->{errno} } sub reconnect_always { $_[0]->{reconnect_always} } sub reconnect_period { $_[0]->{reconnect_period} } sub timeout { my ($self) = @_; return $self->{timeout} if @_ == 1; return $self->{timeout} = $_[1]; } sub set_error { my ($self, $error, $errno) = @_; $errno ||= $error; $self->{state} = 'error'; $self->{error} = $error; $self->{errno} = $errno; $self->{on}{error}($self); $self->{guard} = {}; $self->{wbuf} = ''; $self->_check_reconnect; } sub _check_reconnect { Scalar::Util::weaken(my $self = shift); return if $self->state eq 'connected'; return if $self->state eq 'connecting'; return if $self->{guard}{rc}; return unless $self->reconnect_period; unless ($self->reconnect_always) { return unless $self->{success_connects}; } $self->{guard}{rc} = AE::timer $self->reconnect_period, 0, sub { return unless $self; delete $self->{guard}{rc}; $self->{on}{reconnecting}($self); $self->connect; }; } sub connect { Scalar::Util::weaken(my $self = shift); return if $self->state eq 'connected' or $self->state eq 'connecting'; $self->{state} = 'connecting'; $self->{error} = undef; $self->{errno} = undef; $self->{guard} = {}; $self->{guard}{c} = AnyEvent::Socket::tcp_connect $self->host, $self->port, sub { $self->{guard} = {}; my ($fh) = @_; if ($fh) { $self->{fh} = $fh; $self->{state} = 'connected'; $self->{success_connects}++; $self->push_write('') if length $self->{wbuf}; $self->{on}{connected}($self); return; } $self->{error} = $!; $self->{errno} = _errno; $self->{state} = 'connfail'; $self->{guard} = {}; $self->{on}{connfail}($self); return unless $self; $self->_check_reconnect; }, sub { } ; if (defined $self->timeout) { $self->{guard}{t} = AE::timer $self->timeout, 0, sub { delete $self->{guard}{t}; return unless $self->state eq 'connecting'; $self->{error} = 'Connection timeout'; $self->{errno} = 'ETIMEOUT'; $self->{state} = 'connfail'; $self->{guard} = {}; $self->{on}{connfail}($self); $self->_check_reconnect; }; } $self; } sub disconnect { Scalar::Util::weaken(my $self = shift); return if $self->state eq 'disconnect' or $self->state eq 'init'; $self->{guard} = {}; $self->{error} = 'Disconnected'; $self->{errno} = 'SUCCESS'; $self->{state} = 'disconnect'; $self->{wbuf} = ''; $self->{on}{disconnect}($self); } sub push_write { Scalar::Util::weaken(my $self = shift); my ($str) = @_; $self->{wbuf} .= $str; return unless $self->state eq 'connected'; return unless length $self->{wbuf}; return if $self->{guard}{write}; $self->{guard}{write} = AE::io $self->fh, 1, sub { my $l = syswrite $self->fh, $self->{wbuf}; unless(defined $l) { return if $!{EINTR}; $self->set_error($!, _errno); return; } substr $self->{wbuf}, 0, $l, ''; return if length $self->{wbuf}; delete $self->{guard}{write}; }; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/AsyncClient.pm0000644000000000000000000003050012335134032021756 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::AsyncClient; use DR::Tarantool::LLClient; use DR::Tarantool::Spaces; use DR::Tarantool::Tuple; use Carp; $Carp::Internal{ (__PACKAGE__) }++; use Data::Dumper; use Scalar::Util 'blessed'; =head1 NAME DR::Tarantool::AsyncClient - async client for L =head1 SYNOPSIS use DR::Tarantool::AsyncClient 'tarantool'; DR::Tarantool::AsyncClient->connect( host => '127.0.0.1', port => 12345, spaces => { 0 => { name => 'users', fields => [ qw(login password role), { name => 'counter', type => 'NUM' } ], indexes => { 0 => 'login', 1 => [ qw(login password) ], } }, 2 => { name => 'roles', fields => [ qw(name title) ], indexes => { 0 => 'name', 1 => { name => 'myindex', fields => [ 'name', 'title' ], } } } }, sub { my ($client) = @_; ... } ); $client->ping(sub { ... }); $client->insert('space', [ 'user', 10, 'password' ], sub { ... }); $client->call_lua(foo => ['arg1', 'arg2'], sub { }); $client->select('space', 1, sub { ... }); $client->delete('space', 1, sub { ... }); $client->update('space', 1, [ passwd => set => 'abc' ], sub { .. }); =head1 Class methods =cut sub _split_args { if (@_ % 2) { my ($self, %opts) = @_; my $cb = delete $opts{cb}; return ($self, $cb, %opts); } my $cb = pop; splice @_, 1, 0, $cb; return @_; } =head2 connect Connects to L, returns (by callback) an object which can be used to make requests. DR::Tarantool::AsyncClient->connect( host => $host, port => $port, spaces => $spaces, reconnect_period => 0.5, reconnect_always => 1, sub { my ($obj) = @_; if (ref $obj) { ... # handle errors } ... } ); =head3 Arguments =over =item host & port Address where tarantool is started. =item spaces A hash with space description or a L reference. =item reconnect_period & reconnect_always See L for more details. =back =cut sub connect { my $class = shift; my ($cb, %opts); if ( @_ % 2 ) { $cb = pop; %opts = @_; } else { %opts = @_; $cb = delete $opts{cb}; } $class->_llc->_check_cb( $cb ); my $host = $opts{host} || 'localhost'; my $port = $opts{port} or croak "port isn't defined"; my $spaces = blessed($opts{spaces}) ? $opts{spaces} : DR::Tarantool::Spaces->new($opts{spaces}); my $reconnect_period = $opts{reconnect_period} || 0; my $reconnect_always = $opts{reconnect_always} || 0; DR::Tarantool::LLClient->connect( host => $host, port => $port, reconnect_period => $reconnect_period, reconnect_always => $reconnect_always, sub { my ($client) = @_; my $self; if (ref $client) { $self = bless { llc => $client, spaces => $spaces, } => ref($class) || $class; } else { $self = $client; } $cb->( $self ); } ); return; } =head1 Attributes =head2 space Returns a space object by space name or numeric id. See perldoc L for more details. =cut sub space { my ($self, $name) = @_; return $self->{spaces}->space($name); } sub disconnect { my ($self, $cb) = @_; $self->_llc->disconnect( $cb ); } sub _llc { return $_[0]{llc} if ref $_[0]; return 'DR::Tarantool::LLClient' } sub _cb_default { my ($res, $s, $cb) = @_; if ($res->{status} ne 'ok') { $cb->($res->{status} => $res->{code}, $res->{errstr}); return; } if ($s) { $cb->( ok => $s->tuple_class->unpack( $res->{tuples}, $s ), $res->{code} ); } else { $cb->( 'ok', $res->{tuples}, $res->{code} ); } return; } =head1 Worker methods All methods accept callbacks which are invoked with the following arguments: =over =item status On success, this field has value 'B'. The value of this parameter determines the contents of the rest of the callback arguments. =item a tuple or tuples or an error code On success, the second argument contains tuple(s) produced by the request. On error, it contains the server error code. =item errorstr Error string in case of an error. =back sub { if ($_[0] eq 'ok') { my ($status, $tuples) = @_; ... } else { my ($status, $code, $errstr) = @_; } } =head2 ping Ping the server. $client->ping(sub { ... }); =head3 Arguments =over =item cb =back =cut sub ping { my ($self, $cb, %opts) = &_split_args; $self->_llc->ping(sub { _cb_default($_[0], undef, $cb) }); } =head2 insert Insert a tuple into a space. $client->insert('space', [ 'user', 10, 'password' ], sub { ... }); $client->insert('space', \@tuple, $flags, sub { ... }); =head3 Arguments =over =item space_name =item tuple =item flags (optional) Possible flags are described in perldoc L. =item callback =back =cut sub insert { my $self = shift; $self->_llc->_check_cb( my $cb = pop ); my $space = shift; $self->_llc->_check_tuple( my $tuple = shift ); my $flags = pop || 0; my $s = $self->{spaces}->space($space); $self->_llc->insert( $s->number, $s->pack_tuple( $tuple ), $flags, sub { my ($res) = @_; _cb_default($res, $s, $cb); } ); return; } =head2 call_lua Call a Lua function. All arguments are passed to Lua as binary strings. Returned tuples can be unpacked using either a space description or a format specification. $client->call_lua(foo => ['arg1', 'arg2'], sub { }); $client->call_lua(foo => [], 'space_name', sub { ... }); $client->call_lua(foo => \@args, flags => $f, space => $space_name, sub { ... } ); $client->call_lua(foo => \@args, fields => [ qw(a b c) ], sub { ... } ); $client->call_lua(foo => \@args, fields => [ qw(a b c), { type => 'NUM', name => 'abc'} ... ], sub { ... } ); =head3 Arguments =over =item function name =item function arguments =item space or fields Is optional. If given, this space description will be used to interpret contents of tuples returned by the procedure. Alternatively, instead of providing a reference to a space, the format can be set explicitly with B argument. =item callback =back =head4 Optional arguments =over =item space Space name. Use the argument if your function returns tuple(s) from a space described on L. =item fields Output format of the returned tuple (like 'B' in L method). =item flags Reserved option. =item args Format description for stored procedure arguments. =back =cut sub call_lua { my $self = shift; my $lua_name = shift; my $args = shift; $self->_llc->_check_cb( my $cb = pop ); unshift @_ => 'space' if @_ == 1; my %opts = @_; my $flags = $opts{flags} || 0; my $space_name = $opts{space}; my $fields = $opts{fields}; my $s; croak "You can't use 'fields' and 'space' at the same time" if $fields and $space_name; if ($space_name) { $s = $self->space( $space_name ); } elsif ( $fields ) { $s = DR::Tarantool::Space->new( 0 => { name => 'temp_space', fields => $fields, indexes => {} }, ); } else { $s = DR::Tarantool::Space->new( 0 => { name => 'temp_space', fields => [], indexes => {} }, ); } if ($opts{args}) { my $sa = DR::Tarantool::Space->new( 0 => { name => 'temp_space_args', fields => $opts{args}, indexes => {} }, ); $args = $sa->pack_tuple( $args ); } $self->_llc->call_lua( $lua_name, $args, $flags, sub { _cb_default($_[0], $s, $cb) } ); } =head2 select Select a tuple from a space by index. $tuples = $client->select('space', 1, sub { ... }); $tuples = $client->select('space', [1, 2], sub { ... }); $tuples = $client->select('space_name', [1,2,3] => 'index_name', sub { ... }); =head3 Arguments =over =item space name =item key(s) =item optional arguments =item callback =back =head3 optional arguments This section can contain only one element, which is either an index name, or a hash with the following fields: =over =item index index name or number =item limit =item offset =back =cut sub select { my $self = shift; my $space = shift; my $keys = shift; my $cb = pop; my ($index, $limit, $offset); if (@_ == 1) { $index = shift; } elsif (@_ == 3) { ($index, $limit, $offset) = @_; } elsif (@_) { my %opts = @_; $index = $opts{index}; $limit = $opts{limit}; $offset = $opts{offset}; } $index ||= 0; my $s = $self->space($space); $self->_llc->select( $s->number, $s->_index( $index )->{no}, $s->pack_keys( $keys, $index ), $limit, $offset, sub { _cb_default($_[0], $s, $cb) } ); } =head2 delete Delete a tuple. $client->delete('space', 1, sub { ... }); $client->delete('space', $key, $flags, sub { ... }); Tuple is always deleted by primary key. =head3 Arguments =over =item space name =item key =item flags (optional) Server flags, as described in perldoc L. =item callback =back =cut sub delete :method { my $self = shift; my $space = shift; my $key = shift; $self->_llc->_check_cb( my $cb = pop ); my $flags = shift || 0; my $s = $self->space($space); $self->_llc->delete( $s->number, $s->pack_primary_key( $key ), $flags, sub { _cb_default($_[0], $s, $cb) } ); } =head2 update Update a tuple. $client->update('space', 1, [ passwd => set => 'abc' ], sub { .. }); $client->update( 'space', 1, [ [ passwd => set => 'abc' ], [ login => 'delete' ] ], sub { ... } ); =head3 Arguments =over =item space name =item key =item operation list =item flags (optional) Server flags, as described in perldoc L. =item callback =back =cut sub update { my $self = shift; my $space = shift; my $key = shift; my $op = shift; $self->_llc->_check_cb( my $cb = pop ); my $flags = shift || 0; my $s = $self->space($space); $self->_llc->update( $s->number, $s->pack_primary_key( $key ), $s->pack_operations( $op ), $flags, sub { _cb_default($_[0], $s, $cb) } ); } =head2 last_code The error code returned by the last request (see L). =cut sub last_code { $_[0]->_llc->last_code } =head2 last_error_string The error message associated with the last request (see L), if there was an error. =cut sub last_error_string { $_[0]->_llc->last_error_string } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/CoroClient.pm0000644000000000000000000000620112141712767021620 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::CoroClient; use base 'DR::Tarantool::AsyncClient'; use Coro; use Carp; use AnyEvent; =head1 NAME DR::Tarantool::CoroClient - an asynchronous coro driver for L =head1 SYNOPSIS use DR::Tarantool::CoroClient; use Coro; my $client = DR::Tarantool::CoroClient->connect( port => $port, spaces => $spaces; ); my @res; for (1 .. 100) { async { push @res => $client->select(space_name => $_); } } cede while @res < 100; =head1 METHODS =head2 connect Connects to Tarantool. =head3 Arguments The same as L, excluding the callback. Returns a connection handle or croaks an error. =head3 Additional arguments =over =item raise_error If B (default behaviour) the driver throws an exception for each server error. =back =cut sub connect { my ($class, %opts) = @_; my $raise_error = 1; $raise_error = delete $opts{raise_error} if exists $opts{raise_error}; my $cb = Coro::rouse_cb; $class->SUPER::connect(%opts, $cb); my ($self) = Coro::rouse_wait; unless (ref $self) { croak $self if $raise_error; $! = $self; return undef; } $self->{raise_error} = $raise_error ? 1 : 0; $self; } =head2 ping The same as L, excluding the callback. Returns B on success, B on error. =head2 insert The same as L, excluding the callback. Returns the inserted tuple or undef. Croaks an error if insert failed (B must be set). =head2 select The same as L, excluding the callback. Returns tuple or tuples that match selection criteria, or undef if no matching tuples were found. Croaks an error if an error occurred (provided B is set). =head2 update The same as L, excluding the callback. Returns the new value of the tuple. Croaks an error if update failed (provided B is set). =head2 delete The same as L, excluding the callback. Returns the deleted tuple, or undef. Croaks error if an error occurred (provided B is set). =head2 call_lua The same as L, excluding the callback. Returns a tuple or tuples returned by the called procedure. Croaks an error if an error occurred (provided B is set). =cut for my $method (qw(ping insert select update delete call_lua)) { no strict 'refs'; *{ __PACKAGE__ . "::$method" } = sub { my ($self, @args) = @_; my $cb = Coro::rouse_cb; my $m = "SUPER::$method"; $self->$m(@args, $cb); my @res = Coro::rouse_wait; if ($res[0] eq 'ok') { return 1 if $method eq 'ping'; return $res[1]; } return 0 if $method eq 'ping'; return undef unless $self->{raise_error}; croak sprintf "%s: %s", defined($res[1])? $res[1] : 'unknown', $res[2] ; }; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/Iterator.pm0000644000000000000000000002345012137446532021354 0ustar rootroot=head1 NAME DR::Tarantool::Iterator - an iterator and a container class for L =head1 SYNOPSIS use DR::Tarantool::Iterator; my $iter = DR::Tarantool::Iterator->new([1, 2, 3]); my $item0 = $iter->item(0); my @all = $iter->all; my $all = $iter->all; while(my $item = $iter->next) { do_something_with_item( $item ); } =head1 METHODS =cut use utf8; use strict; use warnings; package DR::Tarantool::Iterator; use Carp; use Data::Dumper; =head2 new A constructor. =head3 Arguments =over =item * An array of tuples to iterate over. =item * A list of named arguments: =over =item item_class Name of the class to bless each tuple in the iterator with. If the field is 'B' then the first element of the array is B, and the second element is B. =item item_constructor Name of a constructor to invoke for each tuple. If this value is undefined and B is defined, the iterator blesses each tuple but does not invoke a constructor on it. The constructor is invoked on with three arguments: B, B and B, for example: my $iter = DR::Tarantool::Iterator->new( [ [1], [2], [3] ], item_class => 'MyClass', item_constructor => 'new' ); my $iter = DR::Tarantool::Iterator->new( # the same [ [1], [2], [3] ], item_class => [ 'MyClass', 'new' ] ); my $item = $iter->item(0); my $item = MyClass->new( [1], 0, $iter ); # the same my $item = $iter->item(2); my $item = MyClass->new( [3], 2, $iter ); # the same =item data Application state to store in the iterator. Is useful if additional state needs to be passed into tuple constructor. =back =back =cut sub new { my ($class, $items, %opts) = @_; croak 'usage: DR::Tarantool::Iterator->new([$item1, $item2, ... ], %opts)' unless 'ARRAY' eq ref $items; my $self = bless { items => $items } => ref($class) || $class; $self->item_class( ('ARRAY' eq ref $opts{item_class}) ? @{ $opts{item_class} } : $opts{item_class} ) if exists $opts{item_class}; $self->item_constructor($opts{item_constructor}) if exists $opts{item_constructor}; $self->data( $opts{data} ) if exists $opts{data}; $self; } =head2 clone(%opt) Clone the iterator object, but do not clone the tuples. This method can be used to create an iterator that has a different B and (or) B. If B argument is true, the function clones the tuple list as well. my $iter1 = $old_iter->clone(item_class => [ 'MyClass', 'new' ]); my $iter2 = $old_iter->clone(item_class => [ 'MyClass', 'new' ], clone_items => 1); $old_iter->sort(sub { $_[0]->name cmp $_[1]->name }); # $iter1 is sorted, too, but $iter2 is not =cut sub clone { my $self = shift; my %opts; if (@_ == 1) { %opts = (clone_items => shift); } else { %opts = @_; } my %pre = ( data => $self->data, item_class => $self->item_class, item_constructor => $self->item_constructor ); my $clone_items = delete $opts{clone_items}; my $items = $clone_items ? [ @{ $self->{items} } ] : $self->{items}; $self = $self->new( $items, %pre, %opts ); $self; } =head2 count Return the number of tuples available through the iterator. =cut sub count { my ($self) = @_; return scalar @{ $self->{items} }; } =head2 item Return one tuple from the iterator by its index (or croak an error if the index is out of range). =cut sub item { my ($self, $no) = @_; my $item = $self->raw_item( $no ); if (my $class = $self->item_class) { if (my $m = $self->item_constructor) { return $class->$m( $item, $no, $self ); } return bless $item => $class if ref $item; return bless \$item => $class; } return $self->{items}[ $no ]; } =head2 raw_item Return one raw tuple from the iterator by its index (or croak error if the index is out of range). In other words, this method ignores B and B. =cut sub raw_item { my ($self, $no) = @_; my $exists = $self->exists($no); croak "wrong item number format: " . (defined($no) ? $no : 'undef') unless defined $exists; croak 'wrong item number: ' . $no unless $exists; if ($no >= 0) { croak "iterator doesn't contain item with number $no" unless $no < $self->count; } else { croak "iterator doesn't contain item with number $no" unless $no >= -$self->count; } return $self->{items}[ $no ]; } =head2 raw_sort(&) Sort the contents referred to by the iterator (changes the current iterator object). The compare function receives two B objects: $iter->raw_sort(sub { $_[0]->field cmp $_[1]->field }); =cut sub raw_sort { my ($self, $cb) = @_; my $items = $self->{items}; @$items = sort { &$cb($a, $b) } @$items; return $self; } =head2 sort(&) Sort the contents referred to by the iterator (changes the current object). The compare function receives two constructed objects: $iter->sort(sub { $_[0]->field <=> $_[1]->field }); =cut sub sort : method { my ($self, $cb) = @_; my $items = $self->{items}; my @bitems = map { $self->item( $_ ) } 0 .. $#$items; my @isorted = sort { &$cb( $bitems[$a], $bitems[$b] ) } 0 .. $#$items; @$items = @$items[ @isorted ]; return $self; } =head2 grep(&) Find all objects in the set referred to by the iterator that match a given search criteria (linear search). my $admins = $users->grep(sub { $_[0]->is_admin }); =cut sub grep :method { my ($self, $cb) = @_; my $items = $self->{items}; my @bitems = map { $self->item( $_ ) } 0 .. $#$items; my @igrepped = grep { &$cb( $bitems[$_] ) } 0 .. $#$items; @igrepped = @$items[ @igrepped ]; return $self->new( \@igrepped, item_class => $self->item_class, item_constructor => $self->item_constructor, data => $self->data ); } =head2 raw_grep(&) Same as grep, but works on raw objects. my $admins = $users->raw_grep(sub { $_[0]->is_admin }); =cut sub raw_grep :method { my ($self, $cb) = @_; my $items = $self->{items}; my @igrepped = grep { &$cb($_) } @$items; return $self->new( \@igrepped, item_class => $self->item_class, item_constructor => $self->item_constructor, data => $self->data ); } =head2 get An alias for L method. =cut sub get { goto \&item; } =head2 exists Return B if the iterator contains a tuple with the given index. my $item = $iter->exists(10) ? $iter->get(10) : somethig_else(); =cut sub exists : method{ my ($self, $no) = @_; return undef unless defined $no; return undef unless $no =~ /^-?\d+$/; return 0 if $no >= $self->count; return 0 if $no < -$self->count; return 1; } =head2 next Return the next tuple, or B in case of eof. while(my $item = $iter->next) { do_something_with( $item ); } Index of the current tuple can be queried with function 'L'. =cut sub next :method { my ($self) = @_; my $iter = $self->iter; if (defined $self->{iter}) { return $self->item(++$self->{iter}) if $self->iter < $#{ $self->{items} }; delete $self->{iter}; return undef; } return $self->item($self->{iter} = 0) if $self->count; return undef; } =head2 iter Return index of the tuple at the current iterator position. =cut sub iter { my ($self) = @_; return $self->{iter}; } =head2 reset Reset iteration index, return the previous value of the index. =cut sub reset :method { my ($self) = @_; return delete $self->{iter}; } =head2 all Return all tuples available through the iterator. my @list = $iter->all; my $list_aref = $iter->all; my @abc_list = map { $_->abc } $iter->all; my @abc_list = $iter->all('abc'); # the same my @list = map { [ $_->abc, $_->cde ] } $iter->all; my @list = $iter->all('abc', 'cde'); # the same my @list = map { $_->abc + $_->cde } $iter->all; my @list = $iter->all(sub { $_[0]->abc + $_->cde }); # the same =cut sub all { my ($self, @items) = @_; return unless defined wantarray; my @res; local $self->{iter}; if (@items == 1) { my $m = shift @items; while (defined(my $i = $self->next)) { push @res => $i->$m; } } elsif (@items) { while (defined(my $i = $self->next)) { push @res => [ map { $i->$_ } @items ]; } } else { while (defined(my $i = $self->next)) { push @res => $i; } } return @res if wantarray; return \@res; } =head2 item_class Set/return the tuple class. If the value is defined, the iterator blesses tuples with it (and also calls L if it is set). =cut sub item_class { my ($self, $v, $m) = @_; $self->item_constructor($m) if @_ > 2; return $self->{item_class} = ref($v) || $v if @_ > 1; return $self->{item_class}; } =head2 item_constructor Set/return the tuple constructor. The value is used only if L is defined. =cut sub item_constructor { my ($self, $v) = @_; return $self->{item_constructor} = $v if @_ > 1; return $self->{item_constructor}; } =head2 push Push a tuple into the iterator. =cut sub push :method { my ($self, @i) = @_; push @{ $self->{items}} => @i; return $self; } =head2 data Return/set an application-specific context maintained in the iterator object. This can be useful to pass additional state to B. =cut sub data { my ($self, $data) = @_; $self->{data} = $data if @_ > 1; return $self->{data}; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/RealSyncClient.pm0000644000000000000000000001305712207407336022441 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::RealSyncClient; =head1 NAME DR::Tarantool::RealSyncClient - a synchronous driver for L =head1 SYNOPSIS my $client = DR::Tarantool::RealSyncClient->connect( port => $tnt->primary_port, spaces => $spaces ); if ($client->ping) { .. }; my $t = $client->insert( first_space => [ 1, 'val', 2, 'test' ], TNT_FLAG_RETURN ); $t = $client->call_lua('luafunc' => [ 0, 0, 1 ], 'space_name'); $t = $client->select(space_name => $key); $t = $client->update(space_name => 2 => [ name => set => 'new' ]); $client->delete(space_name => $key); =head1 DESCRIPTION The module is a clone of L but it doesn't use L or L. The module uses L sockets. =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L<|https://github.com/dr-co/dr-tarantool/>. =cut use DR::Tarantool::LLSyncClient; use DR::Tarantool::Spaces; use DR::Tarantool::Tuple; use Carp; $Carp::Internal{ (__PACKAGE__) }++; use Data::Dumper; use Scalar::Util 'blessed'; my $unpack = sub { my ($self, $res, $s) = @_; return undef unless $res and $res->{status} eq 'ok'; return $s->tuple_class->unpack( $res->{tuples}, $s ) if $s; return $res->{tuples}; }; sub connect { my ($class, %opts) = @_; my $host = $opts{host} || 'localhost'; my $port = $opts{port} or croak "port isn't defined"; my $spaces = blessed($opts{spaces}) ? $opts{spaces} : DR::Tarantool::Spaces->new($opts{spaces}); my $reconnect_period = $opts{reconnect_period} || 0; my $reconnect_always = $opts{reconnect_always} || 0; my $client = DR::Tarantool::LLSyncClient->connect( host => $host, port => $port, reconnect_period => $reconnect_period, reconnect_always => $reconnect_always, exists($opts{raise_error}) ? ( raise_error => $opts{raise_error} ? 1: 0 ) : (), ); return undef unless $client; return bless { llc => $client, spaces => $spaces } => ref($class) || $class; } sub space { my ($self, $name) = @_; return $self->{spaces}->space($name); } sub ping { my ($self) = @_; $self->{llc}->ping; } sub insert { my $self = shift; my $space = shift; $self->_llc->_check_tuple( my $tuple = shift ); my $flags = pop || 0; my $s = $self->{spaces}->space($space); my $res = $self->_llc->insert( $s->number, $s->pack_tuple( $tuple ), $flags ); return $unpack->($self, $res, $s); } sub call_lua { my $self = shift; my $lua_name = shift; my $args = shift; unshift @_ => 'space' if @_ == 1; my %opts = @_; my $flags = $opts{flags} || 0; my $space_name = $opts{space}; my $fields = $opts{fields}; my $s; croak "You can't use 'fields' and 'space' at the same time" if $fields and $space_name; if ($space_name) { $s = $self->space( $space_name ); } elsif ( $fields ) { $s = DR::Tarantool::Space->new( 0 => { name => 'temp_space', fields => $fields, indexes => {} }, ); } else { $s = DR::Tarantool::Space->new( 0 => { name => 'temp_space', fields => [], indexes => {} }, ); } if ($opts{args}) { my $sa = DR::Tarantool::Space->new( 0 => { name => 'temp_space_args', fields => $opts{args}, indexes => {} }, ); $args = $sa->pack_tuple( $args ); } my $res = $self->_llc->call_lua( $lua_name, $args, $flags ); return $unpack->($self, $res, $s); } sub select { my $self = shift; my $space = shift; my $keys = shift; my ($index, $limit, $offset); if (@_ == 1) { $index = shift; } elsif (@_ == 3) { ($index, $limit, $offset) = @_; } elsif (@_) { my %opts = @_; $index = $opts{index}; $limit = $opts{limit}; $offset = $opts{offset}; } $index ||= 0; my $s = $self->space($space); my $res = $self->_llc->select( $s->number, $s->_index( $index )->{no}, $s->pack_keys( $keys, $index ), $limit, $offset ); return $unpack->($self, $res, $s); } sub update { my $self = shift; my $space = shift; my $key = shift; my $op = shift; my $flags = shift || 0; my $s = $self->space($space); my $res = $self->_llc->update( $s->number, $s->pack_primary_key( $key ), $s->pack_operations( $op ), $flags, ); return $unpack->($self, $res, $s); } sub delete :method { my $self = shift; my $space = shift; my $key = shift; my $flags = shift || 0; my $s = $self->space($space); my $res = $self->_llc->delete( $s->number, $s->pack_primary_key( $key ), $flags, ); return $unpack->($self, $res, $s); } sub last_code { $_[0]->{llc}->last_code } sub last_error_string { $_[0]->{llc}->last_error_string } sub raise_error { $_[0]->raise_error }; sub _llc { $_[0]{llc} } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/LLSyncClient.pm0000644000000000000000000001651112331722764022066 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::LLSyncClient; use Carp; use IO::Socket::UNIX; use IO::Socket::INET; require DR::Tarantool; my $LE = $] > 5.01 ? '<' : ''; $Carp::Internal{ (__PACKAGE__) }++; sub connect { my ($class, %opts) = @_; my $host = $opts{host} || 'localhost'; my $port = $opts{port} or croak 'port is undefined'; my $reconnect_period = $opts{reconnect_period} || 0; my $reconnect_always = $opts{reconnect_always} || 0; my $raise_error = 1; if (exists $opts{raise_error}) { $raise_error = $opts{raise_error} ? 1 : 0; } my $self = bless { host => $host, port => $port, raise_error => $raise_error, reconnect_period => $reconnect_period, id => 0, } => ref ($class) || $class; unless ($self->_connect()) { unless ($reconnect_always) { return undef unless $self->{raise_error}; croak "Can't connect to $self->{host}:$self->{port}: $@"; } unless ($reconnect_period) { return undef unless $self->{raise_error}; croak "Can't connect to $self->{host}:$self->{port}: $@"; } } return $self; } sub _connect { my ($self) = @_; if ($self->{host} eq 'unix/' or $self->{port} =~ /\D/) { return $self->{fh} = IO::Socket::UNIX->new(Peer => $self->{port}); } else { return $self->{fh} = IO::Socket::INET->new( PeerHost => $self->{host}, PeerPort => $self->{port}, Proto => 'tcp', ); } } sub _req_id { my ($self) = @_; return $self->{id}++ if $self->{id} < 0x7FFF_FFFE; return $self->{id} = 0; } sub _request { my ($self, $id, $pkt ) = @_; until($self->{fh}) { unless ($self->{reconnect_period}) { $self->{last_error_string} = "Connection isn't established"; croak $self->{last_error_string} if $self->{raise_error}; return undef; } next if $self->_connect; sleep $self->{reconnect_period}; } my $len = length $pkt; # send request while($len > 0) { no warnings; # closed socket my $slen = syswrite $self->{fh}, $pkt; unless(defined $slen) { next if $!{EINTR}; goto SOCKET_ERROR; } $len -= $slen; substr $pkt, 0, $slen, ''; } $pkt = ''; while(12 > length $pkt) { no warnings; # closed socket my $rl = sysread $self->{fh}, $pkt, 12 - length $pkt, length $pkt; unless (defined $rl) { next if $!{EINTR}; goto SOCKET_ERROR; } } my (undef, $blen) = unpack "L$LE L$LE", $pkt; while(12 + $blen > length $pkt) { no warnings; # closed socket my $rl = sysread $self->{fh}, $pkt, 12 + $blen - length $pkt, length $pkt; unless (defined $rl) { next if $!{EINTR}; goto SOCKET_ERROR; } } my $res = DR::Tarantool::_pkt_parse_response( $pkt ); if ($res->{status} ne 'ok') { $self->{last_error_string} = $res->{errstr}; $self->{last_code} = $res->{code}; # disconnect delete $self->{fh} if $res->{status} =~ /^(fatal|buffer)$/; croak $self->{last_error_string} if $self->{raise_error}; return undef; } $self->{last_error_string} = $res->{errstr} || ''; $self->{last_code} = $res->{code}; return $res; SOCKET_ERROR: delete $self->{fh}; $self->{last_error_string} = $!; $self->{last_code} = undef; croak $self->{last_error_string} if $self->{raise_error}; return undef; } sub ping :method { my ($self) = @_; unless ($self->{fh}) { $self->_connect; $self->{last_code} = -1; $self->{last_error_string} = "Connection isn't established"; return 0 unless $self->{fh}; } my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_ping( $id ); my $res = eval { $self->_request( $id, $pkt ); }; return 0 unless $res and $res->{status} eq 'ok'; return 1; } sub call_lua :method { my $self = shift; my $proc = shift; my $tuple = shift; $self->_check_tuple( $tuple ); my $flags = pop || 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_call_lua($id, $flags, $proc, $tuple); return $self->_request( $id, $pkt ); } sub select :method { my $self = shift; $self->_check_number( my $ns = shift ); $self->_check_number( my $idx = shift ); $self->_check_tuple_list( my $keys = shift ); $self->_check_number( my $limit = shift || 0x7FFFFFFF ); $self->_check_number( my $offset = shift || 0 ); my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_select($id, $ns, $idx, $offset, $limit, $keys); return $self->_request( $id, $pkt ); } sub insert :method { my $self = shift; $self->_check_number( my $space = shift ); $self->_check_tuple( my $tuple = shift ); $self->_check_number( my $flags = pop || 0 ); croak "insert: tuple must be ARRAYREF" unless ref $tuple eq 'ARRAY'; $flags ||= 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_insert( $id, $space, $flags, $tuple ); return $self->_request( $id, $pkt ); } sub update :method { my $self = shift; $self->_check_number( my $ns = shift ); $self->_check_tuple( my $key = shift ); $self->_check_operations( my $operations = shift ); $self->_check_number( my $flags = pop || 0 ); my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_update($id, $ns, $flags, $key, $operations); return $self->_request( $id, $pkt ); } sub delete :method { my $self = shift; my $ns = shift; my $key = shift; $self->_check_tuple( $key ); my $flags = pop || 0; my $id = $self->_req_id; my $pkt = DR::Tarantool::_pkt_delete($id, $ns, $flags, $key); return $self->_request( $id, $pkt ); } sub _check_tuple { my ($self, $tuple) = @_; croak 'Tuple must be ARRAYREF' unless 'ARRAY' eq ref $tuple; } sub _check_tuple_list { my ($self, $list) = @_; croak 'Tuplelist must be ARRAYREF of ARRAYREF' unless 'ARRAY' eq ref $list; croak 'Tuplelist is empty' unless @$list; $self->_check_tuple($_) for @$list; } sub _check_number { my ($self, $number) = @_; croak "argument must be number" unless defined $number and $number =~ /^\d+$/; } sub _check_operation { my ($self, $op) = @_; croak 'Operation must be ARRAYREF' unless 'ARRAY' eq ref $op; croak 'Wrong update operation: too short arglist' unless @$op >= 2; croak "Wrong operation: $op->[1]" unless $op->[1] and $op->[1] =~ /^(delete|set|insert|add|and|or|xor|substr)$/; $self->_check_number($op->[0]); } sub _check_operations { my ($self, $list) = @_; croak 'Operations list must be ARRAYREF of ARRAYREF' unless 'ARRAY' eq ref $list; croak 'Operations list is empty' unless @$list; $self->_check_operation( $_ ) for @$list; } sub last_error_string { return $_[0]->{last_error_string}; } sub last_code { return $_[0]->{last_code}; } sub raise_error { return $_[0]->{raise_error}; } 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool/SyncClient.pm0000644000000000000000000000762412207407472021641 0ustar rootrootuse utf8; use strict; use warnings; package DR::Tarantool::SyncClient; use base 'DR::Tarantool::AsyncClient'; use AnyEvent; use Devel::GlobalDestruction; use Carp; $Carp::Internal{ (__PACKAGE__) }++; =head1 NAME DR::Tarantool::SyncClient - a synchronous driver for L. =head1 SYNOPSIS my $client = DR::Tarantool::SyncClient->connect( port => $tnt->primary_port, spaces => $spaces ); if ($client->ping) { .. }; my $t = $client->insert( first_space => [ 1, 'val', 2, 'test' ], TNT_FLAG_RETURN ); $t = $client->call_lua('luafunc' => [ 0, 0, 1 ], 'space_name'); $t = $client->select(space_name => $key); $t = $client->update(space_name => 2 => [ name => set => 'new' ]); $client->delete(space_name => $key); =head1 METHODS =head2 connect Connects to the server. =head3 Arguments The same as L, excluding the callback. Returns a connection handle or croaks an error. =head3 Additional arguments =over =item raise_error If B (default behaviour) the driver throws an exception for each error. =back =cut sub connect { my ($class, %opts) = @_; my $raise_error = 1; $raise_error = delete $opts{raise_error} if exists $opts{raise_error}; my $cv = condvar AnyEvent; my $self; $class->SUPER::connect(%opts, sub { ($self) = @_; $cv->send; }); $cv->recv; unless(ref $self) { croak $self if $raise_error; $! = $self; return undef; } $self->{raise_error} = $raise_error ? 1 : 0; $self; } =head2 ping The same as L, excluding the callback. Returns B on success, b in case of an error. =head2 insert The same as L, excluding the callback. Returns the inserted tuple. Croaks error if an error occurred (as long as B is true). =head2 select The same as L, excluding the callback. Returns tuples contained in the server response or undef. Croaks error if an error occurred (as long as B is true). =head2 update The same as L, excluding the callback. Returns the updated tuple. Croaks error if an error occurred (as long as B is true). =head2 delete The same as L, excluding the callback. Returns the deleted tuple or undef. Croaks error if an error occurred (as long as B is true). =head2 call_lua The same as L, excluding the callback. Returns tuples contained in the server response or undef. Croaks error if an error occurred (as long as B is true). =cut for my $method (qw(ping insert select update delete call_lua)) { no strict 'refs'; *{ __PACKAGE__ . "::$method" } = sub { my ($self, @args) = @_; my @res; my $cv = condvar AnyEvent; my $m = "SUPER::$method"; $self->$m(@args, sub { @res = @_; $cv->send }); $cv->recv; if ($res[0] eq 'ok') { return 1 if $method eq 'ping'; return $res[1]; } return 0 if $method eq 'ping'; return undef unless $self->{raise_error}; croak sprintf "%s: %s", defined($res[1])? $res[1] : 'unknown', $res[2] ; }; } sub DESTROY { my ($self) = @_; return if in_global_destruction; my $cv = condvar AnyEvent; $self->disconnect(sub { $cv->send }); $cv->recv; } =head1 COPYRIGHT AND LICENSE Copyright (C) 2011 Dmitry E. Oboukhov Copyright (C) 2011 Roman V. Nikolaev This program is free software, you can redistribute it and/or modify it under the terms of the Artistic License. =head1 VCS The project is placed git repo on github: L. =cut 1; libdr-tarantool-perl-0.44/lib/DR/Tarantool.pm0000644000000000000000000002453312414725745017572 0ustar rootrootpackage DR::Tarantool; =head1 NAME DR::Tarantool - a Perl driver for L =head1 SYNOPSIS use DR::Tarantool ':constant', 'tarantool'; use DR::Tarantool ':all'; my $tnt = tarantool host => '127.0.0.1', port => 123, spaces => { ... } ; $tnt->update( ... ); my $tnt = coro_tarantool host => '127.0.0.1', port => 123, spaces => { ... } ; use DR::Tarantool ':constant', 'async_tarantool'; async_tarantool host => '127.0.0.1', port => 123, spaces => { ... }, sub { ... } ; $tnt->update(...); =head1 DESCRIPTION This module provides a synchronous and asynchronous driver for L. The driver does not have external dependencies, but includes the official light-weight Tarantool C client (a single C header which implements all protocol formatting) for packing requests and unpacking server responses. This driver implements "iproto" protocol described in https://github.com/mailru/tarantool/blob/master/doc/box-protocol.txt It is built on top of L - an asynchronous event framework, and is therefore easiest to integrate into a program which is already based on L. A synchronous version of the driver exists as well, it starts L event machine for every request. The driver supports three work flow types: =over =item L The primary type, provides an asynchronous, callback-based API. Requires a running L machine. =item L Is built on top of L. Starts L machine for every request. After a request is served, the event loop is stopped, and the results are returned to the caller, or, in case of an error, an exception is thrown. =item L Is also built on top of L, but is designed to work in cooperative multitasking environment provided by L. Is fully syntax-compatible with L, but requires a running event loop to operate, like L. Requests from different coroutines are served concurrently. =back L binary protocol contains no representation of database schema or tuple field types. Due to this deficiency, to easily integrate with Perl and automatically convert tuple fields to Perl values, the driver needs to know field names and types. To tell the driver about them, an instance of a dedicated class must be used. L is essentially a Perl hash which describes field types and names for each space used in the program. It can hardly be useful on its own, but once a connection is "enlightened" with an instance of this class, access to all tuple fields by a field name becomes possible. Type conversion, as well as packing/unpacking from Tarantool binary format is performed automatically. Please follow the docs for L to learn how to describe a schema. =head2 Establishing a connection =head3 L DR::Tarantool::AsyncClient->connect( host => $host, port => $port, spaces => { ... }, sub { my ($tnt) = @_; ... } ); The callback passed to connect() gets invoked after a connection is established. The only argument of the callback is the newly established connection handle. The handle's type is L. =head3 L and L my $tnt = DR::Tarantool::SyncClient->connect( host => $host, port => $port, spaces => { ... } ); my $tnt = DR::Tarantool::CoroClient->connect( host => $host, port => $port, spaces => { ... } ); The only difference of synchronous versions from the asynchronous one is absence of a callback. The created connection handle is returned directly from connect(). In this spirit, the only difference of any synchronous API all from the asynchronous counterpart is also in absence of the callback. =head2 Working with tuples =head3 Querying my $user123 = $tnt->select('users' => 123); my $users_by_roles = $tnt->select('users' => 'admins' => 'role_index'); It is possible to select data by a primary key (expects a Perl scalar), secondary, multi-part key (expects an array). The default index used for selection is the primary one, a non-default index can be set by providing index name. The contents of the result set is interpreted in accordance with schema description provided in L. Supported data types are numbers, Unicode strings, JSON, fixed-point decimals. =head3 Insertion $tnt->insert('users' => [ 123, 'vasya', 'admin' ]); Insert a tuple into space 'users', defined in B hash on connect. =head3 Deletion $tnt->delete(users => 123); Delete a tuple from space 'users'. The deletion is always performed by the primary key. =head3 Update $tnt->update(users => 123 => [[ role => set => 'not_admin' ]]); It is possible to modify any field in a tuple. A field can be accessed by field name or number. A set of modifications can be provided in a Perl array. The following update operations are supported: =over =item set Assign a field =item add, and, or, xor Arithmetic and bitwise operations for integers. =item substr Replace a substring with a paste (similar to Perl splice). =item insert Insert a field before the given field. =item delete Delete a field. =item push Append a field at the tail of the tuple. =item pop Pop a field from the tail of the tuple. =back =head3 Lua $tnt->call_lua(my_proc_name => [ arguments, ...]); Invoke a Lua stored procedure by name. =head2 Supported data types The driver supports all Tarantool types (B, B, B), as well as some client-only types, which are converted to the above server types automatically on the client: =over =item UTF8STR A unicode string. =item MONEY Fixed decimal currency. Stores the value on the server in B type, by multiplying the given amount by 100. The largest amount that can be stored in this type is, therefore, around 20 000 000. Can store negative values. =item BIGMONEY The same as above, but uses B as the underlying storage. =item JSON An arbitrary Perl object is automatically serialized to JSON with L on insertion, and deserialized on selection. =back The basic data transfer unit in Tarantool protocol is a single tuple. A selected tuple is automatically wrapped into an instance of class L. An object of this class can be used as an associative container, in which any field can be accessed by field name: my $user = $tnt->select(users => 123); printf("user: %s, role: %s\n", $user->name, $user->role); To run driver tests, the following Perl modules are also necessary: L, L, L, L, L, L. To run tests, do: perl Makefile.PL make make test The test suite attempts to find the server and start it, thus make sure L is available in the path, or export TARANTOOL_BOX=/path/to/tarantool_box. =cut use 5.008008; use strict; use warnings; use Carp; $Carp::Internal{ (__PACKAGE__) }++; use base qw(Exporter); our %EXPORT_TAGS = ( client => [ qw( tarantool async_tarantool coro_tarantool) ], constant => [ qw( TNT_INSERT TNT_SELECT TNT_UPDATE TNT_DELETE TNT_CALL TNT_PING TNT_FLAG_RETURN TNT_FLAG_ADD TNT_FLAG_REPLACE ) ], ); our @EXPORT_OK = ( map { @$_ } values %EXPORT_TAGS ); $EXPORT_TAGS{all} = \@EXPORT_OK; our @EXPORT = @{ $EXPORT_TAGS{client} }; our $VERSION = '0.44'; =head1 EXPORT =head2 tarantool connects to L in synchronous mode using L. =cut sub tarantool { require DR::Tarantool::SyncClient; no warnings 'redefine'; *tarantool = sub { DR::Tarantool::SyncClient->connect(@_); }; goto \&tarantool; } =head2 rsync_tarantool connects to L in synchronous mode using L. =cut sub rsync_tarantool { require DR::Tarantool::RealSyncClient; no warnings 'redefine'; *rsync_tarantool = sub { DR::Tarantool::RealSyncClient->connect(@_); }; goto \&rsync_tarantool; } =head2 async_tarantool connects to L in async mode using L. =cut sub async_tarantool { require DR::Tarantool::AsyncClient; no warnings 'redefine'; *async_tarantool = sub { DR::Tarantool::AsyncClient->connect(@_); }; goto \&async_tarantool; } =head2 coro_tarantol connects to L in async mode using L. =cut sub coro_tarantool { require DR::Tarantool::CoroClient; no warnings 'redefine'; *coro_tarantool = sub { DR::Tarantool::CoroClient->connect(@_); }; goto \&coro_tarantool; } =head2 :constant Exports constants to use in a client request as flags: =over =item TNT_FLAG_RETURN With this flag on, each INSERT/UPDATE request returns the new value of the tuple. DELETE returns the deleted tuple, if it is found. =item TNT_FLAG_ADD With this flag on, INSERT returns an error if an old tuple with the same primary key already exists. No tuple is inserted in this case. =item TNT_FLAG_REPLACE With this flag on, INSERT returns an error if an old tuple for the primary key does not exist. Without either of the flags, INSERT replaces the old tuple if it doesn't exist. =back =cut require XSLoader; XSLoader::load('DR::Tarantool', $VERSION); =head2 :all Exports all functions and constants. =head1 TODO =over =item * Support push, pop in UPDATE. =item * Make it possible to construct B