home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / db-hash.t < prev    next >
Text File  |  1999-08-20  |  16KB  |  686 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..109\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. {
  27.     package Redirect ;
  28.     use Symbol ;
  29.  
  30.     sub new
  31.     {
  32.         my $class = shift ;
  33.         my $filename = shift ;
  34.     my $fh = gensym ;
  35.     open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  36.     my $real_stdout = select($fh) ;
  37.     return bless [$fh, $real_stdout ] ;
  38.  
  39.     }
  40.     sub DESTROY
  41.     {
  42.         my $self = shift ;
  43.     close $self->[0] ;
  44.     select($self->[1]) ;
  45.     }
  46. }
  47.  
  48. sub docat_del
  49. { 
  50.     my $file = shift;
  51.     local $/ = undef;
  52.     open(CAT,$file) || die "Cannot open $file: $!";
  53.     my $result = <CAT>;
  54.     close(CAT);
  55.     unlink $file ;
  56.     return $result;
  57. }   
  58.  
  59. my $Dfile = "dbhash.tmp";
  60. unlink $Dfile;
  61.  
  62. umask(0);
  63.  
  64. # Check the interface to HASHINFO
  65.  
  66. my $dbh = new DB_File::HASHINFO ;
  67.  
  68. ok(1, ! defined $dbh->{bsize}) ;
  69. ok(2, ! defined $dbh->{ffactor}) ;
  70. ok(3, ! defined $dbh->{nelem}) ;
  71. ok(4, ! defined $dbh->{cachesize}) ;
  72. ok(5, ! defined $dbh->{hash}) ;
  73. ok(6, ! defined $dbh->{lorder}) ;
  74.  
  75. $dbh->{bsize} = 3000 ;
  76. ok(7, $dbh->{bsize} == 3000 );
  77.  
  78. $dbh->{ffactor} = 9000 ;
  79. ok(8, $dbh->{ffactor} == 9000 );
  80.  
  81. $dbh->{nelem} = 400 ;
  82. ok(9, $dbh->{nelem} == 400 );
  83.  
  84. $dbh->{cachesize} = 65 ;
  85. ok(10, $dbh->{cachesize} == 65 );
  86.  
  87. $dbh->{hash} = "abc" ;
  88. ok(11, $dbh->{hash} eq "abc" );
  89.  
  90. $dbh->{lorder} = 1234 ;
  91. ok(12, $dbh->{lorder} == 1234 );
  92.  
  93. # Check that an invalid entry is caught both for store & fetch
  94. eval '$dbh->{fred} = 1234' ;
  95. ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
  96. eval 'my $q = $dbh->{fred}' ;
  97. ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
  98.  
  99.  
  100. # Now check the interface to HASH
  101.  
  102. ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  103.  
  104. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  105.    $blksize,$blocks) = stat($Dfile);
  106. ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
  107.  
  108. while (($key,$value) = each(%h)) {
  109.     $i++;
  110. }
  111. ok(17, !$i );
  112.  
  113. $h{'goner1'} = 'snork';
  114.  
  115. $h{'abc'} = 'ABC';
  116. ok(18, $h{'abc'} eq 'ABC' );
  117. ok(19, !defined $h{'jimmy'} );
  118. ok(20, !exists $h{'jimmy'} );
  119. ok(21, exists $h{'abc'} );
  120.  
  121. $h{'def'} = 'DEF';
  122. $h{'jkl','mno'} = "JKL\034MNO";
  123. $h{'a',2,3,4,5} = join("\034",'A',2,3,4,5);
  124. $h{'a'} = 'A';
  125.  
  126. #$h{'b'} = 'B';
  127. $X->STORE('b', 'B') ;
  128.  
  129. $h{'c'} = 'C';
  130.  
  131. #$h{'d'} = 'D';
  132. $X->put('d', 'D') ;
  133.  
  134. $h{'e'} = 'E';
  135. $h{'f'} = 'F';
  136. $h{'g'} = 'X';
  137. $h{'h'} = 'H';
  138. $h{'i'} = 'I';
  139.  
  140. $h{'goner2'} = 'snork';
  141. delete $h{'goner2'};
  142.  
  143.  
  144. # IMPORTANT - $X must be undefined before the untie otherwise the
  145. #             underlying DB close routine will not get called.
  146. undef $X ;
  147. untie(%h);
  148.  
  149.  
  150. # tie to the same file again, do not supply a type - should default to HASH
  151. ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
  152.  
  153. # Modify an entry from the previous tie
  154. $h{'g'} = 'G';
  155.  
  156. $h{'j'} = 'J';
  157. $h{'k'} = 'K';
  158. $h{'l'} = 'L';
  159. $h{'m'} = 'M';
  160. $h{'n'} = 'N';
  161. $h{'o'} = 'O';
  162. $h{'p'} = 'P';
  163. $h{'q'} = 'Q';
  164. $h{'r'} = 'R';
  165. $h{'s'} = 'S';
  166. $h{'t'} = 'T';
  167. $h{'u'} = 'U';
  168. $h{'v'} = 'V';
  169. $h{'w'} = 'W';
  170. $h{'x'} = 'X';
  171. $h{'y'} = 'Y';
  172. $h{'z'} = 'Z';
  173.  
  174. $h{'goner3'} = 'snork';
  175.  
  176. delete $h{'goner1'};
  177. $X->DELETE('goner3');
  178.  
  179. @keys = keys(%h);
  180. @values = values(%h);
  181.  
  182. ok(23, $#keys == 29 && $#values == 29) ;
  183.  
  184. $i = 0 ;
  185. while (($key,$value) = each(%h)) {
  186.     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  187.     $key =~ y/a-z/A-Z/;
  188.     $i++ if $key eq $value;
  189.     }
  190. }
  191.  
  192. ok(24, $i == 30) ;
  193.  
  194. @keys = ('blurfl', keys(%h), 'dyick');
  195. ok(25, $#keys == 31) ;
  196.  
  197. $h{'foo'} = '';
  198. ok(26, $h{'foo'} eq '' );
  199.  
  200. # Berkeley DB 2 from version 2.4.10 onwards does not allow null keys.
  201. # This feature will be reenabled in a future version of Berkeley DB.
  202. #$h{''} = 'bar';
  203. #ok(27, $h{''} eq 'bar' );
  204. ok(27,1) ;
  205.  
  206. # check cache overflow and numeric keys and contents
  207. $ok = 1;
  208. for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  209. for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  210. ok(28, $ok );
  211.  
  212. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  213.    $blksize,$blocks) = stat($Dfile);
  214. ok(29, $size > 0 );
  215.  
  216. @h{0..200} = 200..400;
  217. @foo = @h{0..200};
  218. ok(30, join(':',200..400) eq join(':',@foo) );
  219.  
  220.  
  221. # Now check all the non-tie specific stuff
  222.  
  223. # Check NOOVERWRITE will make put fail when attempting to overwrite
  224. # an existing record.
  225.  
  226. $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
  227. ok(31, $status == 1 );
  228.  
  229. # check that the value of the key 'x' has not been changed by the 
  230. # previous test
  231. ok(32, $h{'x'} eq 'X' );
  232.  
  233. # standard put
  234. $status = $X->put('key', 'value') ;
  235. ok(33, $status == 0 );
  236.  
  237. #check that previous put can be retrieved
  238. $value = 0 ;
  239. $status = $X->get('key', $value) ;
  240. ok(34, $status == 0 );
  241. ok(35, $value eq 'value' );
  242.  
  243. # Attempting to delete an existing key should work
  244.  
  245. $status = $X->del('q') ;
  246. ok(36, $status == 0 );
  247.  
  248. # Make sure that the key deleted, cannot be retrieved
  249. $^W = 0 ;
  250. ok(37, $h{'q'} eq undef );
  251. $^W = 1 ;
  252.  
  253. # Attempting to delete a non-existant key should fail
  254.  
  255. $status = $X->del('joe') ;
  256. ok(38, $status == 1 );
  257.  
  258. # Check the get interface
  259.  
  260. # First a non-existing key
  261. $status = $X->get('aaaa', $value) ;
  262. ok(39, $status == 1 );
  263.  
  264. # Next an existing key
  265. $status = $X->get('a', $value) ;
  266. ok(40, $status == 0 );
  267. ok(41, $value eq 'A' );
  268.  
  269. # seq
  270. # ###
  271.  
  272. # ditto, but use put to replace the key/value pair.
  273.  
  274. # use seq to walk backwards through a file - check that this reversed is
  275.  
  276. # check seq FIRST/LAST
  277.  
  278. # sync
  279. # ####
  280.  
  281. $status = $X->sync ;
  282. ok(42, $status == 0 );
  283.  
  284.  
  285. # fd
  286. # ##
  287.  
  288. $status = $X->fd ;
  289. ok(43, $status != 0 );
  290.  
  291. undef $X ;
  292. untie %h ;
  293.  
  294. unlink $Dfile;
  295.  
  296. # clear
  297. # #####
  298.  
  299. ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  300. foreach (1 .. 10)
  301.   { $h{$_} = $_ * 100 }
  302.  
  303. # check that there are 10 elements in the hash
  304. $i = 0 ;
  305. while (($key,$value) = each(%h)) {
  306.     $i++;
  307. }
  308. ok(45, $i == 10);
  309.  
  310. # now clear the hash
  311. %h = () ;
  312.  
  313. # check it is empty
  314. $i = 0 ;
  315. while (($key,$value) = each(%h)) {
  316.     $i++;
  317. }
  318. ok(46, $i == 0);
  319.  
  320. untie %h ;
  321. unlink $Dfile ;
  322.  
  323.  
  324. # Now try an in memory file
  325. ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  326.  
  327. # fd with an in memory file should return fail
  328. $status = $X->fd ;
  329. ok(48, $status == -1 );
  330.  
  331. undef $X ;
  332. untie %h ;
  333.  
  334. {
  335.     # check ability to override the default hashing
  336.     my %x ;
  337.     my $filename = "xyz" ;
  338.     my $hi = new DB_File::HASHINFO ;
  339.     $::count = 0 ;
  340.     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
  341.     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
  342.     $h{"abc"} = 123 ;
  343.     ok(50, $h{"abc"} == 123) ;
  344.     untie %x ;
  345.     unlink $filename ;
  346.     ok(51, $::count >0) ;
  347. }
  348.  
  349. {
  350.     # check that attempting to tie an array to a DB_HASH will fail
  351.  
  352.     my $filename = "xyz" ;
  353.     my @x ;
  354.     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
  355.     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
  356.     unlink $filename ;
  357. }
  358.  
  359. {
  360.    # sub-class test
  361.  
  362.    package Another ;
  363.  
  364.    use strict ;
  365.  
  366.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!\n" ;
  367.    print FILE <<'EOM' ;
  368.  
  369.    package SubDB ;
  370.  
  371.    use strict ;
  372.    use vars qw( @ISA @EXPORT) ;
  373.  
  374.    require Exporter ;
  375.    use DB_File;
  376.    @ISA=qw(DB_File);
  377.    @EXPORT = @DB_File::EXPORT ;
  378.  
  379.    sub STORE { 
  380.     my $self = shift ;
  381.         my $key = shift ;
  382.         my $value = shift ;
  383.         $self->SUPER::STORE($key, $value * 2) ;
  384.    }
  385.  
  386.    sub FETCH { 
  387.     my $self = shift ;
  388.         my $key = shift ;
  389.         $self->SUPER::FETCH($key) - 1 ;
  390.    }
  391.  
  392.    sub put { 
  393.     my $self = shift ;
  394.         my $key = shift ;
  395.         my $value = shift ;
  396.         $self->SUPER::put($key, $value * 3) ;
  397.    }
  398.  
  399.    sub get { 
  400.     my $self = shift ;
  401.         $self->SUPER::get($_[0], $_[1]) ;
  402.     $_[1] -= 2 ;
  403.    }
  404.  
  405.    sub A_new_method
  406.    {
  407.     my $self = shift ;
  408.         my $key = shift ;
  409.         my $value = $self->FETCH($key) ;
  410.     return "[[$value]]" ;
  411.    }
  412.  
  413.    1 ;
  414. EOM
  415.  
  416.     close FILE ;
  417.  
  418.     BEGIN { push @INC, '.'; }             
  419.     eval 'use SubDB ; ';
  420.     main::ok(53, $@ eq "") ;
  421.     my %h ;
  422.     my $X ;
  423.     eval '
  424.     $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
  425.     ' ;
  426.  
  427.     main::ok(54, $@ eq "") ;
  428.  
  429.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  430.     main::ok(55, $@ eq "") ;
  431.     main::ok(56, $ret == 5) ;
  432.  
  433.     my $value = 0;
  434.     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
  435.     main::ok(57, $@ eq "") ;
  436.     main::ok(58, $ret == 10) ;
  437.  
  438.     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
  439.     main::ok(59, $@ eq "" ) ;
  440.     main::ok(60, $ret == 1) ;
  441.  
  442.     $ret = eval '$X->A_new_method("joe") ' ;
  443.     main::ok(61, $@ eq "") ;
  444.     main::ok(62, $ret eq "[[11]]") ;
  445.  
  446.     undef $X;
  447.     untie(%h);
  448.     unlink "SubDB.pm", "dbhash.tmp" ;
  449.  
  450. }
  451.  
  452. {
  453.    # DBM Filter tests
  454.    use strict ;
  455.    my (%h, $db) ;
  456.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  457.    unlink $Dfile;
  458.  
  459.    sub checkOutput
  460.    {
  461.        my($fk, $sk, $fv, $sv) = @_ ;
  462.        return
  463.            $fetch_key eq $fk && $store_key eq $sk && 
  464.        $fetch_value eq $fv && $store_value eq $sv &&
  465.        $_ eq 'original' ;
  466.    }
  467.    
  468.    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  469.  
  470.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  471.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  472.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  473.    $db->filter_store_value (sub { $store_value = $_ }) ;
  474.  
  475.    $_ = "original" ;
  476.  
  477.    $h{"fred"} = "joe" ;
  478.    #                   fk   sk     fv   sv
  479.    ok(64, checkOutput( "", "fred", "", "joe")) ;
  480.  
  481.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  482.    ok(65, $h{"fred"} eq "joe");
  483.    #                   fk    sk     fv    sv
  484.    ok(66, checkOutput( "", "fred", "joe", "")) ;
  485.  
  486.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  487.    ok(67, $db->FIRSTKEY() eq "fred") ;
  488.    #                    fk     sk  fv  sv
  489.    ok(68, checkOutput( "fred", "", "", "")) ;
  490.  
  491.    # replace the filters, but remember the previous set
  492.    my ($old_fk) = $db->filter_fetch_key   
  493.                (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  494.    my ($old_sk) = $db->filter_store_key   
  495.                (sub { $_ = lc $_ ; $store_key = $_ }) ;
  496.    my ($old_fv) = $db->filter_fetch_value 
  497.                (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  498.    my ($old_sv) = $db->filter_store_value 
  499.                (sub { s/o/x/g; $store_value = $_ }) ;
  500.    
  501.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  502.    $h{"Fred"} = "Joe" ;
  503.    #                   fk   sk     fv    sv
  504.    ok(69, checkOutput( "", "fred", "", "Jxe")) ;
  505.  
  506.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  507.    ok(70, $h{"Fred"} eq "[Jxe]");
  508.    #                   fk   sk     fv    sv
  509.    ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
  510.  
  511.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  512.    ok(72, $db->FIRSTKEY() eq "FRED") ;
  513.    #                   fk   sk     fv    sv
  514.    ok(73, checkOutput( "FRED", "", "", "")) ;
  515.  
  516.    # put the original filters back
  517.    $db->filter_fetch_key   ($old_fk);
  518.    $db->filter_store_key   ($old_sk);
  519.    $db->filter_fetch_value ($old_fv);
  520.    $db->filter_store_value ($old_sv);
  521.  
  522.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  523.    $h{"fred"} = "joe" ;
  524.    ok(74, checkOutput( "", "fred", "", "joe")) ;
  525.  
  526.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  527.    ok(75, $h{"fred"} eq "joe");
  528.    ok(76, checkOutput( "", "fred", "joe", "")) ;
  529.  
  530.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  531.    ok(77, $db->FIRSTKEY() eq "fred") ;
  532.    ok(78, checkOutput( "fred", "", "", "")) ;
  533.  
  534.    # delete the filters
  535.    $db->filter_fetch_key   (undef);
  536.    $db->filter_store_key   (undef);
  537.    $db->filter_fetch_value (undef);
  538.    $db->filter_store_value (undef);
  539.  
  540.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  541.    $h{"fred"} = "joe" ;
  542.    ok(79, checkOutput( "", "", "", "")) ;
  543.  
  544.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  545.    ok(80, $h{"fred"} eq "joe");
  546.    ok(81, checkOutput( "", "", "", "")) ;
  547.  
  548.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  549.    ok(82, $db->FIRSTKEY() eq "fred") ;
  550.    ok(83, checkOutput( "", "", "", "")) ;
  551.  
  552.    undef $db ;
  553.    untie %h;
  554.    unlink $Dfile;
  555. }
  556.  
  557. {    
  558.     # DBM Filter with a closure
  559.  
  560.     use strict ;
  561.     my (%h, $db) ;
  562.  
  563.     unlink $Dfile;
  564.     ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  565.  
  566.     my %result = () ;
  567.  
  568.     sub Closure
  569.     {
  570.         my ($name) = @_ ;
  571.     my $count = 0 ;
  572.     my @kept = () ;
  573.  
  574.     return sub { ++$count ; 
  575.              push @kept, $_ ; 
  576.              $result{$name} = "$name - $count: [@kept]" ;
  577.            }
  578.     }
  579.  
  580.     $db->filter_store_key(Closure("store key")) ;
  581.     $db->filter_store_value(Closure("store value")) ;
  582.     $db->filter_fetch_key(Closure("fetch key")) ;
  583.     $db->filter_fetch_value(Closure("fetch value")) ;
  584.  
  585.     $_ = "original" ;
  586.  
  587.     $h{"fred"} = "joe" ;
  588.     ok(85, $result{"store key"} eq "store key - 1: [fred]");
  589.     ok(86, $result{"store value"} eq "store value - 1: [joe]");
  590.     ok(87, ! defined $result{"fetch key"} );
  591.     ok(88, ! defined $result{"fetch value"} );
  592.     ok(89, $_ eq "original") ;
  593.  
  594.     ok(90, $db->FIRSTKEY() eq "fred") ;
  595.     ok(91, $result{"store key"} eq "store key - 1: [fred]");
  596.     ok(92, $result{"store value"} eq "store value - 1: [joe]");
  597.     ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
  598.     ok(94, ! defined $result{"fetch value"} );
  599.     ok(95, $_ eq "original") ;
  600.  
  601.     $h{"jim"}  = "john" ;
  602.     ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
  603.     ok(97, $result{"store value"} eq "store value - 2: [joe john]");
  604.     ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
  605.     ok(99, ! defined $result{"fetch value"} );
  606.     ok(100, $_ eq "original") ;
  607.  
  608.     ok(101, $h{"fred"} eq "joe");
  609.     ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
  610.     ok(103, $result{"store value"} eq "store value - 2: [joe john]");
  611.     ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
  612.     ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
  613.     ok(106, $_ eq "original") ;
  614.  
  615.     undef $db ;
  616.     untie %h;
  617.     unlink $Dfile;
  618. }        
  619.  
  620. {
  621.    # DBM Filter recursion detection
  622.    use strict ;
  623.    my (%h, $db) ;
  624.    unlink $Dfile;
  625.  
  626.    ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  627.  
  628.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  629.  
  630.    eval '$h{1} = 1234' ;
  631.    ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
  632.    
  633.    undef $db ;
  634.    untie %h;
  635.    unlink $Dfile;
  636. }
  637.  
  638.  
  639. {
  640.    # Examples from the POD
  641.  
  642.   my $file = "xyzt" ;
  643.   {
  644.     my $redirect = new Redirect $file ;
  645.  
  646.     use strict ;
  647.     use DB_File ;
  648.     use vars qw( %h $k $v ) ;
  649.  
  650.     unlink "fruit" ;
  651.     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
  652.         or die "Cannot open file 'fruit': $!\n";
  653.  
  654.     # Add a few key/value pairs to the file
  655.     $h{"apple"} = "red" ;
  656.     $h{"orange"} = "orange" ;
  657.     $h{"banana"} = "yellow" ;
  658.     $h{"tomato"} = "red" ;
  659.  
  660.     # Check for existence of a key
  661.     print "Banana Exists\n\n" if $h{"banana"} ;
  662.  
  663.     # Delete a key/value pair.
  664.     delete $h{"apple"} ;
  665.  
  666.     # print the contents of the file
  667.     while (($k, $v) = each %h)
  668.       { print "$k -> $v\n" }
  669.  
  670.     untie %h ;
  671.  
  672.     unlink "fruit" ;
  673.   }  
  674.  
  675.   ok(109, docat_del($file) eq <<'EOM') ;
  676. Banana Exists
  677.  
  678. orange -> orange
  679. tomato -> red
  680. banana -> yellow
  681. EOM
  682.    
  683. }
  684.  
  685. exit ;
  686.