1
2# Version number initializations
3$VERSION      = 'main::VERSION';
4$Foo::VERSION = 'Foo::VERSION';
5
6# Set up tests and strictness
7use Test::More tests => 176;
8use strict;
9use warnings;
10
11# Add the termination code
12my $cache;
13END {
14    my $stopped_ok;
15    $stopped_ok = $cache->stop if $cache;
16    diag( "\nStopped memcached server" )
17      if ok( $stopped_ok, "Check if all servers have stopped" );
18} #END
19
20# Make sure we have all the support routines
21require 'testlib';
22my $class = 'Cache::Memcached::Managed';
23
24# For both active and inactive version
25foreach ($class,$class.'::Inactive') {
26
27    # check loading and methods
28    require_ok( $_ );
29    can_ok( $_,qw(
30 add
31 data
32 dead
33 decr
34 delete
35 delete_group
36 delimiter
37 directory
38 errors
39 expiration
40 flush_all
41 flush_interval
42 get
43 get_group
44 get_multi
45 grab_group
46 group
47 group_names
48 incr
49 namespace
50 new
51 replace
52 reset
53 servers
54 set
55 start
56 stats
57 stop
58 version
59) );
60}
61
62# Obtain port and create config
63my $port = anyport();
64ok( $port, "Check whether we have a port to work on" );
65my $config = "127.0.0.1:$port";
66
67# Create a cache object
68my $memcached_class = $ENV{CACHE_MEMCACHED} || 'Cache::Memcached';
69$cache = $class->new(
70  data            => $config,
71  memcached_class => $memcached_class,
72);
73isa_ok( $cache,$class, "Check whether object ok" );
74
75# Start the server, skip further tests if failed
76SKIP: {
77skip( "Memcached server not started", 169 ) if !$cache->start;
78sleep 2; # let the server warm up
79diag("\nStarted memcached server");
80
81# Check version info
82my $versions = $cache->version;
83my $version  = $versions->{$config};
84ok( $version, "Check whether version information available" );
85
86# Show warning if memcached version questionable
87my $pid = $cache->stats->{$config}->{pid};
88diag( <<DIAG ) if $version lt '1.1.12';
89
90\b\b******************** please UPGRADE memcached server software ******************
91\b\b* Please note that some tests have been known to fail on memcached server      *
92\b\b* versions below 1.1.12, most notable 1.1.11.                                  *
93\b\b*                                                                              *
94\b\b* Please upgrade your memcached server software to at least version 1.1.12!    *
95\b\b********************************************************************************
96DIAG
97
98# Do this before and after a reset
99TEST:
100foreach my $reset ( 0 .. 1 ) {
101
102    # Check the backend servers
103    my @server = $cache->servers;
104    is_deeply( \@server, [$config],
105      "Check if all memcached backend servers accounted for from a list" );
106    my $servers = $cache->servers;
107    is_deeply( $servers, { $config => undef },
108      "Check if all memcached backend servers accounted for from a hash ref" );
109
110    # Check whether backend servers all alive
111    my @dead = $cache->dead;
112    is( scalar @dead, 0, "Check that all servers are alive from a list" );
113    my $dead = $cache->dead;
114    is_deeply( $dead, {}, "Check that all servers are alive from a hash ref" );
115
116    # Check group names
117    my @group_name = $cache->group_names;
118    is_deeply( \@group_name, ['group'],
119      "Check that all group names accounted for from a list" );
120    my $group_names = $cache->group_names;
121    is_deeply( $group_names, { group => undef },
122      "Check that all group names accounted for from a hash ref" );
123
124    # No key, no ID
125    my $value = 'value';
126    ok( $cache->set($value), "Check if simple setting works" );
127    is( $cache->get,$value, "Check if simple getting works" );
128    ok( $cache->delete, "Check if simple delete works" );
129    ok( !defined $cache->get, "Check if simple getting fails" );
130
131    # No key, but ID given
132    foreach my $param (
133      [ [ qw(foo foo) ], [qw(bar bar) ] ],
134      [ [ qw(id foo value foo) ], [ qw(id bar value bar) ] ],
135      ) {
136        ok( $cache->set( @{ $param->[0] } ), "Check if setting with ID works" );
137        ok( $cache->set( @{ $param->[1] } ), "Check if setting with ID works" );
138
139        my $got = $cache->get_multi( [ qw(foo bar) ] );
140        diag( Data::Dumper::Dumper($got) ) if
141          !is_deeply( $got,{ foo => 'foo', bar => 'bar' },
142            "Check whether get_multi with ID's works" );
143
144        is( $cache->flush_all, 1, "Check if flushing works" );
145        sleep 1; # give flush time to work through
146
147        $got = $cache->get_multi( qw(foo bar) );
148        diag( Data::Dumper::Dumper($got) ) if
149          !is_deeply( $got,{},
150            "Check whether get_multi with ID's fails" );
151
152        # Remove flushed elements anyway for final stats
153        $cache->delete($_) foreach qw(foo bar);
154    }
155
156    # Check version dependency
157    my $version = do { no strict; $VERSION };
158    ok( $version, "Check whether there was a version for the module itself" );
159    ok( $cache->set($value), "Simple value for version / namespace check" );
160    is( $cache->get( version => $version ), $value,
161      "Check if simple getting with version works" );
162    ok( !defined $cache->get( version => 'foo' ),
163      "Check if simple getting with version fails" );
164
165    # Check namespace dependency
166    my $namespace = $cache->namespace;
167    is( $namespace, $>, "Check whether there was a default namespace" );
168    is( $cache->get( namespace => $namespace ), $value,
169      "Check if simple getting with namespace works" );
170    ok( !defined $cache->get( namespace => 'foo' ),
171      "Check if simple getting with namespace fails" );
172
173    # Check expiration
174    ok( $cache->set( value => $value, expiration => '3' ),
175      "Simple value for expiration check" );
176    is( $cache->get, $value,
177      "Check if simple getting before expiration works" );
178    sleep 5;
179    ok( !defined $cache->get,
180      "Check if simple getting after expiration fails" );
181
182    # Check (magical) in/decrement
183    is( $cache->incr, 1, "Check initial simple increment" );
184    is( $cache->incr, 2, "Check additional simple increment" );
185    is( $cache->incr(7), 9, "Check additional increment with specific value" );
186    is( $cache->decr, 8, "Check additional simple decrement" );
187    is( $cache->decr(6),2, "Check additional decrement with specific value" );
188    ok( $cache->delete, "Check whether deletion successful" );
189    ok( !defined $cache->get,
190      "Check if simple getting after increment + deletion fails" );
191    ok( !$cache->decr( 1, 1 ), "Check if simple decrement fails" );
192
193    # Check add/replace
194    ok( $cache->add($value), "Check if simple add works" );
195    is( $cache->get, $value, "Check if get after add works" );
196    ok( !$cache->add($value), "Check if additional add fails" );
197    is( $cache->get,$value, "Check if get after add still works" );
198    ok( $cache->replace(22), "Check if simple replace works" );
199    is( $cache->get, 22, "Check if get after replace works" );
200    ok( $cache->replace(33), "Check if additional replace works" );
201    is( $cache->get, 33, "Check if get after additional replace works" );
202    ok( $cache->delete, "Check whether deletion successful" );
203    ok( !$cache->replace($value), "Check if replace after delete fails" );
204
205    # determine unique key
206    my $key = $0 =~ m#^/#
207      ? $0
208      : do { my $pwd = `pwd`; chomp $pwd; $pwd } . "/$0";
209
210    # Check simple group management
211    ok( $cache->set( value => $value, group => 'group' ),
212      "Simple value with group" );
213    is( $cache->get, $value, "Check if simple get with group works" );
214    my $expected = { $key => { $version => { '' => $value } } };
215    my $got = $cache->get_group( group => 'group' );
216    diag( Data::Dumper::Dumper($got) ) if
217      !is_deeply( $got,$expected,
218        "Check if simple get_group with group works" );
219    is( $cache->get, $value, "Check if simple get with group works" );
220
221    # Repeat simple group management, now with grab_group
222    $got = $cache->get_group( group => 'group' );
223    diag( Data::Dumper::Dumper($got) ) if
224      !is_deeply( $got,$expected,
225        "Check if simple get_group with group works still" );
226    is( $cache->get, $value, "Check if simple get with group works" );
227    $got = $cache->grab_group( group => 'group' );
228    diag( Data::Dumper::Dumper($got) ) if
229      !is_deeply( $got,$expected,
230        "Check if simple grab_group with group works" );
231    ok( !defined $cache->get,
232      "Check if simple getting with grabbed group fails" );
233
234    # Check simple group deletion
235    ok( $cache->set( value => $value, group => 'group' ),
236      "Simple value with group" );
237    is( $cache->get, $value, "Check if simple get with group works" );
238    ok( $cache->delete_group( group => 'group' ), "Delete group" );
239    ok( !defined $cache->get,
240      "Check if simple getting with deleted group fails" );
241
242    # Check stats fetching
243    $got = $cache->stats;
244    foreach ( values %{$got} ) {
245         $_ = undef foreach values %{$_};
246    }
247    $expected = { $config => { map { $_ => undef } qw(
248     bytes
249     bytes_read
250     bytes_written
251     cmd_get
252     cmd_set
253     connection_structures
254     curr_items
255     curr_connections
256     get_hits
257     get_misses
258     limit_maxbytes
259     pid
260     rusage_system
261     rusage_user
262     time
263     total_connections
264     total_items
265     uptime
266     version
267    ) } };
268
269    # pointer_size introduced in memcached 1.2.1
270    $expected->{$config}->{pointer_size} = undef if $version ge "1.2.1";
271
272TODO: {
273local $TODO = 'Need to look up changes in memcached for different versions';
274    diag( Data::Dumper::Dumper($got) ) if
275      !is_deeply( $got,$expected, "Check if simple stats works" );
276} #TODO
277
278    # Check inside subroutine
279    Foo::bar();
280
281    # Done now if we did a reset already
282    last TEST if $reset;
283
284    # Reset so we can do it again with a clean slate
285    ok( $cache->reset, "Check if client side reset ok" );
286}
287
288# Obtain final stats
289my $got = $cache->stats->{$config};
290
291# Remove stuff that we cannot check reliably
292delete @$got{qw(
293 bytes_read
294 bytes_written
295 connection_structures
296 curr_connections
297 limit_maxbytes
298 rusage_user
299 rusage_system
300 time
301 total_connections
302 uptime
303)};
304
305# Set up the expected stats for the rest
306my $expected = {
307 bytes        => 0,
308 cmd_get      => 108,
309 cmd_set      => 56,
310 curr_items   => 0,
311 get_hits     => 74,
312 get_misses   => 34,
313 pid          => $pid,
314 pointer_size => 32,
315 total_items  => 52,
316 version      => $version,
317};
318
319# Check if it is what we expected
320TODO: {
321local $TODO = 'Need to look up changes in memcached for different versions';
322diag( Data::Dumper::Dumper( $got, $expected ) ) if
323  !is_deeply( $got, $expected, "Check if final stats correct" );
324}    #TODO
325
326} #SKIP
327
328#--------------------------------------------------------------------------
329# Foo::bar
330#
331# A subroutine for checking subroutine relative keys
332
333sub Foo::bar {
334
335    # One set, many different gets
336    ok( $cache->set('foo1'), "Check simple set inside a subroutine" );
337    is( $cache->get, 'foo1', "Check simple get inside a subroutine" );
338    is( $cache->get( key => '::bar' ), 'foo1',
339      "Check simple get with relative key inside a subroutine" );
340    is( $cache->get( key => 'Foo::bar' ), 'foo1',
341      "Check simple get with absolute key inside a subroutine" );
342
343    # Simple delete, many gets
344    ok( $cache->delete, "Check simple delete inside a subroutine" );
345    ok( !$cache->get, "Check whether simple get inside a subroutinei fails" );
346    ok( !$cache->get( key => '::bar' ),
347      "Check whether get with relative key inside a subroutine fails" );
348    ok( !$cache->get( key => 'Foo::bar' ),
349      "Check whether get with absolute key inside a subroutine fails" );
350
351    # Relative key set and delete
352    ok( $cache->set( key => '::bar', value => 'foo2' ),
353      "Check simple set with relative key inside a subroutine" );
354    is( $cache->get, 'foo2',
355      "Check simple get inside a subroutine after set with relative key" );
356    ok( $cache->delete( key => '::bar' ),
357      "Check delete with relative key inside a subroutine" );
358    ok( !$cache->get( key => '::bar' ),
359      "Check whether get with relative key inside a subroutine fails" );
360
361    # Absolute key set and delete
362    ok( $cache->set( key => 'Foo::bar', value => 'foo3' ),
363      "Check simple set with absolute key inside a subroutine" );
364    is( $cache->get, 'foo3',
365      "Check simple get inside a subroutine after set with absolute key" );
366    ok( $cache->delete( key => 'Foo::bar' ),
367      "Check delete with absolute key inside a subroutine" );
368    ok( !$cache->get( key => 'Foo::bar' ),
369      "Check whether get with absolute key inside a subroutine fails" );
370
371    # Check version support
372    ok( $cache->set('foo4'),
373      "Check simple set for version info" );
374    is( $cache->get( version => $Foo::VERSION ), 'foo4',
375      "Check if get with version info ok" );
376    ok( $cache->delete( version => $Foo::VERSION ),
377      "Check if delete with version info ok" );
378    ok( !$cache->get( version => $Foo::VERSION ),
379      "Check whether get with version inside a subroutine fails" );
380    ok( !$cache->get( version => $main::VERSION ),
381      "Check whether get with main version inside a subroutine fails" );
382    ok( !$cache->get( version => $Cache::Memcached::Managed::VERSION ),
383      "Check whether get with module version inside a subroutine fails" );
384} #Foo::bar
385