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, $dbh->{bsize} == 0) ;
36 ok(2, $dbh->{ffactor} == 0) ;
37 ok(3, $dbh->{nelem} == 0) ;
38 ok(4, $dbh->{cachesize} == 0) ;
40 ok(5, $dbh->{hash} == undef) ;
42 ok(6, $dbh->{lorder} == 0) ;
44 $dbh->{bsize} = 3000 ;
45 ok(7, $dbh->{bsize} == 3000 );
47 $dbh->{ffactor} = 9000 ;
48 ok(8, $dbh->{ffactor} == 9000 );
51 ok(9, $dbh->{nelem} == 400 );
53 $dbh->{cachesize} = 65 ;
54 ok(10, $dbh->{cachesize} == 65 );
56 $dbh->{hash} = "abc" ;
57 ok(11, $dbh->{hash} eq "abc" );
59 $dbh->{lorder} = 1234 ;
60 ok(12, $dbh->{lorder} == 1234 );
62 # Check that an invalid entry is caught both for store & fetch
63 eval '$dbh->{fred} = 1234' ;
64 ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
65 eval 'my $q = $dbh->{fred}' ;
66 ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
69 # Now check the interface to HASH
71 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
73 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
74 $blksize,$blocks) = stat($Dfile);
75 ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos');
77 while (($key,$value) = each(%h)) {
82 $h{'goner1'} = 'snork';
85 ok(18, $h{'abc'} eq 'ABC' );
86 ok(19, !defined $h{'jimmy'} );
87 ok(20, !exists $h{'jimmy'} );
88 ok(21, exists $h{'abc'} );
91 $h{'jkl','mno'} = "JKL\034MNO";
92 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
109 $h{'goner2'} = 'snork';
113 # IMPORTANT - $X must be undefined before the untie otherwise the
114 # underlying DB close routine will not get called.
119 # tie to the same file again, do not supply a type - should default to HASH
120 ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
122 # Modify an entry from the previous tie
143 $h{'goner3'} = 'snork';
146 $X->DELETE('goner3');
149 @values = values(%h);
151 ok(23, $#keys == 29 && $#values == 29) ;
154 while (($key,$value) = each(%h)) {
155 if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
157 $i++ if $key eq $value;
163 @keys = ('blurfl', keys(%h), 'dyick');
164 ok(25, $#keys == 31) ;
167 ok(26, $h{'foo'} eq '' );
170 ok(27, $h{''} eq 'bar' );
172 # check cache overflow and numeric keys and contents
174 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
175 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
178 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
179 $blksize,$blocks) = stat($Dfile);
182 @h{0..200} = 200..400;
184 ok(30, join(':',200..400) eq join(':',@foo) );
187 # Now check all the non-tie specific stuff
189 # Check NOOVERWRITE will make put fail when attempting to overwrite
190 # an existing record.
192 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
193 ok(31, $status == 1 );
195 # check that the value of the key 'x' has not been changed by the
197 ok(32, $h{'x'} eq 'X' );
200 $status = $X->put('key', 'value') ;
201 ok(33, $status == 0 );
203 #check that previous put can be retrieved
205 $status = $X->get('key', $value) ;
206 ok(34, $status == 0 );
207 ok(35, $value eq 'value' );
209 # Attempting to delete an existing key should work
211 $status = $X->del('q') ;
212 ok(36, $status == 0 );
214 # Make sure that the key deleted, cannot be retrieved
216 ok(37, $h{'q'} eq undef );
219 # Attempting to delete a non-existant key should fail
221 $status = $X->del('joe') ;
222 ok(38, $status == 1 );
224 # Check the get interface
226 # First a non-existing key
227 $status = $X->get('aaaa', $value) ;
228 ok(39, $status == 1 );
230 # Next an existing key
231 $status = $X->get('a', $value) ;
232 ok(40, $status == 0 );
233 ok(41, $value eq 'A' );
238 # ditto, but use put to replace the key/value pair.
240 # use seq to walk backwards through a file - check that this reversed is
242 # check seq FIRST/LAST
248 ok(42, $status == 0 );
255 ok(43, $status != 0 );
265 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
267 { $h{$_} = $_ * 100 }
269 # check that there are 10 elements in the hash
271 while (($key,$value) = each(%h)) {
281 while (($key,$value) = each(%h)) {
290 # Now try an in memory file
291 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
293 # fd with an in memory file should return fail
295 ok(48, $status == -1 );
301 # check ability to override the default hashing
303 my $filename = "xyz" ;
304 my $hi = new DB_File::HASHINFO ;
306 $hi->{hash} = sub { ++$::count ; length $_[0] } ;
307 ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
309 ok(50, $h{"abc"} == 123) ;
312 ok(51, $::count >0) ;