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