3 # This file is part of Koha.
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.
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.
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>.
20 use Test
::More tests
=> 41;
23 my $destructorcount = 0;
26 use_ok
('Koha::Cache');
27 use_ok
('Koha::Cache::Object');
28 use_ok
('C4::Context');
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();
37 skip
"Cache not enabled", 33
38 unless ( $cache->is_cache_active() && defined $cache );
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" );
44 # set_in_cache should not warn
47 local $SIG{__WARN__
} = sub {
50 $cache->set_in_cache( "a key", undef );
51 is
( $warn, undef, 'Koha::Cache->set_in_cache should not return any warns' );
54 # test expiry time in cache
55 $cache->set_in_cache( "timeout", "I AM DATA", 1 ); # expiry time of 1 second
57 $cache->flush_L1_cache();
58 is
( $cache->get_from_cache("timeout"),
59 undef, "fetching expired item from cache" );
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
67 $cache->get_from_cache("clear_me"),
69 "fetching valid item from cache"
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" );
77 $cache->get_from_cache("dont_clear_me"),
79 "fetching valid item from cache (after clearing another item)"
82 #test flushing from cache
83 $cache->set_in_cache( "flush_me", "testing 1 data" );
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" );
90 my $constructorcount = 0;
91 my $myscalar = $cache->create_scalar(
97 'constructor' => sub { return ++$constructorcount; },
98 'destructor' => sub { return ++$destructorcount; },
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();
107 is
( $$myscalar, 2, 'Constructor called again when timeout reached' );
109 is
( $$myscalar, 5, 'Stored new value to cache' );
110 is
( $constructorcount, 2, 'Constructor not called after storing value' );
113 is
( $cache->get_from_cache("myscalar"),
114 undef, 'Item removed from cache on destruction' );
116 my %hash = ( 'key' => 'value' );
118 my $myhash = $cache->create_hash(
124 'constructor' => sub { return { %hash }; },
128 ok
(defined $myhash, 'Created tied hash');
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';
136 $cache->flush_L1_cache();
137 is
($myhash->{'key2'}, 'nosurprise', 'Cache change caught');
141 foreach my $key (keys %{$myhash}) {
145 is
($foundkeys, 2, 'Found expected 2 keys when iterating through hash');
147 isnt
(scalar %{$myhash}, undef, 'scalar knows the hash is not empty');
149 $hash{'anotherkey'} = 'anothervalue';
152 $cache->flush_L1_cache();
154 ok
(exists $myhash->{'anotherkey'}, 'Cache reset properly');
156 delete $hash{'anotherkey'};
157 delete $myhash->{'anotherkey'};
159 ok
(!exists $myhash->{'anotherkey'}, 'Key successfully deleted');
164 is
(scalar %{$myhash}, 0, 'hash cleared');
166 $hash{'key'} = 'value';
167 is
($myhash->{'key'}, 'value', 'retrieved value after clearing cache');
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
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');
182 # Make sure the item will be deep copied
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' );
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');
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');
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');
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');
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');
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');
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');
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;