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