Commit | Line | Data |
57c7bc08 |
1 | #!/usr/bin/perl |
2 | # |
3 | # Check ->defer and ->flush methods |
4 | # |
6fc0ea7e |
5 | # This is the old version, which you used in the past when |
6 | # there was a defer buffer separate from the read cache. |
7 | # There isn't any longer. |
8 | # |
57c7bc08 |
9 | |
10 | use POSIX 'SEEK_SET'; |
11 | my $file = "tf$$.txt"; |
12 | $: = Tie::File::_default_recsep(); |
13 | my $data = "rec0$:rec1$:rec2$:"; |
14 | my ($o, $n); |
15 | |
16 | print "1..79\n"; |
17 | |
18 | my $N = 1; |
19 | use Tie::File; |
20 | print "ok $N\n"; $N++; |
21 | |
22 | open F, "> $file" or die $!; |
23 | binmode F; |
24 | print F $data; |
25 | close F; |
26 | $o = tie @a, 'Tie::File', $file; |
27 | print $o ? "ok $N\n" : "not ok $N\n"; |
28 | $N++; |
29 | |
30 | # (3-6) Deferred storage |
31 | $o->defer; |
32 | $a[3] = "rec3"; |
33 | check_contents($data); # nothing written yet |
34 | $a[4] = "rec4"; |
35 | check_contents($data); # nothing written yet |
36 | |
37 | # (7-8) Flush |
38 | $o->flush; |
39 | check_contents($data . "rec3$:rec4$:"); # now it's written |
40 | |
41 | # (9-12) Deferred writing disabled? |
42 | $a[3] = "rec9"; |
43 | check_contents("${data}rec9$:rec4$:"); |
44 | $a[4] = "rec8"; |
45 | check_contents("${data}rec9$:rec8$:"); |
46 | |
47 | # (13-18) Now let's try two batches of records |
48 | $#a = 2; |
49 | $o->defer; |
50 | $a[0] = "record0"; |
51 | check_contents($data); # nothing written yet |
52 | $a[2] = "record2"; |
53 | check_contents($data); # nothing written yet |
54 | $o->flush; |
55 | check_contents("record0$:rec1$:record2$:"); |
56 | |
57 | # (19-22) Deferred writing past the end of the file |
58 | $o->defer; |
59 | $a[4] = "record4"; |
60 | check_contents("record0$:rec1$:record2$:"); |
61 | $o->flush; |
62 | check_contents("record0$:rec1$:record2$:$:record4$:"); |
63 | |
64 | |
65 | # (23-26) Now two long batches |
66 | $o->defer; |
67 | for (0..2, 4..6) { |
68 | $a[$_] = "r$_"; |
69 | } |
70 | check_contents("record0$:rec1$:record2$:$:record4$:"); |
71 | $o->flush; |
72 | check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); |
73 | |
74 | # (27-30) Now let's make sure that discarded writes are really discarded |
75 | # We have a 2Mib buffer here, so we can be sure that we aren't accidentally |
76 | # filling it up |
77 | $o->defer; |
78 | for (0, 3, 7) { |
79 | $a[$_] = "discarded$_"; |
80 | } |
81 | check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); |
82 | $o->discard; |
83 | check_contents(join $:, "r0".."r2", "", "r4".."r6", ""); |
84 | |
85 | ################################################################ |
86 | # |
87 | # Now we're going to test the results of a small memory limit |
88 | # |
89 | # |
90 | undef $o; untie @a; |
91 | $data = join "$:", map("record$_", 0..7), ""; # records are 8 or 9 bytes long |
92 | open F, "> $file" or die $!; |
93 | binmode F; |
94 | print F $data; |
95 | close F; |
96 | |
97 | # Limit cache+buffer size to 47 bytes |
98 | my $MAX = 47; |
99 | # -- that's enough space for 5 records, but not 6, on both \n and \r\n systems |
100 | my $BUF = 20; |
101 | # -- that's enough space for 2 records, but not 3, on both \n and \r\n systems |
102 | $o = tie @a, 'Tie::File', $file, memory => $MAX, dw_size => $BUF; |
103 | print $o ? "ok $N\n" : "not ok $N\n"; |
104 | $N++; |
105 | |
106 | # (31-32) Fill up the read cache |
107 | my @z; |
108 | @z = @a; |
109 | # the cache now contains records 3,4,5,6,7. |
110 | check_caches({map(($_ => "record$_$:"), 3..7)}, |
111 | {}); |
112 | |
113 | # (33-44) See if overloading the defer starts by flushing the read cache |
114 | # and then flushes out the defer |
115 | $o->defer; |
116 | $a[0] = "recordA"; # That should flush record 3 from the cache |
117 | check_caches({map(($_ => "record$_$:"), 4..7)}, |
118 | {0 => "recordA$:"}); |
119 | check_contents($data); |
120 | |
121 | $a[1] = "recordB"; # That should flush record 4 from the cache |
122 | check_caches({map(($_ => "record$_$:"), 5..7)}, |
123 | {0 => "recordA$:", |
124 | 1 => "recordB$:"}); |
125 | check_contents($data); |
126 | |
127 | $a[2] = "recordC"; # That should flush the whole darn defer |
6ae23f41 |
128 | # This shouldn't change the cache contents |
129 | check_caches({map(($_ => "record$_$:"), 5..7)}, |
57c7bc08 |
130 | {}); # URRRP |
131 | check_contents(join("$:", qw(recordA recordB recordC |
132 | record3 record4 record5 record6 record7)) . "$:"); |
133 | |
134 | $a[3] = "recordD"; # even though we flushed, deferring is STILL ENABLED |
6ae23f41 |
135 | check_caches({map(($_ => "record$_$:"), 5..7)}, |
57c7bc08 |
136 | {3 => "recordD$:"}); |
137 | check_contents(join("$:", qw(recordA recordB recordC |
138 | record3 record4 record5 record6 record7)) . "$:"); |
139 | |
140 | # Check readcache-deferbuffer interactions |
141 | |
142 | # (45-47) This should remove outdated data from the read cache |
6ae23f41 |
143 | $a[5] = "recordE"; |
144 | check_caches({6 => "record6$:", 7 => "record7$:"}, |
145 | {3 => "recordD$:", 5 => "recordE$:"}); |
57c7bc08 |
146 | check_contents(join("$:", qw(recordA recordB recordC |
147 | record3 record4 record5 record6 record7)) . "$:"); |
148 | |
6fc0ea7e |
149 | # (48-51) This should read back out of the defer buffer |
57c7bc08 |
150 | # without adding anything to the read cache |
151 | my $z; |
6ae23f41 |
152 | $z = $a[5]; |
57c7bc08 |
153 | print $z eq "recordE" ? "ok $N\n" : "not ok $N\n"; $N++; |
6ae23f41 |
154 | check_caches({6 => "record6$:", 7 => "record7$:"}, |
155 | {3 => "recordD$:", 5 => "recordE$:"}); |
57c7bc08 |
156 | check_contents(join("$:", qw(recordA recordB recordC |
157 | record3 record4 record5 record6 record7)) . "$:"); |
158 | |
159 | # (52-55) This should repopulate the read cache with a new record |
160 | $z = $a[0]; |
161 | print $z eq "recordA" ? "ok $N\n" : "not ok $N\n"; $N++; |
6ae23f41 |
162 | check_caches({0 => "recordA$:", 6 => "record6$:", 7 => "record7$:"}, |
163 | {3 => "recordD$:", 5 => "recordE$:"}); |
57c7bc08 |
164 | check_contents(join("$:", qw(recordA recordB recordC |
165 | record3 record4 record5 record6 record7)) . "$:"); |
166 | |
167 | # (56-59) This should flush the LRU record from the read cache |
6ae23f41 |
168 | $z = $a[4]; |
169 | print $z eq "record4" ? "ok $N\n" : "not ok $N\n"; $N++; |
170 | check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:"}, |
171 | {3 => "recordD$:", 5 => "recordE$:"}); |
57c7bc08 |
172 | check_contents(join("$:", qw(recordA recordB recordC |
173 | record3 record4 record5 record6 record7)) . "$:"); |
174 | |
175 | # (60-63) This should FLUSH the deferred buffer |
57c7bc08 |
176 | $z = splice @a, 3, 1, "recordZ"; |
177 | print $z eq "recordD" ? "ok $N\n" : "not ok $N\n"; $N++; |
6ae23f41 |
178 | check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, |
57c7bc08 |
179 | {}); |
6ae23f41 |
180 | check_contents(join("$:", qw(recordA recordB recordC |
181 | recordZ record4 recordE record6 record7)) . "$:"); |
57c7bc08 |
182 | |
183 | # (64-66) We should STILL be in deferred writing mode |
184 | $a[5] = "recordX"; |
6ae23f41 |
185 | check_caches({7 => "record7$:", 0 => "recordA$:", 4 => "record4$:", 3 => "recordZ$:"}, |
57c7bc08 |
186 | {5 => "recordX$:"}); |
6ae23f41 |
187 | check_contents(join("$:", qw(recordA recordB recordC |
188 | recordZ record4 recordE record6 record7)) . "$:"); |
57c7bc08 |
189 | |
190 | # Fill up the defer buffer again |
191 | $a[4] = "recordP"; |
192 | # (67-69) This should OVERWRITE the existing deferred record |
193 | # and NOT flush the buffer |
194 | $a[5] = "recordQ"; |
6ae23f41 |
195 | check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, |
57c7bc08 |
196 | {5 => "recordQ$:", 4 => "recordP$:"}); |
6ae23f41 |
197 | check_contents(join("$:", qw(recordA recordB recordC |
198 | recordZ record4 recordE record6 record7)) . "$:"); |
57c7bc08 |
199 | |
200 | # (70-72) Discard should just dump the whole deferbuffer |
201 | $o->discard; |
6ae23f41 |
202 | check_caches({7 => "record7$:", 0 => "recordA$:", 3 => "recordZ$:"}, |
57c7bc08 |
203 | {}); |
6ae23f41 |
204 | check_contents(join("$:", qw(recordA recordB recordC |
205 | recordZ record4 recordE record6 record7)) . "$:"); |
206 | |
57c7bc08 |
207 | # (73-75) NOW we are out of deferred writing mode |
208 | $a[0] = "recordF"; |
6ae23f41 |
209 | check_caches({7 => "record7$:", 0 => "recordF$:", 3 => "recordZ$:"}, |
57c7bc08 |
210 | {}); |
6ae23f41 |
211 | check_contents(join("$:", qw(recordF recordB recordC |
212 | recordZ record4 recordE record6 record7)) . "$:"); |
57c7bc08 |
213 | |
214 | # (76-79) Last call--untying the array should flush the deferbuffer |
215 | $o->defer; |
216 | $a[0] = "flushed"; |
6ae23f41 |
217 | check_caches({7 => "record7$:", 3 => "recordZ$:"}, |
57c7bc08 |
218 | {0 => "flushed$:" }); |
6ae23f41 |
219 | check_contents(join("$:", qw(recordF recordB recordC |
220 | recordZ record4 recordE record6 record7)) . "$:"); |
57c7bc08 |
221 | undef $o; |
222 | untie @a; |
223 | # (79) We can't use check_contents any more, because the object is dead |
224 | open F, "< $file" or die; |
a4a5e1bc |
225 | binmode F; |
57c7bc08 |
226 | { local $/ ; $z = <F> } |
227 | close F; |
6ae23f41 |
228 | my $x = join("$:", qw(flushed recordB recordC |
229 | recordZ record4 recordE record6 record7)) . "$:"; |
57c7bc08 |
230 | if ($z eq $x) { |
231 | print "ok $N\n"; |
232 | } else { |
233 | my $msg = ctrlfix("expected <$x>, got <$z>"); |
234 | print "not ok $N \# $msg\n"; |
235 | } |
236 | $N++; |
237 | |
238 | ################################################################ |
239 | |
240 | |
241 | sub check_caches { |
242 | my ($xcache, $xdefer) = @_; |
243 | |
244 | # my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
245 | # print $integrity ? "ok $N\n" : "not ok $N\n"; |
246 | # $N++; |
247 | |
248 | my $good = 1; |
6fc0ea7e |
249 | |
250 | # Copy the contents of the cache into a regular hash |
251 | my %cache; |
bf919750 |
252 | for my $k ($o->{cache}->ckeys) { |
6fc0ea7e |
253 | $cache{$k} = $o->{cache}->_produce($k); |
254 | } |
255 | |
256 | $good &&= hash_equal(\%cache, $xcache, "true cache", "expected cache"); |
57c7bc08 |
257 | $good &&= hash_equal($o->{deferred}, $xdefer, "true defer", "expected defer"); |
258 | print $good ? "ok $N\n" : "not ok $N\n"; |
259 | $N++; |
260 | } |
261 | |
262 | sub hash_equal { |
263 | my ($a, $b, $ha, $hb) = @_; |
264 | $ha = 'first hash' unless defined $ha; |
265 | $hb = 'second hash' unless defined $hb; |
266 | |
267 | my $good = 1; |
268 | my %b_seen; |
269 | |
270 | for my $k (keys %$a) { |
271 | if (! exists $b->{$k}) { |
272 | print ctrlfix("# Key $k is in $ha but not $hb"), "\n"; |
273 | $good = 0; |
274 | } elsif ($b->{$k} ne $a->{$k}) { |
275 | print ctrlfix("# Key $k is <$a->{$k}> in $ha but <$b->{$k}> in $hb"), "\n"; |
276 | $b_seen{$k} = 1; |
277 | $good = 0; |
278 | } else { |
279 | $b_seen{$k} = 1; |
280 | } |
281 | } |
282 | |
283 | for my $k (keys %$b) { |
284 | unless ($b_seen{$k}) { |
285 | print ctrlfix("# Key $k is in $hb but not $ha"), "\n"; |
286 | $good = 0; |
287 | } |
288 | } |
289 | |
290 | $good; |
291 | } |
292 | |
293 | |
294 | sub check_contents { |
295 | my $x = shift; |
296 | |
297 | my $integrity = $o->_check_integrity($file, $ENV{INTEGRITY}); |
298 | print $integrity ? "ok $N\n" : "not ok $N\n"; |
299 | $N++; |
300 | |
301 | local *FH = $o->{fh}; |
302 | seek FH, 0, SEEK_SET; |
303 | |
304 | my $a; |
305 | { local $/; $a = <FH> } |
306 | $a = "" unless defined $a; |
307 | if ($a eq $x) { |
308 | print "ok $N\n"; |
309 | } else { |
310 | my $msg = ctrlfix("# expected <$x>, got <$a>"); |
311 | print "not ok $N\n$msg\n"; |
312 | } |
313 | $N++; |
314 | } |
315 | |
316 | sub ctrlfix { |
317 | local $_ = shift; |
318 | s/\n/\\n/g; |
319 | s/\r/\\r/g; |
320 | $_; |
321 | } |
322 | |
323 | END { |
6ae23f41 |
324 | undef $o; |
325 | untie @a if tied @a; |
57c7bc08 |
326 | 1 while unlink $file; |
327 | } |
328 | |