Commit | Line | Data |
f6b705ef |
1 | #!./perl -w |
a0d0e21e |
2 | |
3 | BEGIN { |
93430cb4 |
4 | unshift @INC, '../lib' if -d '../lib' ; |
a0d0e21e |
5 | require Config; import Config; |
6 | if ($Config{'extensions'} !~ /\bDB_File\b/) { |
45c0de28 |
7 | print "1..0 # Skip: DB_File was not built\n"; |
a0d0e21e |
8 | exit 0; |
9 | } |
10 | } |
11 | |
12 | use DB_File; |
13 | use Fcntl; |
55d68b4a |
14 | use strict ; |
045291aa |
15 | use vars qw($dbh $Dfile $bad_ones $FA) ; |
16 | |
17 | # full tied array support started in Perl 5.004_57 |
a9fd575d |
18 | # Double check to see if it is available. |
19 | |
20 | { |
21 | sub try::TIEARRAY { bless [], "try" } |
22 | sub try::FETCHSIZE { $FA = 1 } |
23 | $FA = 0 ; |
24 | my @a ; |
25 | tie @a, 'try' ; |
26 | my $a = @a ; |
27 | } |
28 | |
a0d0e21e |
29 | |
55d68b4a |
30 | sub ok |
31 | { |
32 | my $no = shift ; |
33 | my $result = shift ; |
a0d0e21e |
34 | |
55d68b4a |
35 | print "not " unless $result ; |
36 | print "ok $no\n" ; |
6250ba0a |
37 | |
38 | return $result ; |
39 | } |
40 | |
41 | sub bad_one |
42 | { |
25268f15 |
43 | print STDERR <<EOM unless $bad_ones++ ; |
44 | # |
20896112 |
45 | # Some older versions of Berkeley DB version 1 will fail tests 51, |
46 | # 53 and 55. |
6250ba0a |
47 | # |
48 | # You can safely ignore the errors if you're never going to use the |
49 | # broken functionality (recno databases with a modified bval). |
50 | # Otherwise you'll have to upgrade your DB library. |
51 | # |
20896112 |
52 | # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the |
53 | # last versions that were released. Berkeley DB version 2 is continually |
54 | # being updated -- Check out http://www.sleepycat.com/ for more details. |
6250ba0a |
55 | # |
56 | EOM |
55d68b4a |
57 | } |
58 | |
9fe6733a |
59 | print "1..124\n"; |
55d68b4a |
60 | |
61 | my $Dfile = "recno.tmp"; |
62 | unlink $Dfile ; |
a0d0e21e |
63 | |
64 | umask(0); |
65 | |
66 | # Check the interface to RECNOINFO |
67 | |
55d68b4a |
68 | my $dbh = new DB_File::RECNOINFO ; |
3fe9a6f1 |
69 | ok(1, ! defined $dbh->{bval}) ; |
70 | ok(2, ! defined $dbh->{cachesize}) ; |
71 | ok(3, ! defined $dbh->{psize}) ; |
72 | ok(4, ! defined $dbh->{flags}) ; |
73 | ok(5, ! defined $dbh->{lorder}) ; |
74 | ok(6, ! defined $dbh->{reclen}) ; |
75 | ok(7, ! defined $dbh->{bfname}) ; |
a0d0e21e |
76 | |
77 | $dbh->{bval} = 3000 ; |
f6b705ef |
78 | ok(8, $dbh->{bval} == 3000 ); |
a0d0e21e |
79 | |
80 | $dbh->{cachesize} = 9000 ; |
f6b705ef |
81 | ok(9, $dbh->{cachesize} == 9000 ); |
a0d0e21e |
82 | |
83 | $dbh->{psize} = 400 ; |
f6b705ef |
84 | ok(10, $dbh->{psize} == 400 ); |
a0d0e21e |
85 | |
86 | $dbh->{flags} = 65 ; |
f6b705ef |
87 | ok(11, $dbh->{flags} == 65 ); |
a0d0e21e |
88 | |
89 | $dbh->{lorder} = 123 ; |
f6b705ef |
90 | ok(12, $dbh->{lorder} == 123 ); |
a0d0e21e |
91 | |
92 | $dbh->{reclen} = 1234 ; |
f6b705ef |
93 | ok(13, $dbh->{reclen} == 1234 ); |
a0d0e21e |
94 | |
95 | $dbh->{bfname} = 1234 ; |
f6b705ef |
96 | ok(14, $dbh->{bfname} == 1234 ); |
a0d0e21e |
97 | |
98 | |
99 | # Check that an invalid entry is caught both for store & fetch |
100 | eval '$dbh->{fred} = 1234' ; |
f6b705ef |
101 | ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); |
55d68b4a |
102 | eval 'my $q = $dbh->{fred}' ; |
f6b705ef |
103 | ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); |
a0d0e21e |
104 | |
105 | # Now check the interface to RECNOINFO |
106 | |
55d68b4a |
107 | my $X ; |
108 | my @h ; |
109 | ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; |
a0d0e21e |
110 | |
a9fd575d |
111 | ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) |
112 | || $^O eq 'MSWin32' || $^O eq 'amigaos') ; |
a0d0e21e |
113 | |
55d68b4a |
114 | #my $l = @h ; |
115 | my $l = $X->length ; |
045291aa |
116 | ok(19, ($FA ? @h == 0 : !$l) ); |
a0d0e21e |
117 | |
55d68b4a |
118 | my @data = qw( a b c d ever f g h i j k longername m n o p) ; |
a0d0e21e |
119 | |
120 | $h[0] = shift @data ; |
f6b705ef |
121 | ok(20, $h[0] eq 'a' ); |
a0d0e21e |
122 | |
55d68b4a |
123 | my $ i; |
a0d0e21e |
124 | foreach (@data) |
125 | { $h[++$i] = $_ } |
126 | |
127 | unshift (@data, 'a') ; |
128 | |
f6b705ef |
129 | ok(21, defined $h[1] ); |
130 | ok(22, ! defined $h[16] ); |
045291aa |
131 | ok(23, $FA ? @h == @data : $X->length == @data ); |
a0d0e21e |
132 | |
133 | |
134 | # Overwrite an entry & check fetch it |
135 | $h[3] = 'replaced' ; |
136 | $data[3] = 'replaced' ; |
f6b705ef |
137 | ok(24, $h[3] eq 'replaced' ); |
a0d0e21e |
138 | |
139 | #PUSH |
55d68b4a |
140 | my @push_data = qw(added to the end) ; |
045291aa |
141 | ($FA ? push(@h, @push_data) : $X->push(@push_data)) ; |
a0d0e21e |
142 | push (@data, @push_data) ; |
f6b705ef |
143 | ok(25, $h[++$i] eq 'added' ); |
144 | ok(26, $h[++$i] eq 'to' ); |
145 | ok(27, $h[++$i] eq 'the' ); |
146 | ok(28, $h[++$i] eq 'end' ); |
a0d0e21e |
147 | |
148 | # POP |
f6b705ef |
149 | my $popped = pop (@data) ; |
045291aa |
150 | my $value = ($FA ? pop @h : $X->pop) ; |
f6b705ef |
151 | ok(29, $value eq $popped) ; |
a0d0e21e |
152 | |
153 | # SHIFT |
045291aa |
154 | $value = ($FA ? shift @h : $X->shift) ; |
f6b705ef |
155 | my $shifted = shift @data ; |
156 | ok(30, $value eq $shifted ); |
a0d0e21e |
157 | |
158 | # UNSHIFT |
159 | |
160 | # empty list |
045291aa |
161 | ($FA ? unshift @h : $X->unshift) ; |
162 | ok(31, ($FA ? @h == @data : $X->length == @data )); |
a0d0e21e |
163 | |
55d68b4a |
164 | my @new_data = qw(add this to the start of the array) ; |
045291aa |
165 | $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; |
a0d0e21e |
166 | unshift (@data, @new_data) ; |
045291aa |
167 | ok(32, $FA ? @h == @data : $X->length == @data ); |
f6b705ef |
168 | ok(33, $h[0] eq "add") ; |
169 | ok(34, $h[1] eq "this") ; |
170 | ok(35, $h[2] eq "to") ; |
171 | ok(36, $h[3] eq "the") ; |
172 | ok(37, $h[4] eq "start") ; |
173 | ok(38, $h[5] eq "of") ; |
174 | ok(39, $h[6] eq "the") ; |
175 | ok(40, $h[7] eq "array") ; |
176 | ok(41, $h[8] eq $data[8]) ; |
a0d0e21e |
177 | |
178 | # SPLICE |
179 | |
180 | # Now both arrays should be identical |
181 | |
55d68b4a |
182 | my $ok = 1 ; |
183 | my $j = 0 ; |
a0d0e21e |
184 | foreach (@data) |
185 | { |
186 | $ok = 0, last if $_ ne $h[$j ++] ; |
187 | } |
f6b705ef |
188 | ok(42, $ok ); |
a0d0e21e |
189 | |
55d68b4a |
190 | # Neagtive subscripts |
191 | |
192 | # get the last element of the array |
f6b705ef |
193 | ok(43, $h[-1] eq $data[-1] ); |
045291aa |
194 | ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); |
55d68b4a |
195 | |
196 | # get the first element using a negative subscript |
045291aa |
197 | eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; |
f6b705ef |
198 | ok(45, $@ eq "" ); |
199 | ok(46, $h[0] eq "abcd" ); |
55d68b4a |
200 | |
201 | # now try to read before the start of the array |
045291aa |
202 | eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; |
f6b705ef |
203 | ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); |
55d68b4a |
204 | |
a0d0e21e |
205 | # IMPORTANT - $X must be undefined before the untie otherwise the |
206 | # underlying DB close routine will not get called. |
207 | undef $X ; |
208 | untie(@h); |
209 | |
210 | unlink $Dfile; |
211 | |
a6ed719b |
212 | sub docat |
213 | { |
214 | my $file = shift; |
215 | local $/ = undef; |
216 | open(CAT,$file) || die "Cannot open $file:$!"; |
217 | my $result = <CAT>; |
218 | close(CAT); |
219 | return $result; |
220 | } |
221 | |
222 | |
36477c24 |
223 | { |
224 | # Check bval defaults to \n |
225 | |
226 | my @h = () ; |
227 | my $dbh = new DB_File::RECNOINFO ; |
228 | ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
229 | $h[0] = "abc" ; |
230 | $h[1] = "def" ; |
231 | $h[3] = "ghi" ; |
232 | untie @h ; |
a6ed719b |
233 | my $x = docat($Dfile) ; |
36477c24 |
234 | unlink $Dfile; |
6250ba0a |
235 | ok(49, $x eq "abc\ndef\n\nghi\n") ; |
36477c24 |
236 | } |
237 | |
238 | { |
239 | # Change bval |
240 | |
241 | my @h = () ; |
242 | my $dbh = new DB_File::RECNOINFO ; |
243 | $dbh->{bval} = "-" ; |
244 | ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
245 | $h[0] = "abc" ; |
246 | $h[1] = "def" ; |
247 | $h[3] = "ghi" ; |
248 | untie @h ; |
a6ed719b |
249 | my $x = docat($Dfile) ; |
36477c24 |
250 | unlink $Dfile; |
6250ba0a |
251 | my $ok = ($x eq "abc-def--ghi-") ; |
252 | bad_one() unless $ok ; |
253 | ok(51, $ok) ; |
36477c24 |
254 | } |
255 | |
256 | { |
257 | # Check R_FIXEDLEN with default bval (space) |
258 | |
259 | my @h = () ; |
260 | my $dbh = new DB_File::RECNOINFO ; |
261 | $dbh->{flags} = R_FIXEDLEN ; |
262 | $dbh->{reclen} = 5 ; |
263 | ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
264 | $h[0] = "abc" ; |
265 | $h[1] = "def" ; |
266 | $h[3] = "ghi" ; |
267 | untie @h ; |
a6ed719b |
268 | my $x = docat($Dfile) ; |
36477c24 |
269 | unlink $Dfile; |
6250ba0a |
270 | my $ok = ($x eq "abc def ghi ") ; |
271 | bad_one() unless $ok ; |
272 | ok(53, $ok) ; |
36477c24 |
273 | } |
274 | |
275 | { |
276 | # Check R_FIXEDLEN with user-defined bval |
277 | |
278 | my @h = () ; |
279 | my $dbh = new DB_File::RECNOINFO ; |
280 | $dbh->{flags} = R_FIXEDLEN ; |
281 | $dbh->{bval} = "-" ; |
282 | $dbh->{reclen} = 5 ; |
283 | ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; |
284 | $h[0] = "abc" ; |
285 | $h[1] = "def" ; |
286 | $h[3] = "ghi" ; |
287 | untie @h ; |
a6ed719b |
288 | my $x = docat($Dfile) ; |
36477c24 |
289 | unlink $Dfile; |
6250ba0a |
290 | my $ok = ($x eq "abc--def-------ghi--") ; |
291 | bad_one() unless $ok ; |
292 | ok(55, $ok) ; |
36477c24 |
293 | } |
294 | |
05475680 |
295 | { |
296 | # check that attempting to tie an associative array to a DB_RECNO will fail |
297 | |
298 | my $filename = "xyz" ; |
299 | my %x ; |
300 | eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; |
301 | ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; |
302 | unlink $filename ; |
303 | } |
304 | |
a6ed719b |
305 | { |
306 | # sub-class test |
307 | |
308 | package Another ; |
309 | |
310 | use strict ; |
311 | |
312 | open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; |
313 | print FILE <<'EOM' ; |
314 | |
315 | package SubDB ; |
316 | |
317 | use strict ; |
318 | use vars qw( @ISA @EXPORT) ; |
319 | |
320 | require Exporter ; |
321 | use DB_File; |
322 | @ISA=qw(DB_File); |
323 | @EXPORT = @DB_File::EXPORT ; |
324 | |
325 | sub STORE { |
326 | my $self = shift ; |
327 | my $key = shift ; |
328 | my $value = shift ; |
329 | $self->SUPER::STORE($key, $value * 2) ; |
330 | } |
331 | |
332 | sub FETCH { |
333 | my $self = shift ; |
334 | my $key = shift ; |
335 | $self->SUPER::FETCH($key) - 1 ; |
336 | } |
337 | |
338 | sub put { |
339 | my $self = shift ; |
340 | my $key = shift ; |
341 | my $value = shift ; |
342 | $self->SUPER::put($key, $value * 3) ; |
343 | } |
344 | |
345 | sub get { |
346 | my $self = shift ; |
347 | $self->SUPER::get($_[0], $_[1]) ; |
348 | $_[1] -= 2 ; |
349 | } |
350 | |
351 | sub A_new_method |
352 | { |
353 | my $self = shift ; |
354 | my $key = shift ; |
355 | my $value = $self->FETCH($key) ; |
356 | return "[[$value]]" ; |
357 | } |
358 | |
359 | 1 ; |
360 | EOM |
361 | |
362 | close FILE ; |
363 | |
045291aa |
364 | BEGIN { push @INC, '.'; } |
a6ed719b |
365 | eval 'use SubDB ; '; |
366 | main::ok(57, $@ eq "") ; |
367 | my @h ; |
368 | my $X ; |
369 | eval ' |
370 | $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); |
371 | ' ; |
372 | |
373 | main::ok(58, $@ eq "") ; |
374 | |
375 | my $ret = eval '$h[3] = 3 ; return $h[3] ' ; |
376 | main::ok(59, $@ eq "") ; |
377 | main::ok(60, $ret == 5) ; |
378 | |
379 | my $value = 0; |
380 | $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; |
381 | main::ok(61, $@ eq "") ; |
382 | main::ok(62, $ret == 10) ; |
383 | |
384 | $ret = eval ' R_NEXT eq main::R_NEXT ' ; |
385 | main::ok(63, $@ eq "" ) ; |
386 | main::ok(64, $ret == 1) ; |
387 | |
388 | $ret = eval '$X->A_new_method(1) ' ; |
389 | main::ok(65, $@ eq "") ; |
390 | main::ok(66, $ret eq "[[11]]") ; |
391 | |
fac76ed7 |
392 | undef $X; |
393 | untie(@h); |
a6ed719b |
394 | unlink "SubDB.pm", "recno.tmp" ; |
395 | |
396 | } |
397 | |
045291aa |
398 | { |
399 | |
400 | # test $# |
401 | my $self ; |
402 | unlink $Dfile; |
403 | ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; |
404 | $h[0] = "abc" ; |
405 | $h[1] = "def" ; |
406 | $h[2] = "ghi" ; |
407 | $h[3] = "jkl" ; |
408 | ok(68, $FA ? $#h == 3 : $self->length() == 4) ; |
409 | undef $self ; |
410 | untie @h ; |
411 | my $x = docat($Dfile) ; |
412 | ok(69, $x eq "abc\ndef\nghi\njkl\n") ; |
413 | |
414 | # $# sets array to same length |
415 | ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; |
416 | if ($FA) |
417 | { $#h = 3 } |
418 | else |
419 | { $self->STORESIZE(4) } |
420 | ok(71, $FA ? $#h == 3 : $self->length() == 4) ; |
421 | undef $self ; |
422 | untie @h ; |
423 | $x = docat($Dfile) ; |
424 | ok(72, $x eq "abc\ndef\nghi\njkl\n") ; |
425 | |
426 | # $# sets array to bigger |
427 | ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; |
428 | if ($FA) |
429 | { $#h = 6 } |
430 | else |
431 | { $self->STORESIZE(7) } |
432 | ok(74, $FA ? $#h == 6 : $self->length() == 7) ; |
433 | undef $self ; |
434 | untie @h ; |
435 | $x = docat($Dfile) ; |
436 | ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; |
437 | |
438 | # $# sets array smaller |
439 | ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; |
440 | if ($FA) |
441 | { $#h = 2 } |
442 | else |
443 | { $self->STORESIZE(3) } |
444 | ok(77, $FA ? $#h == 2 : $self->length() == 3) ; |
445 | undef $self ; |
446 | untie @h ; |
447 | $x = docat($Dfile) ; |
448 | ok(78, $x eq "abc\ndef\nghi\n") ; |
449 | |
450 | unlink $Dfile; |
451 | |
452 | |
453 | } |
454 | |
9fe6733a |
455 | { |
456 | # DBM Filter tests |
457 | use strict ; |
458 | my (@h, $db) ; |
459 | my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
460 | unlink $Dfile; |
461 | |
462 | sub checkOutput |
463 | { |
464 | my($fk, $sk, $fv, $sv) = @_ ; |
465 | return |
466 | $fetch_key eq $fk && $store_key eq $sk && |
467 | $fetch_value eq $fv && $store_value eq $sv && |
468 | $_ eq 'original' ; |
469 | } |
470 | |
471 | ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
472 | |
473 | $db->filter_fetch_key (sub { $fetch_key = $_ }) ; |
474 | $db->filter_store_key (sub { $store_key = $_ }) ; |
475 | $db->filter_fetch_value (sub { $fetch_value = $_}) ; |
476 | $db->filter_store_value (sub { $store_value = $_ }) ; |
477 | |
478 | $_ = "original" ; |
479 | |
480 | $h[0] = "joe" ; |
481 | # fk sk fv sv |
482 | ok(80, checkOutput( "", 0, "", "joe")) ; |
483 | |
484 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
485 | ok(81, $h[0] eq "joe"); |
486 | # fk sk fv sv |
487 | ok(82, checkOutput( "", 0, "joe", "")) ; |
488 | |
489 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
490 | ok(83, $db->FIRSTKEY() == 0) ; |
491 | # fk sk fv sv |
492 | ok(84, checkOutput( 0, "", "", "")) ; |
493 | |
494 | # replace the filters, but remember the previous set |
495 | my ($old_fk) = $db->filter_fetch_key |
496 | (sub { ++ $_ ; $fetch_key = $_ }) ; |
497 | my ($old_sk) = $db->filter_store_key |
498 | (sub { $_ *= 2 ; $store_key = $_ }) ; |
499 | my ($old_fv) = $db->filter_fetch_value |
500 | (sub { $_ = "[$_]"; $fetch_value = $_ }) ; |
501 | my ($old_sv) = $db->filter_store_value |
502 | (sub { s/o/x/g; $store_value = $_ }) ; |
503 | |
504 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
505 | $h[1] = "Joe" ; |
506 | # fk sk fv sv |
507 | ok(85, checkOutput( "", 2, "", "Jxe")) ; |
508 | |
509 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
510 | ok(86, $h[1] eq "[Jxe]"); |
511 | # fk sk fv sv |
512 | ok(87, checkOutput( "", 2, "[Jxe]", "")) ; |
513 | |
514 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
515 | ok(88, $db->FIRSTKEY() == 1) ; |
516 | # fk sk fv sv |
517 | ok(89, checkOutput( 1, "", "", "")) ; |
518 | |
519 | # put the original filters back |
520 | $db->filter_fetch_key ($old_fk); |
521 | $db->filter_store_key ($old_sk); |
522 | $db->filter_fetch_value ($old_fv); |
523 | $db->filter_store_value ($old_sv); |
524 | |
525 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
526 | $h[0] = "joe" ; |
527 | ok(90, checkOutput( "", 0, "", "joe")) ; |
528 | |
529 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
530 | ok(91, $h[0] eq "joe"); |
531 | ok(92, checkOutput( "", 0, "joe", "")) ; |
532 | |
533 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
534 | ok(93, $db->FIRSTKEY() == 0) ; |
535 | ok(94, checkOutput( 0, "", "", "")) ; |
536 | |
537 | # delete the filters |
538 | $db->filter_fetch_key (undef); |
539 | $db->filter_store_key (undef); |
540 | $db->filter_fetch_value (undef); |
541 | $db->filter_store_value (undef); |
542 | |
543 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
544 | $h[0] = "joe" ; |
545 | ok(95, checkOutput( "", "", "", "")) ; |
546 | |
547 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
548 | ok(96, $h[0] eq "joe"); |
549 | ok(97, checkOutput( "", "", "", "")) ; |
550 | |
551 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; |
552 | ok(98, $db->FIRSTKEY() == 0) ; |
553 | ok(99, checkOutput( "", "", "", "")) ; |
554 | |
555 | undef $db ; |
556 | untie @h; |
557 | unlink $Dfile; |
558 | } |
559 | |
560 | { |
561 | # DBM Filter with a closure |
562 | |
563 | use strict ; |
564 | my (@h, $db) ; |
565 | |
566 | unlink $Dfile; |
567 | ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
568 | |
569 | my %result = () ; |
570 | |
571 | sub Closure |
572 | { |
573 | my ($name) = @_ ; |
574 | my $count = 0 ; |
575 | my @kept = () ; |
576 | |
577 | return sub { ++$count ; |
578 | push @kept, $_ ; |
579 | $result{$name} = "$name - $count: [@kept]" ; |
580 | } |
581 | } |
582 | |
583 | $db->filter_store_key(Closure("store key")) ; |
584 | $db->filter_store_value(Closure("store value")) ; |
585 | $db->filter_fetch_key(Closure("fetch key")) ; |
586 | $db->filter_fetch_value(Closure("fetch value")) ; |
587 | |
588 | $_ = "original" ; |
589 | |
590 | $h[0] = "joe" ; |
591 | ok(101, $result{"store key"} eq "store key - 1: [0]"); |
592 | ok(102, $result{"store value"} eq "store value - 1: [joe]"); |
593 | ok(103, ! defined $result{"fetch key"} ); |
594 | ok(104, ! defined $result{"fetch value"} ); |
595 | ok(105, $_ eq "original") ; |
596 | |
597 | ok(106, $db->FIRSTKEY() == 0 ) ; |
598 | ok(107, $result{"store key"} eq "store key - 1: [0]"); |
599 | ok(108, $result{"store value"} eq "store value - 1: [joe]"); |
600 | ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); |
601 | ok(110, ! defined $result{"fetch value"} ); |
602 | ok(111, $_ eq "original") ; |
603 | |
604 | $h[7] = "john" ; |
605 | ok(112, $result{"store key"} eq "store key - 2: [0 7]"); |
606 | ok(113, $result{"store value"} eq "store value - 2: [joe john]"); |
607 | ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); |
608 | ok(115, ! defined $result{"fetch value"} ); |
609 | ok(116, $_ eq "original") ; |
610 | |
611 | ok(117, $h[0] eq "joe"); |
612 | ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); |
613 | ok(119, $result{"store value"} eq "store value - 2: [joe john]"); |
614 | ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); |
615 | ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); |
616 | ok(122, $_ eq "original") ; |
617 | |
618 | undef $db ; |
619 | untie @h; |
620 | unlink $Dfile; |
621 | } |
622 | |
623 | { |
624 | # DBM Filter recursion detection |
625 | use strict ; |
626 | my (@h, $db) ; |
627 | unlink $Dfile; |
628 | |
629 | ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); |
630 | |
631 | $db->filter_store_key (sub { $_ = $h[0] }) ; |
632 | |
633 | eval '$h[1] = 1234' ; |
634 | ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); |
635 | |
636 | undef $db ; |
637 | untie @h; |
638 | unlink $Dfile; |
639 | } |
640 | |
a0d0e21e |
641 | exit ; |