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

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

MySQL数据库

开发平台：

Visual C++

db-hash.t：源码内容
  1. #!./perl 
  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..111n";
  19.             exit 0;
  20.         }
  21.     }
  22. }
  24. use DB_File; 
  25. use Fcntl;
  27. print "1..111n";
  29. sub ok
  30. {
  31.     my $no = shift ;
  32.     my $result = shift ;
  33.  
  34.     print "not " unless $result ;
  35.     print "ok $non" ;
  36. }
  38. {
  39.     package Redirect ;
  40.     use Symbol ;
  42.     sub new
  43.     {
  44.         my $class = shift ;
  45.         my $filename = shift ;
  46. my $fh = gensym ;
  47. open ($fh, ">$filename") || die "Cannot open $filename: $!" ;
  48. my $real_stdout = select($fh) ;
  49. return bless [$fh, $real_stdout ] ;
  51.     }
  52.     sub DESTROY
  53.     {
  54.         my $self = shift ;
  55. close $self->[0] ;
  56. select($self->[1]) ;
  57.     }
  58. }
  60. sub docat_del
  61. { 
  62.     my $file = shift;
  63.     local $/ = undef;
  64.     open(CAT,$file) || die "Cannot open $file: $!";
  65.     my $result = <CAT>;
  66.     close(CAT);
  67.     unlink $file ;
  68.     return $result;
  69. }   
  71. my $Dfile = "dbhash.tmp";
  72. my $null_keys_allowed = ($DB_File::db_ver < 2.004010 
  73. || $DB_File::db_ver >= 3.1 );
  75. unlink $Dfile;
  77. umask(0);
  79. # Check the interface to HASHINFO
  81. my $dbh = new DB_File::HASHINFO ;
  83. ok(1, ! defined $dbh->{bsize}) ;
  84. ok(2, ! defined $dbh->{ffactor}) ;
  85. ok(3, ! defined $dbh->{nelem}) ;
  86. ok(4, ! defined $dbh->{cachesize}) ;
  87. ok(5, ! defined $dbh->{hash}) ;
  88. ok(6, ! defined $dbh->{lorder}) ;
  90. $dbh->{bsize} = 3000 ;
  91. ok(7, $dbh->{bsize} == 3000 );
  93. $dbh->{ffactor} = 9000 ;
  94. ok(8, $dbh->{ffactor} == 9000 );
  96. $dbh->{nelem} = 400 ;
  97. ok(9, $dbh->{nelem} == 400 );
  99. $dbh->{cachesize} = 65 ;
  100. ok(10, $dbh->{cachesize} == 65 );
  102. $dbh->{hash} = "abc" ;
  103. ok(11, $dbh->{hash} eq "abc" );
  105. $dbh->{lorder} = 1234 ;
  106. ok(12, $dbh->{lorder} == 1234 );
  108. # Check that an invalid entry is caught both for store & fetch
  109. eval '$dbh->{fred} = 1234' ;
  110. ok(13, $@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ );
  111. eval 'my $q = $dbh->{fred}' ;
  112. ok(14, $@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ );
  115. # Now check the interface to HASH
  116. my ($X, %h);
  117. ok(15, $X = tie(%h, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  119. my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  120.    $blksize,$blocks) = stat($Dfile);
  121. ok(16, ($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) || $^O eq 'amigaos' || $^O eq 'MSWin32');
  123. my ($key, $value, $i);
  124. while (($key,$value) = each(%h)) {
  125.     $i++;
  126. }
  127. ok(17, !$i );
  129. $h{'goner1'} = 'snork';
  131. $h{'abc'} = 'ABC';
  132. ok(18, $h{'abc'} eq 'ABC' );
  133. ok(19, !defined $h{'jimmy'} );
  134. ok(20, !exists $h{'jimmy'} );
  135. ok(21, exists $h{'abc'} );
  137. $h{'def'} = 'DEF';
  138. $h{'jkl','mno'} = "JKL34MNO";
  139. $h{'a',2,3,4,5} = join("34",'A',2,3,4,5);
  140. $h{'a'} = 'A';
  142. #$h{'b'} = 'B';
  143. $X->STORE('b', 'B') ;
  145. $h{'c'} = 'C';
  147. #$h{'d'} = 'D';
  148. $X->put('d', 'D') ;
  150. $h{'e'} = 'E';
  151. $h{'f'} = 'F';
  152. $h{'g'} = 'X';
  153. $h{'h'} = 'H';
  154. $h{'i'} = 'I';
  156. $h{'goner2'} = 'snork';
  157. delete $h{'goner2'};
  160. # IMPORTANT - $X must be undefined before the untie otherwise the
  161. #             underlying DB close routine will not get called.
  162. undef $X ;
  163. untie(%h);
  166. # tie to the same file again, do not supply a type - should default to HASH
  167. ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
  169. # Modify an entry from the previous tie
  170. $h{'g'} = 'G';
  172. $h{'j'} = 'J';
  173. $h{'k'} = 'K';
  174. $h{'l'} = 'L';
  175. $h{'m'} = 'M';
  176. $h{'n'} = 'N';
  177. $h{'o'} = 'O';
  178. $h{'p'} = 'P';
  179. $h{'q'} = 'Q';
  180. $h{'r'} = 'R';
  181. $h{'s'} = 'S';
  182. $h{'t'} = 'T';
  183. $h{'u'} = 'U';
  184. $h{'v'} = 'V';
  185. $h{'w'} = 'W';
  186. $h{'x'} = 'X';
  187. $h{'y'} = 'Y';
  188. $h{'z'} = 'Z';
  190. $h{'goner3'} = 'snork';
  192. delete $h{'goner1'};
  193. $X->DELETE('goner3');
  195. my @keys = keys(%h);
  196. my @values = values(%h);
  198. ok(23, $#keys == 29 && $#values == 29) ;
  200. $i = 0 ;
  201. while (($key,$value) = each(%h)) {
  202.     if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
  203. $key =~ y/a-z/A-Z/;
  204. $i++ if $key eq $value;
  205.     }
  206. }
  208. ok(24, $i == 30) ;
  210. @keys = ('blurfl', keys(%h), 'dyick');
  211. ok(25, $#keys == 31) ;
  213. $h{'foo'} = '';
  214. ok(26, $h{'foo'} eq '' );
  216. # Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
  217. # This feature was reenabled in version 3.1 of Berkeley DB.
  218. my $result = 0 ;
  219. if ($null_keys_allowed) {
  220.     $h{''} = 'bar';
  221.     $result = ( $h{''} eq 'bar' );
  222. }
  223. else
  224.   { $result = 1 }
  225. ok(27, $result) ;
  227. # check cache overflow and numeric keys and contents
  228. my $ok = 1;
  229. for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
  230. for ($i = 1; $i < 200; $i++) { $ok = 0 unless $h{$i} == $i; }
  231. ok(28, $ok );
  233. ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
  234.    $blksize,$blocks) = stat($Dfile);
  235. ok(29, $size > 0 );
  237. @h{0..200} = 200..400;
  238. my @foo = @h{0..200};
  239. ok(30, join(':',200..400) eq join(':',@foo) );
  242. # Now check all the non-tie specific stuff
  244. # Check NOOVERWRITE will make put fail when attempting to overwrite
  245. # an existing record.
  246.  
  247. my $status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
  248. ok(31, $status == 1 );
  249.  
  250. # check that the value of the key 'x' has not been changed by the 
  251. # previous test
  252. ok(32, $h{'x'} eq 'X' );
  254. # standard put
  255. $status = $X->put('key', 'value') ;
  256. ok(33, $status == 0 );
  258. #check that previous put can be retrieved
  259. $value = 0 ;
  260. $status = $X->get('key', $value) ;
  261. ok(34, $status == 0 );
  262. ok(35, $value eq 'value' );
  264. # Attempting to delete an existing key should work
  266. $status = $X->del('q') ;
  267. ok(36, $status == 0 );
  269. # Make sure that the key deleted, cannot be retrieved
  270. {
  271.     no warnings 'uninitialized' ;
  272.     ok(37, $h{'q'} eq undef );
  273. }
  275. # Attempting to delete a non-existant key should fail
  277. $status = $X->del('joe') ;
  278. ok(38, $status == 1 );
  280. # Check the get interface
  282. # First a non-existing key
  283. $status = $X->get('aaaa', $value) ;
  284. ok(39, $status == 1 );
  286. # Next an existing key
  287. $status = $X->get('a', $value) ;
  288. ok(40, $status == 0 );
  289. ok(41, $value eq 'A' );
  291. # seq
  292. # ###
  294. # ditto, but use put to replace the key/value pair.
  296. # use seq to walk backwards through a file - check that this reversed is
  298. # check seq FIRST/LAST
  300. # sync
  301. # ####
  303. $status = $X->sync ;
  304. ok(42, $status == 0 );
  307. # fd
  308. # ##
  310. $status = $X->fd ;
  311. ok(43, $status != 0 );
  313. undef $X ;
  314. untie %h ;
  316. unlink $Dfile;
  318. # clear
  319. # #####
  321. ok(44, tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  322. foreach (1 .. 10)
  323.   { $h{$_} = $_ * 100 }
  325. # check that there are 10 elements in the hash
  326. $i = 0 ;
  327. while (($key,$value) = each(%h)) {
  328.     $i++;
  329. }
  330. ok(45, $i == 10);
  332. # now clear the hash
  333. %h = () ;
  335. # check it is empty
  336. $i = 0 ;
  337. while (($key,$value) = each(%h)) {
  338.     $i++;
  339. }
  340. ok(46, $i == 0);
  342. untie %h ;
  343. unlink $Dfile ;
  346. # Now try an in memory file
  347. ok(47, $X = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  349. # fd with an in memory file should return fail
  350. $status = $X->fd ;
  351. ok(48, $status == -1 );
  353. undef $X ;
  354. untie %h ;
  356. {
  357.     # check ability to override the default hashing
  358.     my %x ;
  359.     my $filename = "xyz" ;
  360.     my $hi = new DB_File::HASHINFO ;
  361.     $::count = 0 ;
  362.     $hi->{hash} = sub { ++$::count ; length $_[0] } ;
  363.     ok(49, tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $hi ) ;
  364.     $h{"abc"} = 123 ;
  365.     ok(50, $h{"abc"} == 123) ;
  366.     untie %x ;
  367.     unlink $filename ;
  368.     ok(51, $::count >0) ;
  369. }
  371. {
  372.     # check that attempting to tie an array to a DB_HASH will fail
  374.     my $filename = "xyz" ;
  375.     my @x ;
  376.     eval { tie @x, 'DB_File', $filename, O_RDWR|O_CREAT, 0640, $DB_HASH ; } ;
  377.     ok(52, $@ =~ /^DB_File can only tie an associative array to a DB_HASH database/) ;
  378.     unlink $filename ;
  379. }
  381. {
  382.    # sub-class test
  384.    package Another ;
  386.    use warnings ;
  387.    use strict ;
  389.    open(FILE, ">SubDB.pm") or die "Cannot open SubDB.pm: $!n" ;
  390.    print FILE <<'EOM' ;
  392.    package SubDB ;
  394.    use warnings ;
  395.    use strict ;
  396.    use vars qw( @ISA @EXPORT) ;
  398.    require Exporter ;
  399.    use DB_File;
  400.    @ISA=qw(DB_File);
  401.    @EXPORT = @DB_File::EXPORT ;
  403.    sub STORE { 
  404. my $self = shift ;
  405.         my $key = shift ;
  406.         my $value = shift ;
  407.         $self->SUPER::STORE($key, $value * 2) ;
  408.    }
  410.    sub FETCH { 
  411. my $self = shift ;
  412.         my $key = shift ;
  413.         $self->SUPER::FETCH($key) - 1 ;
  414.    }
  416.    sub put { 
  417. my $self = shift ;
  418.         my $key = shift ;
  419.         my $value = shift ;
  420.         $self->SUPER::put($key, $value * 3) ;
  421.    }
  423.    sub get { 
  424. my $self = shift ;
  425.         $self->SUPER::get($_[0], $_[1]) ;
  426. $_[1] -= 2 ;
  427.    }
  429.    sub A_new_method
  430.    {
  431. my $self = shift ;
  432.         my $key = shift ;
  433.         my $value = $self->FETCH($key) ;
  434. return "[[$value]]" ;
  435.    }
  437.    1 ;
  438. EOM
  440.     close FILE ;
  442.     BEGIN { push @INC, '.'; }             
  443.     eval 'use SubDB ; ';
  444.     main::ok(53, $@ eq "") ;
  445.     my %h ;
  446.     my $X ;
  447.     eval '
  448. $X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
  449. ' ;
  451.     main::ok(54, $@ eq "") ;
  453.     my $ret = eval '$h{"fred"} = 3 ; return $h{"fred"} ' ;
  454.     main::ok(55, $@ eq "") ;
  455.     main::ok(56, $ret == 5) ;
  457.     my $value = 0;
  458.     $ret = eval '$X->put("joe", 4) ; $X->get("joe", $value) ; return $value' ;
  459.     main::ok(57, $@ eq "") ;
  460.     main::ok(58, $ret == 10) ;
  462.     $ret = eval ' R_NEXT eq main::R_NEXT ' ;
  463.     main::ok(59, $@ eq "" ) ;
  464.     main::ok(60, $ret == 1) ;
  466.     $ret = eval '$X->A_new_method("joe") ' ;
  467.     main::ok(61, $@ eq "") ;
  468.     main::ok(62, $ret eq "[[11]]") ;
  470.     undef $X;
  471.     untie(%h);
  472.     unlink "SubDB.pm", "dbhash.tmp" ;
  474. }
  476. {
  477.    # DBM Filter tests
  478.    use warnings ;
  479.    use strict ;
  480.    my (%h, $db) ;
  481.    my ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  482.    unlink $Dfile;
  484.    sub checkOutput
  485.    {
  486.        my($fk, $sk, $fv, $sv) = @_ ;
  487.        return
  488.            $fetch_key eq $fk && $store_key eq $sk && 
  489.    $fetch_value eq $fv && $store_value eq $sv &&
  490.    $_ eq 'original' ;
  491.    }
  492.    
  493.    ok(63, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  495.    $db->filter_fetch_key   (sub { $fetch_key = $_ }) ;
  496.    $db->filter_store_key   (sub { $store_key = $_ }) ;
  497.    $db->filter_fetch_value (sub { $fetch_value = $_}) ;
  498.    $db->filter_store_value (sub { $store_value = $_ }) ;
  500.    $_ = "original" ;
  502.    $h{"fred"} = "joe" ;
  503.    #                   fk   sk     fv   sv
  504.    ok(64, checkOutput( "", "fred", "", "joe")) ;
  506.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  507.    ok(65, $h{"fred"} eq "joe");
  508.    #                   fk    sk     fv    sv
  509.    ok(66, checkOutput( "", "fred", "joe", "")) ;
  511.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  512.    ok(67, $db->FIRSTKEY() eq "fred") ;
  513.    #                    fk     sk  fv  sv
  514.    ok(68, checkOutput( "fred", "", "", "")) ;
  516.    # replace the filters, but remember the previous set
  517.    my ($old_fk) = $db->filter_fetch_key   
  518.     (sub { $_ = uc $_ ; $fetch_key = $_ }) ;
  519.    my ($old_sk) = $db->filter_store_key   
  520.     (sub { $_ = lc $_ ; $store_key = $_ }) ;
  521.    my ($old_fv) = $db->filter_fetch_value 
  522.     (sub { $_ = "[$_]"; $fetch_value = $_ }) ;
  523.    my ($old_sv) = $db->filter_store_value 
  524.     (sub { s/o/x/g; $store_value = $_ }) ;
  525.    
  526.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  527.    $h{"Fred"} = "Joe" ;
  528.    #                   fk   sk     fv    sv
  529.    ok(69, checkOutput( "", "fred", "", "Jxe")) ;
  531.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  532.    ok(70, $h{"Fred"} eq "[Jxe]");
  533.    #                   fk   sk     fv    sv
  534.    ok(71, checkOutput( "", "fred", "[Jxe]", "")) ;
  536.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  537.    ok(72, $db->FIRSTKEY() eq "FRED") ;
  538.    #                   fk   sk     fv    sv
  539.    ok(73, checkOutput( "FRED", "", "", "")) ;
  541.    # put the original filters back
  542.    $db->filter_fetch_key   ($old_fk);
  543.    $db->filter_store_key   ($old_sk);
  544.    $db->filter_fetch_value ($old_fv);
  545.    $db->filter_store_value ($old_sv);
  547.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  548.    $h{"fred"} = "joe" ;
  549.    ok(74, checkOutput( "", "fred", "", "joe")) ;
  551.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  552.    ok(75, $h{"fred"} eq "joe");
  553.    ok(76, checkOutput( "", "fred", "joe", "")) ;
  555.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  556.    ok(77, $db->FIRSTKEY() eq "fred") ;
  557.    ok(78, checkOutput( "fred", "", "", "")) ;
  559.    # delete the filters
  560.    $db->filter_fetch_key   (undef);
  561.    $db->filter_store_key   (undef);
  562.    $db->filter_fetch_value (undef);
  563.    $db->filter_store_value (undef);
  565.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  566.    $h{"fred"} = "joe" ;
  567.    ok(79, checkOutput( "", "", "", "")) ;
  569.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  570.    ok(80, $h{"fred"} eq "joe");
  571.    ok(81, checkOutput( "", "", "", "")) ;
  573.    ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
  574.    ok(82, $db->FIRSTKEY() eq "fred") ;
  575.    ok(83, checkOutput( "", "", "", "")) ;
  577.    undef $db ;
  578.    untie %h;
  579.    unlink $Dfile;
  580. }
  582. {    
  583.     # DBM Filter with a closure
  585.     use warnings ;
  586.     use strict ;
  587.     my (%h, $db) ;
  589.     unlink $Dfile;
  590.     ok(84, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  592.     my %result = () ;
  594.     sub Closure
  595.     {
  596.         my ($name) = @_ ;
  597. my $count = 0 ;
  598. my @kept = () ;
  600. return sub { ++$count ; 
  601.      push @kept, $_ ; 
  602.      $result{$name} = "$name - $count: [@kept]" ;
  603.    }
  604.     }
  606.     $db->filter_store_key(Closure("store key")) ;
  607.     $db->filter_store_value(Closure("store value")) ;
  608.     $db->filter_fetch_key(Closure("fetch key")) ;
  609.     $db->filter_fetch_value(Closure("fetch value")) ;
  611.     $_ = "original" ;
  613.     $h{"fred"} = "joe" ;
  614.     ok(85, $result{"store key"} eq "store key - 1: [fred]");
  615.     ok(86, $result{"store value"} eq "store value - 1: [joe]");
  616.     ok(87, ! defined $result{"fetch key"} );
  617.     ok(88, ! defined $result{"fetch value"} );
  618.     ok(89, $_ eq "original") ;
  620.     ok(90, $db->FIRSTKEY() eq "fred") ;
  621.     ok(91, $result{"store key"} eq "store key - 1: [fred]");
  622.     ok(92, $result{"store value"} eq "store value - 1: [joe]");
  623.     ok(93, $result{"fetch key"} eq "fetch key - 1: [fred]");
  624.     ok(94, ! defined $result{"fetch value"} );
  625.     ok(95, $_ eq "original") ;
  627.     $h{"jim"}  = "john" ;
  628.     ok(96, $result{"store key"} eq "store key - 2: [fred jim]");
  629.     ok(97, $result{"store value"} eq "store value - 2: [joe john]");
  630.     ok(98, $result{"fetch key"} eq "fetch key - 1: [fred]");
  631.     ok(99, ! defined $result{"fetch value"} );
  632.     ok(100, $_ eq "original") ;
  634.     ok(101, $h{"fred"} eq "joe");
  635.     ok(102, $result{"store key"} eq "store key - 3: [fred jim fred]");
  636.     ok(103, $result{"store value"} eq "store value - 2: [joe john]");
  637.     ok(104, $result{"fetch key"} eq "fetch key - 1: [fred]");
  638.     ok(105, $result{"fetch value"} eq "fetch value - 1: [joe]");
  639.     ok(106, $_ eq "original") ;
  641.     undef $db ;
  642.     untie %h;
  643.     unlink $Dfile;
  644. }
  646. {
  647.    # DBM Filter recursion detection
  648.    use warnings ;
  649.    use strict ;
  650.    my (%h, $db) ;
  651.    unlink $Dfile;
  653.    ok(107, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
  655.    $db->filter_store_key (sub { $_ = $h{$_} }) ;
  657.    eval '$h{1} = 1234' ;
  658.    ok(108, $@ =~ /^recursion detected in filter_store_key at/ );
  659.    
  660.    undef $db ;
  661.    untie %h;
  662.    unlink $Dfile;
  663. }
  666. {
  667.    # Examples from the POD
  669.   my $file = "xyzt" ;
  670.   {
  671.     my $redirect = new Redirect $file ;
  673.     use warnings FATAL => qw(all);
  674.     use strict ;
  675.     use DB_File ;
  676.     use vars qw( %h $k $v ) ;
  678.     unlink "fruit" ;
  679.     tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
  680.         or die "Cannot open file 'fruit': $!n";
  682.     # Add a few key/value pairs to the file
  683.     $h{"apple"} = "red" ;
  684.     $h{"orange"} = "orange" ;
  685.     $h{"banana"} = "yellow" ;
  686.     $h{"tomato"} = "red" ;
  688.     # Check for existence of a key
  689.     print "Banana Existsnn" if $h{"banana"} ;
  691.     # Delete a key/value pair.
  692.     delete $h{"apple"} ;
  694.     # print the contents of the file
  695.     while (($k, $v) = each %h)
  696.       { print "$k -> $vn" }
  698.     untie %h ;
  700.     unlink "fruit" ;
  701.   }  
  703.   ok(109, docat_del($file) eq <<'EOM') ;
  704. Banana Exists
  706. orange -> orange
  707. tomato -> red
  708. banana -> yellow
  709. EOM
  710.    
  711. }
  713. {
  714.     # Bug ID 20001013.009
  715.     #
  716.     # test that $hash{KEY} = undef doesn't produce the warning
  717.     #     Use of uninitialized value in null operation 
  718.     use warnings ;
  719.     use strict ;
  720.     use DB_File ;
  722.     unlink $Dfile;
  723.     my %h ;
  724.     my $a = "";
  725.     local $SIG{__WARN__} = sub {$a = $_[0]} ;
  726.     
  727.     tie %h, 'DB_File', $Dfile or die "Can't open file: $!n" ;
  728.     $h{ABC} = undef;
  729.     ok(110, $a eq "") ;
  730.     untie %h ;
  731.     unlink $Dfile;
  732. }
  734. {
  735.     # test that %hash = () doesn't produce the warning
  736.     #     Argument "" isn't numeric in entersub
  737.     use warnings ;
  738.     use strict ;
  739.     use DB_File ;
  741.     unlink $Dfile;
  742.     my %h ;
  743.     my $a = "";
  744.     local $SIG{__WARN__} = sub {$a = $_[0]} ;
  745.     
  746.     tie %h, 'DB_File', $Dfile or die "Can't open file: $!n" ;
  747.     %h = (); ;
  748.     ok(111, $a eq "") ;
  749.     untie %h ;
  750.     unlink $Dfile;
  751. }
  753. exit ;