db-recno.t revision 7c478bd95313f5f23a4c958a745db2134aa03244
#!./perl -w
BEGIN {
print "1..0 # Skip: DB_File was not built\n";
exit 0;
}
}
use DB_File;
use Fcntl;
use strict ;
use warnings;
# full tied array support started in Perl 5.004_57
# Double check to see if it is available.
{
$FA = 0 ;
my @a ;
my $a = @a ;
}
sub ok
{
my $no = shift ;
my $result = shift ;
return $result ;
}
{
use Symbol ;
sub new
{
my $class = shift ;
my $filename = shift ;
return bless [$fh, $real_stdout ] ;
}
sub DESTROY
{
my $self = shift ;
}
}
sub docat
{
my $file = shift;
local $/ = undef;
return $result;
}
sub docat_del
{
my $file = shift;
local $/ = undef;
return $result;
}
sub bad_one
{
print STDERR <<EOM unless $bad_ones++ ;
#
# Some older versions of Berkeley DB version 1 will fail tests 51,
# 53 and 55.
#
# You can safely ignore the errors if you're never going to use the
# broken functionality (recno databases with a modified bval).
# Otherwise you'll have to upgrade your DB library.
#
# If you want to use Berkeley DB version 1, then 1.85 and 1.86 are the
# last versions that were released. Berkeley DB version 2 is continually
# being updated -- Check out http://www.sleepycat.com/ for more details.
#
EOM
}
print "1..128\n";
umask(0);
# Check the interface to RECNOINFO
# 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 RECNOINFO
my $X ;
my @h ;
#my $l = @h ;
my $l = $X->length ;
$h[0] = shift @data ;
my $ i;
foreach (@data)
{ $h[++$i] = $_ }
# Overwrite an entry & check fetch it
$h[3] = 'replaced' ;
#PUSH
# POP
# SHIFT
# UNSHIFT
# empty list
# SPLICE
# Now both arrays should be identical
my $ok = 1 ;
my $j = 0 ;
foreach (@data)
{
}
# Neagtive subscripts
# get the last element of the array
# get the first element using a negative subscript
eval '$h[ - ( $FA ? @h : $X->length)] = "abcd"' ;
# now try to read before the start of the array
eval '$h[ - (1 + ($FA ? @h : $X->length))] = 1234' ;
# IMPORTANT - $X must be undefined before the untie otherwise the
# underlying DB close routine will not get called.
undef $X ;
{
# Check bval defaults to \n
my @h = () ;
$h[0] = "abc" ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
}
{
# Change bval
my @h = () ;
$h[0] = "abc" ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
}
{
# Check R_FIXEDLEN with default bval (space)
my @h = () ;
$dbh->{flags} = R_FIXEDLEN ;
$h[0] = "abc" ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
}
{
# Check R_FIXEDLEN with user-defined bval
my @h = () ;
$dbh->{flags} = R_FIXEDLEN ;
$h[0] = "abc" ;
$h[1] = "def" ;
$h[3] = "ghi" ;
untie @h ;
}
{
# check that attempting to tie an associative array to a DB_RECNO 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","recno.tmp", O_RDWR|O_CREAT, 0640, $DB_RECNO );
' ;
my $value = 0;
undef $X;
}
{
# test $#
my $self ;
$h[0] = "abc" ;
$h[1] = "def" ;
$h[2] = "ghi" ;
$h[3] = "jkl" ;
untie @h ;
# $# sets array to same length
if ($FA)
{ $#h = 3 }
else
untie @h ;
# $# sets array to bigger
if ($FA)
{ $#h = 6 }
else
untie @h ;
# $# sets array smaller
if ($FA)
{ $#h = 2 }
else
untie @h ;
}
{
# 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[0] = "joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# replace the filters, but remember the previous set
$h[1] = "Joe" ;
# fk sk fv sv
# fk sk fv sv
# fk sk fv sv
# put the original filters back
$h[0] = "joe" ;
# delete the filters
$h[0] = "joe" ;
untie @h;
}
{
# DBM Filter with a closure
use warnings ;
use strict ;
sub Closure
{
my $count = 0 ;
return sub { ++$count ;
}
}
$_ = "original" ;
$h[0] = "joe" ;
$h[7] = "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 ;
my @h ;
$h[0] = "orange" ;
$h[1] = "blue" ;
$h[2] = "yellow" ;
# Check for existence of a key
print "Element 1 Exists with value $h[1]\n" if $h[1] ;
# use a negative index
print "The last element is $h[-1]\n" ;
print "The 2nd last element is $h[-2]\n" ;
undef $x ;
untie @h ;
}
{
my $redirect = new Redirect $save_output ;
use strict ;
use DB_File ;
use Fcntl ;
# first create a text file to play with
$h[0] = "zero" ;
$h[1] = "one" ;
$h[2] = "two" ;
$h[3] = "three" ;
$h[4] = "four" ;
# Print the records in order.
#
# The length method is needed here because evaluating a tied
# array in a scalar context does not return the number of
# elements in the array.
print "\nORIGINAL\n" ;
print "$i: $h[$i]\n" ;
}
# use the push & pop methods
$a = $H->pop ;
print "\nThe last record was [$a]\n" ;
# and the shift & unshift methods
$a = $H->shift ;
print "The first record was [$a]\n" ;
# Use the API to add a new record after record 2.
$i = 2 ;
# and a new record before record 1.
$i = 1 ;
# delete record 3
# now print the records in reverse order
print "\nREVERSE\n" ;
for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
{ print "$i: $h[$i]\n" }
# same again, but use the API functions instead
print "\nREVERSE again\n" ;
my ($s, $k, $v) = (0, 0, 0) ;
$s == 0 ;
{ print "$k: $v\n" }
undef $H ;
untie @h ;
}
0: zero
1: one
2: two
3: three
4: four
5: last
4: three
3: Newbie
2: one
0: first
5: last
4: three
3: Newbie
2: one
0: first
}
{
# 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 = "";
$h[0] = undef;
untie @h ;
}
{
# test that %hash = () doesn't produce the warning
# Argument "" isn't numeric in entersub
use warnings ;
use strict ;
use DB_File ;
my $a = "";
my @h ;
@h = (); ;
untie @h ;
}
exit ;