t/lib/db-btree.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     @INC = '../lib' if -d '../lib' ;
   5     require Config; import Config;
   6     if ($Config{'extensions'} !~ /\bDB_File\b/) {
   7         print "1..0\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use DB_File;
  13 use Fcntl;
  14
  15 print "1..91\n";
  16
  17 sub ok
  18 {
  19     my $no = shift ;
  20     my $result = shift ;
  21
  22     print "not " unless $result ;
  23     print "ok $no\n" ;
  24 }
  25
  26 sub lexical
  27 {
  28     my(@a) = unpack ("C*", $a) ;
  29     my(@b) = unpack ("C*", $b) ;
  30
  31     my $len = (@a > @b ? @b : @a) ;
  32     my $i = 0 ;
  33
  34     foreach $i ( 0 .. $len -1) {
  35         return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
  36     }
  37
  38     return @a - @b ;
  39 }
  40
  41 $Dfile = "dbbtree.tmp";
  42 unlink $Dfile;
  43
  44 umask(0);
  45
  46 # Check the interface to BTREEINFO
  47
  48 my $dbh = new DB_File::BTREEINFO ;
  49 ok(1, $dbh->{flags} == 0) ;
  50 ok(2, $dbh->{cachesize} == 0) ;
  51 ok(3, $dbh->{psize} == 0) ;
  52 ok(4, $dbh->{lorder} == 0) ;
  53 ok(5, $dbh->{minkeypage} == 0) ;
  54 ok(6, $dbh->{maxkeypage} == 0) ;
  55 $^W = 0 ;
  56 ok(7, $dbh->{compare} == undef) ;
  57 ok(8, $dbh->{prefix} == undef) ;
  58 $^W = 1 ;
  59
  60 $dbh->{flags} = 3000 ;
  61 ok(9, $dbh->{flags} == 3000) ;
  62
  63 $dbh->{cachesize} = 9000 ;
  64 ok(10, $dbh->{cachesize} == 9000);
  65
  66 $dbh->{psize} = 400 ;
  67 ok(11, $dbh->{psize} == 400) ;
  68
  69 $dbh->{lorder} = 65 ;
  70 ok(12, $dbh->{lorder} == 65) ;
  71
  72 $dbh->{minkeypage} = 123 ;
  73 ok(13, $dbh->{minkeypage} == 123) ;
  74
  75 $dbh->{maxkeypage} = 1234 ;
  76 ok(14, $dbh->{maxkeypage} == 1234 );
  77
  78 $dbh->{compare} = 1234 ;
  79 ok(15, $dbh->{compare} == 1234) ;
  80
  81 $dbh->{prefix} = 1234 ;
  82 ok(16, $dbh->{prefix} == 1234 );
  83
  84 # Check that an invalid entry is caught both for store & fetch
  85 eval '$dbh->{fred} = 1234' ;
  86 ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
  87 eval '$q = $dbh->{fred}' ;
  88 ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
  89
  90 # Now check the interface to BTREE
  91
  92 ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
  93
  94 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  95    $blksize,$blocks) = stat($Dfile);
  96 ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) );
  97
  98 while (($key,$value) = each(%h)) {
  99     $i++;
 100 }
 101 ok(21, !$i ) ;
 102
 103 $h{'goner1'} = 'snork';
 104
 105 $h{'abc'} = 'ABC';
 106 ok(22, $h{'abc'} eq 'ABC' );
 107 ok(23, ! defined $h{'jimmy'} ) ;
 108 ok(24, ! exists $h{'jimmy'} ) ;
 109 ok(25,  defined $h{'abc'} ) ;
 110
 111 $h{'def'} = 'DEF';
 112 $h{'jkl','mno'} = "JKL\034MNO";
 113 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
 114 $h{'a'} = 'A';
 115
 116 #$h{'b'} = 'B';
 117 $X->STORE('b', 'B') ;
 118
 119 $h{'c'} = 'C';
 120
 121 #$h{'d'} = 'D';
 122 $X->put('d', 'D') ;
 123
 124 $h{'e'} = 'E';
 125 $h{'f'} = 'F';
 126 $h{'g'} = 'X';
 127 $h{'h'} = 'H';
 128 $h{'i'} = 'I';
 129
 130 $h{'goner2'} = 'snork';
 131 delete $h{'goner2'};
 132
 133
 134 # IMPORTANT - $X must be undefined before the untie otherwise the
 135 #             underlying DB close routine will not get called.
 136 undef $X ;
 137 untie(%h);
 138
 139
 140 # tie to the same file again
 141 ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
 142
 143 # Modify an entry from the previous tie
 144 $h{'g'} = 'G';
 145
 146 $h{'j'} = 'J';
 147 $h{'k'} = 'K';
 148 $h{'l'} = 'L';
 149 $h{'m'} = 'M';
 150 $h{'n'} = 'N';
 151 $h{'o'} = 'O';
 152 $h{'p'} = 'P';
 153 $h{'q'} = 'Q';
 154 $h{'r'} = 'R';
 155 $h{'s'} = 'S';
 156 $h{'t'} = 'T';
 157 $h{'u'} = 'U';
 158 $h{'v'} = 'V';
 159 $h{'w'} = 'W';
 160 $h{'x'} = 'X';
 161 $h{'y'} = 'Y';
 162 $h{'z'} = 'Z';
 163
 164 $h{'goner3'} = 'snork';
 165
 166 delete $h{'goner1'};
 167 $X->DELETE('goner3');
 168
 169 @keys = keys(%h);
 170 @values = values(%h);
 171
 172 ok(27, $#keys == 29 && $#values == 29) ;
 173
 174 $i = 0 ;
 175 while (($key,$value) = each(%h)) {
 176     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 177         $key =~ y/a-z/A-Z/;
 178         $i++ if $key eq $value;
 179     }
 180 }
 181
 182 ok(28, $i == 30) ;
 183
 184 @keys = ('blurfl', keys(%h), 'dyick');
 185 ok(29, $#keys == 31) ;
 186
 187 #Check that the keys can be retrieved in order
 188 my @b = keys %h ;
 189 my @c = sort lexical @b ;
 190 ok(30, ArrayCompare(\@b, \@c)) ;
 191
 192 $h{'foo'} = '';
 193 ok(31, $h{'foo'} eq '' ) ;
 194
 195 $h{''} = 'bar';
 196 ok(32, $h{''} eq 'bar' );
 197
 198 # check cache overflow and numeric keys and contents
 199 $ok = 1;
 200 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 201 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 202 ok(33, $ok);
 203
 204 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 205    $blksize,$blocks) = stat($Dfile);
 206 ok(34, $size > 0 );
 207
 208 @h{0..200} = 200..400;
 209 @foo = @h{0..200};
 210 ok(35, join(':',200..400) eq join(':',@foo) );
 211
 212 # Now check all the non-tie specific stuff
 213
 214
 215 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
 216 # an existing record.
 217
 218 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 219 ok(36, $status == 1 );
 220
 221 # check that the value of the key 'x' has not been changed by the
 222 # previous test
 223 ok(37, $h{'x'} eq 'X' );
 224
 225 # standard put
 226 $status = $X->put('key', 'value') ;
 227 ok(38, $status == 0 );
 228
 229 #check that previous put can be retrieved
 230 $value = 0 ;
 231 $status = $X->get('key', $value) ;
 232 ok(39, $status == 0 );
 233 ok(40, $value eq 'value' );
 234
 235 # Attempting to delete an existing key should work
 236
 237 $status = $X->del('q') ;
 238 ok(41, $status == 0 );
 239 $status = $X->del('') ;
 240 ok(42, $status == 0 );
 241
 242 # Make sure that the key deleted, cannot be retrieved
 243 $^W = 0 ;
 244 ok(43, $h{'q'} eq undef) ;
 245 ok(44, $h{''} eq undef) ;
 246 $^W = 1 ;
 247
 248 undef $X ;
 249 untie %h ;
 250
 251 ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
 252
 253 # Attempting to delete a non-existant key should fail
 254
 255 $status = $X->del('joe') ;
 256 ok(46, $status == 1 );
 257
 258 # Check the get interface
 259
 260 # First a non-existing key
 261 $status = $X->get('aaaa', $value) ;
 262 ok(47, $status == 1 );
 263
 264 # Next an existing key
 265 $status = $X->get('a', $value) ;
 266 ok(48, $status == 0 );
 267 ok(49, $value eq 'A' );
 268
 269 # seq
 270 # ###
 271
 272 # use seq to find an approximate match
 273 $key = 'ke' ;
 274 $value = '' ;
 275 $status = $X->seq($key, $value, R_CURSOR) ;
 276 ok(50, $status == 0 );
 277 ok(51, $key eq 'key' );
 278 ok(52, $value eq 'value' );
 279
 280 # seq when the key does not match
 281 $key = 'zzz' ;
 282 $value = '' ;
 283 $status = $X->seq($key, $value, R_CURSOR) ;
 284 ok(53, $status == 1 );
 285
 286
 287 # use seq to set the cursor, then delete the record @ the cursor.
 288
 289 $key = 'x' ;
 290 $value = '' ;
 291 $status = $X->seq($key, $value, R_CURSOR) ;
 292 ok(54, $status == 0 );
 293 ok(55, $key eq 'x' );
 294 ok(56, $value eq 'X' );
 295 $status = $X->del(0, R_CURSOR) ;
 296 ok(57, $status == 0 );
 297 $status = $X->get('x', $value) ;
 298 ok(58, $status == 1 );
 299
 300 # ditto, but use put to replace the key/value pair.
 301 $key = 'y' ;
 302 $value = '' ;
 303 $status = $X->seq($key, $value, R_CURSOR) ;
 304 ok(59, $status == 0 );
 305 ok(60, $key eq 'y' );
 306 ok(61, $value eq 'Y' );
 307
 308 $key = "replace key" ;
 309 $value = "replace value" ;
 310 $status = $X->put($key, $value, R_CURSOR) ;
 311 ok(62, $status == 0 );
 312 ok(63, $key eq 'replace key' );
 313 ok(64, $value eq 'replace value' );
 314 $status = $X->get('y', $value) ;
 315 ok(65, $status == 1 );
 316
 317 # use seq to walk forwards through a file
 318
 319 $status = $X->seq($key, $value, R_FIRST) ;
 320 ok(66, $status == 0 );
 321 $previous = $key ;
 322
 323 $ok = 1 ;
 324 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
 325 {
 326     ($ok = 0), last if ($previous cmp $key) == 1 ;
 327 }
 328
 329 ok(67, $status == 1 );
 330 ok(68, $ok == 1 );
 331
 332 # use seq to walk backwards through a file
 333 $status = $X->seq($key, $value, R_LAST) ;
 334 ok(69, $status == 0 );
 335 $previous = $key ;
 336
 337 $ok = 1 ;
 338 while (($status = $X->seq($key, $value, R_PREV)) == 0)
 339 {
 340     ($ok = 0), last if ($previous cmp $key) == -1 ;
 341     #print "key = [$key] value = [$value]\n" ;
 342 }
 343
 344 ok(70, $status == 1 );
 345 ok(71, $ok == 1 );
 346
 347
 348 # check seq FIRST/LAST
 349
 350 # sync
 351 # ####
 352
 353 $status = $X->sync ;
 354 ok(72, $status == 0 );
 355
 356
 357 # fd
 358 # ##
 359
 360 $status = $X->fd ;
 361 ok(73, $status != 0 );
 362
 363
 364 undef $X ;
 365 untie %h ;
 366
 367 unlink $Dfile;
 368
 369 # Now try an in memory file
 370 ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
 371
 372 # fd with an in memory file should return failure
 373 $status = $Y->fd ;
 374 ok(75, $status == -1 );
 375
 376
 377 undef $Y ;
 378 untie %h ;
 379
 380 # Duplicate keys
 381 my $bt = new DB_File::BTREEINFO ;
 382 $bt->{flags} = R_DUP ;
 383 ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
 384
 385 $hh{'Wall'} = 'Larry' ;
 386 $hh{'Wall'} = 'Stone' ; # Note the duplicate key
 387 $hh{'Wall'} = 'Brick' ; # Note the duplicate key
 388 $hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
 389 $hh{'Smith'} = 'John' ;
 390 $hh{'mouse'} = 'mickey' ;
 391
 392 # first work in scalar context
 393 ok(77, scalar $YY->get_dup('Unknown') == 0 );
 394 ok(78, scalar $YY->get_dup('Smith') == 1 );
 395 ok(79, scalar $YY->get_dup('Wall') == 4 );
 396
 397 # now in list context
 398 my @unknown = $YY->get_dup('Unknown') ;
 399 ok(80, "@unknown" eq "" );
 400
 401 my @smith = $YY->get_dup('Smith') ;
 402 ok(81, "@smith" eq "John" );
 403
 404 {
 405 my @wall = $YY->get_dup('Wall') ;
 406 my %wall ;
 407 @wall{@wall} = @wall ;
 408 ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
 409 }
 410
 411 # hash
 412 my %unknown = $YY->get_dup('Unknown', 1) ;
 413 ok(83, keys %unknown == 0 );
 414
 415 my %smith = $YY->get_dup('Smith', 1) ;
 416 ok(84, keys %smith == 1 && $smith{'John'}) ;
 417
 418 my %wall = $YY->get_dup('Wall', 1) ;
 419 ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
 420                 && $wall{'Brick'} == 2);
 421
 422 undef $YY ;
 423 untie %hh ;
 424 unlink $Dfile;
 425
 426
 427 # test multiple callbacks
 428 $Dfile1 = "btree1" ;
 429 $Dfile2 = "btree2" ;
 430 $Dfile3 = "btree3" ;
 431
 432 $dbh1 = TIEHASH DB_File::BTREEINFO ;
 433 $dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
 434
 435 $dbh2 = TIEHASH DB_File::BTREEINFO ;
 436 $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
 437
 438 $dbh3 = TIEHASH DB_File::BTREEINFO ;
 439 $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
 440
 441
 442 tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
 443 tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
 444 tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
 445
 446 @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
 447 $^W = 0 ;
 448 @srt_1 = sort { $a <=> $b } @Keys ;
 449 $^W = 1 ;
 450 @srt_2 = sort { $a cmp $b } @Keys ;
 451 @srt_3 = sort { length $a <=> length $b } @Keys ;
 452
 453 foreach (@Keys) {
 454     $^W = 0 ;
 455     $h{$_} = 1 ;
 456     $^W = 1 ;
 457     $g{$_} = 1 ;
 458     $k{$_} = 1 ;
 459 }
 460
 461 sub ArrayCompare
 462 {
 463     my($a, $b) = @_ ;
 464
 465     return 0 if @$a != @$b ;
 466
 467     foreach (1 .. length @$a)
 468     {
 469         return 0 unless $$a[$_] eq $$b[$_] ;
 470     }
 471
 472     1 ;
 473 }
 474
 475 ok(86, ArrayCompare (\@srt_1, [keys %h]) );
 476 ok(87, ArrayCompare (\@srt_2, [keys %g]) );
 477 ok(88, ArrayCompare (\@srt_3, [keys %k]) );
 478
 479 untie %h ;
 480 untie %g ;
 481 untie %k ;
 482 unlink $Dfile1, $Dfile2, $Dfile3 ;
 483
 484 # clear
 485 # #####
 486
 487 ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
 488 foreach (1 .. 10)
 489   { $h{$_} = $_ * 100 }
 490
 491 # check that there are 10 elements in the hash
 492 $i = 0 ;
 493 while (($key,$value) = each(%h)) {
 494     $i++;
 495 }
 496 ok(90, $i == 10);
 497
 498 # now clear the hash
 499 %h = () ;
 500
 501 # check it is empty
 502 $i = 0 ;
 503 while (($key,$value) = each(%h)) {
 504     $i++;
 505 }
 506 ok(91, $i == 0);
 507
 508 untie %h ;
 509 unlink $Dfile1 ;
 510
 511 exit ;