home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / db-btree.t < prev    next >
Text File  |  1999-09-13  |  27KB  |  1,221 lines
  1. #!./perl -w
  2.  
  3. BEGIN {
  4.     unshift @INC, '../lib' if -d '../lib' ;
  5.     require Config; import Config;
  6.     if ($Config{'extensions'} !~ /\bDB_File\b/) {
  7.     print "1..0 # Skip: DB_File was not built\n";
  8.     exit 0;
  9.     }
  10. }
  11.  
  12. use DB_File; 
  13. use Fcntl;
  14.  
  15. print "1..155\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. sub lexical
  27. {
  28.     my(@a) = unpack ("C*", $a) ;
  29.     my(@b) = unpack ("C*", $b) ;
  30.  
  31.     my $len = (@a > @b ? @b : @a) ;
  32.     my $i = 0 ;
  33.  
  34.     foreach $i ( 0 .. $len -1) {
  35.         return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
  36.     }
  37.  
  38.     return @a - @b ;
  39. }
  40.  
  41. {
  42.     package Redirect ;
  43.     use Symbol ;
  44.  
  45.     sub new
  46.     {
  47.         my $class = shift ;
  48.         my $filename = shift ;
  49.     my $fh = gensym ;
  50.     open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  51.     my $real_stdout = select($fh) ;
  52.     return bless [$fh, $real_stdout ] ;
  53.  
  54.     }
  55.     sub DESTROY
  56.     {
  57.         my $self = shift ;
  58.     close $self->[0] ;
  59.     select($self->[1]) ;
  60.     }
  61. }
  62.  
  63. sub docat
  64. { 
  65.     my $file = shift;
  66.     #local $/ = undef unless wantarray ;
  67.     open(CAT,$file) || die "Cannot open $file: $!";
  68.     my @result = <CAT>;
  69.     close(CAT);
  70.     wantarray ? @result : join("", @result) ;
  71. }   
  72.  
  73. sub docat_del
  74. { 
  75.     my $file = shift;
  76.     #local $/ = undef unless wantarray ;
  77.     open(CAT,$file) || die "Cannot open $file: $!";
  78.     my @result = <CAT>;
  79.     close(CAT);
  80.     unlink $file ;
  81.     wantarray ? @result : join("", @result) ;
  82. }   
  83.  
  84.  
  85. $db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
  86.  
  87. my $Dfile = "dbbtree.tmp";
  88. unlink $Dfile;
  89.  
  90. umask(0);
  91.  
  92. # Check the interface to BTREEINFO
  93.  
  94. my $dbh = new DB_File::BTREEINFO ;
  95. ok(1, ! defined $dbh->{flags}) ;
  96. ok(2, ! defined $dbh->{cachesize}) ;
  97. ok(3, ! defined $dbh->{psize}) ;
  98. ok(4, ! defined $dbh->{lorder}) ;
  99. ok(5, ! defined $dbh->{minkeypage}) ;
  100. ok(6, ! defined $dbh->{maxkeypage}) ;
  101. ok(7, ! defined $dbh->{compare}) ;
  102. ok(8, ! defined $dbh->{prefix}) ;
  103.  
  104. $dbh->{flags} = 3000 ;
  105. ok(9, $dbh->{flags} == 3000) ;
  106.  
  107. $dbh->{cachesize} = 9000 ;
  108. ok(10, $dbh->{cachesize} == 9000);
  109.  
  110. $dbh->{psize} = 400 ;
  111. ok(11, $dbh->{psize} == 400) ;
  112.  
  113. $dbh->{lorder} = 65 ;
  114. ok(12, $dbh->{lorder} == 65) ;
  115.  
  116. $dbh->{minkeypage} = 123 ;
  117. ok(13, $dbh->{minkeypage} == 123) ;
  118.  
  119. $dbh->{maxkeypage} = 1234 ;
  120. ok(14, $dbh->{maxkeypage} == 1234 );
  121.  
  122. $dbh->{compare} = 1234 ;
  123. ok(15, $dbh->{compare} == 1234) ;
  124.  
  125. $dbh->{prefix} = 1234 ;
  126. ok(16, $dbh->{prefix} == 1234 );
  127.  
  128. # Check that an invalid entry is caught both for store & fetch
  129. eval '$dbh->{fred} = 1234' ;
  130. ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
  131. eval '$q = $dbh->{fred}' ;
  132. ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
  133.  
  134. # Now check the interface to BTREE
  135.  
  136. ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
  137.  
  138. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  139.    $blksize,$blocks) = stat($Dfile);
  140. ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
  141.  
  142. while (($key,$value) = each(%h)) {
  143.     $i++;
  144. }
  145. ok(21, !$i ) ;
  146.  
  147. $h{'goner1'} = 'snork';
  148.  
  149. $h{'abc'} = 'ABC';
  150. ok(22, $h{'abc'} eq 'ABC' );
  151. ok(23, ! defined $h{'jimmy'} ) ;
  152. ok(24, ! exists $h{'jimmy'} ) ;
  153. ok(25,  defined $h{'abc'} ) ;
  154.  
  155. $h{'def'} = 'DEF';
  156. $h{'jkl','mno'} = "JKL\034MNO";
  157. $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  158. $h{'a'} = 'A';
  159.  
  160. #$h{'b'} = 'B';
  161. $X->STORE('b', 'B') ;
  162.  
  163. $h{'c'} = 'C';
  164.  
  165. #$h{'d'} = 'D';
  166. $X->put('d', 'D') ;
  167.  
  168. $h{'e'} = 'E';
  169. $h{'f'} = 'F';
  170. $h{'g'} = 'X';
  171. $h{'h'} = 'H';
  172. $h{'i'} = 'I';
  173.  
  174. $h{'goner2'} = 'snork';
  175. delete $h{'goner2'};
  176.  
  177.  
  178. # IMPORTANT - $X must be undefined before the untie otherwise the
  179. #             underlying DB close routine will not get called.
  180. undef $X ;
  181. untie(%h);
  182.  
  183. # tie to the same file again
  184. ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
  185.  
  186. # Modify an entry from the previous tie
  187. $h{'g'} = 'G';
  188.  
  189. $h{'j'} = 'J';
  190. $h{'k'} = 'K';
  191. $h{'l'} = 'L';
  192. $h{'m'} = 'M';
  193. $h{'n'} = 'N';
  194. $h{'o'} = 'O';
  195. $h{'p'} = 'P';
  196. $h{'q'} = 'Q';
  197. $h{'r'} = 'R';
  198. $h{'s'} = 'S';
  199. $h{'t'} = 'T';
  200. $h{'u'} = 'U';
  201. $h{'v'} = 'V';
  202. $h{'w'} = 'W';
  203. $h{'x'} = 'X';
  204. $h{'y'} = 'Y';
  205. $h{'z'} = 'Z';
  206.  
  207. $h{'goner3'} = 'snork';
  208.  
  209. delete $h{'goner1'};
  210. $X->DELETE('goner3');
  211.  
  212. @keys = keys(%h);
  213. @values = values(%h);
  214.  
  215. ok(27, $#keys == 29 && $#values == 29) ;
  216.  
  217. $i = 0 ;
  218. while (($key,$value) = each(%h)) {
  219.     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  220.     $key =~ y/a-z/A-Z/;
  221.     $i++ if $key eq $value;
  222.     }
  223. }
  224.  
  225. ok(28, $i == 30) ;
  226.  
  227. @keys = ('blurfl', keys(%h), 'dyick');
  228. ok(29, $#keys == 31) ;
  229.  
  230. #Check that the keys can be retrieved in order
  231. my @b = keys %h ;
  232. my @c = sort lexical @b ;
  233. ok(30, ArrayCompare(\@b, \@c)) ;
  234.  
  235. $h{'foo'} = '';
  236. ok(31, $h{'foo'} eq '' ) ;
  237.  
  238. #$h{''} = 'bar';
  239. #ok(32, $h{''} eq 'bar' );
  240. ok(32,1) ;
  241.  
  242. # check cache overflow and numeric keys and contents
  243. $ok = 1;
  244. for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  245. for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  246. ok(33, $ok);
  247.  
  248. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  249.    $blksize,$blocks) = stat($Dfile);
  250. ok(34, $size > 0 );
  251.  
  252. @h{0..200} = 200..400;
  253. @foo = @h{0..200};
  254. ok(35, join(':',200..400) eq join(':',@foo) );
  255.  
  256. # Now check all the non-tie specific stuff
  257.  
  258.  
  259. # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
  260. # an existing record.
  261.  
  262. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
  263. ok(36, $status == 1 );
  264.  
  265. # check that the value of the key 'x' has not been changed by the 
  266. # previous test
  267. ok(37, $h{'x'} eq 'X' );
  268.  
  269. # standard put
  270. $status = $X->put('key', 'value') ;
  271. ok(38, $status == 0 );
  272.  
  273. #check that previous put can be retrieved
  274. $value = 0 ;
  275. $status = $X->get('key', $value) ;
  276. ok(39, $status == 0 );
  277. ok(40, $value eq 'value' );
  278.  
  279. # Attempting to delete an existing key should work
  280.  
  281. $status = $X->del('q') ;
  282. ok(41, $status == 0 );
  283. #$status = $X->del('') ;
  284. #ok(42, $status == 0 );
  285. ok(42,1) ;
  286.  
  287. # Make sure that the key deleted, cannot be retrieved
  288. ok(43, ! defined $h{'q'}) ;
  289. ok(44, ! defined $h{''}) ;
  290.  
  291. undef $X ;
  292. untie %h ;
  293.  
  294. ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
  295.  
  296. # Attempting to delete a non-existant key should fail
  297.  
  298. $status = $X->del('joe') ;
  299. ok(46, $status == 1 );
  300.  
  301. # Check the get interface
  302.  
  303. # First a non-existing key
  304. $status = $X->get('aaaa', $value) ;
  305. ok(47, $status == 1 );
  306.  
  307. # Next an existing key
  308. $status = $X->get('a', $value) ;
  309. ok(48, $status == 0 );
  310. ok(49, $value eq 'A' );
  311.  
  312. # seq
  313. # ###
  314.  
  315. # use seq to find an approximate match
  316. $key = 'ke' ;
  317. $value = '' ;
  318. $status = $X->seq($key, $value, R_CURSOR) ;
  319. ok(50, $status == 0 );
  320. ok(51, $key eq 'key' );
  321. ok(52, $value eq 'value' );
  322.  
  323. # seq when the key does not match
  324. $key = 'zzz' ;
  325. $value = '' ;
  326. $status = $X->seq($key, $value, R_CURSOR) ;
  327. ok(53, $status == 1 );
  328.  
  329.  
  330. # use seq to set the cursor, then delete the record @ the cursor.
  331.  
  332. $key = 'x' ;
  333. $value = '' ;
  334. $status = $X->seq($key, $value, R_CURSOR) ;
  335. ok(54, $status == 0 );
  336. ok(55, $key eq 'x' );
  337. ok(56, $value eq 'X' );
  338. $status = $X->del(0, R_CURSOR) ;
  339. ok(57, $status == 0 );
  340. $status = $X->get('x', $value) ;
  341. ok(58, $status == 1 );
  342.  
  343. # ditto, but use put to replace the key/value pair.
  344. $key = 'y' ;
  345. $value = '' ;
  346. $status = $X->seq($key, $value, R_CURSOR) ;
  347. ok(59, $status == 0 );
  348. ok(60, $key eq 'y' );
  349. ok(61, $value eq 'Y' );
  350.  
  351. $key = "replace key" ;
  352. $value = "replace value" ;
  353. $status = $X->put($key, $value, R_CURSOR) ;
  354. ok(62, $status == 0 );
  355. ok(63, $key eq 'replace key' );
  356. ok(64, $value eq 'replace value' );
  357. $status = $X->get('y', $value) ;
  358. ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
  359.         # only worked because of a bug in 1.85/6
  360.  
  361. # use seq to walk forwards through a file 
  362.  
  363. $status = $X->seq($key, $value, R_FIRST) ;
  364. ok(66, $status == 0 );
  365. $previous = $key ;
  366.  
  367. $ok = 1 ;
  368. while (($status = $X->seq($key, $value, R_NEXT)) == 0)
  369. {
  370.     ($ok = 0), last if ($previous cmp $key) == 1 ;
  371. }
  372.  
  373. ok(67, $status == 1 );
  374. ok(68, $ok == 1 );
  375.  
  376. # use seq to walk backwards through a file 
  377. $status = $X->seq($key, $value, R_LAST) ;
  378. ok(69, $status == 0 );
  379. $previous = $key ;
  380.  
  381. $ok = 1 ;
  382. while (($status = $X->seq($key, $value, R_PREV)) == 0)
  383. {
  384.     ($ok = 0), last if ($previous cmp $key) == -1 ;
  385.     #print "key = [$key] value = [$value]\n" ;
  386. }
  387.  
  388. ok(70, $status == 1 );
  389. ok(71, $ok == 1 );
  390.  
  391.  
  392. # check seq FIRST/LAST
  393.  
  394. # sync
  395. # ####
  396.  
  397. $status = $X->sync ;
  398. ok(72, $status == 0 );
  399.  
  400.  
  401. # fd
  402. # ##
  403.  
  404. $status = $X->fd ;
  405. ok(73, $status != 0 );
  406.  
  407.  
  408. undef $X ;
  409. untie %h ;
  410.  
  411. unlink $Dfile;
  412.  
  413. # Now try an in memory file
  414. ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
  415.  
  416. # fd with an in memory file should return failure
  417. $status = $Y->fd ;
  418. ok(75, $status == -1 );
  419.  
  420.  
  421. undef $Y ;
  422. untie %h ;
  423.  
  424. # Duplicate keys
  425. my $bt = new DB_File::BTREEINFO ;
  426. $bt->{flags} = R_DUP ;
  427. ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
  428.  
  429. $hh{'Wall'} = 'Larry' ;
  430. $hh{'Wall'} = 'Stone' ; # Note the duplicate key
  431. $hh{'Wall'} = 'Brick' ; # Note the duplicate key
  432. $hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
  433. $hh{'Smith'} = 'John' ;
  434. $hh{'mouse'} = 'mickey' ;
  435.  
  436. # first work in scalar context
  437. ok(77, scalar $YY->get_dup('Unknown') == 0 );
  438. ok(78, scalar $YY->get_dup('Smith') == 1 );
  439. ok(79, scalar $YY->get_dup('Wall') == 4 );
  440.  
  441. # now in list context
  442. my @unknown = $YY->get_dup('Unknown') ;
  443. ok(80, "@unknown" eq "" );
  444.  
  445. my @smith = $YY->get_dup('Smith') ;
  446. ok(81, "@smith" eq "John" );
  447.  
  448. {
  449. my @wall = $YY->get_dup('Wall') ;
  450. my %wall ;
  451. @wall{@wall} = @wall ;
  452. ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
  453. }
  454.  
  455. # hash
  456. my %unknown = $YY->get_dup('Unknown', 1) ;
  457. ok(83, keys %unknown == 0 );
  458.  
  459. my %smith = $YY->get_dup('Smith', 1) ;
  460. ok(84, keys %smith == 1 && $smith{'John'}) ;
  461.  
  462. my %wall = $YY->get_dup('Wall', 1) ;
  463. ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
  464.         && $wall{'Brick'} == 2);
  465.  
  466. undef $YY ;
  467. untie %hh ;
  468. unlink $Dfile;
  469.  
  470.  
  471. # test multiple callbacks
  472. $Dfile1 = "btree1" ;
  473. $Dfile2 = "btree2" ;
  474. $Dfile3 = "btree3" ;
  475.  
  476. $dbh1 = new DB_File::BTREEINFO ;
  477. { local $^W = 0 ;
  478.   $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; }
  479.  
  480. $dbh2 = new DB_File::BTREEINFO ;
  481. $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
  482.  
  483. $dbh3 = new DB_File::BTREEINFO ;
  484. $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
  485.  
  486.  
  487. tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ;
  488. tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
  489. tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
  490.  
  491. @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
  492. { local $^W = 0 ;
  493.   @srt_1 = sort { $a <=> $b } @Keys ; }
  494. @srt_2 = sort { $a cmp $b } @Keys ;
  495. @srt_3 = sort { length $a <=> length $b } @Keys ;
  496.  
  497. foreach (@Keys) {
  498.     { local $^W = 0 ; 
  499.       $h{$_} = 1 ; }
  500.     $g{$_} = 1 ;
  501.     $k{$_} = 1 ;
  502. }
  503.  
  504. sub ArrayCompare
  505. {
  506.     my($a, $b) = @_ ;
  507.  
  508.     return 0 if @$a != @$b ;
  509.  
  510.     foreach (1 .. length @$a)
  511.     {
  512.         return 0 unless $$a[$_] eq $$b[$_] ;
  513.     }
  514.  
  515.     1 ;
  516. }
  517.  
  518. ok(86, ArrayCompare (\@srt_1, [keys %h]) );
  519. ok(87, ArrayCompare (\@srt_2, [keys %g]) );
  520. ok(88, ArrayCompare (\@srt_3, [keys %k]) );
  521.  
  522. untie %h ;
  523. untie %g ;
  524. untie %k ;
  525. unlink $Dfile1, $Dfile2, $Dfile3 ;
  526.  
  527. # clear
  528. # #####
  529.  
  530. ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  531. foreach (1 .. 10)
  532.   { $h{$_} = $_ * 100 }
  533.  
  534. # check that there are 10 elements in the hash
  535. $i = 0 ;
  536. while (($key,$value) = each(%h)) {
  537.     $i++;
  538. }
  539. ok(90, $i == 10);
  540.  
  541. # now clear the hash
  542. %h = () ;
  543.  
  544. # check it is empty
  545. $i = 0 ;
  546. while (($key,$value) = each(%h)) {
  547.     $i++;
  548. }
  549. ok(91, $i == 0);
  550.  
  551. untie %h ;
  552. unlink $Dfile1 ;
  553.  
  554. {
  555.     # check that attempting to tie an array to a DB_BTREE will fail
  556.  
  557.     my $filename = "xyz" ;
  558.     my @x ;
  559.     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
  560.     ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
  561.     unlink $filename ;
  562. }
  563.  
  564. {
  565.    # sub-class test
  566.  
  567.    package Another ;
  568.  
  569.    use strict ;
  570.  
  571.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
  572.    print FILE <<'EOM' ;
  573.  
  574.    package SubDB ;
  575.  
  576.    use strict ;
  577.    use vars qw( @ISA @EXPORT) ;
  578.  
  579.    require Exporter ;
  580.    use DB_File;
  581.    @ISA=qw(DB_File);
  582.    @EXPORT = @DB_File::EXPORT ;
  583.  
  584.    sub STORE { 
  585.     my $self = shift ;
  586.         my $key = shift ;
  587.         my $value = shift ;
  588.         $self->SUPER::STORE($key, $value * 2) ;
  589.    }
  590.  
  591.    sub FETCH { 
  592.     my $self = shift ;
  593.         my $key = shift ;
  594.         $self->SUPER::FETCH($key) - 1 ;
  595.    }
  596.  
  597.    sub put { 
  598.     my $self = shift ;
  599.         my $key = shift ;
  600.         my $value = shift ;
  601.         $self->SUPER::put($key, $value * 3) ;
  602.    }
  603.  
  604.    sub get { 
  605.     my $self = shift ;
  606.         $self->SUPER::get($_[0], $_[1]) ;
  607.     $_[1] -= 2 ;
  608.    }
  609.  
  610.    sub A_new_method
  611.    {
  612.     my $self = shift ;
  613.         my $key = shift ;
  614.         my $value = $self->FETCH($key) ;
  615.     return "[[$value]]" ;
  616.    }
  617.  
  618.    1 ;
  619. EOM
  620.  
  621.     close FILE ;
  622.  
  623.     BEGIN { push @INC, '.'; }    
  624.     eval 'use SubDB ; ';
  625.     main::ok(93, $@ eq "") ;
  626.     my %h ;
  627.     my $X ;
  628.     eval '
  629.     $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
  630.     ' ;
  631.  
  632.     main::ok(94, $@ eq "") ;
  633.  
  634.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  635.     main::ok(95, $@ eq "") ;
  636.     main::ok(96, $ret == 5) ;
  637.  
  638.     my $value = 0;
  639.     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
  640.     main::ok(97, $@ eq "") ;
  641.     main::ok(98, $ret == 10) ;
  642.  
  643.     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
  644.     main::ok(99, $@ eq "" ) ;
  645.     main::ok(100, $ret == 1) ;
  646.  
  647.     $ret = eval '$X->A_new_method("joe") ' ;
  648.     main::ok(101, $@ eq "") ;
  649.     main::ok(102, $ret eq "[[11]]") ;
  650.  
  651.     undef $X;
  652.     untie(%h);
  653.     unlink "SubDB.pm", "dbbtree.tmp" ;
  654.  
  655. }
  656.  
  657. {
  658.    # DBM Filter tests
  659.    use strict ;
  660.    my (%h, $db) ;
  661.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  662.    unlink $Dfile;
  663.  
  664.    sub checkOutput
  665.    {
  666.        my($fk, $sk, $fv, $sv) = @_ ;
  667.        return
  668.            $fetch_key eq $fk && $store_key eq $sk && 
  669.        $fetch_value eq $fv && $store_value eq $sv &&
  670.        $_ eq 'original' ;
  671.    }
  672.    
  673.    ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  674.  
  675.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  676.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  677.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  678.    $db->filter_store_value (sub { $store_value = $_ }) ;
  679.  
  680.    $_ = "original" ;
  681.  
  682.    $h{"fred"} = "joe" ;
  683.    #                   fk   sk     fv   sv
  684.    ok(104, checkOutput( "", "fred", "", "joe")) ;
  685.  
  686.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  687.    ok(105, $h{"fred"} eq "joe");
  688.    #                   fk    sk     fv    sv
  689.    ok(106, checkOutput( "", "fred", "joe", "")) ;
  690.  
  691.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  692.    ok(107, $db->FIRSTKEY() eq "fred") ;
  693.    #                    fk     sk  fv  sv
  694.    ok(108, checkOutput( "fred", "", "", "")) ;
  695.  
  696.    # replace the filters, but remember the previous set
  697.    my ($old_fk) = $db->filter_fetch_key   
  698.                (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  699.    my ($old_sk) = $db->filter_store_key   
  700.                (sub { $_ = lc $_ ; $store_key = $_ }) ;
  701.    my ($old_fv) = $db->filter_fetch_value 
  702.                (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  703.    my ($old_sv) = $db->filter_store_value 
  704.                (sub { s/o/x/g; $store_value = $_ }) ;
  705.    
  706.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  707.    $h{"Fred"} = "Joe" ;
  708.    #                   fk   sk     fv    sv
  709.    ok(109, checkOutput( "", "fred", "", "Jxe")) ;
  710.  
  711.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  712.    ok(110, $h{"Fred"} eq "[Jxe]");
  713.    #                   fk   sk     fv    sv
  714.    ok(111, checkOutput( "", "fred", "[Jxe]", "")) ;
  715.  
  716.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  717.    ok(112, $db->FIRSTKEY() eq "FRED") ;
  718.    #                   fk   sk     fv    sv
  719.    ok(113, checkOutput( "FRED", "", "", "")) ;
  720.  
  721.    # put the original filters back
  722.    $db->filter_fetch_key   ($old_fk);
  723.    $db->filter_store_key   ($old_sk);
  724.    $db->filter_fetch_value ($old_fv);
  725.    $db->filter_store_value ($old_sv);
  726.  
  727.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  728.    $h{"fred"} = "joe" ;
  729.    ok(114, checkOutput( "", "fred", "", "joe")) ;
  730.  
  731.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  732.    ok(115, $h{"fred"} eq "joe");
  733.    ok(116, checkOutput( "", "fred", "joe", "")) ;
  734.  
  735.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  736.    ok(117, $db->FIRSTKEY() eq "fred") ;
  737.    ok(118, checkOutput( "fred", "", "", "")) ;
  738.  
  739.    # delete the filters
  740.    $db->filter_fetch_key   (undef);
  741.    $db->filter_store_key   (undef);
  742.    $db->filter_fetch_value (undef);
  743.    $db->filter_store_value (undef);
  744.  
  745.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  746.    $h{"fred"} = "joe" ;
  747.    ok(119, checkOutput( "", "", "", "")) ;
  748.  
  749.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  750.    ok(120, $h{"fred"} eq "joe");
  751.    ok(121, checkOutput( "", "", "", "")) ;
  752.  
  753.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  754.    ok(122, $db->FIRSTKEY() eq "fred") ;
  755.    ok(123, checkOutput( "", "", "", "")) ;
  756.  
  757.    undef $db ;
  758.    untie %h;
  759.    unlink $Dfile;
  760. }
  761.  
  762. {    
  763.     # DBM Filter with a closure
  764.  
  765.     use strict ;
  766.     my (%h, $db) ;
  767.  
  768.     unlink $Dfile;
  769.     ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  770.  
  771.     my %result = () ;
  772.  
  773.     sub Closure
  774.     {
  775.         my ($name) = @_ ;
  776.     my $count = 0 ;
  777.     my @kept = () ;
  778.  
  779.     return sub { ++$count ; 
  780.              push @kept, $_ ; 
  781.              $result{$name} = "$name - $count: [@kept]" ;
  782.            }
  783.     }
  784.  
  785.     $db->filter_store_key(Closure("store key")) ;
  786.     $db->filter_store_value(Closure("store value")) ;
  787.     $db->filter_fetch_key(Closure("fetch key")) ;
  788.     $db->filter_fetch_value(Closure("fetch value")) ;
  789.  
  790.     $_ = "original" ;
  791.  
  792.     $h{"fred"} = "joe" ;
  793.     ok(125, $result{"store key"} eq "store key - 1: [fred]");
  794.     ok(126, $result{"store value"} eq "store value - 1: [joe]");
  795.     ok(127, ! defined $result{"fetch key"} );
  796.     ok(128, ! defined $result{"fetch value"} );
  797.     ok(129, $_ eq "original") ;
  798.  
  799.     ok(130, $db->FIRSTKEY() eq "fred") ;
  800.     ok(131, $result{"store key"} eq "store key - 1: [fred]");
  801.     ok(132, $result{"store value"} eq "store value - 1: [joe]");
  802.     ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]");
  803.     ok(134, ! defined $result{"fetch value"} );
  804.     ok(135, $_ eq "original") ;
  805.  
  806.     $h{"jim"}  = "john" ;
  807.     ok(136, $result{"store key"} eq "store key - 2: [fred jim]");
  808.     ok(137, $result{"store value"} eq "store value - 2: [joe john]");
  809.     ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]");
  810.     ok(139, ! defined $result{"fetch value"} );
  811.     ok(140, $_ eq "original") ;
  812.  
  813.     ok(141, $h{"fred"} eq "joe");
  814.     ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]");
  815.     ok(143, $result{"store value"} eq "store value - 2: [joe john]");
  816.     ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]");
  817.     ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]");
  818.     ok(146, $_ eq "original") ;
  819.  
  820.     undef $db ;
  821.     untie %h;
  822.     unlink $Dfile;
  823. }        
  824.  
  825. {
  826.    # DBM Filter recursion detection
  827.    use strict ;
  828.    my (%h, $db) ;
  829.    unlink $Dfile;
  830.  
  831.    ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  832.  
  833.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  834.  
  835.    eval '$h{1} = 1234' ;
  836.    ok(148, $@ =~ /^recursion detected in filter_store_key at/ );
  837.    
  838.    undef $db ;
  839.    untie %h;
  840.    unlink $Dfile;
  841. }
  842.  
  843.  
  844. {
  845.    # Examples from the POD
  846.  
  847.  
  848.   my $file = "xyzt" ;
  849.   {
  850.     my $redirect = new Redirect $file ;
  851.  
  852.     # BTREE example 1
  853.     ###
  854.  
  855.     use strict ;
  856.     use DB_File ;
  857.  
  858.     my %h ;
  859.  
  860.     sub Compare
  861.     {
  862.         my ($key1, $key2) = @_ ;
  863.         "\L$key1" cmp "\L$key2" ;
  864.     }
  865.  
  866.     # specify the Perl sub that will do the comparison
  867.     $DB_BTREE->{'compare'} = \&Compare ;
  868.  
  869.     unlink "tree" ;
  870.     tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE 
  871.         or die "Cannot open file 'tree': $!\n" ;
  872.  
  873.     # Add a key/value pair to the file
  874.     $h{'Wall'} = 'Larry' ;
  875.     $h{'Smith'} = 'John' ;
  876.     $h{'mouse'} = 'mickey' ;
  877.     $h{'duck'}  = 'donald' ;
  878.  
  879.     # Delete
  880.     delete $h{"duck"} ;
  881.  
  882.     # Cycle through the keys printing them in order.
  883.     # Note it is not necessary to sort the keys as
  884.     # the btree will have kept them in order automatically.
  885.     foreach (keys %h)
  886.       { print "$_\n" }
  887.  
  888.     untie %h ;
  889.  
  890.     unlink "tree" ;
  891.   }  
  892.  
  893.   delete $DB_BTREE->{'compare'} ;
  894.  
  895.   ok(149, docat_del($file) eq <<'EOM') ;
  896. mouse
  897. Smith
  898. Wall
  899. EOM
  900.    
  901.   {
  902.     my $redirect = new Redirect $file ;
  903.  
  904.     # BTREE example 2
  905.     ###
  906.  
  907.     use strict ;
  908.     use DB_File ;
  909.  
  910.     use vars qw($filename %h ) ;
  911.  
  912.     $filename = "tree" ;
  913.     unlink $filename ;
  914.  
  915.     # Enable duplicate records
  916.     $DB_BTREE->{'flags'} = R_DUP ;
  917.  
  918.     tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  919.     or die "Cannot open $filename: $!\n";
  920.  
  921.     # Add some key/value pairs to the file
  922.     $h{'Wall'} = 'Larry' ;
  923.     $h{'Wall'} = 'Brick' ; # Note the duplicate key
  924.     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
  925.     $h{'Smith'} = 'John' ;
  926.     $h{'mouse'} = 'mickey' ;
  927.  
  928.     # iterate through the associative array
  929.     # and print each key/value pair.
  930.     foreach (keys %h)
  931.       { print "$_    -> $h{$_}\n" }
  932.  
  933.     untie %h ;
  934.  
  935.     unlink $filename ;
  936.   }  
  937.  
  938.   ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
  939. Smith    -> John
  940. Wall    -> Brick
  941. Wall    -> Brick
  942. Wall    -> Brick
  943. mouse    -> mickey
  944. EOM
  945. Smith    -> John
  946. Wall    -> Larry
  947. Wall    -> Larry
  948. Wall    -> Larry
  949. mouse    -> mickey
  950. EOM
  951.  
  952.   {
  953.     my $redirect = new Redirect $file ;
  954.  
  955.     # BTREE example 3
  956.     ###
  957.  
  958.     use strict ;
  959.     use DB_File ;
  960.  
  961.     use vars qw($filename $x %h $status $key $value) ;
  962.  
  963.     $filename = "tree" ;
  964.     unlink $filename ;
  965.  
  966.     # Enable duplicate records
  967.     $DB_BTREE->{'flags'} = R_DUP ;
  968.  
  969.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  970.     or die "Cannot open $filename: $!\n";
  971.  
  972.     # Add some key/value pairs to the file
  973.     $h{'Wall'} = 'Larry' ;
  974.     $h{'Wall'} = 'Brick' ; # Note the duplicate key
  975.     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
  976.     $h{'Smith'} = 'John' ;
  977.     $h{'mouse'} = 'mickey' ;
  978.  
  979.     # iterate through the btree using seq
  980.     # and print each key/value pair.
  981.     $key = $value = 0 ;
  982.     for ($status = $x->seq($key, $value, R_FIRST) ;
  983.          $status == 0 ;
  984.          $status = $x->seq($key, $value, R_NEXT) )
  985.       {  print "$key    -> $value\n" }
  986.  
  987.  
  988.     undef $x ;
  989.     untie %h ;
  990.   }
  991.  
  992.   ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
  993. Smith    -> John
  994. Wall    -> Brick
  995. Wall    -> Brick
  996. Wall    -> Larry
  997. mouse    -> mickey
  998. EOM
  999. Smith    -> John
  1000. Wall    -> Larry
  1001. Wall    -> Brick
  1002. Wall    -> Brick
  1003. mouse    -> mickey
  1004. EOM
  1005.  
  1006.  
  1007.   {
  1008.     my $redirect = new Redirect $file ;
  1009.  
  1010.     # BTREE example 4
  1011.     ###
  1012.  
  1013.     use strict ;
  1014.     use DB_File ;
  1015.  
  1016.     use vars qw($filename $x %h ) ;
  1017.  
  1018.     $filename = "tree" ;
  1019.  
  1020.     # Enable duplicate records
  1021.     $DB_BTREE->{'flags'} = R_DUP ;
  1022.  
  1023.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1024.     or die "Cannot open $filename: $!\n";
  1025.  
  1026.     my $cnt  = $x->get_dup("Wall") ;
  1027.     print "Wall occurred $cnt times\n" ;
  1028.  
  1029.     my %hash = $x->get_dup("Wall", 1) ;
  1030.     print "Larry is there\n" if $hash{'Larry'} ;
  1031.     print "There are $hash{'Brick'} Brick Walls\n" ;
  1032.  
  1033.     my @list = sort $x->get_dup("Wall") ;
  1034.     print "Wall =>    [@list]\n" ;
  1035.  
  1036.     @list = $x->get_dup("Smith") ;
  1037.     print "Smith =>    [@list]\n" ;
  1038.  
  1039.     @list = $x->get_dup("Dog") ;
  1040.     print "Dog =>    [@list]\n" ; 
  1041.  
  1042.     undef $x ;
  1043.     untie %h ;
  1044.   }
  1045.  
  1046.   ok(152, docat_del($file) eq <<'EOM') ;
  1047. Wall occurred 3 times
  1048. Larry is there
  1049. There are 2 Brick Walls
  1050. Wall =>    [Brick Brick Larry]
  1051. Smith =>    [John]
  1052. Dog =>    []
  1053. EOM
  1054.  
  1055.   {
  1056.     my $redirect = new Redirect $file ;
  1057.  
  1058.     # BTREE example 5
  1059.     ###
  1060.  
  1061.     use strict ;
  1062.     use DB_File ;
  1063.  
  1064.     use vars qw($filename $x %h $found) ;
  1065.  
  1066.     my $filename = "tree" ;
  1067.  
  1068.     # Enable duplicate records
  1069.     $DB_BTREE->{'flags'} = R_DUP ;
  1070.  
  1071.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1072.     or die "Cannot open $filename: $!\n";
  1073.  
  1074.     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
  1075.     print "Larry Wall is $found there\n" ;
  1076.     
  1077.     $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; 
  1078.     print "Harry Wall is $found there\n" ;
  1079.     
  1080.     undef $x ;
  1081.     untie %h ;
  1082.   }
  1083.  
  1084.   ok(153, docat_del($file) eq <<'EOM') ;
  1085. Larry Wall is  there
  1086. Harry Wall is not there
  1087. EOM
  1088.  
  1089.   {
  1090.     my $redirect = new Redirect $file ;
  1091.  
  1092.     # BTREE example 6
  1093.     ###
  1094.  
  1095.     use strict ;
  1096.     use DB_File ;
  1097.  
  1098.     use vars qw($filename $x %h $found) ;
  1099.  
  1100.     my $filename = "tree" ;
  1101.  
  1102.     # Enable duplicate records
  1103.     $DB_BTREE->{'flags'} = R_DUP ;
  1104.  
  1105.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1106.     or die "Cannot open $filename: $!\n";
  1107.  
  1108.     $x->del_dup("Wall", "Larry") ;
  1109.  
  1110.     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
  1111.     print "Larry Wall is $found there\n" ;
  1112.     
  1113.     undef $x ;
  1114.     untie %h ;
  1115.  
  1116.     unlink $filename ;
  1117.   }
  1118.  
  1119.   ok(154, docat_del($file) eq <<'EOM') ;
  1120. Larry Wall is not there
  1121. EOM
  1122.  
  1123.   {
  1124.     my $redirect = new Redirect $file ;
  1125.  
  1126.     # BTREE example 7
  1127.     ###
  1128.  
  1129.     use strict ;
  1130.     use DB_File ;
  1131.     use Fcntl ;
  1132.  
  1133.     use vars qw($filename $x %h $st $key $value) ;
  1134.  
  1135.     sub match
  1136.     {
  1137.         my $key = shift ;
  1138.         my $value = 0;
  1139.         my $orig_key = $key ;
  1140.         $x->seq($key, $value, R_CURSOR) ;
  1141.         print "$orig_key\t-> $key\t-> $value\n" ;
  1142.     }
  1143.  
  1144.     $filename = "tree" ;
  1145.     unlink $filename ;
  1146.  
  1147.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
  1148.         or die "Cannot open $filename: $!\n";
  1149.  
  1150.     # Add some key/value pairs to the file
  1151.     $h{'mouse'} = 'mickey' ;
  1152.     $h{'Wall'} = 'Larry' ;
  1153.     $h{'Walls'} = 'Brick' ; 
  1154.     $h{'Smith'} = 'John' ;
  1155.  
  1156.  
  1157.     $key = $value = 0 ;
  1158.     print "IN ORDER\n" ;
  1159.     for ($st = $x->seq($key, $value, R_FIRST) ;
  1160.      $st == 0 ;
  1161.          $st = $x->seq($key, $value, R_NEXT) )
  1162.     
  1163.       {  print "$key    -> $value\n" }
  1164.  
  1165.     print "\nPARTIAL MATCH\n" ;
  1166.  
  1167.     match "Wa" ;
  1168.     match "A" ;
  1169.     match "a" ;
  1170.  
  1171.     undef $x ;
  1172.     untie %h ;
  1173.  
  1174.     unlink $filename ;
  1175.  
  1176.   }
  1177.  
  1178.   ok(155, docat_del($file) eq <<'EOM') ;
  1179. IN ORDER
  1180. Smith    -> John
  1181. Wall    -> Larry
  1182. Walls    -> Brick
  1183. mouse    -> mickey
  1184.  
  1185. PARTIAL MATCH
  1186. Wa    -> Wall    -> Larry
  1187. A    -> Smith    -> John
  1188. a    -> mouse    -> mickey
  1189. EOM
  1190.  
  1191. }
  1192.  
  1193. #{
  1194. #   # R_SETCURSOR
  1195. #   use strict ;
  1196. #   my (%h, $db) ;
  1197. #   unlink $Dfile;
  1198. #
  1199. #   ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  1200. #
  1201. #   $h{abc} = 33 ;
  1202. #   my $k = "newest" ;
  1203. #   my $v = 44 ;
  1204. #   my $status = $db->put($k, $v, R_SETCURSOR) ;
  1205. #   print "status = [$status]\n" ;
  1206. #   ok(157, $status == 0) ;
  1207. #   $status = $db->del($k, R_CURSOR) ;
  1208. #   print "status = [$status]\n" ;
  1209. #   ok(158, $status == 0) ;
  1210. #   $k = "newest" ;
  1211. #   ok(159, $db->get($k, $v, R_CURSOR)) ;
  1212. #
  1213. #   ok(160, keys %h == 1) ;
  1214. #   
  1215. #   undef $db ;
  1216. #   untie %h;
  1217. #   unlink $Dfile;
  1218. #}
  1219.  
  1220. exit ;
  1221.