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