t/lib/db-hash.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     unshift @INC, '../lib' if -d '../lib' ;
   5     require Config; import Config;
   6     if ($Config{'extensions'} !~ /\bDB_File\b/) {
   7         print "1..0 # Skip: DB_File was not built\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use DB_File;
  13 use Fcntl;
  14
  15 print "1..108\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 my $Dfile = "dbhash.tmp";
  27 unlink $Dfile;
  28
  29 umask(0);
  30
  31 # Check the interface to HASHINFO
  32
  33 my $dbh = new DB_File::HASHINFO ;
  34
  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}) ;
  41
  42 $dbh->{bsize} = 3000 ;
  43 ok(7, $dbh->{bsize} == 3000 );
  44
  45 $dbh->{ffactor} = 9000 ;
  46 ok(8, $dbh->{ffactor} == 9000 );
  47
  48 $dbh->{nelem} = 400 ;
  49 ok(9, $dbh->{nelem} == 400 );
  50
  51 $dbh->{cachesize} = 65 ;
  52 ok(10, $dbh->{cachesize} == 65 );
  53
  54 $dbh->{hash} = "abc" ;
  55 ok(11, $dbh->{hash} eq "abc" );
  56
  57 $dbh->{lorder} = 1234 ;
  58 ok(12, $dbh->{lorder} == 1234 );
  59
  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/ );
  65
  66
  67 # Now check the interface to HASH
  68
  69 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  70
  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');
  74
  75 while (($key,$value) = each(%h)) {
  76     $i++;
  77 }
  78 ok(17, !$i );
  79
  80 $h{'goner1'} = 'snork';
  81
  82 $h{'abc'} = 'ABC';
  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'} );
  87
  88 $h{'def'} = 'DEF';
  89 $h{'jkl','mno'} = "JKL\034MNO";
  90 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  91 $h{'a'} = 'A';
  92
  93 #$h{'b'} = 'B';
  94 $X->STORE('b', 'B') ;
  95
  96 $h{'c'} = 'C';
  97
  98 #$h{'d'} = 'D';
  99 $X->put('d', 'D') ;
 100
 101 $h{'e'} = 'E';
 102 $h{'f'} = 'F';
 103 $h{'g'} = 'X';
 104 $h{'h'} = 'H';
 105 $h{'i'} = 'I';
 106
 107 $h{'goner2'} = 'snork';
 108 delete $h{'goner2'};
 109
 110
 111 # IMPORTANT - $X must be undefined before the untie otherwise the
 112 #             underlying DB close routine will not get called.
 113 undef $X ;
 114 untie(%h);
 115
 116
 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) );
 119
 120 # Modify an entry from the previous tie
 121 $h{'g'} = 'G';
 122
 123 $h{'j'} = 'J';
 124 $h{'k'} = 'K';
 125 $h{'l'} = 'L';
 126 $h{'m'} = 'M';
 127 $h{'n'} = 'N';
 128 $h{'o'} = 'O';
 129 $h{'p'} = 'P';
 130 $h{'q'} = 'Q';
 131 $h{'r'} = 'R';
 132 $h{'s'} = 'S';
 133 $h{'t'} = 'T';
 134 $h{'u'} = 'U';
 135 $h{'v'} = 'V';
 136 $h{'w'} = 'W';
 137 $h{'x'} = 'X';
 138 $h{'y'} = 'Y';
 139 $h{'z'} = 'Z';
 140
 141 $h{'goner3'} = 'snork';
 142
 143 delete $h{'goner1'};
 144 $X->DELETE('goner3');
 145
 146 @keys = keys(%h);
 147 @values = values(%h);
 148
 149 ok(23, $#keys == 29 && $#values == 29) ;
 150
 151 $i = 0 ;
 152 while (($key,$value) = each(%h)) {
 153     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 154         $key =~ y/a-z/A-Z/;
 155         $i++ if $key eq $value;
 156     }
 157 }
 158
 159 ok(24, $i == 30) ;
 160
 161 @keys = ('blurfl', keys(%h), 'dyick');
 162 ok(25, $#keys == 31) ;
 163
 164 $h{'foo'} = '';
 165 ok(26, $h{'foo'} eq '' );
 166
 167 #$h{''} = 'bar';
 168 #ok(27, $h{''} eq 'bar' );
 169 ok(27,1) ;
 170
 171 # check cache overflow and numeric keys and contents
 172 $ok = 1;
 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; }
 175 ok(28, $ok );
 176
 177 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 178    $blksize,$blocks) = stat($Dfile);
 179 ok(29, $size > 0 );
 180
 181 @h{0..200} = 200..400;
 182 @foo = @h{0..200};
 183 ok(30, join(':',200..400) eq join(':',@foo) );
 184
 185
 186 # Now check all the non-tie specific stuff
 187
 188 # Check NOOVERWRITE will make put fail when attempting to overwrite
 189 # an existing record.
 190
 191 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 192 ok(31, $status == 1 );
 193
 194 # check that the value of the key 'x' has not been changed by the
 195 # previous test
 196 ok(32, $h{'x'} eq 'X' );
 197
 198 # standard put
 199 $status = $X->put('key', 'value') ;
 200 ok(33, $status == 0 );
 201
 202 #check that previous put can be retrieved
 203 $value = 0 ;
 204 $status = $X->get('key', $value) ;
 205 ok(34, $status == 0 );
 206 ok(35, $value eq 'value' );
 207
 208 # Attempting to delete an existing key should work
 209
 210 $status = $X->del('q') ;
 211 ok(36, $status == 0 );
 212
 213 # Make sure that the key deleted, cannot be retrieved
 214 $^W = 0 ;
 215 ok(37, $h{'q'} eq undef );
 216 $^W = 1 ;
 217
 218 # Attempting to delete a non-existant key should fail
 219
 220 $status = $X->del('joe') ;
 221 ok(38, $status == 1 );
 222
 223 # Check the get interface
 224
 225 # First a non-existing key
 226 $status = $X->get('aaaa', $value) ;
 227 ok(39, $status == 1 );
 228
 229 # Next an existing key
 230 $status = $X->get('a', $value) ;
 231 ok(40, $status == 0 );
 232 ok(41, $value eq 'A' );
 233
 234 # seq
 235 # ###
 236
 237 # ditto, but use put to replace the key/value pair.
 238
 239 # use seq to walk backwards through a file - check that this reversed is
 240
 241 # check seq FIRST/LAST
 242
 243 # sync
 244 # ####
 245
 246 $status = $X->sync ;
 247 ok(42, $status == 0 );
 248
 249
 250 # fd
 251 # ##
 252
 253 $status = $X->fd ;
 254 ok(43, $status != 0 );
 255
 256 undef $X ;
 257 untie %h ;
 258
 259 unlink $Dfile;
 260
 261 # clear
 262 # #####
 263
 264 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 265 foreach (1 .. 10)
 266   { $h{$_} = $_ * 100 }
 267
 268 # check that there are 10 elements in the hash
 269 $i = 0 ;
 270 while (($key,$value) = each(%h)) {
 271     $i++;
 272 }
 273 ok(45, $i == 10);
 274
 275 # now clear the hash
 276 %h = () ;
 277
 278 # check it is empty
 279 $i = 0 ;
 280 while (($key,$value) = each(%h)) {
 281     $i++;
 282 }
 283 ok(46, $i == 0);
 284
 285 untie %h ;
 286 unlink $Dfile ;
 287
 288
 289 # Now try an in memory file
 290 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 291
 292 # fd with an in memory file should return fail
 293 $status = $X->fd ;
 294 ok(48, $status == -1 );
 295
 296 undef $X ;
 297 untie %h ;
 298
 299 {
 300     # check ability to override the default hashing
 301     my %x ;
 302     my $filename = "xyz" ;
 303     my $hi = new DB_File::HASHINFO ;
 304     $::count = 0 ;
 305     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 306     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 307     $h{"abc"} = 123 ;
 308     ok(50, $h{"abc"} == 123) ;
 309     untie %x ;
 310     unlink $filename ;
 311     ok(51, $::count >0) ;
 312 }
 313
 314 {
 315     # check that attempting to tie an array to a DB_HASH will fail
 316
 317     my $filename = "xyz" ;
 318     my @x ;
 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/) ;
 321     unlink $filename ;
 322 }
 323
 324 {
 325    # sub-class test
 326
 327    package Another ;
 328
 329    use strict ;
 330
 331    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 332    print FILE <<'EOM' ;
 333
 334    package SubDB ;
 335
 336    use strict ;
 337    use vars qw( @ISA @EXPORT) ;
 338
 339    require Exporter ;
 340    use DB_File;
 341    @ISA=qw(DB_File);
 342    @EXPORT = @DB_File::EXPORT ;
 343
 344    sub STORE {
 345         my $self = shift ;
 346         my $key = shift ;
 347         my $value = shift ;
 348         $self->SUPER::STORE($key, $value * 2) ;
 349    }
 350
 351    sub FETCH {
 352         my $self = shift ;
 353         my $key = shift ;
 354         $self->SUPER::FETCH($key) - 1 ;
 355    }
 356
 357    sub put {
 358         my $self = shift ;
 359         my $key = shift ;
 360         my $value = shift ;
 361         $self->SUPER::put($key, $value * 3) ;
 362    }
 363
 364    sub get {
 365         my $self = shift ;
 366         $self->SUPER::get($_[0], $_[1]) ;
 367         $_[1] -= 2 ;
 368    }
 369
 370    sub A_new_method
 371    {
 372         my $self = shift ;
 373         my $key = shift ;
 374         my $value = $self->FETCH($key) ;
 375         return "[[$value]]" ;
 376    }
 377
 378    1 ;
 379 EOM
 380
 381     close FILE ;
 382
 383     BEGIN { push @INC, '.'; }
 384     eval 'use SubDB ; ';
 385     main::ok(53, $@ eq "") ;
 386     my %h ;
 387     my $X ;
 388     eval '
 389         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
 390         ' ;
 391
 392     main::ok(54, $@ eq "") ;
 393
 394     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 395     main::ok(55, $@ eq "") ;
 396     main::ok(56, $ret == 5) ;
 397
 398     my $value = 0;
 399     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 400     main::ok(57, $@ eq "") ;
 401     main::ok(58, $ret == 10) ;
 402
 403     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 404     main::ok(59, $@ eq "" ) ;
 405     main::ok(60, $ret == 1) ;
 406
 407     $ret = eval '$X->A_new_method("joe") ' ;
 408     main::ok(61, $@ eq "") ;
 409     main::ok(62, $ret eq "[[11]]") ;
 410
 411     undef $X;
 412     untie(%h);
 413     unlink "SubDB.pm", "dbhash.tmp" ;
 414
 415 }
 416
 417 {
 418    # DBM Filter tests
 419    use strict ;
 420    my (%h, $db) ;
 421    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 422    unlink $Dfile;
 423
 424    sub checkOutput
 425    {
 426        my($fk, $sk, $fv, $sv) = @_ ;
 427        return
 428            $fetch_key eq $fk && $store_key eq $sk &&
 429            $fetch_value eq $fv && $store_value eq $sv &&
 430            $_ eq 'original' ;
 431    }
 432
 433    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 434
 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 = $_ }) ;
 439
 440    $_ = "original" ;
 441
 442    $h{"fred"} = "joe" ;
 443    #                   fk   sk     fv   sv
 444    ok(64, checkOutput( "", "fred", "", "joe")) ;
 445
 446    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 447    ok(65, $h{"fred"} eq "joe");
 448    #                   fk    sk     fv    sv
 449    ok(66, checkOutput( "", "fred", "joe", "")) ;
 450
 451    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 452    ok(67, $db->FIRSTKEY() eq "fred") ;
 453    #                    fk     sk  fv  sv
 454    ok(68, checkOutput( "fred", "", "", "")) ;
 455
 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 = $_ }) ;
 465
 466    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 467    $h{"Fred"} = "Joe" ;
 468    #                   fk   sk     fv    sv
 469    ok(69, checkOutput( "", "fred", "", "Jxe")) ;
 470
 471    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 472    ok(70, $h{"Fred"} eq "[Jxe]");
 473    #                   fk   sk     fv    sv
 474    ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
 475
 476    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 477    ok(72, $db->FIRSTKEY() eq "FRED") ;
 478    #                   fk   sk     fv    sv
 479    ok(73, checkOutput( "FRED", "", "", "")) ;
 480
 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);
 486
 487    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 488    $h{"fred"} = "joe" ;
 489    ok(74, checkOutput( "", "fred", "", "joe")) ;
 490
 491    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 492    ok(75, $h{"fred"} eq "joe");
 493    ok(76, checkOutput( "", "fred", "joe", "")) ;
 494
 495    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 496    ok(77, $db->FIRSTKEY() eq "fred") ;
 497    ok(78, checkOutput( "fred", "", "", "")) ;
 498
 499    # delete the filters
 500    $db->filter_fetch_key   (undef);
 501    $db->filter_store_key   (undef);
 502    $db->filter_fetch_value (undef);
 503    $db->filter_store_value (undef);
 504
 505    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 506    $h{"fred"} = "joe" ;
 507    ok(79, checkOutput( "", "", "", "")) ;
 508
 509    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 510    ok(80, $h{"fred"} eq "joe");
 511    ok(81, checkOutput( "", "", "", "")) ;
 512
 513    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
 514    ok(82, $db->FIRSTKEY() eq "fred") ;
 515    ok(83, checkOutput( "", "", "", "")) ;
 516
 517    undef $db ;
 518    untie %h;
 519    unlink $Dfile;
 520 }
 521
 522 {
 523     # DBM Filter with a closure
 524
 525     use strict ;
 526     my (%h, $db) ;
 527
 528     unlink $Dfile;
 529     ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 530
 531     my %result = () ;
 532
 533     sub Closure
 534     {
 535         my ($name) = @_ ;
 536         my $count = 0 ;
 537         my @kept = () ;
 538
 539         return sub { ++$count ;
 540                      push @kept, $_ ;
 541                      $result{$name} = "$name - $count: [@kept]" ;
 542                    }
 543     }
 544
 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")) ;
 549
 550     $_ = "original" ;
 551
 552     $h{"fred"} = "joe" ;
 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") ;
 558
 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") ;
 565
 566     $h{"jim"}  = "john" ;
 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") ;
 572
 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") ;
 579
 580     undef $db ;
 581     untie %h;
 582     unlink $Dfile;
 583 }
 584
 585 {
 586    # DBM Filter recursion detection
 587    use strict ;
 588    my (%h, $db) ;
 589    unlink $Dfile;
 590
 591    ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 592
 593    $db->filter_store_key (sub { $_ = $h{$_} }) ;
 594
 595    eval '$h{1} = 1234' ;
 596    ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
 597
 598    undef $db ;
 599    untie %h;
 600    unlink $Dfile;
 601 }
 602
 603 exit ;