The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.

# tests for functions documented in memcached_set.pod

use strict;
use warnings;

use Test::More;

use Memcached::libmemcached
    #   functions explicitly tested by this file
    qw(
    ),
    #   other functions used by the tests
    qw(
        memcached_set
        memcached_get
        memcached_mget
        memcached_mget_into_hashref
    );

use lib 't/lib';
use libmemcached_test;

my $memc = libmemcached_test_create();

my $items = 2;
plan tests => 21;

my ($rv, $rc, $flags);
my $t1= time();

my $flag_orig = 0xF000F00F;
my %data = map { ("k$_.$t1" => "val$_.$t1") } (1..$items);

my ($set_cb_expected_defsv, @set_cb_expected_args);
my $set_cb_called = 0;
my $set_cb = sub {
    ++$set_cb_called;
    print "set_cb(@_)\n";
    is $_, $set_cb_expected_defsv, '$_ should be the value';
    is scalar @_, 2, '@_ should be two elems: $key and $flags';
    is $_[0], $set_cb_expected_args[0], 'arg 0 should be the key';
    is $_[1], $set_cb_expected_args[1], 'arg 1 should be the flags';
    return;
};
$memc->set_callback_coderefs($set_cb, undef);

print "test read-only access to values from callback\n";
for my $k (keys %data) {
    $set_cb_expected_defsv = $data{$k};
    @set_cb_expected_args  = ( $k, $flag_orig );
    ok memcached_set($memc, $k, $data{$k}, 0, $flag_orig);
}

for my $k (keys %data) {
    $set_cb_expected_defsv = $data{$k};
    @set_cb_expected_args  = ( $k, $flag_orig );
    is memcached_get($memc, $k), $data{$k};
}
is $set_cb_called, scalar keys %data;

$set_cb_called = 0;
$memc->set_callback_coderefs(undef, sub { ++$set_cb_called; return });
my %got;
ok memcached_mget_into_hashref($memc, [ keys %data ], \%got);
is_deeply \%got, \%data;


print "test modification of values by callback\n";

my $expected_flags = 0xE0E0E0E0;
$set_cb = sub {
    $_ = uc($_).lc($_);
    $_[1] = $expected_flags;
    return;
};
$memc->set_callback_coderefs(undef, $set_cb);

for my $k (keys %data) {
    my $v = $data{$k};
    ok memcached_set($memc, $k, $v);
    is memcached_get($memc, $k, my $flags), uc($v).lc($v);
    is $flags, $expected_flags, "flags is $flags (expected $expected_flags)" ;
}