4 @INC = '../lib' if -d '../lib' ;
5 require Config; import Config;
6 if ($Config{'extensions'} !~ /\bDB_File\b/) {
22 print "not " unless $result ;
26 $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" ;