t/Cache.t

   1 #!/usr/bin/perl
   2
   3 # This file is part of Koha.
   4 #
   5 # Koha is free software; you can redistribute it and/or modify it
   6 # under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 3 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but
  11 # WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  17
  18 use Modern::Perl;
  19
  20 use Test::More tests => 44;
  21 use Test::Warn;
  22
  23 my $destructorcount = 0;
  24
  25 BEGIN {
  26     use_ok('Koha::Cache');
  27     use_ok('Koha::Caches');
  28     use_ok('Koha::Cache::Object');
  29     use_ok('Koha::Cache::Memory::Lite');
  30     use_ok('C4::Context');
  31 }
  32
  33 SKIP: {
  34     # Set a special namespace for testing, to avoid breaking
  35     # if test is run with a different user than Apache's.
  36     $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
  37     my $cache = Koha::Caches->get_instance();
  38
  39     skip "Cache not enabled", 36
  40       unless ( $cache->is_cache_active() && defined $cache );
  41
  42     # test fetching an item that isnt in the cache
  43     is( $cache->get_from_cache("not in here"),
  44         undef, "fetching item NOT in cache" );
  45
  46     # set_in_cache should not warn
  47     my $warn;
  48     {
  49         local $SIG{__WARN__} = sub {
  50             $warn = shift;
  51         };
  52         $cache->set_in_cache( "a key", undef );
  53         is( $warn, undef, 'Koha::Cache->set_in_cache should not return any warns' );
  54     }
  55
  56     # test expiry time in cache
  57     $cache->set_in_cache( "timeout", "I AM DATA", { expiry => 1 } ); # expiry time of 1 second
  58     sleep 2;
  59     $cache->flush_L1_cache();
  60     is( $cache->get_from_cache("timeout"),
  61         undef, "fetching expired item from cache" );
  62
  63     # test fetching a valid, non expired, item from cache
  64     $cache->set_in_cache( "clear_me", "I AM MORE DATA", { expiry => 1000 } )
  65       ;    # overly large expiry time, clear below
  66     $cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22", { expiry => 1000 } )
  67       ;    # overly large expiry time, clear below
  68     is(
  69         $cache->get_from_cache("clear_me"),
  70         "I AM MORE DATA",
  71         "fetching valid item from cache"
  72     );
  73
  74     # test clearing from cache
  75     $cache->clear_from_cache("clear_me");
  76     is( $cache->get_from_cache("clear_me"),
  77         undef, "fetching cleared item from cache" );
  78     is(
  79         $cache->get_from_cache("dont_clear_me"),
  80         "I AM MORE DATA22",
  81         "fetching valid item from cache (after clearing another item)"
  82     );
  83
  84     #test flushing from cache
  85     $cache->set_in_cache( "flush_me", "testing 1 data" );
  86     $cache->flush_all;
  87     is( $cache->get_from_cache("flush_me"),
  88         undef, "fetching flushed item from cache" );
  89     is( $cache->get_from_cache("dont_clear_me"),
  90         undef, "fetching flushed item from cache" );
  91
  92     my $constructorcount = 0;
  93     my $myscalar         = $cache->create_scalar(
  94         {
  95             'key'         => 'myscalar',
  96             'timeout'     => 1,
  97             'allowupdate' => 1,
  98             'unset'       => 1,
  99             'constructor' => sub { return ++$constructorcount; },
 100             'destructor'  => sub { return ++$destructorcount; },
 101         }
 102     );
 103     ok( defined($myscalar), 'Created tied scalar' );
 104     is( $$myscalar, 1, 'Constructor called to first initialize' );
 105     $cache->flush_L1_cache();
 106     is( $$myscalar, 1, 'Data retrieved from cache' );
 107     $cache->flush_L1_cache();
 108     sleep 2;
 109     is( $$myscalar, 2, 'Constructor called again when timeout reached' );
 110     $$myscalar = 5;
 111     is( $$myscalar,        5, 'Stored new value to cache' );
 112     is( $constructorcount, 2, 'Constructor not called after storing value' );
 113     undef $myscalar;
 114
 115     is( $cache->get_from_cache("myscalar"),
 116         undef, 'Item removed from cache on destruction' );
 117
 118     my %hash = ( 'key' => 'value' );
 119
 120     my $myhash         = $cache->create_hash(
 121         {
 122             'key'         => 'myhash',
 123             'timeout'     => 1,
 124             'allowupdate' => 1,
 125             'unset'       => 1,
 126             'constructor' => sub { return { %hash }; },
 127         }
 128     );
 129
 130     ok(defined $myhash, 'Created tied hash');
 131
 132     is($myhash->{'key'}, 'value', 'Found expected value in hash');
 133     ok(exists $myhash->{'key'}, 'Exists works');
 134     $myhash->{'key2'} = 'surprise';
 135     is($myhash->{'key2'}, 'surprise', 'Setting hash member worked');
 136     $hash{'key2'} = 'nosurprise';
 137     sleep 2;
 138     $cache->flush_L1_cache();
 139     is($myhash->{'key2'}, 'nosurprise', 'Cache change caught');
 140
 141
 142     my $foundkeys = 0;
 143     foreach my $key (keys %{$myhash}) {
 144         $foundkeys++;
 145     }
 146
 147     is($foundkeys, 2, 'Found expected 2 keys when iterating through hash');
 148
 149     isnt(scalar %{$myhash}, undef, 'scalar knows the hash is not empty');
 150
 151     $hash{'anotherkey'} = 'anothervalue';
 152
 153     sleep 2;
 154     $cache->flush_L1_cache();
 155
 156     ok(exists $myhash->{'anotherkey'}, 'Cache reset properly');
 157
 158     delete $hash{'anotherkey'};
 159     delete $myhash->{'anotherkey'};
 160
 161     ok(!exists $myhash->{'anotherkey'}, 'Key successfully deleted');
 162
 163     undef %hash;
 164     %{$myhash} = ();
 165
 166     is(scalar %{$myhash}, 0, 'hash cleared');
 167
 168     $hash{'key'} = 'value';
 169     is($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
 170
 171     # UTF8 testing
 172     my $utf8_str = "A Møøse once bit my sister";
 173     $cache->set_in_cache('utf8_1', $utf8_str);
 174     is($cache->get_from_cache('utf8_1'), $utf8_str, 'Simple 8-bit UTF8 correctly retrieved');
 175     $utf8_str = "\x{20ac}"; # €
 176     $cache->set_in_cache('utf8_1', $utf8_str);
 177     my $utf8_res = $cache->get_from_cache('utf8_1');
 178     # This'll ensure that we're getting a unicode string back, rather than
 179     # a couple of bytes.
 180     is(length($utf8_res), 1, 'UTF8 string length correct');
 181     # ...and that it's really the character we intend
 182     is(ord($utf8_res), 8364, 'UTF8 string value correct');
 183
 184     # Make sure the item will be deep copied
 185     # Scalar
 186     my $item = "just a simple scalar";
 187     $cache->set_in_cache('test_deep_copy', $item);
 188     my $item_from_cache = $cache->get_from_cache('test_deep_copy');
 189     $item_from_cache = "a modified scalar";
 190     is( $cache->get_from_cache('test_deep_copy'), 'just a simple scalar', 'A scalar will not be modified in the cache if get from the cache' );
 191     # Array
 192     my @item = qw( an array ref );
 193     $cache->set_in_cache('test_deep_copy_array', \@item);
 194     $item_from_cache = $cache->get_from_cache('test_deep_copy_array');
 195     @$item_from_cache = qw( another array ref );
 196     is_deeply( $cache->get_from_cache('test_deep_copy_array'), [ qw ( an array ref ) ], 'An array will be deep copied');
 197
 198     $cache->flush_L1_cache();
 199     $item_from_cache = $cache->get_from_cache('test_deep_copy_array');
 200     @$item_from_cache = qw( another array ref );
 201     is_deeply( $cache->get_from_cache('test_deep_copy_array'), [ qw ( an array ref ) ], 'An array will be deep copied even it is the first fetch from L2');
 202
 203     $item_from_cache = $cache->get_from_cache('test_deep_copy_array', { unsafe => 1 });
 204     @$item_from_cache = qw( another array ref );
 205     is_deeply( $cache->get_from_cache('test_deep_copy_array', { unsafe => 1 }), [ qw ( another array ref ) ], 'An array will not be deep copied if the unsafe flag is set');
 206     # Hash
 207     my %item = ( a => 'hashref' );
 208     $cache->set_in_cache('test_deep_copy_hash', \%item);
 209     $item_from_cache = $cache->get_from_cache('test_deep_copy_hash');
 210     %$item_from_cache = ( another => 'hashref' );
 211     is_deeply( $cache->get_from_cache('test_deep_copy_hash'), { a => 'hashref' }, 'A hash will be deep copied');
 212
 213     %item = ( a_modified => 'hashref' );
 214     is_deeply( $cache->get_from_cache('test_deep_copy_hash'), { a => 'hashref' }, 'A hash will be deep copied when set in cache');
 215
 216     %item = ( a => 'hashref' );
 217     $cache->set_in_cache('test_deep_copy_hash', \%item);
 218     $item_from_cache = $cache->get_from_cache('test_deep_copy_hash', { unsafe => 1 });
 219     %$item_from_cache = ( another => 'hashref' );
 220     is_deeply( $cache->get_from_cache('test_deep_copy_hash', { unsafe => 1 }), { another => 'hashref' }, 'A hash will not be deep copied if the unsafe flag is set');
 221 }
 222
 223 subtest 'Koha::Cache::Memory::Lite' => sub {
 224     plan tests => 6;
 225     my $memory_cache = Koha::Cache::Memory::Lite->get_instance();
 226
 227     # test fetching an item that isnt in the cache
 228     is( $memory_cache->get_from_cache("not in here"),
 229         undef, "fetching item NOT in cache" );
 230
 231     # test fetching a valid item from cache
 232     $memory_cache->set_in_cache( "clear_me", "I AM MORE DATA" );
 233     $memory_cache->set_in_cache( "dont_clear_me", "I AM MORE DATA22" );
 234       ;    # overly large expiry time, clear below
 235     is(
 236         $memory_cache->get_from_cache("clear_me"),
 237         "I AM MORE DATA",
 238         "fetching valid item from cache"
 239     );
 240
 241     # test clearing from cache
 242     $memory_cache->clear_from_cache("clear_me");
 243     is( $memory_cache->get_from_cache("clear_me"),
 244         undef, "fetching cleared item from cache" );
 245     is(
 246         $memory_cache->get_from_cache("dont_clear_me"),
 247         "I AM MORE DATA22",
 248         "fetching valid item from cache (after clearing another item)"
 249     );
 250
 251     #test flushing from cache
 252     $memory_cache->set_in_cache( "flush_me", "testing 1 data" );
 253     $memory_cache->flush;
 254     is( $memory_cache->get_from_cache("flush_me"),
 255         undef, "fetching flushed item from cache" );
 256     is( $memory_cache->get_from_cache("dont_clear_me"),
 257         undef, "fetching flushed item from cache" );
 258 };
 259
 260 subtest 'Koha::Caches' => sub {
 261     plan tests => 8;
 262     my $default_cache = Koha::Caches->get_instance();
 263     my $another_cache = Koha::Caches->get_instance('another_cache');
 264     $default_cache->set_in_cache('key_a', 'value_a');
 265     $default_cache->set_in_cache('key_b', 'value_b');
 266     $another_cache->set_in_cache('key_a', 'another_value_a');
 267     $another_cache->set_in_cache('key_b', 'another_value_b');
 268     is( $default_cache->get_from_cache('key_a'), 'value_a' );
 269     is( $another_cache->get_from_cache('key_a'), 'another_value_a' );
 270     is( $default_cache->get_from_cache('key_b'), 'value_b' );
 271     is( $another_cache->get_from_cache('key_b'), 'another_value_b' );
 272     $another_cache->clear_from_cache('key_b');
 273     is( $default_cache->get_from_cache('key_b'), 'value_b' );
 274     is( $another_cache->get_from_cache('key_b'), undef );
 275     $another_cache->flush_all();
 276     is( $default_cache->get_from_cache('key_a'), 'value_a' );
 277     is( $another_cache->get_from_cache('key_a'), undef );
 278 };
 279
 280 END {
 281   SKIP: {
 282         $ENV{ MEMCACHED_NAMESPACE } = 'unit_tests';
 283         my $cache = Koha::Caches->get_instance();
 284         skip "Cache not enabled", 1
 285           unless ( $cache->is_cache_active() );
 286         is( $destructorcount, 1, 'Destructor run exactly once' );
 287         # cleanup temporary file
 288         my $tmp_file = $cache->{ fastmmap_cache }->{ share_file };
 289         unlink $tmp_file if defined $tmp_file;
 290
 291     }
 292 }