4 unshift @INC, '../lib' if -d '../lib' ;
5 require Config; import Config;
6 if ($Config{'extensions'} !~ /\bDB_File\b/) {
22 print "not " unless $result ;
26 my $Dfile = "dbhash.tmp";
31 # Check the interface to HASHINFO
33 my $dbh = new DB_File::HASHINFO ;
35 ok(1, ! defined $dbh->{bsize}) ;
36 ok(2, ! defined $dbh->{ffactor}) ;
37 ok(3, ! defined $dbh->{nelem}) ;
38 ok(4, ! defined $dbh->{cachesize}) ;
39 ok(5, ! defined $dbh->{hash}) ;
40 ok(6, ! defined $dbh->{lorder}) ;
42 $dbh->{bsize} = 3000 ;
43 ok(7, $dbh->{bsize} == 3000 );
45 $dbh->{ffactor} = 9000 ;
46 ok(8, $dbh->{ffactor} == 9000 );
49 ok(9, $dbh->{nelem} == 400 );
51 $dbh->{cachesize} = 65 ;
52 ok(10, $dbh->{cachesize} == 65 );
54 $dbh->{hash} = "abc" ;
55 ok(11, $dbh->{hash} eq "abc" );
57 $dbh->{lorder} = 1234 ;
58 ok(12, $dbh->{lorder} == 1234 );
60 # Check that an invalid entry is caught both for store & fetch
61 eval '$dbh->{fred} = 1234' ;
62 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
63 eval 'my $q = $dbh->{fred}' ;
64 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
67 # Now check the interface to HASH
69 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
71 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
72 $blksize,$blocks) = stat($Dfile);
73 ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
75 while (($key,$value) = each(%h)) {
80 $h{'goner1'} = 'snork';
83 ok(18, $h{'abc'} eq 'ABC' );
84 ok(19, !defined $h{'jimmy'} );
85 ok(20, !exists $h{'jimmy'} );
86 ok(21, exists $h{'abc'} );
89 $h{'jkl','mno'} = "JKL\034MNO";
90 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
107 $h{'goner2'} = 'snork';
111 # IMPORTANT - $X must be undefined before the untie otherwise the
112 # underlying DB close routine will not get called.
117 # tie to the same file again, do not supply a type - should default to HASH
118 ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
120 # Modify an entry from the previous tie
141 $h{'goner3'} = 'snork';
144 $X->DELETE('goner3');
147 @values = values(%h);
149 ok(23, $#keys == 29 && $#values == 29) ;
152 while (($key,$value) = each(%h)) {
153 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
155 $i++ if $key eq $value;
161 @keys = ('blurfl', keys(%h), 'dyick');
162 ok(25, $#keys == 31) ;
165 ok(26, $h{'foo'} eq '' );
168 #ok(27, $h{''} eq 'bar' );
171 # check cache overflow and numeric keys and contents
173 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
174 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
177 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
178 $blksize,$blocks) = stat($Dfile);
181 @h{0..200} = 200..400;
183 ok(30, join(':',200..400) eq join(':',@foo) );
186 # Now check all the non-tie specific stuff
188 # Check NOOVERWRITE will make put fail when attempting to overwrite
189 # an existing record.
191 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
192 ok(31, $status == 1 );
194 # check that the value of the key 'x' has not been changed by the
196 ok(32, $h{'x'} eq 'X' );
199 $status = $X->put('key', 'value') ;
200 ok(33, $status == 0 );
202 #check that previous put can be retrieved
204 $status = $X->get('key', $value) ;
205 ok(34, $status == 0 );
206 ok(35, $value eq 'value' );
208 # Attempting to delete an existing key should work
210 $status = $X->del('q') ;
211 ok(36, $status == 0 );
213 # Make sure that the key deleted, cannot be retrieved
215 ok(37, $h{'q'} eq undef );
218 # Attempting to delete a non-existant key should fail
220 $status = $X->del('joe') ;
221 ok(38, $status == 1 );
223 # Check the get interface
225 # First a non-existing key
226 $status = $X->get('aaaa', $value) ;
227 ok(39, $status == 1 );
229 # Next an existing key
230 $status = $X->get('a', $value) ;
231 ok(40, $status == 0 );
232 ok(41, $value eq 'A' );
237 # ditto, but use put to replace the key/value pair.
239 # use seq to walk backwards through a file - check that this reversed is
241 # check seq FIRST/LAST
247 ok(42, $status == 0 );
254 ok(43, $status != 0 );
264 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
266 { $h{$_} = $_ * 100 }
268 # check that there are 10 elements in the hash
270 while (($key,$value) = each(%h)) {
280 while (($key,$value) = each(%h)) {
289 # Now try an in memory file
290 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
292 # fd with an in memory file should return fail
294 ok(48, $status == -1 );
300 # check ability to override the default hashing
302 my $filename = "xyz" ;
303 my $hi = new DB_File::HASHINFO ;
305 $hi->{hash} = sub { ++$::count ; length $_[0] } ;
306 ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
308 ok(50, $h{"abc"} == 123) ;
311 ok(51, $::count >0) ;
315 # check that attempting to tie an array to a DB_HASH will fail
317 my $filename = "xyz" ;
319 eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
320 ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
331 open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
337 use vars qw( @ISA @EXPORT) ;
342 @EXPORT = @DB_File::EXPORT ;
348 $self->SUPER::STORE($key, $value * 2) ;
354 $self->SUPER::FETCH($key) - 1 ;
361 $self->SUPER::put($key, $value * 3) ;
366 $self->SUPER::get($_[0], $_[1]) ;
374 my $value = $self->FETCH($key) ;
375 return "[[$value]]" ;
383 BEGIN { push @INC, '.'; }
385 main::ok(53, $@ eq "") ;
389 $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
392 main::ok(54, $@ eq "") ;
394 my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
395 main::ok(55, $@ eq "") ;
396 main::ok(56, $ret == 5) ;
399 $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
400 main::ok(57, $@ eq "") ;
401 main::ok(58, $ret == 10) ;
403 $ret = eval ' R_NEXT eq main::R_NEXT ' ;
404 main::ok(59, $@ eq "" ) ;
405 main::ok(60, $ret == 1) ;
407 $ret = eval '$X->A_new_method("joe") ' ;
408 main::ok(61, $@ eq "") ;
409 main::ok(62, $ret eq "[[11]]") ;
413 unlink "SubDB.pm", "dbhash.tmp" ;
421 my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
426 my($fk, $sk, $fv, $sv) = @_ ;
428 $fetch_key eq $fk && $store_key eq $sk &&
429 $fetch_value eq $fv && $store_value eq $sv &&
433 ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
435 $db->filter_fetch_key (sub { $fetch_key = $_ }) ;
436 $db->filter_store_key (sub { $store_key = $_ }) ;
437 $db->filter_fetch_value (sub { $fetch_value = $_}) ;
438 $db->filter_store_value (sub { $store_value = $_ }) ;
444 ok(64, checkOutput( "", "fred", "", "joe")) ;
446 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
447 ok(65, $h{"fred"} eq "joe");
449 ok(66, checkOutput( "", "fred", "joe", "")) ;
451 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
452 ok(67, $db->FIRSTKEY() eq "fred") ;
454 ok(68, checkOutput( "fred", "", "", "")) ;
456 # replace the filters, but remember the previous set
457 my ($old_fk) = $db->filter_fetch_key
458 (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
459 my ($old_sk) = $db->filter_store_key
460 (sub { $_ = lc $_ ; $store_key = $_ }) ;
461 my ($old_fv) = $db->filter_fetch_value
462 (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
463 my ($old_sv) = $db->filter_store_value
464 (sub { s/o/x/g; $store_value = $_ }) ;
466 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
469 ok(69, checkOutput( "", "fred", "", "Jxe")) ;
471 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
472 ok(70, $h{"Fred"} eq "[Jxe]");
474 ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
476 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
477 ok(72, $db->FIRSTKEY() eq "FRED") ;
479 ok(73, checkOutput( "FRED", "", "", "")) ;
481 # put the original filters back
482 $db->filter_fetch_key ($old_fk);
483 $db->filter_store_key ($old_sk);
484 $db->filter_fetch_value ($old_fv);
485 $db->filter_store_value ($old_sv);
487 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
489 ok(74, checkOutput( "", "fred", "", "joe")) ;
491 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
492 ok(75, $h{"fred"} eq "joe");
493 ok(76, checkOutput( "", "fred", "joe", "")) ;
495 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
496 ok(77, $db->FIRSTKEY() eq "fred") ;
497 ok(78, checkOutput( "fred", "", "", "")) ;
500 $db->filter_fetch_key (undef);
501 $db->filter_store_key (undef);
502 $db->filter_fetch_value (undef);
503 $db->filter_store_value (undef);
505 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
507 ok(79, checkOutput( "", "", "", "")) ;
509 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
510 ok(80, $h{"fred"} eq "joe");
511 ok(81, checkOutput( "", "", "", "")) ;
513 ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
514 ok(82, $db->FIRSTKEY() eq "fred") ;
515 ok(83, checkOutput( "", "", "", "")) ;
523 # DBM Filter with a closure
529 ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
539 return sub { ++$count ;
541 $result{$name} = "$name - $count: [@kept]" ;
545 $db->filter_store_key(Closure("store key")) ;
546 $db->filter_store_value(Closure("store value")) ;
547 $db->filter_fetch_key(Closure("fetch key")) ;
548 $db->filter_fetch_value(Closure("fetch value")) ;
553 ok(85, $result{"store key"} eq "store key - 1: [fred]");
554 ok(86, $result{"store value"} eq "store value - 1: [joe]");
555 ok(87, ! defined $result{"fetch key"} );
556 ok(88, ! defined $result{"fetch value"} );
557 ok(89, $_ eq "original") ;
559 ok(90, $db->FIRSTKEY() eq "fred") ;
560 ok(91, $result{"store key"} eq "store key - 1: [fred]");
561 ok(92, $result{"store value"} eq "store value - 1: [joe]");
562 ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
563 ok(94, ! defined $result{"fetch value"} );
564 ok(95, $_ eq "original") ;
567 ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
568 ok(97, $result{"store value"} eq "store value - 2: [joe john]");
569 ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
570 ok(99, ! defined $result{"fetch value"} );
571 ok(100, $_ eq "original") ;
573 ok(101, $h{"fred"} eq "joe");
574 ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
575 ok(103, $result{"store value"} eq "store value - 2: [joe john]");
576 ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
577 ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
578 ok(106, $_ eq "original") ;
586 # DBM Filter recursion detection
591 ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
593 $db->filter_store_key (sub { $_ = $h{$_} }) ;
595 eval '$h{1} = 1234' ;
596 ok(108, $@ =~ /^recursion detected in filter_store_key at/ );