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..51\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, $dbh->{bsize} == 0) ;
  36 ok(2, $dbh->{ffactor} == 0) ;
  37 ok(3, $dbh->{nelem} == 0) ;
  38 ok(4, $dbh->{cachesize} == 0) ;
  39 $^W = 0 ;
  40 ok(5, $dbh->{hash} == undef) ;
  41 $^W = 1 ;
  42 ok(6, $dbh->{lorder} == 0) ;
  43
  44 $dbh->{bsize} = 3000 ;
  45 ok(7, $dbh->{bsize} == 3000 );
  46
  47 $dbh->{ffactor} = 9000 ;
  48 ok(8, $dbh->{ffactor} == 9000 );
  49
  50 $dbh->{nelem} = 400 ;
  51 ok(9, $dbh->{nelem} == 400 );
  52
  53 $dbh->{cachesize} = 65 ;
  54 ok(10, $dbh->{cachesize} == 65 );
  55
  56 $dbh->{hash} = "abc" ;
  57 ok(11, $dbh->{hash} eq "abc" );
  58
  59 $dbh->{lorder} = 1234 ;
  60 ok(12, $dbh->{lorder} == 1234 );
  61
  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/ );
  67
  68
  69 # Now check the interface to HASH
  70
  71 ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  72
  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');
  76
  77 while (($key,$value) = each(%h)) {
  78     $i++;
  79 }
  80 ok(17, !$i );
  81
  82 $h{'goner1'} = 'snork';
  83
  84 $h{'abc'} = 'ABC';
  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'} );
  89
  90 $h{'def'} = 'DEF';
  91 $h{'jkl','mno'} = "JKL\034MNO";
  92 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  93 $h{'a'} = 'A';
  94
  95 #$h{'b'} = 'B';
  96 $X->STORE('b', 'B') ;
  97
  98 $h{'c'} = 'C';
  99
 100 #$h{'d'} = 'D';
 101 $X->put('d', 'D') ;
 102
 103 $h{'e'} = 'E';
 104 $h{'f'} = 'F';
 105 $h{'g'} = 'X';
 106 $h{'h'} = 'H';
 107 $h{'i'} = 'I';
 108
 109 $h{'goner2'} = 'snork';
 110 delete $h{'goner2'};
 111
 112
 113 # IMPORTANT - $X must be undefined before the untie otherwise the
 114 #             underlying DB close routine will not get called.
 115 undef $X ;
 116 untie(%h);
 117
 118
 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) );
 121
 122 # Modify an entry from the previous tie
 123 $h{'g'} = 'G';
 124
 125 $h{'j'} = 'J';
 126 $h{'k'} = 'K';
 127 $h{'l'} = 'L';
 128 $h{'m'} = 'M';
 129 $h{'n'} = 'N';
 130 $h{'o'} = 'O';
 131 $h{'p'} = 'P';
 132 $h{'q'} = 'Q';
 133 $h{'r'} = 'R';
 134 $h{'s'} = 'S';
 135 $h{'t'} = 'T';
 136 $h{'u'} = 'U';
 137 $h{'v'} = 'V';
 138 $h{'w'} = 'W';
 139 $h{'x'} = 'X';
 140 $h{'y'} = 'Y';
 141 $h{'z'} = 'Z';
 142
 143 $h{'goner3'} = 'snork';
 144
 145 delete $h{'goner1'};
 146 $X->DELETE('goner3');
 147
 148 @keys = keys(%h);
 149 @values = values(%h);
 150
 151 ok(23, $#keys == 29 && $#values == 29) ;
 152
 153 $i = 0 ;
 154 while (($key,$value) = each(%h)) {
 155     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
 156         $key =~ y/a-z/A-Z/;
 157         $i++ if $key eq $value;
 158     }
 159 }
 160
 161 ok(24, $i == 30) ;
 162
 163 @keys = ('blurfl', keys(%h), 'dyick');
 164 ok(25, $#keys == 31) ;
 165
 166 $h{'foo'} = '';
 167 ok(26, $h{'foo'} eq '' );
 168
 169 $h{''} = 'bar';
 170 ok(27, $h{''} eq 'bar' );
 171
 172 # check cache overflow and numeric keys and contents
 173 $ok = 1;
 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; }
 176 ok(28, $ok );
 177
 178 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 179    $blksize,$blocks) = stat($Dfile);
 180 ok(29, $size > 0 );
 181
 182 @h{0..200} = 200..400;
 183 @foo = @h{0..200};
 184 ok(30, join(':',200..400) eq join(':',@foo) );
 185
 186
 187 # Now check all the non-tie specific stuff
 188
 189 # Check NOOVERWRITE will make put fail when attempting to overwrite
 190 # an existing record.
 191
 192 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 193 ok(31, $status == 1 );
 194
 195 # check that the value of the key 'x' has not been changed by the
 196 # previous test
 197 ok(32, $h{'x'} eq 'X' );
 198
 199 # standard put
 200 $status = $X->put('key', 'value') ;
 201 ok(33, $status == 0 );
 202
 203 #check that previous put can be retrieved
 204 $value = 0 ;
 205 $status = $X->get('key', $value) ;
 206 ok(34, $status == 0 );
 207 ok(35, $value eq 'value' );
 208
 209 # Attempting to delete an existing key should work
 210
 211 $status = $X->del('q') ;
 212 ok(36, $status == 0 );
 213
 214 # Make sure that the key deleted, cannot be retrieved
 215 $^W = 0 ;
 216 ok(37, $h{'q'} eq undef );
 217 $^W = 1 ;
 218
 219 # Attempting to delete a non-existant key should fail
 220
 221 $status = $X->del('joe') ;
 222 ok(38, $status == 1 );
 223
 224 # Check the get interface
 225
 226 # First a non-existing key
 227 $status = $X->get('aaaa', $value) ;
 228 ok(39, $status == 1 );
 229
 230 # Next an existing key
 231 $status = $X->get('a', $value) ;
 232 ok(40, $status == 0 );
 233 ok(41, $value eq 'A' );
 234
 235 # seq
 236 # ###
 237
 238 # ditto, but use put to replace the key/value pair.
 239
 240 # use seq to walk backwards through a file - check that this reversed is
 241
 242 # check seq FIRST/LAST
 243
 244 # sync
 245 # ####
 246
 247 $status = $X->sync ;
 248 ok(42, $status == 0 );
 249
 250
 251 # fd
 252 # ##
 253
 254 $status = $X->fd ;
 255 ok(43, $status != 0 );
 256
 257 undef $X ;
 258 untie %h ;
 259
 260 unlink $Dfile;
 261
 262 # clear
 263 # #####
 264
 265 ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 266 foreach (1 .. 10)
 267   { $h{$_} = $_ * 100 }
 268
 269 # check that there are 10 elements in the hash
 270 $i = 0 ;
 271 while (($key,$value) = each(%h)) {
 272     $i++;
 273 }
 274 ok(45, $i == 10);
 275
 276 # now clear the hash
 277 %h = () ;
 278
 279 # check it is empty
 280 $i = 0 ;
 281 while (($key,$value) = each(%h)) {
 282     $i++;
 283 }
 284 ok(46, $i == 0);
 285
 286 untie %h ;
 287 unlink $Dfile ;
 288
 289
 290 # Now try an in memory file
 291 ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
 292
 293 # fd with an in memory file should return fail
 294 $status = $X->fd ;
 295 ok(48, $status == -1 );
 296
 297 undef $X ;
 298 untie %h ;
 299
 300 {
 301     # check ability to override the default hashing
 302     my %x ;
 303     my $filename = "xyz" ;
 304     my $hi = new DB_File::HASHINFO ;
 305     $::count = 0 ;
 306     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
 307     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
 308     $h{"abc"} = 123 ;
 309     ok(50, $h{"abc"} == 123) ;
 310     untie %x ;
 311     unlink $filename ;
 312     ok(51, $::count >0) ;
 313 }
 314
 315 exit ;