开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > 数据库系统 > MySQL数据库 > 查看源码
db-btree.t
资源名称：mysql-3.23.35.tar.gz　[点击查看]
上传用户：tsgydb
上传日期：2007-04-14
资源大小：10674k
文件大小：28k
源码类别：

MySQL数据库

开发平台：

Visual C++

db-btree.t：源码内容
  1. #!./perl -w
  3. use warnings;
  4. use strict;
  6. BEGIN {
  7.     unless(grep /blib/, @INC) {
  8.         chdir 't' if -d 't';
  9.         @INC = '../lib' if -d '../lib';
  10.     }
  11. }
  12.  
  13. use Config;
  14.  
  15. BEGIN {
  16.     if(-d "lib" && -f "TEST") {
  17.         if ($Config{'extensions'} !~ /bDB_Fileb/ ) {
  18.             print "1..157n";
  19.             exit 0;
  20.         }
  21.     }
  22. }
  24. use DB_File; 
  25. use Fcntl;
  27. print "1..157n";
  29. sub ok
  30. {
  31.     my $no = shift ;
  32.     my $result = shift ;
  33.  
  34.     print "not " unless $result ;
  35.     print "ok $non" ;
  36. }
  38. sub lexical
  39. {
  40.     my(@a) = unpack ("C*", $a) ;
  41.     my(@b) = unpack ("C*", $b) ;
  43.     my $len = (@a > @b ? @b : @a) ;
  44.     my $i = 0 ;
  46.     foreach $i ( 0 .. $len -1) {
  47.         return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
  48.     }
  50.     return @a - @b ;
  51. }
  53. {
  54.     package Redirect ;
  55.     use Symbol ;
  57.     sub new
  58.     {
  59.         my $class = shift ;
  60.         my $filename = shift ;
  61. my $fh = gensym ;
  62. open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  63. my $real_stdout = select($fh) ;
  64. return bless [$fh, $real_stdout ] ;
  66.     }
  67.     sub DESTROY
  68.     {
  69.         my $self = shift ;
  70. close $self->[0] ;
  71. select($self->[1]) ;
  72.     }
  73. }
  75. sub docat
  76. { 
  77.     my $file = shift;
  78.     #local $/ = undef unless wantarray ;
  79.     open(CAT,$file) || die "Cannot open $file: $!";
  80.     my @result = <CAT>;
  81.     close(CAT);
  82.     wantarray ? @result : join("", @result) ;
  83. }   
  85. sub docat_del
  86. { 
  87.     my $file = shift;
  88.     #local $/ = undef unless wantarray ;
  89.     open(CAT,$file) || die "Cannot open $file: $!";
  90.     my @result = <CAT>;
  91.     close(CAT);
  92.     unlink $file ;
  93.     wantarray ? @result : join("", @result) ;
  94. }   
  97. my $db185mode =  ($DB_File::db_version == 1 && ! $DB_File::db_185_compat) ;
  98. my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
  99. || $DB_File::db_ver >= 3.1 );
  101. my $Dfile = "dbbtree.tmp";
  102. unlink $Dfile;
  104. umask(0);
  106. # Check the interface to BTREEINFO
  108. my $dbh = new DB_File::BTREEINFO ;
  109. ok(1, ! defined $dbh->{flags}) ;
  110. ok(2, ! defined $dbh->{cachesize}) ;
  111. ok(3, ! defined $dbh->{psize}) ;
  112. ok(4, ! defined $dbh->{lorder}) ;
  113. ok(5, ! defined $dbh->{minkeypage}) ;
  114. ok(6, ! defined $dbh->{maxkeypage}) ;
  115. ok(7, ! defined $dbh->{compare}) ;
  116. ok(8, ! defined $dbh->{prefix}) ;
  118. $dbh->{flags} = 3000 ;
  119. ok(9, $dbh->{flags} == 3000) ;
  121. $dbh->{cachesize} = 9000 ;
  122. ok(10, $dbh->{cachesize} == 9000);
  124. $dbh->{psize} = 400 ;
  125. ok(11, $dbh->{psize} == 400) ;
  127. $dbh->{lorder} = 65 ;
  128. ok(12, $dbh->{lorder} == 65) ;
  130. $dbh->{minkeypage} = 123 ;
  131. ok(13, $dbh->{minkeypage} == 123) ;
  133. $dbh->{maxkeypage} = 1234 ;
  134. ok(14, $dbh->{maxkeypage} == 1234 );
  136. $dbh->{compare} = 1234 ;
  137. ok(15, $dbh->{compare} == 1234) ;
  139. $dbh->{prefix} = 1234 ;
  140. ok(16, $dbh->{prefix} == 1234 );
  142. # Check that an invalid entry is caught both for store & fetch
  143. eval '$dbh->{fred} = 1234' ;
  144. ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
  145. eval 'my $q = $dbh->{fred}' ;
  146. ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
  148. # Now check the interface to BTREE
  150. my ($X, %h) ;
  151. ok(19, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ;
  153. my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  154.    $blksize,$blocks) = stat($Dfile);
  155. ok(20, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
  157. my ($key, $value, $i);
  158. while (($key,$value) = each(%h)) {
  159.     $i++;
  160. }
  161. ok(21, !$i ) ;
  163. $h{'goner1'} = 'snork';
  165. $h{'abc'} = 'ABC';
  166. ok(22, $h{'abc'} eq 'ABC' );
  167. ok(23, ! defined $h{'jimmy'} ) ;
  168. ok(24, ! exists $h{'jimmy'} ) ;
  169. ok(25,  defined $h{'abc'} ) ;
  171. $h{'def'} = 'DEF';
  172. $h{'jkl','mno'} = "JKL34MNO";
  173. $h{'a',2,3,4,5} = join("34",'A',2,3,4,5);
  174. $h{'a'} = 'A';
  176. #$h{'b'} = 'B';
  177. $X->STORE('b', 'B') ;
  179. $h{'c'} = 'C';
  181. #$h{'d'} = 'D';
  182. $X->put('d', 'D') ;
  184. $h{'e'} = 'E';
  185. $h{'f'} = 'F';
  186. $h{'g'} = 'X';
  187. $h{'h'} = 'H';
  188. $h{'i'} = 'I';
  190. $h{'goner2'} = 'snork';
  191. delete $h{'goner2'};
  194. # IMPORTANT - $X must be undefined before the untie otherwise the
  195. #             underlying DB close routine will not get called.
  196. undef $X ;
  197. untie(%h);
  199. # tie to the same file again
  200. ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
  202. # Modify an entry from the previous tie
  203. $h{'g'} = 'G';
  205. $h{'j'} = 'J';
  206. $h{'k'} = 'K';
  207. $h{'l'} = 'L';
  208. $h{'m'} = 'M';
  209. $h{'n'} = 'N';
  210. $h{'o'} = 'O';
  211. $h{'p'} = 'P';
  212. $h{'q'} = 'Q';
  213. $h{'r'} = 'R';
  214. $h{'s'} = 'S';
  215. $h{'t'} = 'T';
  216. $h{'u'} = 'U';
  217. $h{'v'} = 'V';
  218. $h{'w'} = 'W';
  219. $h{'x'} = 'X';
  220. $h{'y'} = 'Y';
  221. $h{'z'} = 'Z';
  223. $h{'goner3'} = 'snork';
  225. delete $h{'goner1'};
  226. $X->DELETE('goner3');
  228. my @keys = keys(%h);
  229. my @values = values(%h);
  231. ok(27, $#keys == 29 && $#values == 29) ;
  233. $i = 0 ;
  234. while (($key,$value) = each(%h)) {
  235.     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  236. $key =~ y/a-z/A-Z/;
  237. $i++ if $key eq $value;
  238.     }
  239. }
  241. ok(28, $i == 30) ;
  243. @keys = ('blurfl', keys(%h), 'dyick');
  244. ok(29, $#keys == 31) ;
  246. #Check that the keys can be retrieved in order
  247. my @b = keys %h ;
  248. my @c = sort lexical @b ;
  249. ok(30, ArrayCompare(@b, @c)) ;
  251. $h{'foo'} = '';
  252. ok(31, $h{'foo'} eq '' ) ;
  254. # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
  255. # This feature was reenabled in version 3.1 of Berkeley DB.
  256. my $result = 0 ;
  257. if ($null_keys_allowed) {
  258.     $h{''} = 'bar';
  259.     $result = ( $h{''} eq 'bar' );
  260. }
  261. else
  262.   { $result = 1 }
  263. ok(32, $result) ;
  265. # check cache overflow and numeric keys and contents
  266. my $ok = 1;
  267. for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  268. for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  269. ok(33, $ok);
  271. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  272.    $blksize,$blocks) = stat($Dfile);
  273. ok(34, $size > 0 );
  275. @h{0..200} = 200..400;
  276. my @foo = @h{0..200};
  277. ok(35, join(':',200..400) eq join(':',@foo) );
  279. # Now check all the non-tie specific stuff
  282. # Check R_NOOVERWRITE flag will make put fail when attempting to overwrite
  283. # an existing record.
  284.  
  285. my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
  286. ok(36, $status == 1 );
  287.  
  288. # check that the value of the key 'x' has not been changed by the 
  289. # previous test
  290. ok(37, $h{'x'} eq 'X' );
  292. # standard put
  293. $status = $X->put('key', 'value') ;
  294. ok(38, $status == 0 );
  296. #check that previous put can be retrieved
  297. $value = 0 ;
  298. $status = $X->get('key', $value) ;
  299. ok(39, $status == 0 );
  300. ok(40, $value eq 'value' );
  302. # Attempting to delete an existing key should work
  304. $status = $X->del('q') ;
  305. ok(41, $status == 0 );
  306. if ($null_keys_allowed) {
  307.     $status = $X->del('') ;
  308. } else {
  309.     $status = 0 ;
  310. }
  311. ok(42, $status == 0 );
  313. # Make sure that the key deleted, cannot be retrieved
  314. ok(43, ! defined $h{'q'}) ;
  315. ok(44, ! defined $h{''}) ;
  317. undef $X ;
  318. untie %h ;
  320. ok(45, $X = tie(%h, 'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE ));
  322. # Attempting to delete a non-existant key should fail
  324. $status = $X->del('joe') ;
  325. ok(46, $status == 1 );
  327. # Check the get interface
  329. # First a non-existing key
  330. $status = $X->get('aaaa', $value) ;
  331. ok(47, $status == 1 );
  333. # Next an existing key
  334. $status = $X->get('a', $value) ;
  335. ok(48, $status == 0 );
  336. ok(49, $value eq 'A' );
  338. # seq
  339. # ###
  341. # use seq to find an approximate match
  342. $key = 'ke' ;
  343. $value = '' ;
  344. $status = $X->seq($key, $value, R_CURSOR) ;
  345. ok(50, $status == 0 );
  346. ok(51, $key eq 'key' );
  347. ok(52, $value eq 'value' );
  349. # seq when the key does not match
  350. $key = 'zzz' ;
  351. $value = '' ;
  352. $status = $X->seq($key, $value, R_CURSOR) ;
  353. ok(53, $status == 1 );
  356. # use seq to set the cursor, then delete the record @ the cursor.
  358. $key = 'x' ;
  359. $value = '' ;
  360. $status = $X->seq($key, $value, R_CURSOR) ;
  361. ok(54, $status == 0 );
  362. ok(55, $key eq 'x' );
  363. ok(56, $value eq 'X' );
  364. $status = $X->del(0, R_CURSOR) ;
  365. ok(57, $status == 0 );
  366. $status = $X->get('x', $value) ;
  367. ok(58, $status == 1 );
  369. # ditto, but use put to replace the key/value pair.
  370. $key = 'y' ;
  371. $value = '' ;
  372. $status = $X->seq($key, $value, R_CURSOR) ;
  373. ok(59, $status == 0 );
  374. ok(60, $key eq 'y' );
  375. ok(61, $value eq 'Y' );
  377. $key = "replace key" ;
  378. $value = "replace value" ;
  379. $status = $X->put($key, $value, R_CURSOR) ;
  380. ok(62, $status == 0 );
  381. ok(63, $key eq 'replace key' );
  382. ok(64, $value eq 'replace value' );
  383. $status = $X->get('y', $value) ;
  384. ok(65, 1) ; # hard-wire to always pass. the previous test ($status == 1)
  385.     # only worked because of a bug in 1.85/6
  387. # use seq to walk forwards through a file 
  389. $status = $X->seq($key, $value, R_FIRST) ;
  390. ok(66, $status == 0 );
  391. my $previous = $key ;
  393. $ok = 1 ;
  394. while (($status = $X->seq($key, $value, R_NEXT)) == 0)
  395. {
  396.     ($ok = 0), last if ($previous cmp $key) == 1 ;
  397. }
  399. ok(67, $status == 1 );
  400. ok(68, $ok == 1 );
  402. # use seq to walk backwards through a file 
  403. $status = $X->seq($key, $value, R_LAST) ;
  404. ok(69, $status == 0 );
  405. $previous = $key ;
  407. $ok = 1 ;
  408. while (($status = $X->seq($key, $value, R_PREV)) == 0)
  409. {
  410.     ($ok = 0), last if ($previous cmp $key) == -1 ;
  411.     #print "key = [$key] value = [$value]n" ;
  412. }
  414. ok(70, $status == 1 );
  415. ok(71, $ok == 1 );
  418. # check seq FIRST/LAST
  420. # sync
  421. # ####
  423. $status = $X->sync ;
  424. ok(72, $status == 0 );
  427. # fd
  428. # ##
  430. $status = $X->fd ;
  431. ok(73, $status != 0 );
  434. undef $X ;
  435. untie %h ;
  437. unlink $Dfile;
  439. # Now try an in memory file
  440. my $Y;
  441. ok(74, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));
  443. # fd with an in memory file should return failure
  444. $status = $Y->fd ;
  445. ok(75, $status == -1 );
  448. undef $Y ;
  449. untie %h ;
  451. # Duplicate keys
  452. my $bt = new DB_File::BTREEINFO ;
  453. $bt->{flags} = R_DUP ;
  454. my ($YY, %hh);
  455. ok(76, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;
  457. $hh{'Wall'} = 'Larry' ;
  458. $hh{'Wall'} = 'Stone' ; # Note the duplicate key
  459. $hh{'Wall'} = 'Brick' ; # Note the duplicate key
  460. $hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
  461. $hh{'Smith'} = 'John' ;
  462. $hh{'mouse'} = 'mickey' ;
  464. # first work in scalar context
  465. ok(77, scalar $YY->get_dup('Unknown') == 0 );
  466. ok(78, scalar $YY->get_dup('Smith') == 1 );
  467. ok(79, scalar $YY->get_dup('Wall') == 4 );
  469. # now in list context
  470. my @unknown = $YY->get_dup('Unknown') ;
  471. ok(80, "@unknown" eq "" );
  473. my @smith = $YY->get_dup('Smith') ;
  474. ok(81, "@smith" eq "John" );
  476. {
  477. my @wall = $YY->get_dup('Wall') ;
  478. my %wall ;
  479. @wall{@wall} = @wall ;
  480. ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
  481. }
  483. # hash
  484. my %unknown = $YY->get_dup('Unknown', 1) ;
  485. ok(83, keys %unknown == 0 );
  487. my %smith = $YY->get_dup('Smith', 1) ;
  488. ok(84, keys %smith == 1 && $smith{'John'}) ;
  490. my %wall = $YY->get_dup('Wall', 1) ;
  491. ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1 
  492. && $wall{'Brick'} == 2);
  494. undef $YY ;
  495. untie %hh ;
  496. unlink $Dfile;
  499. # test multiple callbacks
  500. my $Dfile1 = "btree1" ;
  501. my $Dfile2 = "btree2" ;
  502. my $Dfile3 = "btree3" ;
  503.  
  504. my $dbh1 = new DB_File::BTREEINFO ;
  505. $dbh1->{compare} = sub { 
  506. no warnings 'numeric' ;
  507. $_[0] <=> $_[1] } ; 
  508.  
  509. my $dbh2 = new DB_File::BTREEINFO ;
  510. $dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
  511.  
  512. my $dbh3 = new DB_File::BTREEINFO ;
  513. $dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;
  514.  
  515.  
  516. my (%g, %k);
  517. tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) ; 
  518. tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) ;
  519. tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) ;
  520.  
  521. my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
  522. my (@srt_1, @srt_2, @srt_3);
  523. { 
  524.   no warnings 'numeric' ;
  525.   @srt_1 = sort { $a <=> $b } @Keys ; 
  526. }
  527. @srt_2 = sort { $a cmp $b } @Keys ;
  528. @srt_3 = sort { length $a <=> length $b } @Keys ;
  529.  
  530. foreach (@Keys) {
  531.     $h{$_} = 1 ;
  532.     $g{$_} = 1 ;
  533.     $k{$_} = 1 ;
  534. }
  535.  
  536. sub ArrayCompare
  537. {
  538.     my($a, $b) = @_ ;
  539.  
  540.     return 0 if @$a != @$b ;
  541.  
  542.     foreach (1 .. length @$a)
  543.     {
  544.         return 0 unless $$a[$_] eq $$b[$_] ;
  545.     }
  546.  
  547.     1 ;
  548. }
  549.  
  550. ok(86, ArrayCompare (@srt_1, [keys %h]) );
  551. ok(87, ArrayCompare (@srt_2, [keys %g]) );
  552. ok(88, ArrayCompare (@srt_3, [keys %k]) );
  554. untie %h ;
  555. untie %g ;
  556. untie %k ;
  557. unlink $Dfile1, $Dfile2, $Dfile3 ;
  559. # clear
  560. # #####
  562. ok(89, tie(%h, 'DB_File', $Dfile1, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  563. foreach (1 .. 10)
  564.   { $h{$_} = $_ * 100 }
  566. # check that there are 10 elements in the hash
  567. $i = 0 ;
  568. while (($key,$value) = each(%h)) {
  569.     $i++;
  570. }
  571. ok(90, $i == 10);
  573. # now clear the hash
  574. %h = () ;
  576. # check it is empty
  577. $i = 0 ;
  578. while (($key,$value) = each(%h)) {
  579.     $i++;
  580. }
  581. ok(91, $i == 0);
  583. untie %h ;
  584. unlink $Dfile1 ;
  586. {
  587.     # check that attempting to tie an array to a DB_BTREE will fail
  589.     my $filename = "xyz" ;
  590.     my @x ;
  591.     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE ; } ;
  592.     ok(92, $@ =~ /^DB_File can only tie an associative array to a DB_BTREE database/) ;
  593.     unlink $filename ;
  594. }
  596. {
  597.    # sub-class test
  599.    package Another ;
  601.    use warnings ;
  602.    use strict ;
  604.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  605.    print FILE <<'EOM' ;
  607.    package SubDB ;
  609.    use warnings ;
  610.    use strict ;
  611.    use vars qw( @ISA @EXPORT) ;
  613.    require Exporter ;
  614.    use DB_File;
  615.    @ISA=qw(DB_File);
  616.    @EXPORT = @DB_File::EXPORT ;
  618.    sub STORE { 
  619. my $self = shift ;
  620.         my $key = shift ;
  621.         my $value = shift ;
  622.         $self->SUPER::STORE($key, $value * 2) ;
  623.    }
  625.    sub FETCH { 
  626. my $self = shift ;
  627.         my $key = shift ;
  628.         $self->SUPER::FETCH($key) - 1 ;
  629.    }
  631.    sub put { 
  632. my $self = shift ;
  633.         my $key = shift ;
  634.         my $value = shift ;
  635.         $self->SUPER::put($key, $value * 3) ;
  636.    }
  638.    sub get { 
  639. my $self = shift ;
  640.         $self->SUPER::get($_[0], $_[1]) ;
  641. $_[1] -= 2 ;
  642.    }
  644.    sub A_new_method
  645.    {
  646. my $self = shift ;
  647.         my $key = shift ;
  648.         my $value = $self->FETCH($key) ;
  649. return "[[$value]]" ;
  650.    }
  652.    1 ;
  653. EOM
  655.     close FILE ;
  657.     BEGIN { push @INC, '.'; }    
  658.     eval 'use SubDB ; ';
  659.     main::ok(93, $@ eq "") ;
  660.     my %h ;
  661.     my $X ;
  662.     eval '
  663. $X = tie(%h, "SubDB","dbbtree.tmp", O_RDWR|O_CREAT, 0640, $DB_BTREE );
  664. ' ;
  666.     main::ok(94, $@ eq "") ;
  668.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  669.     main::ok(95, $@ eq "") ;
  670.     main::ok(96, $ret == 5) ;
  672.     my $value = 0;
  673.     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
  674.     main::ok(97, $@ eq "") ;
  675.     main::ok(98, $ret == 10) ;
  677.     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
  678.     main::ok(99, $@ eq "" ) ;
  679.     main::ok(100, $ret == 1) ;
  681.     $ret = eval '$X->A_new_method("joe") ' ;
  682.     main::ok(101, $@ eq "") ;
  683.     main::ok(102, $ret eq "[[11]]") ;
  685.     undef $X;
  686.     untie(%h);
  687.     unlink "SubDB.pm", "dbbtree.tmp" ;
  689. }
  691. {
  692.    # DBM Filter tests
  693.    use warnings ;
  694.    use strict ;
  695.    my (%h, $db) ;
  696.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  697.    unlink $Dfile;
  699.    sub checkOutput
  700.    {
  701.        my($fk, $sk, $fv, $sv) = @_ ;
  702.        return
  703.            $fetch_key eq $fk && $store_key eq $sk && 
  704.    $fetch_value eq $fv && $store_value eq $sv &&
  705.    $_ eq 'original' ;
  706.    }
  707.    
  708.    ok(103, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  710.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  711.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  712.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  713.    $db->filter_store_value (sub { $store_value = $_ }) ;
  715.    $_ = "original" ;
  717.    $h{"fred"} = "joe" ;
  718.    #                   fk   sk     fv   sv
  719.    ok(104, checkOutput( "", "fred", "", "joe")) ;
  721.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  722.    ok(105, $h{"fred"} eq "joe");
  723.    #                   fk    sk     fv    sv
  724.    ok(106, checkOutput( "", "fred", "joe", "")) ;
  726.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  727.    ok(107, $db->FIRSTKEY() eq "fred") ;
  728.    #                    fk     sk  fv  sv
  729.    ok(108, checkOutput( "fred", "", "", "")) ;
  731.    # replace the filters, but remember the previous set
  732.    my ($old_fk) = $db->filter_fetch_key   
  733.     (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  734.    my ($old_sk) = $db->filter_store_key   
  735.     (sub { $_ = lc $_ ; $store_key = $_ }) ;
  736.    my ($old_fv) = $db->filter_fetch_value 
  737.     (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  738.    my ($old_sv) = $db->filter_store_value 
  739.     (sub { s/o/x/g; $store_value = $_ }) ;
  740.    
  741.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  742.    $h{"Fred"} = "Joe" ;
  743.    #                   fk   sk     fv    sv
  744.    ok(109, checkOutput( "", "fred", "", "Jxe")) ;
  746.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  747.    ok(110, $h{"Fred"} eq "[Jxe]");
  748.    #                   fk   sk     fv    sv
  749.    ok(111, checkOutput( "", "fred", "[Jxe]", "")) ;
  751.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  752.    ok(112, $db->FIRSTKEY() eq "FRED") ;
  753.    #                   fk   sk     fv    sv
  754.    ok(113, checkOutput( "FRED", "", "", "")) ;
  756.    # put the original filters back
  757.    $db->filter_fetch_key   ($old_fk);
  758.    $db->filter_store_key   ($old_sk);
  759.    $db->filter_fetch_value ($old_fv);
  760.    $db->filter_store_value ($old_sv);
  762.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  763.    $h{"fred"} = "joe" ;
  764.    ok(114, checkOutput( "", "fred", "", "joe")) ;
  766.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  767.    ok(115, $h{"fred"} eq "joe");
  768.    ok(116, checkOutput( "", "fred", "joe", "")) ;
  770.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  771.    ok(117, $db->FIRSTKEY() eq "fred") ;
  772.    ok(118, checkOutput( "fred", "", "", "")) ;
  774.    # delete the filters
  775.    $db->filter_fetch_key   (undef);
  776.    $db->filter_store_key   (undef);
  777.    $db->filter_fetch_value (undef);
  778.    $db->filter_store_value (undef);
  780.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  781.    $h{"fred"} = "joe" ;
  782.    ok(119, checkOutput( "", "", "", "")) ;
  784.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  785.    ok(120, $h{"fred"} eq "joe");
  786.    ok(121, checkOutput( "", "", "", "")) ;
  788.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  789.    ok(122, $db->FIRSTKEY() eq "fred") ;
  790.    ok(123, checkOutput( "", "", "", "")) ;
  792.    undef $db ;
  793.    untie %h;
  794.    unlink $Dfile;
  795. }
  797. {    
  798.     # DBM Filter with a closure
  800.     use warnings ;
  801.     use strict ;
  802.     my (%h, $db) ;
  804.     unlink $Dfile;
  805.     ok(124, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  807.     my %result = () ;
  809.     sub Closure
  810.     {
  811.         my ($name) = @_ ;
  812. my $count = 0 ;
  813. my @kept = () ;
  815. return sub { ++$count ; 
  816.      push @kept, $_ ; 
  817.      $result{$name} = "$name - $count: [@kept]" ;
  818.    }
  819.     }
  821.     $db->filter_store_key(Closure("store key")) ;
  822.     $db->filter_store_value(Closure("store value")) ;
  823.     $db->filter_fetch_key(Closure("fetch key")) ;
  824.     $db->filter_fetch_value(Closure("fetch value")) ;
  826.     $_ = "original" ;
  828.     $h{"fred"} = "joe" ;
  829.     ok(125, $result{"store key"} eq "store key - 1: [fred]");
  830.     ok(126, $result{"store value"} eq "store value - 1: [joe]");
  831.     ok(127, ! defined $result{"fetch key"} );
  832.     ok(128, ! defined $result{"fetch value"} );
  833.     ok(129, $_ eq "original") ;
  835.     ok(130, $db->FIRSTKEY() eq "fred") ;
  836.     ok(131, $result{"store key"} eq "store key - 1: [fred]");
  837.     ok(132, $result{"store value"} eq "store value - 1: [joe]");
  838.     ok(133, $result{"fetch key"} eq "fetch key - 1: [fred]");
  839.     ok(134, ! defined $result{"fetch value"} );
  840.     ok(135, $_ eq "original") ;
  842.     $h{"jim"}  = "john" ;
  843.     ok(136, $result{"store key"} eq "store key - 2: [fred jim]");
  844.     ok(137, $result{"store value"} eq "store value - 2: [joe john]");
  845.     ok(138, $result{"fetch key"} eq "fetch key - 1: [fred]");
  846.     ok(139, ! defined $result{"fetch value"} );
  847.     ok(140, $_ eq "original") ;
  849.     ok(141, $h{"fred"} eq "joe");
  850.     ok(142, $result{"store key"} eq "store key - 3: [fred jim fred]");
  851.     ok(143, $result{"store value"} eq "store value - 2: [joe john]");
  852.     ok(144, $result{"fetch key"} eq "fetch key - 1: [fred]");
  853.     ok(145, $result{"fetch value"} eq "fetch value - 1: [joe]");
  854.     ok(146, $_ eq "original") ;
  856.     undef $db ;
  857.     untie %h;
  858.     unlink $Dfile;
  859. }
  861. {
  862.    # DBM Filter recursion detection
  863.    use warnings ;
  864.    use strict ;
  865.    my (%h, $db) ;
  866.    unlink $Dfile;
  868.    ok(147, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  870.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  872.    eval '$h{1} = 1234' ;
  873.    ok(148, $@ =~ /^recursion detected in filter_store_key at/ );
  874.    
  875.    undef $db ;
  876.    untie %h;
  877.    unlink $Dfile;
  878. }
  881. {
  882.    # Examples from the POD
  885.   my $file = "xyzt" ;
  886.   {
  887.     my $redirect = new Redirect $file ;
  889.     # BTREE example 1
  890.     ###
  892.     use warnings FATAL => qw(all) ;
  893.     use strict ;
  894.     use DB_File ;
  896.     my %h ;
  898.     sub Compare
  899.     {
  900.         my ($key1, $key2) = @_ ;
  901.         "L$key1" cmp "L$key2" ;
  902.     }
  904.     # specify the Perl sub that will do the comparison
  905.     $DB_BTREE->{'compare'} = &Compare ;
  907.     unlink "tree" ;
  908.     tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE 
  909.         or die "Cannot open file 'tree': $!n" ;
  911.     # Add a key/value pair to the file
  912.     $h{'Wall'} = 'Larry' ;
  913.     $h{'Smith'} = 'John' ;
  914.     $h{'mouse'} = 'mickey' ;
  915.     $h{'duck'}  = 'donald' ;
  917.     # Delete
  918.     delete $h{"duck"} ;
  920.     # Cycle through the keys printing them in order.
  921.     # Note it is not necessary to sort the keys as
  922.     # the btree will have kept them in order automatically.
  923.     foreach (keys %h)
  924.       { print "$_n" }
  926.     untie %h ;
  928.     unlink "tree" ;
  929.   }  
  931.   delete $DB_BTREE->{'compare'} ;
  933.   ok(149, docat_del($file) eq <<'EOM') ;
  934. mouse
  935. Smith
  936. Wall
  937. EOM
  938.    
  939.   {
  940.     my $redirect = new Redirect $file ;
  942.     # BTREE example 2
  943.     ###
  945.     use warnings FATAL => qw(all) ;
  946.     use strict ;
  947.     use DB_File ;
  949.     use vars qw($filename %h ) ;
  951.     $filename = "tree" ;
  952.     unlink $filename ;
  953.  
  954.     # Enable duplicate records
  955.     $DB_BTREE->{'flags'} = R_DUP ;
  956.  
  957.     tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  958. or die "Cannot open $filename: $!n";
  959.  
  960.     # Add some key/value pairs to the file
  961.     $h{'Wall'} = 'Larry' ;
  962.     $h{'Wall'} = 'Brick' ; # Note the duplicate key
  963.     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
  964.     $h{'Smith'} = 'John' ;
  965.     $h{'mouse'} = 'mickey' ;
  967.     # iterate through the associative array
  968.     # and print each key/value pair.
  969.     foreach (keys %h)
  970.       { print "$_ -> $h{$_}n" }
  972.     untie %h ;
  974.     unlink $filename ;
  975.   }  
  977.   ok(150, docat_del($file) eq ($db185mode ? <<'EOM' : <<'EOM') ) ;
  978. Smith -> John
  979. Wall -> Brick
  980. Wall -> Brick
  981. Wall -> Brick
  982. mouse -> mickey
  983. EOM
  984. Smith -> John
  985. Wall -> Larry
  986. Wall -> Larry
  987. Wall -> Larry
  988. mouse -> mickey
  989. EOM
  991.   {
  992.     my $redirect = new Redirect $file ;
  994.     # BTREE example 3
  995.     ###
  997.     use warnings FATAL => qw(all) ;
  998.     use strict ;
  999.     use DB_File ;
  1000.  
  1001.     use vars qw($filename $x %h $status $key $value) ;
  1003.     $filename = "tree" ;
  1004.     unlink $filename ;
  1005.  
  1006.     # Enable duplicate records
  1007.     $DB_BTREE->{'flags'} = R_DUP ;
  1008.  
  1009.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1010. or die "Cannot open $filename: $!n";
  1011.  
  1012.     # Add some key/value pairs to the file
  1013.     $h{'Wall'} = 'Larry' ;
  1014.     $h{'Wall'} = 'Brick' ; # Note the duplicate key
  1015.     $h{'Wall'} = 'Brick' ; # Note the duplicate key and value
  1016.     $h{'Smith'} = 'John' ;
  1017.     $h{'mouse'} = 'mickey' ;
  1018.  
  1019.     # iterate through the btree using seq
  1020.     # and print each key/value pair.
  1021.     $key = $value = 0 ;
  1022.     for ($status = $x->seq($key, $value, R_FIRST) ;
  1023.          $status == 0 ;
  1024.          $status = $x->seq($key, $value, R_NEXT) )
  1025.       {  print "$key -> $valuen" }
  1026.  
  1027.  
  1028.     undef $x ;
  1029.     untie %h ;
  1030.   }
  1032.   ok(151, docat_del($file) eq ($db185mode == 1 ? <<'EOM' : <<'EOM') ) ;
  1033. Smith -> John
  1034. Wall -> Brick
  1035. Wall -> Brick
  1036. Wall -> Larry
  1037. mouse -> mickey
  1038. EOM
  1039. Smith -> John
  1040. Wall -> Larry
  1041. Wall -> Brick
  1042. Wall -> Brick
  1043. mouse -> mickey
  1044. EOM
  1047.   {
  1048.     my $redirect = new Redirect $file ;
  1050.     # BTREE example 4
  1051.     ###
  1053.     use warnings FATAL => qw(all) ;
  1054.     use strict ;
  1055.     use DB_File ;
  1056.  
  1057.     use vars qw($filename $x %h ) ;
  1059.     $filename = "tree" ;
  1060.  
  1061.     # Enable duplicate records
  1062.     $DB_BTREE->{'flags'} = R_DUP ;
  1063.  
  1064.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1065. or die "Cannot open $filename: $!n";
  1066.  
  1067.     my $cnt  = $x->get_dup("Wall") ;
  1068.     print "Wall occurred $cnt timesn" ;
  1070.     my %hash = $x->get_dup("Wall", 1) ;
  1071.     print "Larry is theren" if $hash{'Larry'} ;
  1072.     print "There are $hash{'Brick'} Brick Wallsn" ;
  1074.     my @list = sort $x->get_dup("Wall") ;
  1075.     print "Wall => [@list]n" ;
  1077.     @list = $x->get_dup("Smith") ;
  1078.     print "Smith => [@list]n" ;
  1079.  
  1080.     @list = $x->get_dup("Dog") ;
  1081.     print "Dog => [@list]n" ; 
  1082.  
  1083.     undef $x ;
  1084.     untie %h ;
  1085.   }
  1087.   ok(152, docat_del($file) eq <<'EOM') ;
  1088. Wall occurred 3 times
  1089. Larry is there
  1090. There are 2 Brick Walls
  1091. Wall => [Brick Brick Larry]
  1092. Smith => [John]
  1093. Dog => []
  1094. EOM
  1096.   {
  1097.     my $redirect = new Redirect $file ;
  1099.     # BTREE example 5
  1100.     ###
  1102.     use warnings FATAL => qw(all) ;
  1103.     use strict ;
  1104.     use DB_File ;
  1105.  
  1106.     use vars qw($filename $x %h $found) ;
  1108.     my $filename = "tree" ;
  1109.  
  1110.     # Enable duplicate records
  1111.     $DB_BTREE->{'flags'} = R_DUP ;
  1112.  
  1113.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1114. or die "Cannot open $filename: $!n";
  1116.     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
  1117.     print "Larry Wall is $found theren" ;
  1118.     
  1119.     $found = ( $x->find_dup("Wall", "Harry") == 0 ? "" : "not") ; 
  1120.     print "Harry Wall is $found theren" ;
  1121.     
  1122.     undef $x ;
  1123.     untie %h ;
  1124.   }
  1126.   ok(153, docat_del($file) eq <<'EOM') ;
  1127. Larry Wall is  there
  1128. Harry Wall is not there
  1129. EOM
  1131.   {
  1132.     my $redirect = new Redirect $file ;
  1134.     # BTREE example 6
  1135.     ###
  1137.     use warnings FATAL => qw(all) ;
  1138.     use strict ;
  1139.     use DB_File ;
  1140.  
  1141.     use vars qw($filename $x %h $found) ;
  1143.     my $filename = "tree" ;
  1144.  
  1145.     # Enable duplicate records
  1146.     $DB_BTREE->{'flags'} = R_DUP ;
  1147.  
  1148.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE 
  1149. or die "Cannot open $filename: $!n";
  1151.     $x->del_dup("Wall", "Larry") ;
  1153.     $found = ( $x->find_dup("Wall", "Larry") == 0 ? "" : "not") ; 
  1154.     print "Larry Wall is $found theren" ;
  1155.     
  1156.     undef $x ;
  1157.     untie %h ;
  1159.     unlink $filename ;
  1160.   }
  1162.   ok(154, docat_del($file) eq <<'EOM') ;
  1163. Larry Wall is not there
  1164. EOM
  1166.   {
  1167.     my $redirect = new Redirect $file ;
  1169.     # BTREE example 7
  1170.     ###
  1172.     use warnings FATAL => qw(all) ;
  1173.     use strict ;
  1174.     use DB_File ;
  1175.     use Fcntl ;
  1177.     use vars qw($filename $x %h $st $key $value) ;
  1179.     sub match
  1180.     {
  1181.         my $key = shift ;
  1182.         my $value = 0;
  1183.         my $orig_key = $key ;
  1184.         $x->seq($key, $value, R_CURSOR) ;
  1185.         print "$orig_keyt-> $keyt-> $valuen" ;
  1186.     }
  1188.     $filename = "tree" ;
  1189.     unlink $filename ;
  1191.     $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
  1192.         or die "Cannot open $filename: $!n";
  1193.  
  1194.     # Add some key/value pairs to the file
  1195.     $h{'mouse'} = 'mickey' ;
  1196.     $h{'Wall'} = 'Larry' ;
  1197.     $h{'Walls'} = 'Brick' ; 
  1198.     $h{'Smith'} = 'John' ;
  1199.  
  1201.     $key = $value = 0 ;
  1202.     print "IN ORDERn" ;
  1203.     for ($st = $x->seq($key, $value, R_FIRST) ;
  1204.  $st == 0 ;
  1205.          $st = $x->seq($key, $value, R_NEXT) )
  1207.       {  print "$key -> $valuen" }
  1208.  
  1209.     print "nPARTIAL MATCHn" ;
  1211.     match "Wa" ;
  1212.     match "A" ;
  1213.     match "a" ;
  1215.     undef $x ;
  1216.     untie %h ;
  1218.     unlink $filename ;
  1220.   }
  1222.   ok(155, docat_del($file) eq <<'EOM') ;
  1223. IN ORDER
  1224. Smith -> John
  1225. Wall -> Larry
  1226. Walls -> Brick
  1227. mouse -> mickey
  1229. PARTIAL MATCH
  1230. Wa -> Wall -> Larry
  1231. A -> Smith -> John
  1232. a -> mouse -> mickey
  1233. EOM
  1235. }
  1237. #{
  1238. #   # R_SETCURSOR
  1239. #   use strict ;
  1240. #   my (%h, $db) ;
  1241. #   unlink $Dfile;
  1242. #
  1243. #   ok(156, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE ) );
  1244. #
  1245. #   $h{abc} = 33 ;
  1246. #   my $k = "newest" ;
  1247. #   my $v = 44 ;
  1248. #   my $status = $db->put($k, $v, R_SETCURSOR) ;
  1249. #   print "status = [$status]n" ;
  1250. #   ok(157, $status == 0) ;
  1251. #   $status = $db->del($k, R_CURSOR) ;
  1252. #   print "status = [$status]n" ;
  1253. #   ok(158, $status == 0) ;
  1254. #   $k = "newest" ;
  1255. #   ok(159, $db->get($k, $v, R_CURSOR)) ;
  1256. #
  1257. #   ok(160, keys %h == 1) ;
  1258. #   
  1259. #   undef $db ;
  1260. #   untie %h;
  1261. #   unlink $Dfile;
  1262. #}
  1264. {
  1265.     # Bug ID 20001013.009
  1266.     #
  1267.     # test that $hash{KEY} = undef doesn't produce the warning
  1268.     #     Use of uninitialized value in null operation 
  1269.     use warnings ;
  1270.     use strict ;
  1271.     use DB_File ;
  1273.     unlink $Dfile;
  1274.     my %h ;
  1275.     my $a = "";
  1276.     local $SIG{__WARN__} = sub {$a = $_[0]} ;
  1277.     
  1278.     tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
  1279. or die "Can't open file: $!n" ;
  1280.     $h{ABC} = undef;
  1281.     ok(156, $a eq "") ;
  1282.     untie %h ;
  1283.     unlink $Dfile;
  1284. }
  1286. {
  1287.     # test that %hash = () doesn't produce the warning
  1288.     #     Argument "" isn't numeric in entersub
  1289.     use warnings ;
  1290.     use strict ;
  1291.     use DB_File ;
  1293.     unlink $Dfile;
  1294.     my %h ;
  1295.     my $a = "";
  1296.     local $SIG{__WARN__} = sub {$a = $_[0]} ;
  1297.     
  1298.     tie %h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_BTREE
  1299. or die "Can't open file: $!n" ;
  1300.     %h = (); ;
  1301.     ok(157, $a eq "") ;
  1302.     untie %h ;
  1303.     unlink $Dfile;
  1304. }
  1306. exit ;