t/lib/db-btree.t

   1 #!./perl
   2
   3 BEGIN {
   4     @INC = '../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..73\n";
  16
  17 $Dfile = "Op.db-btree";
  18 unlink $Dfile;
  19
  20 umask(0);
  21
  22 # Check the interface to BTREEINFO
  23
  24 $dbh = TIEHASH DB_File::BTREEINFO ;
  25 print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
  26 print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
  27 print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
  28 print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ;
  29 print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ;
  30 print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ;
  31 print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ;
  32 print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ;
  33
  34 $dbh->{flags} = 3000 ;
  35 print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ;
  36
  37 $dbh->{cachesize} = 9000 ;
  38 print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ;
  39 #
  40 $dbh->{psize} = 400 ;
  41 print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ;
  42
  43 $dbh->{lorder} = 65 ;
  44 print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ;
  45
  46 $dbh->{minkeypage} = 123 ;
  47 print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ;
  48
  49 $dbh->{maxkeypage} = 1234 ;
  50 print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ;
  51
  52 $dbh->{compare} = 1234 ;
  53 print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ;
  54
  55 $dbh->{prefix} = 1234 ;
  56 print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;
  57
  58 # Check that an invalid entry is caught both for store & fetch
  59 eval '$dbh->{fred} = 1234' ;
  60 print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ;
  61 eval '$q = $dbh->{fred}' ;
  62 print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ;
  63
  64 # Now check the interface to BTREE
  65
  66 print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
  67
  68 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  69    $blksize,$blocks) = stat($Dfile);
  70 print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n");
  71
  72 while (($key,$value) = each(%h)) {
  73     $i++;
  74 }
  75 print (!$i ? "ok 21\n" : "not ok 21\n");
  76
  77 $h{'goner1'} = 'snork';
  78
  79 $h{'abc'} = 'ABC';
  80 print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ;
  81 print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
  82
  83 $h{'def'} = 'DEF';
  84 $h{'jkl','mno'} = "JKL\034MNO";
  85 $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  86 $h{'a'} = 'A';
  87
  88 #$h{'b'} = 'B';
  89 $X->STORE('b', 'B') ;
  90
  91 $h{'c'} = 'C';
  92
  93 #$h{'d'} = 'D';
  94 $X->put('d', 'D') ;
  95
  96 $h{'e'} = 'E';
  97 $h{'f'} = 'F';
  98 $h{'g'} = 'X';
  99 $h{'h'} = 'H';
 100 $h{'i'} = 'I';
 101
 102 $h{'goner2'} = 'snork';
 103 delete $h{'goner2'};
 104
 105
 106 # IMPORTANT - $X must be undefined before the untie otherwise the
 107 #             underlying DB close routine will not get called.
 108 undef $X ;
 109 untie(%h);
 110
 111
 112 # tie to the same file again
 113 print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n");
 114
 115 # Modify an entry from the previous tie
 116 $h{'g'} = 'G';
 117
 118 $h{'j'} = 'J';
 119 $h{'k'} = 'K';
 120 $h{'l'} = 'L';
 121 $h{'m'} = 'M';
 122 $h{'n'} = 'N';
 123 $h{'o'} = 'O';
 124 $h{'p'} = 'P';
 125 $h{'q'} = 'Q';
 126 $h{'r'} = 'R';
 127 $h{'s'} = 'S';
 128 $h{'t'} = 'T';
 129 $h{'u'} = 'U';
 130 $h{'v'} = 'V';
 131 $h{'w'} = 'W';
 132 $h{'x'} = 'X';
 133 $h{'y'} = 'Y';
 134 $h{'z'} = 'Z';
 135
 136 $h{'goner3'} = 'snork';
 137
 138 delete $h{'goner1'};
 139 $X->DELETE('goner3');
 140
 141 @keys = keys(%h);
 142 @values = values(%h);
 143
 144 if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";}
 145
 146 while (($key,$value) = each(%h)) {
 147     if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
 148         $key =~ y/a-z/A-Z/;
 149         $i++ if $key eq $value;
 150     }
 151 }
 152
 153 if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
 154
 155 @keys = ('blurfl', keys(h), 'dyick');
 156 if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
 157
 158 #Check that the keys can be retrieved in order
 159 $ok = 1 ;
 160 foreach (keys %h)
 161 {
 162     ($ok = 0), last if defined $previous && $previous gt $_ ;
 163     $previous = $_ ;
 164 }
 165 print ($ok ? "ok 28\n" : "not ok 28\n") ;
 166
 167 $h{'foo'} = '';
 168 print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ;
 169
 170 $h{''} = 'bar';
 171 print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ;
 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 print ($ok ? "ok 31\n" : "not ok 31\n");
 178
 179 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
 180    $blksize,$blocks) = stat($Dfile);
 181 print ($size > 0 ? "ok 32\n" : "not ok 32\n");
 182
 183 @h{0..200} = 200..400;
 184 @foo = @h{0..200};
 185 print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";
 186
 187 # Now check all the non-tie specific stuff
 188
 189
 190 # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
 191 # an existing record.
 192
 193 $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
 194 print ($status == 1 ? "ok 34\n" : "not ok 34\n") ;
 195
 196 # check that the value of the key 'x' has not been changed by the
 197 # previous test
 198 print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ;
 199
 200 # standard put
 201 $status = $X->put('key', 'value') ;
 202 print ($status == 0 ? "ok 36\n" : "not ok 36\n") ;
 203
 204 #check that previous put can be retrieved
 205 $status = $X->get('key', $value) ;
 206 print ($status == 0 ? "ok 37\n" : "not ok 37\n") ;
 207 print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ;
 208
 209 # Attempting to delete an existing key should work
 210
 211 $status = $X->del('q') ;
 212 print ($status == 0 ? "ok 39\n" : "not ok 39\n") ;
 213 $status = $X->del('') ;
 214 print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;
 215
 216 # Make sure that the key deleted, cannot be retrieved
 217 print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ;
 218 print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ;
 219
 220 undef $X ;
 221 untie %h ;
 222
 223 print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43");
 224
 225 # Attempting to delete a non-existant key should fail
 226
 227 $status = $X->del('joe') ;
 228 print ($status == 1 ? "ok 44\n" : "not ok 44\n") ;
 229
 230 # Check the get interface
 231
 232 # First a non-existing key
 233 $status = $X->get('aaaa', $value) ;
 234 print ($status == 1 ? "ok 45\n" : "not ok 45\n") ;
 235
 236 # Next an existing key
 237 $status = $X->get('a', $value) ;
 238 print ($status == 0 ? "ok 46\n" : "not ok 46\n") ;
 239 print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;
 240
 241 # seq
 242 # ###
 243
 244 # use seq to find an approximate match
 245 $key = 'ke' ;
 246 $value = '' ;
 247 $status = $X->seq($key, $value, R_CURSOR) ;
 248 print ($status == 0 ? "ok 48\n" : "not ok 48\n") ;
 249 print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ;
 250 print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ;
 251
 252 # seq when the key does not match
 253 $key = 'zzz' ;
 254 $value = '' ;
 255 $status = $X->seq($key, $value, R_CURSOR) ;
 256 print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;
 257
 258
 259 # use seq to set the cursor, then delete the record @ the cursor.
 260
 261 $key = 'x' ;
 262 $value = '' ;
 263 $status = $X->seq($key, $value, R_CURSOR) ;
 264 print ($status == 0 ? "ok 52\n" : "not ok 52\n") ;
 265 print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ;
 266 print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ;
 267 $status = $X->del(0, R_CURSOR) ;
 268 print ($status == 0 ? "ok 55\n" : "not ok 55\n") ;
 269 $status = $X->get('x', $value) ;
 270 print ($status == 1 ? "ok 56\n" : "not ok 56\n") ;
 271
 272 # ditto, but use put to replace the key/value pair.
 273 $key = 'y' ;
 274 $value = '' ;
 275 $status = $X->seq($key, $value, R_CURSOR) ;
 276 print ($status == 0 ? "ok 57\n" : "not ok 57\n") ;
 277 print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ;
 278 print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ;
 279
 280 $key = "replace key" ;
 281 $value = "replace value" ;
 282 $status = $X->put($key, $value, R_CURSOR) ;
 283 print ($status == 0 ? "ok 60\n" : "not ok 60\n") ;
 284 print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ;
 285 print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ;
 286 $status = $X->get('y', $value) ;
 287 print ($status == 1 ? "ok 63\n" : "not ok 63\n") ;
 288
 289 # use seq to walk forwards through a file
 290
 291 $status = $X->seq($key, $value, R_FIRST) ;
 292 print ($status == 0 ? "ok 64\n" : "not ok 64\n") ;
 293 $previous = $key ;
 294
 295 $ok = 1 ;
 296 while (($status = $X->seq($key, $value, R_NEXT)) == 0)
 297 {
 298     ($ok = 0), last if ($previous cmp $key) == 1 ;
 299 }
 300
 301 print ($status == 1 ? "ok 65\n" : "not ok 65\n") ;
 302 print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ;
 303
 304 # use seq to walk backwards through a file
 305 $status = $X->seq($key, $value, R_LAST) ;
 306 print ($status == 0 ? "ok 67\n" : "not ok 67\n") ;
 307 $previous = $key ;
 308
 309 $ok = 1 ;
 310 while (($status = $X->seq($key, $value, R_PREV)) == 0)
 311 {
 312     ($ok = 0), last if ($previous cmp $key) == -1 ;
 313     #print "key = [$key] value = [$value]\n" ;
 314 }
 315
 316 print ($status == 1 ? "ok 68\n" : "not ok 68\n") ;
 317 print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;
 318
 319
 320 # check seq FIRST/LAST
 321
 322 # sync
 323 # ####
 324
 325 $status = $X->sync ;
 326 print ($status == 0 ? "ok 70\n" : "not ok 70\n") ;
 327
 328
 329 # fd
 330 # ##
 331
 332 $status = $X->fd ;
 333 print ($status != 0 ? "ok 71\n" : "not ok 71\n") ;
 334
 335
 336 undef $X ;
 337 untie %h ;
 338
 339 unlink $Dfile;
 340
 341 # Now try an in memory file
 342 print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72");
 343
 344 # fd with an in memory file should return failure
 345 $status = $Y->fd ;
 346 print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
 347
 348 undef $Y ;
 349 untie %h ;
 350
 351 exit ;