5 require Config; import Config;
6 if ($Config{'extensions'} !~ /\bDB_File\b/) {
17 $Dfile = "dbbtree.tmp";
22 # Check the interface to BTREEINFO
24 #$dbh = TIEHASH DB_File::BTREEINFO ;
25 $dbh = new DB_File::BTREEINFO ;
26 print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
27 print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
28 print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
29 print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ;
30 print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ;
31 print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ;
32 print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ;
33 print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ;
35 $dbh->{flags} = 3000 ;
36 print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ;
38 $dbh->{cachesize} = 9000 ;
39 print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ;
42 print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ;
45 print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ;
47 $dbh->{minkeypage} = 123 ;
48 print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ;
50 $dbh->{maxkeypage} = 1234 ;
51 print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ;
53 $dbh->{compare} = 1234 ;
54 print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ;
56 $dbh->{prefix} = 1234 ;
57 print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;
59 # Check that an invalid entry is caught both for store & fetch
60 eval '$dbh->{fred} = 1234' ;
61 print ($@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ? "ok 17\n" : "not ok 17\n") ;
62 eval '$q = $dbh->{fred}' ;
63 print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "ok 18\n" : "not ok 18\n") ;
65 # Now check the interface to BTREE
67 print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
69 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
70 $blksize,$blocks) = stat($Dfile);
71 print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n");
73 while (($key,$value) = each(%h)) {
76 print (!$i ? "ok 21\n" : "not ok 21\n");
78 $h{'goner1'} = 'snork';
81 print ($h{'abc'} eq 'ABC' ? "ok 22\n" : "not ok 22\n") ;
82 print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
85 $h{'jkl','mno'} = "JKL\034MNO";
86 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
103 $h{'goner2'} = 'snork';
107 # IMPORTANT - $X must be undefined before the untie otherwise the
108 # underlying DB close routine will not get called.
113 # tie to the same file again
114 print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n");
116 # Modify an entry from the previous tie
137 $h{'goner3'} = 'snork';
140 $X->DELETE('goner3');
143 @values = values(%h);
145 if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";}
147 while (($key,$value) = each(%h)) {
148 if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
150 $i++ if $key eq $value;
154 if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
156 @keys = ('blurfl', keys(%h), 'dyick');
157 if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
159 #Check that the keys can be retrieved in order
163 ($ok = 0), last if defined $previous && $previous gt $_ ;
166 print ($ok ? "ok 28\n" : "not ok 28\n") ;
169 print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ;
172 print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ;
174 # check cache overflow and numeric keys and contents
176 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
177 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
178 print ($ok ? "ok 31\n" : "not ok 31\n");
180 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
181 $blksize,$blocks) = stat($Dfile);
182 print ($size > 0 ? "ok 32\n" : "not ok 32\n");
184 @h{0..200} = 200..400;
186 print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";
188 # Now check all the non-tie specific stuff
191 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
192 # an existing record.
194 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
195 print ($status == 1 ? "ok 34\n" : "not ok 34\n") ;
197 # check that the value of the key 'x' has not been changed by the
199 print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ;
202 $status = $X->put('key', 'value') ;
203 print ($status == 0 ? "ok 36\n" : "not ok 36\n") ;
205 #check that previous put can be retrieved
206 $status = $X->get('key', $value) ;
207 print ($status == 0 ? "ok 37\n" : "not ok 37\n") ;
208 print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ;
210 # Attempting to delete an existing key should work
212 $status = $X->del('q') ;
213 print ($status == 0 ? "ok 39\n" : "not ok 39\n") ;
214 $status = $X->del('') ;
215 print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;
217 # Make sure that the key deleted, cannot be retrieved
218 print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ;
219 print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ;
224 print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43");
226 # Attempting to delete a non-existant key should fail
228 $status = $X->del('joe') ;
229 print ($status == 1 ? "ok 44\n" : "not ok 44\n") ;
231 # Check the get interface
233 # First a non-existing key
234 $status = $X->get('aaaa', $value) ;
235 print ($status == 1 ? "ok 45\n" : "not ok 45\n") ;
237 # Next an existing key
238 $status = $X->get('a', $value) ;
239 print ($status == 0 ? "ok 46\n" : "not ok 46\n") ;
240 print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;
245 # use seq to find an approximate match
248 $status = $X->seq($key, $value, R_CURSOR) ;
249 print ($status == 0 ? "ok 48\n" : "not ok 48\n") ;
250 print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ;
251 print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ;
253 # seq when the key does not match
256 $status = $X->seq($key, $value, R_CURSOR) ;
257 print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;
260 # use seq to set the cursor, then delete the record @ the cursor.
264 $status = $X->seq($key, $value, R_CURSOR) ;
265 print ($status == 0 ? "ok 52\n" : "not ok 52\n") ;
266 print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ;
267 print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ;
268 $status = $X->del(0, R_CURSOR) ;
269 print ($status == 0 ? "ok 55\n" : "not ok 55\n") ;
270 $status = $X->get('x', $value) ;
271 print ($status == 1 ? "ok 56\n" : "not ok 56\n") ;
273 # ditto, but use put to replace the key/value pair.
276 $status = $X->seq($key, $value, R_CURSOR) ;
277 print ($status == 0 ? "ok 57\n" : "not ok 57\n") ;
278 print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ;
279 print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ;
281 $key = "replace key" ;
282 $value = "replace value" ;
283 $status = $X->put($key, $value, R_CURSOR) ;
284 print ($status == 0 ? "ok 60\n" : "not ok 60\n") ;
285 print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ;
286 print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ;
287 $status = $X->get('y', $value) ;
288 print ($status == 1 ? "ok 63\n" : "not ok 63\n") ;
290 # use seq to walk forwards through a file
292 $status = $X->seq($key, $value, R_FIRST) ;
293 print ($status == 0 ? "ok 64\n" : "not ok 64\n") ;
297 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
299 ($ok = 0), last if ($previous cmp $key) == 1 ;
302 print ($status == 1 ? "ok 65\n" : "not ok 65\n") ;
303 print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ;
305 # use seq to walk backwards through a file
306 $status = $X->seq($key, $value, R_LAST) ;
307 print ($status == 0 ? "ok 67\n" : "not ok 67\n") ;
311 while (($status = $X->seq($key, $value, R_PREV)) == 0)
313 ($ok = 0), last if ($previous cmp $key) == -1 ;
314 #print "key = [$key] value = [$value]\n" ;
317 print ($status == 1 ? "ok 68\n" : "not ok 68\n") ;
318 print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;
321 # check seq FIRST/LAST
327 print ($status == 0 ? "ok 70\n" : "not ok 70\n") ;
334 print ($status != 0 ? "ok 71\n" : "not ok 71\n") ;
342 # Now try an in memory file
343 print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72");
345 # fd with an in memory file should return failure
347 print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
354 my $bt = new DB_File::BTREEINFO ;
355 $bt->{flags} = R_DUP ;
356 print (($YY = tie(%hh, DB_File, $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ? "ok 74\n" : "not ok 74");
358 $hh{'Wall'} = 'Larry' ;
359 $hh{'Wall'} = 'Stone' ; # Note the duplicate key
360 $hh{'Wall'} = 'Brick' ; # Note the duplicate key
361 $hh{'Smith'} = 'John' ;
362 $hh{'mouse'} = 'mickey' ;
364 # first work in scalar context
365 print(scalar $YY->get_dup('Unknown') == 0 ? "ok 75\n" : "not ok 75\n") ;
366 print(scalar $YY->get_dup('Smith') == 1 ? "ok 76\n" : "not ok 76\n") ;
367 print(scalar $YY->get_dup('Wall') == 3 ? "ok 77\n" : "not ok 77\n") ;
369 # now in list context
370 my @unknown = $YY->get_dup('Unknown') ;
371 print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;
373 my @smith = $YY->get_dup('Smith') ;
374 print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;
377 my @wall = $YY->get_dup('Wall') ;
379 @wall{@wall} = @wall ;
380 print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ;
384 my %unknown = $YY->get_dup('Unknown', 1) ;
385 print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;
387 my %smith = $YY->get_dup('Smith', 1) ;
388 print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;
390 %wall = $YY->get_dup('Wall', 1) ;
391 print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;
398 # test multiple callbacks
403 $dbh1 = TIEHASH DB_File::BTREEINFO ;
404 $dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
406 $dbh2 = TIEHASH DB_File::BTREEINFO ;
407 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
409 $dbh3 = TIEHASH DB_File::BTREEINFO ;
410 $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
413 tie(%h, DB_File,$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
414 tie(%g, DB_File,$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
415 tie(%k, DB_File,$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
417 @Keys = qw( 0123 12 -1234 9 987654321 def ) ;
418 @srt_1 = sort { $a <=> $b } @Keys ;
419 @srt_2 = sort { $a cmp $b } @Keys ;
420 @srt_3 = sort { length $a <=> length $b } @Keys ;
432 return 0 if @$a != @$b ;
434 foreach (1 .. length @$a)
436 return 0 unless $$a[$_] eq $$b[$_] ;
442 print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 84\n" : "not ok 84\n") ;
443 print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 85\n" : "not ok 85\n") ;
444 print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 86\n" : "not ok 86\n") ;
449 unlink $Dfile1, $Dfile2, $Dfile3 ;