home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / perl-5.003-src.tgz / tar.out / fsf / perl / t / lib / db-btree.t < prev    next >
Text File  |  1996-09-28  |  10KB  |  405 lines
  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..76\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. # test multiple callbacks
  352. $Dfile1 = "btree1" ;
  353. $Dfile2 = "btree2" ;
  354. $Dfile3 = "btree3" ;
  355.  
  356. $dbh1 = TIEHASH DB_File::BTREEINFO ;
  357. $dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
  358.  
  359. $dbh2 = TIEHASH DB_File::BTREEINFO ;
  360. $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
  361.  
  362. $dbh3 = TIEHASH DB_File::BTREEINFO ;
  363. $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
  364.  
  365.  
  366. tie(%h, DB_File,$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
  367. tie(%g, DB_File,$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
  368. tie(%k, DB_File,$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
  369.  
  370. @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
  371. @srt_1 = sort { $a <=> $b } @Keys ;
  372. @srt_2 = sort { $a cmp $b } @Keys ;
  373. @srt_3 = sort { length $a <=> length $b } @Keys ;
  374.  
  375. foreach (@Keys) {
  376.     $h{$_} = 1 ;
  377.     $g{$_} = 1 ;
  378.     $k{$_} = 1 ;
  379. }
  380.  
  381. sub ArrayCompare
  382. {
  383.     my($a, $b) = @_ ;
  384.  
  385.     return 0 if @$a != @$b ;
  386.  
  387.     foreach (1 .. length @$a)
  388.     {
  389.         return 0 unless $$a[$_] eq $$b[$_] ;
  390.     }
  391.  
  392.     1 ;
  393. }
  394.  
  395. print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ;
  396. print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ;
  397. print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ;
  398.  
  399. untie %h ;
  400. untie %g ;
  401. untie %k ;
  402. unlink $Dfile1, $Dfile2, $Dfile3 ;
  403.  
  404. exit ;
  405.