t/lib/db-hash.t

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