TIMB / Memcached-libmemcached-1.001700_01 / t / lib / libmemcached_test.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

              
package libmemcached_test;
# functions to support the Memcached::libmemcached test suite
use strict;
use warnings;
use base 'Exporter';
use Test::More;
our @EXPORT = qw(
    libmemcached_test_create
    libmemcached_test_key
    libmemcached_version_ge
    libmemcached_test_servers
);
use Memcached::libmemcached qw(
    memcached_create
    memcached_server_add
    memcached_get
    memcached_set
    memcached_errstr
    memcached_version
);
sub libmemcached_test_servers {
    my $servers = $ENV{PERL_LIBMEMCACHED_TEST_SERVERS};
    # XXX add the default port as well to stop uninit
    # warnings from the test suite
    $servers ||= 'localhost:11211';
    return split(/\s*,\s*/, $servers);
}
sub libmemcached_test_create {
    my ($args) = @_;
    my $memc = memcached_create()
        or die "memcached_create failed";
    # XXX would be good to filter this list by those we can communicate with
    # (and have sufficient version number)
    # then pick the first of those to use as the default test server
    my ($server,$port) = split /:/, (libmemcached_test_servers())[0];
    # XXX may change to memcached_parse_options or somesuch so the env
    # var can set behaviours etc   
    my $rc = memcached_server_add($memc, $server, $port);
    die "libmemcached_test_create: memcached_server_add($server) failed: ".memcached_errstr($memc)
        if not $rc;
    # XXX ideally this should be a much 'simpler/safer' command
    memcached_set($memc, "foo", "hello memcached");
    plan skip_all => "Can't talk to any memcached servers"
        if memcached_errstr($memc) !~ /SERVER END|SUCCESS|NOT FOUND/;
    plan skip_all => "memcached server version less than $args->{min_version}"
        if $args->{min_version}
        && not libmemcached_version_ge($memc, $args->{min_version});
    return $memc;
}
sub libmemcached_version_ge {
    my ($memc, $min_version) = @_;
    my @min_version = split /\./, $min_version;
    my @memcached_version = memcached_version($memc);
    for (0,1,2) {
        return 1 if $memcached_version[$_] > $min_version[$_];
        return 0 if $memcached_version[$_] < $min_version[$_];
    }
    return 1; # identical versions
}
sub libmemcached_test_key {
    # return a value suitable for use as a memcached key
    # that is unique for each run of the script
    # but returns the same value for the life of the script
    our $time_rand ||= ($^T + rand());
    return $time_rand;
}
1;