db-hash.t

关于Berkelay数据库的共享源码

   $db->filter_fetch_value (undef);
   $db->filter_store_value (undef);

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   $h{"fred"} = "joe" ;
   ok(85, checkOutput( "", "", "", "")) ;

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   ok(86, $h{"fred"} eq "joe");
   ok(87, checkOutput( "", "", "", "")) ;

   ($fetch_key, $store_key, $fetch_value, $store_value) = ("") x 4 ;
   $k = 'fred';
   ok(88, ! $db->seq($k, $v, R_FIRST) ) ;
   ok(89, $k eq "fred") ;
   ok(90, $v eq "joe") ;
   ok(91, checkOutput( "", "", "", "")) ;

   undef $db ;
   untie %h;
   unlink $Dfile;
}

{    
    # DBM Filter with a closure

    use warnings ;
    use strict ;
    my (%h, $db) ;

    unlink $Dfile;
    ok(92, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );

    my %result = () ;

    sub Closure
    {
        my ($name) = @_ ;
	my $count = 0 ;
	my @kept = () ;

	return sub { ++$count ; 
		     push @kept, $_ ; 
		     $result{$name} = "$name - $count: [@kept]" ;
		   }
    }

    $db->filter_store_key(Closure("store key")) ;
    $db->filter_store_value(Closure("store value")) ;
    $db->filter_fetch_key(Closure("fetch key")) ;
    $db->filter_fetch_value(Closure("fetch value")) ;

    $_ = "original" ;

    $h{"fred"} = "joe" ;
    ok(93, $result{"store key"} eq "store key - 1: [fred]");
    ok(94, $result{"store value"} eq "store value - 1: [joe]");
    ok(95, ! defined $result{"fetch key"} );
    ok(96, ! defined $result{"fetch value"} );
    ok(97, $_ eq "original") ;

    ok(98, $db->FIRSTKEY() eq "fred") ;
    ok(99, $result{"store key"} eq "store key - 1: [fred]");
    ok(100, $result{"store value"} eq "store value - 1: [joe]");
    ok(101, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(102, ! defined $result{"fetch value"} );
    ok(103, $_ eq "original") ;

    $h{"jim"}  = "john" ;
    ok(104, $result{"store key"} eq "store key - 2: [fred jim]");
    ok(105, $result{"store value"} eq "store value - 2: [joe john]");
    ok(106, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(107, ! defined $result{"fetch value"} );
    ok(108, $_ eq "original") ;

    ok(109, $h{"fred"} eq "joe");
    ok(110, $result{"store key"} eq "store key - 3: [fred jim fred]");
    ok(111, $result{"store value"} eq "store value - 2: [joe john]");
    ok(112, $result{"fetch key"} eq "fetch key - 1: [fred]");
    ok(113, $result{"fetch value"} eq "fetch value - 1: [joe]");
    ok(114, $_ eq "original") ;

    undef $db ;
    untie %h;
    unlink $Dfile;
}		

{
   # DBM Filter recursion detection
   use warnings ;
   use strict ;
   my (%h, $db) ;
   unlink $Dfile;

   ok(115, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );

   $db->filter_store_key (sub { $_ = $h{$_} }) ;

   eval '$h{1} = 1234' ;
   ok(116, $@ =~ /^recursion detected in filter_store_key at/ );
   
   undef $db ;
   untie %h;
   unlink $Dfile;
}


{
   # Examples from the POD

  my $file = "xyzt" ;
  {
    my $redirect = new Redirect $file ;

    use warnings FATAL => qw(all);
    use strict ;
    use DB_File ;
    our (%h, $k, $v);

    unlink "fruit" ;
    tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH 
        or die "Cannot open file 'fruit': $!\n";

    # Add a few key/value pairs to the file
    $h{"apple"} = "red" ;
    $h{"orange"} = "orange" ;
    $h{"banana"} = "yellow" ;
    $h{"tomato"} = "red" ;

    # Check for existence of a key
    print "Banana Exists\n\n" if $h{"banana"} ;

    # Delete a key/value pair.
    delete $h{"apple"} ;

    # print the contents of the file
    while (($k, $v) = each %h)
      { print "$k -> $v\n" }

    untie %h ;

    unlink "fruit" ;
  }  

  ok(117, docat_del($file) eq <<'EOM') ;
Banana Exists

orange -> orange
tomato -> red
banana -> yellow
EOM
   
}

{
    # Bug ID 20001013.009
    #
    # test that $hash{KEY} = undef doesn't produce the warning
    #     Use of uninitialized value in null operation 
    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
    
    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
    $h{ABC} = undef;
    ok(118, $a eq "") ;
    untie %h ;
    unlink $Dfile;
}

{
    # test that %hash = () doesn't produce the warning
    #     Argument "" isn't numeric in entersub
    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my %h ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;
    
    tie %h, 'DB_File', $Dfile or die "Can't open file: $!\n" ;
    %h = (); ;
    ok(119, $a eq "") ;
    untie %h ;
    unlink $Dfile;
}

{
    # When iterating over a tied hash using "each", the key passed to FETCH
    # will be recycled and passed to NEXTKEY. If a Source Filter modifies the
    # key in FETCH via a filter_fetch_key method we need to check that the
    # modified key doesn't get passed to NEXTKEY.
    # Also Test "keys" & "values" while we are at it.

    use warnings ;
    use strict ;
    use DB_File ;

    unlink $Dfile;
    my $bad_key = 0 ;
    my %h = () ;
    my $db ;
    ok(120, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );
    $db->filter_fetch_key (sub { $_ =~ s/^Beta_/Alpha_/ if defined $_}) ;
    $db->filter_store_key (sub { $bad_key = 1 if /^Beta_/ ; $_ =~ s/^Alpha_/Beta_/}) ;

    $h{'Alpha_ABC'} = 2 ;
    $h{'Alpha_DEF'} = 5 ;

    ok(121, $h{'Alpha_ABC'} == 2);
    ok(122, $h{'Alpha_DEF'} == 5);

    my ($k, $v) = ("","");
    while (($k, $v) = each %h) {}
    ok(123, $bad_key == 0);

    $bad_key = 0 ;
    foreach $k (keys %h) {}
    ok(124, $bad_key == 0);

    $bad_key = 0 ;
    foreach $v (values %h) {}
    ok(125, $bad_key == 0);

    undef $db ;
    untie %h ;
    unlink $Dfile;
}

{
    # now an error to pass 'hash' a non-code reference
    my $dbh = new DB_File::HASHINFO ;

    eval { $dbh->{hash} = 2 };
    ok(126, $@ =~ /^Key 'hash' not associated with a code reference at/);

}


#{
#    # recursion detection in hash
#    my %hash ;
#    my $Dfile = "xxx.db";
#    unlink $Dfile;
#    my $dbh = new DB_File::HASHINFO ;
#    $dbh->{hash} = sub { $hash{3} = 4 ; length $_[0] } ;
# 
# 
#    ok(127, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
#
#    eval {	$hash{1} = 2;
#    		$hash{4} = 5;
#	 };
#
#    ok(128, $@ =~ /^DB_File hash callback: recursion detected/);
#    {
#        no warnings;
#        untie %hash;
#    }
#    unlink $Dfile;
#}

#ok(127, 1);
#ok(128, 1);

{
    # Check that two hash's don't interact
    my %hash1 ;
    my %hash2 ;
    my $h1_count = 0;
    my $h2_count = 0;
    unlink $Dfile, $Dfile2;
    my $dbh1 = new DB_File::HASHINFO ;
    $dbh1->{hash} = sub { ++ $h1_count ; length $_[0] } ;

    my $dbh2 = new DB_File::HASHINFO ;
    $dbh2->{hash} = sub { ++ $h2_count ; length $_[0] } ;
 
 
 
    my (%h);
    ok(127, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
    ok(128, tie(%hash2, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) );

    $hash1{DEFG} = 5;
    $hash1{XYZ} = 2;
    $hash1{ABCDE} = 5;

    $hash2{defg} = 5;
    $hash2{xyz} = 2;
    $hash2{abcde} = 5;

    ok(129, $h1_count > 0);
    ok(130, $h1_count == $h2_count);

    ok(131, safeUntie \%hash1);
    ok(132, safeUntie \%hash2);
    unlink $Dfile, $Dfile2;
}

{
    # Passing undef for flags and/or mode when calling tie could cause 
    #     Use of uninitialized value in subroutine entry
    

    my $warn_count = 0 ;
    #local $SIG{__WARN__} = sub { ++ $warn_count };
    my %hash1;
    unlink $Dfile;

    tie %hash1, 'DB_File',$Dfile, undef;
    ok(133, $warn_count == 0);
    $warn_count = 0;
    untie %hash1;
    unlink $Dfile;
    tie %hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, undef;
    ok(134, $warn_count == 0);
    untie %hash1;
    unlink $Dfile;
    tie %hash1, 'DB_File',$Dfile, undef, undef;
    ok(135, $warn_count == 0);
    $warn_count = 0;

    untie %hash1;
    unlink $Dfile;
}

{
   # Check that DBM Filter can cope with read-only $_

   use warnings ;
   use strict ;
   my (%h, $db) ;
   my $Dfile = "xxy.db";
   unlink $Dfile;

   ok(136, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );

   $db->filter_fetch_key   (sub { }) ;
   $db->filter_store_key   (sub { }) ;
   $db->filter_fetch_value (sub { }) ;
   $db->filter_store_value (sub { }) ;

   $_ = "original" ;

   $h{"fred"} = "joe" ;
   ok(137, $h{"fred"} eq "joe");

   eval { grep { $h{$_} } (1, 2, 3) };
   ok (138, ! $@);


   # delete the filters
   $db->filter_fetch_key   (undef);
   $db->filter_store_key   (undef);
   $db->filter_fetch_value (undef);
   $db->filter_store_value (undef);

   $h{"fred"} = "joe" ;

   ok(139, $h{"fred"} eq "joe");

   ok(140, $db->FIRSTKEY() eq "fred") ;
   
   eval { grep { $h{$_} } (1, 2, 3) };
   ok (141, ! $@);

   undef $db ;
   untie %h;
   unlink $Dfile;
}

{
   # Check low-level API works with filter

   use warnings ;
   use strict ;
   my (%h, $db) ;
   my $Dfile = "xxy.db";
   unlink $Dfile;

   ok(142, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );


   $db->filter_fetch_key   (sub { $_ = unpack("i", $_) } );
   $db->filter_store_key   (sub { $_ = pack("i", $_) } );
   $db->filter_fetch_value (sub { $_ = unpack("i", $_) } );
   $db->filter_store_value (sub { $_ = pack("i", $_) } );

   $_ = 'fred';

   my $key = 22 ;
   my $value = 34 ;

   $db->put($key, $value) ;
   ok 143, $key == 22;
   ok 144, $value == 34 ;
   ok 145, $_ eq 'fred';
   #print "k [$key][$value]\n" ;

   my $val ;
   $db->get($key, $val) ;
   ok 146, $key == 22;
   ok 147, $val == 34 ;
   ok 148, $_ eq 'fred';

   $key = 51 ;
   $value = 454;
   $h{$key} = $value ;
   ok 149, $key == 51;
   ok 150, $value == 454 ;
   ok 151, $_ eq 'fred';

   undef $db ;
   untie %h;
   unlink $Dfile;
}


{
    # Regression Test for bug 30237
    # Check that substr can be used in the key to db_put
    # and that db_put does not trigger the warning
    # 
    #     Use of uninitialized value in subroutine entry


    use warnings ;
    use strict ;
    my (%h, $db) ;
    my $Dfile = "xxy.db";
    unlink $Dfile;

    ok(152, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );

    my $warned = '';
    local $SIG{__WARN__} = sub {$warned = $_[0]} ;

    # db-put with substr of key
    my %remember = () ;
    for my $ix ( 1 .. 2 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $db->put(substr($key,0), $value) ;
    }

    ok 153, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # db-put with substr of value
    $warned = '';
    for my $ix ( 10 .. 12 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $db->put($key, substr($value,0)) ;
    }

    ok 154, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # via the tied hash is not a problem, but check anyway
    # substr of key
    $warned = '';
    for my $ix ( 30 .. 32 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $h{substr($key,0)} = $value ;
    }

    ok 155, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    # via the tied hash is not a problem, but check anyway
    # substr of value
    $warned = '';
    for my $ix ( 40 .. 42 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $h{$key} = substr($value,0) ;
    }

    ok 156, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;

    my %bad = () ;
    $key = '';
    for ($status = $db->seq(substr($key,0), substr($value,0), R_FIRST ) ;
         $status == 0 ;
         $status = $db->seq(substr($key,0), substr($value,0), R_NEXT ) ) {

        #print "# key [$key] value [$value]\n" ;
        if (defined $remember{$key} && defined $value && 
             $remember{$key} eq $value) {
            delete $remember{$key} ;
        }
        else {
            $bad{$key} = $value ;
        }
    }
    
    ok 157, keys %bad == 0 ;
    ok 158, keys %remember == 0 ;

    print "# missing -- $key=>$value\n" while ($key, $value) = each %remember;
    print "# bad     -- $key=>$value\n" while ($key, $value) = each %bad;

    # Make sure this fix does not break code to handle an undef key
    # Berkeley DB undef key is broken between versions 2.3.16 and 3.1
    my $value = 'fred';
    $warned = '';
    $db->put(undef, $value) ;
    ok 159, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    my $no_NULL = ($DB_File::db_ver >= 2.003016 && $DB_File::db_ver < 3.001) ;
    print "# db_ver $DB_File::db_ver\n";
    $value = '' ;
    $db->get(undef, $value) ;
    ok 160, $no_NULL || $value eq 'fred' or print "# got [$value]\n" ;
    ok 161, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    undef $db ;
    untie %h;
    unlink $Dfile;
}

{
   # Check filter + substr

   use warnings ;
   use strict ;
   my (%h, $db) ;
   my $Dfile = "xxy.db";
   unlink $Dfile;

   ok(162, $db = tie(%h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH ) );


   {
       $db->filter_fetch_key   (sub { lc $_ } );
       $db->filter_store_key   (sub { uc $_ } );
       $db->filter_fetch_value (sub { lc $_ } );
       $db->filter_store_value (sub { uc $_ } );
   }

   $_ = 'fred';

    # db-put with substr of key
    my %remember = () ;
    my $status = 0 ;
    for my $ix ( 1 .. 2 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{$key} = $value ;
        $status += $db->put(substr($key,0), substr($value,0)) ;
    }

    ok 163, $status == 0 or print "# Status $status\n" ;

    if (1)
    {
       $db->filter_fetch_key   (undef);
       $db->filter_store_key   (undef);
       $db->filter_fetch_value (undef);
       $db->filter_store_value (undef);
    }

    my %bad = () ;
    my $key = '';
    my $value = '';
    for ($status = $db->seq($key, $value, R_FIRST ) ;
         $status == 0 ;
         $status = $db->seq($key, $value, R_NEXT ) ) {

        #print "# key [$key] value [$value]\n" ;
        if (defined $remember{$key} && defined $value && 
             $remember{$key} eq $value) {
            delete $remember{$key} ;
        }
        else {
            $bad{$key} = $value ;
        }
    }
    
    ok 164, $_ eq 'fred';
    ok 165, keys %bad == 0 ;
    ok 166, keys %remember == 0 ;

    print "# missing -- $key $value\n" while ($key, $value) = each %remember;
    print "# bad     -- $key $value\n" while ($key, $value) = each %bad;
   undef $db ;
   untie %h;
   unlink $Dfile;
}

exit ;