Commit | Line | Data |
---|---|---|
f6b705ef | 1 | #!./perl -w |
a0d0e21e LW |
2 | |
3 | BEGIN { | |
93430cb4 | 4 | unshift @INC, '../lib' if -d '../lib' ; |
a0d0e21e LW |
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 LW |
8 | exit 0; |
9 | } | |
10 | } | |
11 | ||
12 | use DB_File; | |
13 | use Fcntl; | |
55d68b4a | 14 | use strict ; |
045291aa PM |
15 | use vars qw($dbh $Dfile $bad_ones $FA) ; |
16 | ||
17 | # full tied array support started in Perl 5.004_57 | |
a9fd575d PM |
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 PM |
37 | |
38 | return $result ; | |
39 | } | |
40 | ||
2c2d71f5 JH |
41 | { |
42 | package Redirect ; | |
43 | use Symbol ; | |
44 | ||
45 | sub new | |
46 | { | |
47 | my $class = shift ; | |
48 | my $filename = shift ; | |
49 | my $fh = gensym ; | |
50 | open ($fh, ">$filename") || die "Cannot open $filename: $!" ; | |
51 | my $real_stdout = select($fh) ; | |
52 | return bless [$fh, $real_stdout ] ; | |
53 | ||
54 | } | |
55 | sub DESTROY | |
56 | { | |
57 | my $self = shift ; | |
58 | close $self->[0] ; | |
59 | select($self->[1]) ; | |
60 | } | |
61 | } | |
62 | ||
63 | sub docat | |
64 | { | |
65 | my $file = shift; | |
66 | local $/ = undef; | |
67 | open(CAT,$file) || die "Cannot open $file:$!"; | |
68 | my $result = <CAT>; | |
69 | close(CAT); | |
70 | return $result; | |
71 | } | |
72 | ||
73 | sub docat_del | |
74 | { | |
75 | my $file = shift; | |
76 | local $/ = undef; | |
77 | open(CAT,$file) || die "Cannot open $file: $!"; | |
78 | my $result = <CAT>; | |
79 | close(CAT); | |
80 | unlink $file ; | |
81 | return $result; | |
82 | } | |
83 | ||
6250ba0a PM |
84 | sub bad_one |
85 | { | |
25268f15 CS |
86 | print STDERR <<EOM unless $bad_ones++ ; |
87 | # | |
20896112 PM |
88 | # Some older versions of Berkeley DB version 1 will fail tests 51, |
89 | # 53 and 55. | |
6250ba0a PM |
90 | # |
91 | # You can safely ignore the errors if you're never going to use the | |
92 | # broken functionality (recno databases with a modified bval). | |
93 | # Otherwise you'll have to upgrade your DB library. | |
94 | # | |
20896112 PM |
95 | # If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the |
96 | # last versions that were released. Berkeley DB version 2 is continually | |
97 | # being updated -- Check out http://www.sleepycat.com/ for more details. | |
6250ba0a PM |
98 | # |
99 | EOM | |
55d68b4a | 100 | } |
101 | ||
2c2d71f5 | 102 | print "1..126\n"; |
55d68b4a | 103 | |
104 | my $Dfile = "recno.tmp"; | |
105 | unlink $Dfile ; | |
a0d0e21e LW |
106 | |
107 | umask(0); | |
108 | ||
109 | # Check the interface to RECNOINFO | |
110 | ||
55d68b4a | 111 | my $dbh = new DB_File::RECNOINFO ; |
3fe9a6f1 | 112 | ok(1, ! defined $dbh->{bval}) ; |
113 | ok(2, ! defined $dbh->{cachesize}) ; | |
114 | ok(3, ! defined $dbh->{psize}) ; | |
115 | ok(4, ! defined $dbh->{flags}) ; | |
116 | ok(5, ! defined $dbh->{lorder}) ; | |
117 | ok(6, ! defined $dbh->{reclen}) ; | |
118 | ok(7, ! defined $dbh->{bfname}) ; | |
a0d0e21e LW |
119 | |
120 | $dbh->{bval} = 3000 ; | |
f6b705ef | 121 | ok(8, $dbh->{bval} == 3000 ); |
a0d0e21e LW |
122 | |
123 | $dbh->{cachesize} = 9000 ; | |
f6b705ef | 124 | ok(9, $dbh->{cachesize} == 9000 ); |
a0d0e21e LW |
125 | |
126 | $dbh->{psize} = 400 ; | |
f6b705ef | 127 | ok(10, $dbh->{psize} == 400 ); |
a0d0e21e LW |
128 | |
129 | $dbh->{flags} = 65 ; | |
f6b705ef | 130 | ok(11, $dbh->{flags} == 65 ); |
a0d0e21e LW |
131 | |
132 | $dbh->{lorder} = 123 ; | |
f6b705ef | 133 | ok(12, $dbh->{lorder} == 123 ); |
a0d0e21e LW |
134 | |
135 | $dbh->{reclen} = 1234 ; | |
f6b705ef | 136 | ok(13, $dbh->{reclen} == 1234 ); |
a0d0e21e LW |
137 | |
138 | $dbh->{bfname} = 1234 ; | |
f6b705ef | 139 | ok(14, $dbh->{bfname} == 1234 ); |
a0d0e21e LW |
140 | |
141 | ||
142 | # Check that an invalid entry is caught both for store & fetch | |
143 | eval '$dbh->{fred} = 1234' ; | |
f6b705ef | 144 | ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ); |
55d68b4a | 145 | eval 'my $q = $dbh->{fred}' ; |
f6b705ef | 146 | ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ); |
a0d0e21e LW |
147 | |
148 | # Now check the interface to RECNOINFO | |
149 | ||
55d68b4a | 150 | my $X ; |
151 | my @h ; | |
152 | ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; | |
a0d0e21e | 153 | |
a9fd575d PM |
154 | ok(18, ((stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640) |
155 | || $^O eq 'MSWin32' || $^O eq 'amigaos') ; | |
a0d0e21e | 156 | |
55d68b4a | 157 | #my $l = @h ; |
158 | my $l = $X->length ; | |
045291aa | 159 | ok(19, ($FA ? @h == 0 : !$l) ); |
a0d0e21e | 160 | |
55d68b4a | 161 | my @data = qw( a b c d ever f g h i j k longername m n o p) ; |
a0d0e21e LW |
162 | |
163 | $h[0] = shift @data ; | |
f6b705ef | 164 | ok(20, $h[0] eq 'a' ); |
a0d0e21e | 165 | |
55d68b4a | 166 | my $ i; |
a0d0e21e LW |
167 | foreach (@data) |
168 | { $h[++$i] = $_ } | |
169 | ||
170 | unshift (@data, 'a') ; | |
171 | ||
f6b705ef | 172 | ok(21, defined $h[1] ); |
173 | ok(22, ! defined $h[16] ); | |
045291aa | 174 | ok(23, $FA ? @h == @data : $X->length == @data ); |
a0d0e21e LW |
175 | |
176 | ||
177 | # Overwrite an entry & check fetch it | |
178 | $h[3] = 'replaced' ; | |
179 | $data[3] = 'replaced' ; | |
f6b705ef | 180 | ok(24, $h[3] eq 'replaced' ); |
a0d0e21e LW |
181 | |
182 | #PUSH | |
55d68b4a | 183 | my @push_data = qw(added to the end) ; |
045291aa | 184 | ($FA ? push(@h, @push_data) : $X->push(@push_data)) ; |
a0d0e21e | 185 | push (@data, @push_data) ; |
f6b705ef | 186 | ok(25, $h[++$i] eq 'added' ); |
187 | ok(26, $h[++$i] eq 'to' ); | |
188 | ok(27, $h[++$i] eq 'the' ); | |
189 | ok(28, $h[++$i] eq 'end' ); | |
a0d0e21e LW |
190 | |
191 | # POP | |
f6b705ef | 192 | my $popped = pop (@data) ; |
045291aa | 193 | my $value = ($FA ? pop @h : $X->pop) ; |
f6b705ef | 194 | ok(29, $value eq $popped) ; |
a0d0e21e LW |
195 | |
196 | # SHIFT | |
045291aa | 197 | $value = ($FA ? shift @h : $X->shift) ; |
f6b705ef | 198 | my $shifted = shift @data ; |
199 | ok(30, $value eq $shifted ); | |
a0d0e21e LW |
200 | |
201 | # UNSHIFT | |
202 | ||
203 | # empty list | |
045291aa PM |
204 | ($FA ? unshift @h : $X->unshift) ; |
205 | ok(31, ($FA ? @h == @data : $X->length == @data )); | |
a0d0e21e | 206 | |
55d68b4a | 207 | my @new_data = qw(add this to the start of the array) ; |
045291aa | 208 | $FA ? unshift (@h, @new_data) : $X->unshift (@new_data) ; |
a0d0e21e | 209 | unshift (@data, @new_data) ; |
045291aa | 210 | ok(32, $FA ? @h == @data : $X->length == @data ); |
f6b705ef | 211 | ok(33, $h[0] eq "add") ; |
212 | ok(34, $h[1] eq "this") ; | |
213 | ok(35, $h[2] eq "to") ; | |
214 | ok(36, $h[3] eq "the") ; | |
215 | ok(37, $h[4] eq "start") ; | |
216 | ok(38, $h[5] eq "of") ; | |
217 | ok(39, $h[6] eq "the") ; | |
218 | ok(40, $h[7] eq "array") ; | |
219 | ok(41, $h[8] eq $data[8]) ; | |
a0d0e21e LW |
220 | |
221 | # SPLICE | |
222 | ||
223 | # Now both arrays should be identical | |
224 | ||
55d68b4a | 225 | my $ok = 1 ; |
226 | my $j = 0 ; | |
a0d0e21e LW |
227 | foreach (@data) |
228 | { | |
229 | $ok = 0, last if $_ ne $h[$j ++] ; | |
230 | } | |
f6b705ef | 231 | ok(42, $ok ); |
a0d0e21e | 232 | |
55d68b4a | 233 | # Neagtive subscripts |
234 | ||
235 | # get the last element of the array | |
f6b705ef | 236 | ok(43, $h[-1] eq $data[-1] ); |
045291aa | 237 | ok(44, $h[-1] eq $h[ ($FA ? @h : $X->length) -1] ); |
55d68b4a | 238 | |
239 | # get the first element using a negative subscript | |
045291aa | 240 | eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ; |
f6b705ef | 241 | ok(45, $@ eq "" ); |
242 | ok(46, $h[0] eq "abcd" ); | |
55d68b4a | 243 | |
244 | # now try to read before the start of the array | |
045291aa | 245 | eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ; |
f6b705ef | 246 | ok(47, $@ =~ '^Modification of non-creatable array value attempted' ); |
55d68b4a | 247 | |
a0d0e21e LW |
248 | # IMPORTANT - $X must be undefined before the untie otherwise the |
249 | # underlying DB close routine will not get called. | |
250 | undef $X ; | |
251 | untie(@h); | |
252 | ||
253 | unlink $Dfile; | |
254 | ||
a6ed719b | 255 | |
36477c24 | 256 | { |
257 | # Check bval defaults to \n | |
258 | ||
259 | my @h = () ; | |
260 | my $dbh = new DB_File::RECNOINFO ; | |
261 | ok(48, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; | |
262 | $h[0] = "abc" ; | |
263 | $h[1] = "def" ; | |
264 | $h[3] = "ghi" ; | |
265 | untie @h ; | |
a6ed719b | 266 | my $x = docat($Dfile) ; |
36477c24 | 267 | unlink $Dfile; |
6250ba0a | 268 | ok(49, $x eq "abc\ndef\n\nghi\n") ; |
36477c24 | 269 | } |
270 | ||
271 | { | |
272 | # Change bval | |
273 | ||
274 | my @h = () ; | |
275 | my $dbh = new DB_File::RECNOINFO ; | |
276 | $dbh->{bval} = "-" ; | |
277 | ok(50, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; | |
278 | $h[0] = "abc" ; | |
279 | $h[1] = "def" ; | |
280 | $h[3] = "ghi" ; | |
281 | untie @h ; | |
a6ed719b | 282 | my $x = docat($Dfile) ; |
36477c24 | 283 | unlink $Dfile; |
6250ba0a PM |
284 | my $ok = ($x eq "abc-def--ghi-") ; |
285 | bad_one() unless $ok ; | |
286 | ok(51, $ok) ; | |
36477c24 | 287 | } |
288 | ||
289 | { | |
290 | # Check R_FIXEDLEN with default bval (space) | |
291 | ||
292 | my @h = () ; | |
293 | my $dbh = new DB_File::RECNOINFO ; | |
294 | $dbh->{flags} = R_FIXEDLEN ; | |
295 | $dbh->{reclen} = 5 ; | |
296 | ok(52, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; | |
297 | $h[0] = "abc" ; | |
298 | $h[1] = "def" ; | |
299 | $h[3] = "ghi" ; | |
300 | untie @h ; | |
a6ed719b | 301 | my $x = docat($Dfile) ; |
36477c24 | 302 | unlink $Dfile; |
6250ba0a PM |
303 | my $ok = ($x eq "abc def ghi ") ; |
304 | bad_one() unless $ok ; | |
305 | ok(53, $ok) ; | |
36477c24 | 306 | } |
307 | ||
308 | { | |
309 | # Check R_FIXEDLEN with user-defined bval | |
310 | ||
311 | my @h = () ; | |
312 | my $dbh = new DB_File::RECNOINFO ; | |
313 | $dbh->{flags} = R_FIXEDLEN ; | |
314 | $dbh->{bval} = "-" ; | |
315 | $dbh->{reclen} = 5 ; | |
316 | ok(54, tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $dbh ) ; | |
317 | $h[0] = "abc" ; | |
318 | $h[1] = "def" ; | |
319 | $h[3] = "ghi" ; | |
320 | untie @h ; | |
a6ed719b | 321 | my $x = docat($Dfile) ; |
36477c24 | 322 | unlink $Dfile; |
6250ba0a PM |
323 | my $ok = ($x eq "abc--def-------ghi--") ; |
324 | bad_one() unless $ok ; | |
325 | ok(55, $ok) ; | |
36477c24 | 326 | } |
327 | ||
05475680 PM |
328 | { |
329 | # check that attempting to tie an associative array to a DB_RECNO will fail | |
330 | ||
331 | my $filename = "xyz" ; | |
332 | my %x ; | |
333 | eval { tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO ; } ; | |
334 | ok(56, $@ =~ /^DB_File can only tie an array to a DB_RECNO database/) ; | |
335 | unlink $filename ; | |
336 | } | |
337 | ||
a6ed719b PM |
338 | { |
339 | # sub-class test | |
340 | ||
341 | package Another ; | |
342 | ||
343 | use strict ; | |
344 | ||
345 | open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ; | |
346 | print FILE <<'EOM' ; | |
347 | ||
348 | package SubDB ; | |
349 | ||
350 | use strict ; | |
351 | use vars qw( @ISA @EXPORT) ; | |
352 | ||
353 | require Exporter ; | |
354 | use DB_File; | |
355 | @ISA=qw(DB_File); | |
356 | @EXPORT = @DB_File::EXPORT ; | |
357 | ||
358 | sub STORE { | |
359 | my $self = shift ; | |
360 | my $key = shift ; | |
361 | my $value = shift ; | |
362 | $self->SUPER::STORE($key, $value * 2) ; | |
363 | } | |
364 | ||
365 | sub FETCH { | |
366 | my $self = shift ; | |
367 | my $key = shift ; | |
368 | $self->SUPER::FETCH($key) - 1 ; | |
369 | } | |
370 | ||
371 | sub put { | |
372 | my $self = shift ; | |
373 | my $key = shift ; | |
374 | my $value = shift ; | |
375 | $self->SUPER::put($key, $value * 3) ; | |
376 | } | |
377 | ||
378 | sub get { | |
379 | my $self = shift ; | |
380 | $self->SUPER::get($_[0], $_[1]) ; | |
381 | $_[1] -= 2 ; | |
382 | } | |
383 | ||
384 | sub A_new_method | |
385 | { | |
386 | my $self = shift ; | |
387 | my $key = shift ; | |
388 | my $value = $self->FETCH($key) ; | |
389 | return "[[$value]]" ; | |
390 | } | |
391 | ||
392 | 1 ; | |
393 | EOM | |
394 | ||
395 | close FILE ; | |
396 | ||
045291aa | 397 | BEGIN { push @INC, '.'; } |
a6ed719b PM |
398 | eval 'use SubDB ; '; |
399 | main::ok(57, $@ eq "") ; | |
400 | my @h ; | |
401 | my $X ; | |
402 | eval ' | |
403 | $X = tie(@h, "SubDB","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO ); | |
404 | ' ; | |
405 | ||
406 | main::ok(58, $@ eq "") ; | |
407 | ||
408 | my $ret = eval '$h[3] = 3 ; return $h[3] ' ; | |
409 | main::ok(59, $@ eq "") ; | |
410 | main::ok(60, $ret == 5) ; | |
411 | ||
412 | my $value = 0; | |
413 | $ret = eval '$X->put(1, 4) ; $X->get(1, $value) ; return $value' ; | |
414 | main::ok(61, $@ eq "") ; | |
415 | main::ok(62, $ret == 10) ; | |
416 | ||
417 | $ret = eval ' R_NEXT eq main::R_NEXT ' ; | |
418 | main::ok(63, $@ eq "" ) ; | |
419 | main::ok(64, $ret == 1) ; | |
420 | ||
421 | $ret = eval '$X->A_new_method(1) ' ; | |
422 | main::ok(65, $@ eq "") ; | |
423 | main::ok(66, $ret eq "[[11]]") ; | |
424 | ||
fac76ed7 MB |
425 | undef $X; |
426 | untie(@h); | |
a6ed719b PM |
427 | unlink "SubDB.pm", "recno.tmp" ; |
428 | ||
429 | } | |
430 | ||
045291aa PM |
431 | { |
432 | ||
433 | # test $# | |
434 | my $self ; | |
435 | unlink $Dfile; | |
436 | ok(67, $self = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ; | |
437 | $h[0] = "abc" ; | |
438 | $h[1] = "def" ; | |
439 | $h[2] = "ghi" ; | |
440 | $h[3] = "jkl" ; | |
441 | ok(68, $FA ? $#h == 3 : $self->length() == 4) ; | |
442 | undef $self ; | |
443 | untie @h ; | |
444 | my $x = docat($Dfile) ; | |
445 | ok(69, $x eq "abc\ndef\nghi\njkl\n") ; | |
446 | ||
447 | # $# sets array to same length | |
448 | ok(70, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; | |
449 | if ($FA) | |
450 | { $#h = 3 } | |
451 | else | |
452 | { $self->STORESIZE(4) } | |
453 | ok(71, $FA ? $#h == 3 : $self->length() == 4) ; | |
454 | undef $self ; | |
455 | untie @h ; | |
456 | $x = docat($Dfile) ; | |
457 | ok(72, $x eq "abc\ndef\nghi\njkl\n") ; | |
458 | ||
459 | # $# sets array to bigger | |
460 | ok(73, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; | |
461 | if ($FA) | |
462 | { $#h = 6 } | |
463 | else | |
464 | { $self->STORESIZE(7) } | |
465 | ok(74, $FA ? $#h == 6 : $self->length() == 7) ; | |
466 | undef $self ; | |
467 | untie @h ; | |
468 | $x = docat($Dfile) ; | |
469 | ok(75, $x eq "abc\ndef\nghi\njkl\n\n\n\n") ; | |
470 | ||
471 | # $# sets array smaller | |
472 | ok(76, $self = tie @h, 'DB_File', $Dfile, O_RDWR, 0640, $DB_RECNO ) ; | |
473 | if ($FA) | |
474 | { $#h = 2 } | |
475 | else | |
476 | { $self->STORESIZE(3) } | |
477 | ok(77, $FA ? $#h == 2 : $self->length() == 3) ; | |
478 | undef $self ; | |
479 | untie @h ; | |
480 | $x = docat($Dfile) ; | |
481 | ok(78, $x eq "abc\ndef\nghi\n") ; | |
482 | ||
483 | unlink $Dfile; | |
484 | ||
485 | ||
486 | } | |
487 | ||
9fe6733a PM |
488 | { |
489 | # DBM Filter tests | |
490 | use strict ; | |
491 | my (@h, $db) ; | |
492 | my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
493 | unlink $Dfile; | |
494 | ||
495 | sub checkOutput | |
496 | { | |
497 | my($fk, $sk, $fv, $sv) = @_ ; | |
498 | return | |
499 | $fetch_key eq $fk && $store_key eq $sk && | |
500 | $fetch_value eq $fv && $store_value eq $sv && | |
501 | $_ eq 'original' ; | |
502 | } | |
503 | ||
504 | ok(79, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); | |
505 | ||
506 | $db->filter_fetch_key (sub { $fetch_key = $_ }) ; | |
507 | $db->filter_store_key (sub { $store_key = $_ }) ; | |
508 | $db->filter_fetch_value (sub { $fetch_value = $_}) ; | |
509 | $db->filter_store_value (sub { $store_value = $_ }) ; | |
510 | ||
511 | $_ = "original" ; | |
512 | ||
513 | $h[0] = "joe" ; | |
514 | # fk sk fv sv | |
515 | ok(80, checkOutput( "", 0, "", "joe")) ; | |
516 | ||
517 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
518 | ok(81, $h[0] eq "joe"); | |
519 | # fk sk fv sv | |
520 | ok(82, checkOutput( "", 0, "joe", "")) ; | |
521 | ||
522 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
523 | ok(83, $db->FIRSTKEY() == 0) ; | |
524 | # fk sk fv sv | |
525 | ok(84, checkOutput( 0, "", "", "")) ; | |
526 | ||
527 | # replace the filters, but remember the previous set | |
528 | my ($old_fk) = $db->filter_fetch_key | |
529 | (sub { ++ $_ ; $fetch_key = $_ }) ; | |
530 | my ($old_sk) = $db->filter_store_key | |
531 | (sub { $_ *= 2 ; $store_key = $_ }) ; | |
532 | my ($old_fv) = $db->filter_fetch_value | |
533 | (sub { $_ = "[$_]"; $fetch_value = $_ }) ; | |
534 | my ($old_sv) = $db->filter_store_value | |
535 | (sub { s/o/x/g; $store_value = $_ }) ; | |
536 | ||
537 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
538 | $h[1] = "Joe" ; | |
539 | # fk sk fv sv | |
540 | ok(85, checkOutput( "", 2, "", "Jxe")) ; | |
541 | ||
542 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
543 | ok(86, $h[1] eq "[Jxe]"); | |
544 | # fk sk fv sv | |
545 | ok(87, checkOutput( "", 2, "[Jxe]", "")) ; | |
546 | ||
547 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
548 | ok(88, $db->FIRSTKEY() == 1) ; | |
549 | # fk sk fv sv | |
550 | ok(89, checkOutput( 1, "", "", "")) ; | |
551 | ||
552 | # put the original filters back | |
553 | $db->filter_fetch_key ($old_fk); | |
554 | $db->filter_store_key ($old_sk); | |
555 | $db->filter_fetch_value ($old_fv); | |
556 | $db->filter_store_value ($old_sv); | |
557 | ||
558 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
559 | $h[0] = "joe" ; | |
560 | ok(90, checkOutput( "", 0, "", "joe")) ; | |
561 | ||
562 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
563 | ok(91, $h[0] eq "joe"); | |
564 | ok(92, checkOutput( "", 0, "joe", "")) ; | |
565 | ||
566 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
567 | ok(93, $db->FIRSTKEY() == 0) ; | |
568 | ok(94, checkOutput( 0, "", "", "")) ; | |
569 | ||
570 | # delete the filters | |
571 | $db->filter_fetch_key (undef); | |
572 | $db->filter_store_key (undef); | |
573 | $db->filter_fetch_value (undef); | |
574 | $db->filter_store_value (undef); | |
575 | ||
576 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
577 | $h[0] = "joe" ; | |
578 | ok(95, checkOutput( "", "", "", "")) ; | |
579 | ||
580 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
581 | ok(96, $h[0] eq "joe"); | |
582 | ok(97, checkOutput( "", "", "", "")) ; | |
583 | ||
584 | ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ; | |
585 | ok(98, $db->FIRSTKEY() == 0) ; | |
586 | ok(99, checkOutput( "", "", "", "")) ; | |
587 | ||
588 | undef $db ; | |
589 | untie @h; | |
590 | unlink $Dfile; | |
591 | } | |
592 | ||
593 | { | |
594 | # DBM Filter with a closure | |
595 | ||
596 | use strict ; | |
597 | my (@h, $db) ; | |
598 | ||
599 | unlink $Dfile; | |
600 | ok(100, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); | |
601 | ||
602 | my %result = () ; | |
603 | ||
604 | sub Closure | |
605 | { | |
606 | my ($name) = @_ ; | |
607 | my $count = 0 ; | |
608 | my @kept = () ; | |
609 | ||
610 | return sub { ++$count ; | |
611 | push @kept, $_ ; | |
612 | $result{$name} = "$name - $count: [@kept]" ; | |
613 | } | |
614 | } | |
615 | ||
616 | $db->filter_store_key(Closure("store key")) ; | |
617 | $db->filter_store_value(Closure("store value")) ; | |
618 | $db->filter_fetch_key(Closure("fetch key")) ; | |
619 | $db->filter_fetch_value(Closure("fetch value")) ; | |
620 | ||
621 | $_ = "original" ; | |
622 | ||
623 | $h[0] = "joe" ; | |
624 | ok(101, $result{"store key"} eq "store key - 1: [0]"); | |
625 | ok(102, $result{"store value"} eq "store value - 1: [joe]"); | |
626 | ok(103, ! defined $result{"fetch key"} ); | |
627 | ok(104, ! defined $result{"fetch value"} ); | |
628 | ok(105, $_ eq "original") ; | |
629 | ||
630 | ok(106, $db->FIRSTKEY() == 0 ) ; | |
631 | ok(107, $result{"store key"} eq "store key - 1: [0]"); | |
632 | ok(108, $result{"store value"} eq "store value - 1: [joe]"); | |
633 | ok(109, $result{"fetch key"} eq "fetch key - 1: [0]"); | |
634 | ok(110, ! defined $result{"fetch value"} ); | |
635 | ok(111, $_ eq "original") ; | |
636 | ||
637 | $h[7] = "john" ; | |
638 | ok(112, $result{"store key"} eq "store key - 2: [0 7]"); | |
639 | ok(113, $result{"store value"} eq "store value - 2: [joe john]"); | |
640 | ok(114, $result{"fetch key"} eq "fetch key - 1: [0]"); | |
641 | ok(115, ! defined $result{"fetch value"} ); | |
642 | ok(116, $_ eq "original") ; | |
643 | ||
644 | ok(117, $h[0] eq "joe"); | |
645 | ok(118, $result{"store key"} eq "store key - 3: [0 7 0]"); | |
646 | ok(119, $result{"store value"} eq "store value - 2: [joe john]"); | |
647 | ok(120, $result{"fetch key"} eq "fetch key - 1: [0]"); | |
648 | ok(121, $result{"fetch value"} eq "fetch value - 1: [joe]"); | |
649 | ok(122, $_ eq "original") ; | |
650 | ||
651 | undef $db ; | |
652 | untie @h; | |
653 | unlink $Dfile; | |
654 | } | |
655 | ||
656 | { | |
657 | # DBM Filter recursion detection | |
658 | use strict ; | |
659 | my (@h, $db) ; | |
660 | unlink $Dfile; | |
661 | ||
662 | ok(123, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ); | |
663 | ||
664 | $db->filter_store_key (sub { $_ = $h[0] }) ; | |
665 | ||
666 | eval '$h[1] = 1234' ; | |
667 | ok(124, $@ =~ /^recursion detected in filter_store_key at/ ); | |
668 | ||
669 | undef $db ; | |
670 | untie @h; | |
671 | unlink $Dfile; | |
672 | } | |
673 | ||
2c2d71f5 JH |
674 | |
675 | { | |
676 | # Examples from the POD | |
677 | ||
678 | my $file = "xyzt" ; | |
679 | { | |
680 | my $redirect = new Redirect $file ; | |
681 | ||
682 | use strict ; | |
683 | use DB_File ; | |
684 | ||
685 | my $filename = "text" ; | |
686 | unlink $filename ; | |
687 | ||
688 | my @h ; | |
689 | my $x = tie @h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_RECNO | |
690 | or die "Cannot open file 'text': $!\n" ; | |
691 | ||
692 | # Add a few key/value pairs to the file | |
693 | $h[0] = "orange" ; | |
694 | $h[1] = "blue" ; | |
695 | $h[2] = "yellow" ; | |
696 | ||
697 | $FA ? push @h, "green", "black" | |
698 | : $x->push("green", "black") ; | |
699 | ||
700 | my $elements = $FA ? scalar @h : $x->length ; | |
701 | print "The array contains $elements entries\n" ; | |
702 | ||
703 | my $last = $FA ? pop @h : $x->pop ; | |
704 | print "popped $last\n" ; | |
705 | ||
706 | $FA ? unshift @h, "white" | |
707 | : $x->unshift("white") ; | |
708 | my $first = $FA ? shift @h : $x->shift ; | |
709 | print "shifted $first\n" ; | |
710 | ||
711 | # Check for existence of a key | |
712 | print "Element 1 Exists with value $h[1]\n" if $h[1] ; | |
713 | ||
714 | # use a negative index | |
715 | print "The last element is $h[-1]\n" ; | |
716 | print "The 2nd last element is $h[-2]\n" ; | |
717 | ||
718 | undef $x ; | |
719 | untie @h ; | |
720 | ||
721 | unlink $filename ; | |
722 | } | |
723 | ||
724 | ok(125, docat_del($file) eq <<'EOM') ; | |
725 | The array contains 5 entries | |
726 | popped black | |
727 | shifted white | |
728 | Element 1 Exists with value blue | |
729 | The last element is green | |
730 | The 2nd last element is yellow | |
731 | EOM | |
732 | ||
733 | my $save_output = "xyzt" ; | |
734 | { | |
735 | my $redirect = new Redirect $save_output ; | |
736 | ||
737 | use strict ; | |
738 | use vars qw(@h $H $file $i) ; | |
739 | use DB_File ; | |
740 | use Fcntl ; | |
741 | ||
742 | $file = "text" ; | |
743 | ||
744 | unlink $file ; | |
745 | ||
746 | $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO | |
747 | or die "Cannot open file $file: $!\n" ; | |
748 | ||
749 | # first create a text file to play with | |
750 | $h[0] = "zero" ; | |
751 | $h[1] = "one" ; | |
752 | $h[2] = "two" ; | |
753 | $h[3] = "three" ; | |
754 | $h[4] = "four" ; | |
755 | ||
756 | ||
757 | # Print the records in order. | |
758 | # | |
759 | # The length method is needed here because evaluating a tied | |
760 | # array in a scalar context does not return the number of | |
761 | # elements in the array. | |
762 | ||
763 | print "\nORIGINAL\n" ; | |
764 | foreach $i (0 .. $H->length - 1) { | |
765 | print "$i: $h[$i]\n" ; | |
766 | } | |
767 | ||
768 | # use the push & pop methods | |
769 | $a = $H->pop ; | |
770 | $H->push("last") ; | |
771 | print "\nThe last record was [$a]\n" ; | |
772 | ||
773 | # and the shift & unshift methods | |
774 | $a = $H->shift ; | |
775 | $H->unshift("first") ; | |
776 | print "The first record was [$a]\n" ; | |
777 | ||
778 | # Use the API to add a new record after record 2. | |
779 | $i = 2 ; | |
780 | $H->put($i, "Newbie", R_IAFTER) ; | |
781 | ||
782 | # and a new record before record 1. | |
783 | $i = 1 ; | |
784 | $H->put($i, "New One", R_IBEFORE) ; | |
785 | ||
786 | # delete record 3 | |
787 | $H->del(3) ; | |
788 | ||
789 | # now print the records in reverse order | |
790 | print "\nREVERSE\n" ; | |
791 | for ($i = $H->length - 1 ; $i >= 0 ; -- $i) | |
792 | { print "$i: $h[$i]\n" } | |
793 | ||
794 | # same again, but use the API functions instead | |
795 | print "\nREVERSE again\n" ; | |
796 | my ($s, $k, $v) = (0, 0, 0) ; | |
797 | for ($s = $H->seq($k, $v, R_LAST) ; | |
798 | $s == 0 ; | |
799 | $s = $H->seq($k, $v, R_PREV)) | |
800 | { print "$k: $v\n" } | |
801 | ||
802 | undef $H ; | |
803 | untie @h ; | |
804 | ||
805 | unlink $file ; | |
806 | } | |
807 | ||
808 | ok(126, docat_del($save_output) eq <<'EOM') ; | |
809 | ||
810 | ORIGINAL | |
811 | 0: zero | |
812 | 1: one | |
813 | 2: two | |
814 | 3: three | |
815 | 4: four | |
816 | ||
817 | The last record was [four] | |
818 | The first record was [zero] | |
819 | ||
820 | REVERSE | |
821 | 5: last | |
822 | 4: three | |
823 | 3: Newbie | |
824 | 2: one | |
825 | 1: New One | |
826 | 0: first | |
827 | ||
828 | REVERSE again | |
829 | 5: last | |
830 | 4: three | |
831 | 3: Newbie | |
832 | 2: one | |
833 | 1: New One | |
834 | 0: first | |
835 | EOM | |
836 | ||
837 | } | |
838 | ||
a0d0e21e | 839 | exit ; |