db-recno.t

File system using stacked.

{
    # test that %hash = () doesn't produce the warning
    #     Argument "" isn't numeric in entersub
    use warnings ;
    use strict ;
    use DB_File ;
    my $a = "";
    local $SIG{__WARN__} = sub {$a = $_[0]} ;

    unlink $Dfile;
    my @h ;
    
    tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
	or die "Can't open file: $!\n" ;
    @h = (); ;
    ok(152, $a eq "") ;
    ok(153, safeUntie \@h);
    unlink $Dfile;
}

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

   use warnings ;
   use strict ;
   my (@h, $db) ;
   unlink $Dfile;

   ok(154, $db = tie(@h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) );

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

   $_ = "original" ;

   $h[0] = "joe" ;
   ok(155, $h[0] eq "joe");

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


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

   $h[1] = "joe" ;

   ok(157, $h[1] eq "joe");

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

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

# Only test splice if this is a newish version of Perl
exit unless $FA ;

# Test SPLICE

{
    # check that the splice warnings are under the same lexical control
    # as their non-tied counterparts.

    use warnings;
    use strict;

    my $a = '';
    my @a = (1);
    local $SIG{__WARN__} = sub {$a = $_[0]} ;

    unlink $Dfile;
    my @tied ;
    
    tie @tied, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0664, $DB_RECNO 
	or die "Can't open file: $!\n" ;

    # uninitialized offset
    use warnings;
    my $offset ;
    $a = '';
    splice(@a, $offset);
    ok(159, $a =~ /^Use of uninitialized value /);
    $a = '';
    splice(@tied, $offset);
    ok(160, $a =~ /^Use of uninitialized value in splice/);

    no warnings 'uninitialized';
    $a = '';
    splice(@a, $offset);
    ok(161, $a eq '');
    $a = '';
    splice(@tied, $offset);
    ok(162, $a eq '');

    # uninitialized length
    use warnings;
    my $length ;
    $a = '';
    splice(@a, 0, $length);
    ok(163, $a =~ /^Use of uninitialized value /);
    $a = '';
    splice(@tied, 0, $length);
    ok(164, $a =~ /^Use of uninitialized value in splice/);

    no warnings 'uninitialized';
    $a = '';
    splice(@a, 0, $length);
    ok(165, $a eq '');
    $a = '';
    splice(@tied, 0, $length);
    ok(166, $a eq '');

    # offset past end of array
    use warnings;
    $a = '';
    splice(@a, 3);
    my $splice_end_array = ($a =~ /^splice\(\) offset past end of array/);
    $a = '';
    splice(@tied, 3);
    ok(167, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);

    no warnings 'misc';
    $a = '';
    splice(@a, 3);
    ok(168, $a eq '');
    $a = '';
    splice(@tied, 3);
    ok(169, $a eq '');

    ok(170, safeUntie \@tied);
    unlink $Dfile;
}

# 
# These are a few regression tests: bundles of five arguments to pass
# to test_splice().  The first four arguments correspond to those
# given to splice(), and the last says which context to call it in
# (scalar, list or void).
# 
# The expected result is not needed because we get that by running
# Perl's built-in splice().
# 
my @tests = ([ [ 'falsely', 'dinosaur', 'remedy', 'commotion',
		 'rarely', 'paleness' ],
	       -4, -2,
	       [ 'redoubled', 'Taylorize', 'Zoe', 'halogen' ],
	       'void' ],

	     [ [ 'a' ], -2, 1, [ 'B' ], 'void' ],

	     [ [ 'Hartley', 'Islandia', 'assents', 'wishful' ],
	       0, -4,
	       [ 'maids' ],
	       'void' ],

	     [ [ 'visibility', 'pocketful', 'rectangles' ],
	       -10, 0,
	       [ 'garbages' ],
	       'void' ],

	     [ [ 'sleeplessly' ],
	       8, -4,
	       [ 'Margery', 'clearing', 'repercussion', 'clubs',
		 'arise' ],
	       'void' ],

	     [ [ 'chastises', 'recalculates' ],
	       0, 0,
	       [ 'momentariness', 'mediates', 'accents', 'toils',
		 'regaled' ],
	       'void' ],

	     [ [ 'b', '' ],
	       9, 8,
	       [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
	       'scalar' ],

	     [ [ 'b', '' ],
	       undef, undef,
	       [ 'otrb', 'stje', 'ixrpw', 'vxfx', 'lhhf' ],
	       'scalar' ],
	     
	     [ [ 'riheb' ], -8, undef, [], 'void' ],

	     [ [ 'uft', 'qnxs', '' ],
	       6, -2,
	       [ 'znp', 'mhnkh', 'bn' ],
	       'void' ],
	    );

my $testnum = 171;
my $failed = 0;
require POSIX; my $tmp = POSIX::tmpnam();
foreach my $test (@tests) {
    my $err = test_splice(@$test);
    if (defined $err) {
	print STDERR "# failed: ", Dumper($test);
	print STDERR "# error: $err\n";
	$failed = 1;
	ok($testnum++, 0);
    }
    else { ok($testnum++, 1) }
}

if ($failed) {
    # Not worth running the random ones
    print STDERR '# skipping ', $testnum++, "\n";
}
else {
    # A thousand randomly-generated tests
    $failed = 0;
    srand(0);
    foreach (0 .. 1000 - 1) {
	my $test = rand_test();
	my $err = test_splice(@$test);
	if (defined $err) {
	    print STDERR "# failed: ", Dumper($test);
	    print STDERR "# error: $err\n";
	    $failed = 1;
	    print STDERR "# skipping any remaining random tests\n";
	    last;
	}
    }

    ok($testnum++, not $failed);
}

die "testnum ($testnum) != total_tests ($total_tests) + 1" 
    if $testnum != $total_tests + 1;

exit ;

# Subroutines for SPLICE testing

# test_splice()
# 
# Test the new splice() against Perl's built-in one.  The first four
# parameters are those passed to splice(), except that the lists must
# be (explicitly) passed by reference, and are not actually modified.
# (It's just a test!)  The last argument specifies the context in
# which to call the functions: 'list', 'scalar', or 'void'.
# 
# Returns:
#   undef, if the two splices give the same results for the given
#     arguments and context;
# 
#   an error message showing the difference, otherwise.
# 
# Reads global variable $tmp.
# 
sub test_splice {
    die 'usage: test_splice(array, offset, length, list, context)' if @_ != 5;
    my ($array, $offset, $length, $list, $context) = @_;
    my @array = @$array;
    my @list = @$list;

    unlink $tmp;
    
    my @h;
    my $H = tie @h, 'DB_File', $tmp, O_CREAT|O_RDWR, 0644, $DB_RECNO
      or die "cannot open $tmp: $!";

    my $i = 0;
    foreach ( @array ) { $h[$i++] = $_ }
    
    return "basic DB_File sanity check failed"
      if list_diff(\@array, \@h);

    # Output from splice():
    # Returned value (munged a bit), error msg, warnings
    # 
    my ($s_r, $s_error, @s_warnings);

    my $gather_warning = sub { push @s_warnings, $_[0] };
    if ($context eq 'list') {
	my @r;
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    @r = splice @array, $offset, $length, @list;
	};
	$s_error = $@;
	$s_r = \@r;
    }
    elsif ($context eq 'scalar') {
	my $r;
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    $r = splice @array, $offset, $length, @list;
	};
	$s_error = $@;
	$s_r = [ $r ];
    }
    elsif ($context eq 'void') {
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    splice @array, $offset, $length, @list;
	};
	$s_error = $@;
	$s_r = [];
    }
    else {
	die "bad context $context";
    }

    foreach ($s_error, @s_warnings) {
	chomp;
	s/ at \S+ line \d+\.$//;
    }

    # Now do the same for DB_File's version of splice
    my ($ms_r, $ms_error, @ms_warnings);
    $gather_warning = sub { push @ms_warnings, $_[0] };
    if ($context eq 'list') {
	my @r;
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    @r = splice @h, $offset, $length, @list;
	};
	$ms_error = $@;
	$ms_r = \@r;
    }
    elsif ($context eq 'scalar') {
	my $r;
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    $r = splice @h, $offset, $length, @list;
	};
	$ms_error = $@;
	$ms_r = [ $r ];
    }
    elsif ($context eq 'void') {
	eval {
	    local $SIG{__WARN__} = $gather_warning;
	    splice @h, $offset, $length, @list;
	};
	$ms_error = $@;
	$ms_r = [];
    }
    else {
	die "bad context $context";
    }

    foreach ($ms_error, @ms_warnings) {
	chomp;
	s/ at \S+ line \d+\.?.*//s;
    }

    return "different errors: '$s_error' vs '$ms_error'"
      if $s_error ne $ms_error;
    return('different return values: ' . Dumper($s_r) . ' vs ' . Dumper($ms_r))
      if list_diff($s_r, $ms_r);
    return('different changed list: ' . Dumper(\@array) . ' vs ' . Dumper(\@h))
      if list_diff(\@array, \@h);

    if ((scalar @s_warnings) != (scalar @ms_warnings)) {
	return 'different number of warnings';
    }

    while (@s_warnings) {
	my $sw  = shift @s_warnings;
	my $msw = shift @ms_warnings;
	
	if (defined $sw and defined $msw) {
	    $msw =~ s/ \(.+\)$//;
	    $msw =~ s/ in splice$// if $] < 5.006;
	    if ($sw ne $msw) {
		return "different warning: '$sw' vs '$msw'";
	    }
	}
	elsif (not defined $sw and not defined $msw) {
	    # Okay.
	}
	else {
	    return "one warning defined, another undef";
	}
    }
    
    undef $H;
    untie @h;
    
    open(TEXT, $tmp) or die "cannot open $tmp: $!";
    @h = <TEXT>; normalise @h; chomp @h;
    close TEXT or die "cannot close $tmp: $!";
    return('list is different when re-read from disk: '
	   . Dumper(\@array) . ' vs ' . Dumper(\@h))
      if list_diff(\@array, \@h);

    return undef; # success
}


# list_diff()
#
# Do two lists differ?
#
# Parameters:
#   reference to first list
#   reference to second list
#
# Returns true iff they differ.  Only works for lists of (string or
# undef). 
# 
# Surely there is a better way to do this?
# 
sub list_diff {
    die 'usage: list_diff(ref to first list, ref to second list)'
      if @_ != 2;
    my ($a, $b) = @_;
    my @a = @$a; my @b = @$b;
    return 1 if (scalar @a) != (scalar @b);
    for (my $i = 0; $i < @a; $i++) {
	my ($ae, $be) = ($a[$i], $b[$i]);
	if (defined $ae and defined $be) {
	    return 1 if $ae ne $be;
	}
	elsif (not defined $ae and not defined $be) {
	    # Two undefined values are 'equal'
	}
	else {
	    return 1;
	}
    }
    return 0;
} 


# rand_test()
# 
# Think up a random ARRAY, OFFSET, LENGTH, LIST, and context.
# ARRAY or LIST might be empty, and OFFSET or LENGTH might be
# undefined.  Return a 'test' - a listref of these five things.
# 
sub rand_test {
    die 'usage: rand_test()' if @_;
    my @contexts = qw<list scalar void>;
    my $context = $contexts[int(rand @contexts)];
    return [ rand_list(),
	     (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
	     (rand() < 0.5) ? (int(rand(20)) - 10) : undef,
	     rand_list(),
	     $context ];
}


sub rand_list {
    die 'usage: rand_list()' if @_;
    my @r;

    while (rand() > 0.1 * (scalar @r + 1)) {
	push @r, rand_word();
    }
    return \@r;
}


sub rand_word {
    die 'usage: rand_word()' if @_;
    my $r = '';
    my @chars = qw<a b c d e f g h i j k l m n o p q r s t u v w x y z>;
    while (rand() > 0.1 * (length($r) + 1)) {
	$r .= $chars[int(rand(scalar @chars))];
    }
    return $r;
}