db-hash.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./perl -w
BEGIN {
print "1..0 # Skip: DB_File was not built\n";
exit 0;
}
}
use strict;
use warnings;
use DB_File;
use Fcntl;
print "1..111\n";
sub ok
{
my $no = shift ;
my $result = shift ;
}
{
use Symbol ;
sub new
{
my $class = shift ;
my $filename = shift ;
return bless [$fh, $real_stdout ] ;
}
sub DESTROY
{
my $self = shift ;
}
}
sub docat_del
{
my $file = shift;
local $/ = undef;
return $result;
}
my $Dfile = "dbhash.tmp";
my $null_keys_allowed = ($DB_File::db_ver < 2.004010
umask(0);
# Check the interface to HASHINFO
$dbh->{hash} = "abc" ;
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
eval 'my $q = $dbh->{fred}' ;
# Now check the interface to HASH
my ($X, %h);
$i++;
}
ok(17, !$i );
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
$h{'jkl','mno'} = "JKL\034MNO";
$h{'a'} = 'A';
#$h{'b'} = 'B';
$h{'c'} = 'C';
#$h{'d'} = 'D';
$h{'e'} = 'E';
$h{'f'} = 'F';
$h{'g'} = 'X';
$h{'h'} = 'H';
$h{'i'} = 'I';
$h{'goner2'} = 'snork';
delete $h{'goner2'};
# IMPORTANT - $X must be undefined before the untie otherwise the
# underlying DB close routine will not get called.
undef $X ;
untie(%h);
# tie to the same file again, do not supply a type - should default to HASH
# Modify an entry from the previous tie
$h{'g'} = 'G';
$h{'j'} = 'J';
$h{'k'} = 'K';
$h{'l'} = 'L';
$h{'m'} = 'M';
$h{'n'} = 'N';
$h{'o'} = 'O';
$h{'p'} = 'P';
$h{'q'} = 'Q';
$h{'r'} = 'R';
$h{'s'} = 'S';
$h{'t'} = 'T';
$h{'u'} = 'U';
$h{'v'} = 'V';
$h{'w'} = 'W';
$h{'x'} = 'X';
$h{'y'} = 'Y';
$h{'z'} = 'Z';
$h{'goner3'} = 'snork';
delete $h{'goner1'};
$i = 0 ;
}
}
ok(24, $i == 30) ;
$h{'foo'} = '';
# Berkeley DB from version 2.4.10 to 3.0 does not allow null keys.
# This feature was reenabled in version 3.1 of Berkeley DB.
my $result = 0 ;
if ($null_keys_allowed) {
$h{''} = 'bar';
}
else
{ $result = 1 }
# check cache overflow and numeric keys and contents
my $ok = 1;
for ($i = 1; $i < 200; $i++) { $h{$i + 0} = $i + 0; }
@h{0..200} = 200..400;
my @foo = @h{0..200};
# Now check all the non-tie specific stuff
# Check NOOVERWRITE will make put fail when attempting to overwrite
# an existing record.
# check that the value of the key 'x' has not been changed by the
# previous test
# standard put
#check that previous put can be retrieved
$value = 0 ;
# Attempting to delete an existing key should work
# Make sure that the key deleted, cannot be retrieved
{
}
# Attempting to delete a non-existant key should fail
# Check the get interface
# First a non-existing key
# Next an existing key
# seq
# ###
# use seq to walk backwards through a file - check that this reversed is
# sync
# ####
# fd
# ##
undef $X ;
untie %h ;
# clear
# #####
foreach (1 .. 10)
{ $h{$_} = $_ * 100 }
# check that there are 10 elements in the hash
$i = 0 ;
$i++;
}
# now clear the hash
%h = () ;
# check it is empty
$i = 0 ;
$i++;
}
untie %h ;
# Now try an in memory file
# fd with an in memory file should return fail
undef $X ;
untie %h ;
{
# check ability to override the default hashing
my %x ;
$::count = 0 ;
$h{"abc"} = 123 ;
untie %x ;
}
{
# check that attempting to tie an array to a DB_HASH will fail
my @x ;
}
{
# sub-class test
use warnings ;
use strict ;
use warnings ;
use strict ;
require Exporter ;
use DB_File;
sub STORE {
my $self = shift ;
my $key = shift ;
my $value = shift ;
}
sub FETCH {
my $self = shift ;
my $key = shift ;
}
sub put {
my $self = shift ;
my $key = shift ;
my $value = shift ;
}
sub get {
my $self = shift ;
$_[1] -= 2 ;
}
sub A_new_method
{
my $self = shift ;
my $key = shift ;
}
1 ;
eval 'use SubDB ; ';
my %h ;
my $X ;
eval '
$X = tie(%h, "SubDB","dbhash.tmp", O_RDWR|O_CREAT, 0640, $DB_HASH );
' ;
my $value = 0;
undef $X;
}
{
# DBM Filter tests
use warnings ;
use strict ;
sub checkOutput
{
return
$fetch_key eq $fk && $store_key eq $sk &&
$fetch_value eq $fv && $store_value eq $sv &&
}
$_ = "original" ;
$h{"fred"} = "joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# replace the filters, but remember the previous set
$h{"Fred"} = "Joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# put the original filters back
$h{"fred"} = "joe" ;
# delete the filters
$h{"fred"} = "joe" ;
untie %h;
}
{
# DBM Filter with a closure
use warnings ;
use strict ;
sub Closure
{
my $count = 0 ;
return sub { ++$count ;
}
}
$_ = "original" ;
$h{"fred"} = "joe" ;
$h{"jim"} = "john" ;
untie %h;
}
{
# DBM Filter recursion detection
use warnings ;
use strict ;
eval '$h{1} = 1234' ;
untie %h;
}
{
# Examples from the POD
{
use strict ;
use DB_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"} ;
# print the contents of the file
{ print "$k -> $v\n" }
untie %h ;
}
}
{
# 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 ;
my %h ;
my $a = "";
untie %h ;
}
{
# test that %hash = () doesn't produce the warning
# Argument "" isn't numeric in entersub
use warnings ;
use strict ;
use DB_File ;
my %h ;
my $a = "";
%h = (); ;
untie %h ;
}
exit ;