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