t/lib/db-hash.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..62\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 $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' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
  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
 170 # check cache overflow and numeric keys and contents
 171 $ok = 1;
 172 for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
 173 for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
 174 ok(28, $ok );
 175
 176 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 177    $blksize,$blocks) = stat($Dfile);
 178 ok(29, $size > 0 );
 179
 180 @h{0..200} = 200..400;
 181 @foo = @h{0..200};
 182 ok(30, join(':',200..400) eq join(':',@foo) );
 183
 184
 185 # Now check all the non-tie specific stuff
 186
 187 # Check NOOVERWRITE will make put fail when attempting to overwrite
 188 # an existing record.
 189
 190 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 191 ok(31, $status == 1 );
 192
 193 # check that the value of the key 'x' has not been changed by the
 194 # previous test
 195 ok(32, $h{'x'} eq 'X' );
 196
 197 # standard put
 198 $status = $X->put('key', 'value') ;
 199 ok(33, $status == 0 );
 200
 201 #check that previous put can be retrieved
 202 $value = 0 ;
 203 $status = $X->get('key', $value) ;
 204 ok(34, $status == 0 );
 205 ok(35, $value eq 'value' );
 206
 207 # Attempting to delete an existing key should work
 208
 209 $status = $X->del('q') ;
 210 ok(36, $status == 0 );
 211
 212 # Make sure that the key deleted, cannot be retrieved
 213 $^W = 0 ;
 214 ok(37, $h{'q'} eq undef );
 215 $^W = 1 ;
 216
 217 # Attempting to delete a non-existant key should fail
 218
 219 $status = $X->del('joe') ;
 220 ok(38, $status == 1 );
 221
 222 # Check the get interface
 223
 224 # First a non-existing key
 225 $status = $X->get('aaaa', $value) ;
 226 ok(39, $status == 1 );
 227
 228 # Next an existing key
 229 $status = $X->get('a', $value) ;
 230 ok(40, $status == 0 );
 231 ok(41, $value eq 'A' );
 232
 233 # seq
 234 # ###
 235
 236 # ditto, but use put to replace the key/value pair.
 237
 238 # use seq to walk backwards through a file - check that this reversed is
 239
 240 # check seq FIRST/LAST
 241
 242 # sync
 243 # ####
 244
 245 $status = $X->sync ;
 246 ok(42, $status == 0 );
 247
 248
 249 # fd
 250 # ##
 251
 252 $status = $X->fd ;
 253 ok(43, $status != 0 );
 254
 255 undef $X ;
 256 untie %h ;
 257
 258 unlink $Dfile;
 259
 260 # clear
 261 # #####
 262
 263 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 264 foreach (1 .. 10)
 265   { $h{$_} = $_ * 100 }
 266
 267 # check that there are 10 elements in the hash
 268 $i = 0 ;
 269 while (($key,$value) = each(%h)) {
 270     $i++;
 271 }
 272 ok(45, $i == 10);
 273
 274 # now clear the hash
 275 %h = () ;
 276
 277 # check it is empty
 278 $i = 0 ;
 279 while (($key,$value) = each(%h)) {
 280     $i++;
 281 }
 282 ok(46, $i == 0);
 283
 284 untie %h ;
 285 unlink $Dfile ;
 286
 287
 288 # Now try an in memory file
 289 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 290
 291 # fd with an in memory file should return fail
 292 $status = $X->fd ;
 293 ok(48, $status == -1 );
 294
 295 undef $X ;
 296 untie %h ;
 297
 298 {
 299     # check ability to override the default hashing
 300     my %x ;
 301     my $filename = "xyz" ;
 302     my $hi = new DB_File::HASHINFO ;
 303     $::count = 0 ;
 304     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 305     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 306     $h{"abc"} = 123 ;
 307     ok(50, $h{"abc"} == 123) ;
 308     untie %x ;
 309     unlink $filename ;
 310     ok(51, $::count >0) ;
 311 }
 312
 313 {
 314     # check that attempting to tie an array to a DB_HASH will fail
 315
 316     my $filename = "xyz" ;
 317     my @x ;
 318     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
 319     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
 320     unlink $filename ;
 321 }
 322
 323 {
 324    # sub-class test
 325
 326    package Another ;
 327
 328    use strict ;
 329
 330    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
 331    print FILE <<'EOM' ;
 332
 333    package SubDB ;
 334
 335    use strict ;
 336    use vars qw( @ISA @EXPORT) ;
 337
 338    require Exporter ;
 339    use DB_File;
 340    @ISA=qw(DB_File);
 341    @EXPORT = @DB_File::EXPORT ;
 342
 343    sub STORE {
 344         my $self = shift ;
 345         my $key = shift ;
 346         my $value = shift ;
 347         $self->SUPER::STORE($key, $value * 2) ;
 348    }
 349
 350    sub FETCH {
 351         my $self = shift ;
 352         my $key = shift ;
 353         $self->SUPER::FETCH($key) - 1 ;
 354    }
 355
 356    sub put {
 357         my $self = shift ;
 358         my $key = shift ;
 359         my $value = shift ;
 360         $self->SUPER::put($key, $value * 3) ;
 361    }
 362
 363    sub get {
 364         my $self = shift ;
 365         $self->SUPER::get($_[0], $_[1]) ;
 366         $_[1] -= 2 ;
 367    }
 368
 369    sub A_new_method
 370    {
 371         my $self = shift ;
 372         my $key = shift ;
 373         my $value = $self->FETCH($key) ;
 374         return "[[$value]]" ;
 375    }
 376
 377    1 ;
 378 EOM
 379
 380     close FILE ;
 381
 382     BEGIN { push @INC, '.'; }
 383     eval 'use SubDB ; ';
 384     main::ok(53, $@ eq "") ;
 385     my %h ;
 386     my $X ;
 387     eval '
 388         $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
 389         ' ;
 390
 391     main::ok(54, $@ eq "") ;
 392
 393     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
 394     main::ok(55, $@ eq "") ;
 395     main::ok(56, $ret == 5) ;
 396
 397     my $value = 0;
 398     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
 399     main::ok(57, $@ eq "") ;
 400     main::ok(58, $ret == 10) ;
 401
 402     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
 403     main::ok(59, $@ eq "" ) ;
 404     main::ok(60, $ret == 1) ;
 405
 406     $ret = eval '$X->A_new_method("joe") ' ;
 407     main::ok(61, $@ eq "") ;
 408     main::ok(62, $ret eq "[[11]]") ;
 409
 410     undef $X;
 411     untie(%h);
 412     unlink "SubDB.pm", "dbhash.tmp" ;
 413
 414 }
 415
 416 exit ;