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