db-recno.t

berkeleyDB,强大的嵌入式数据,多个数据库的内核

    #     Use of uninitialized value in subroutine entry


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

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

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

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

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

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

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

    # via the tied array is not a problem, but check anyway
    # substr of key
    $warned = '';
    for my $ix ( 6 .. 8 )
    {
        my $key = $ix . "data" ;
        my $value = "value$ix" ;
        $remember{substr($key,0,1)} = $value ;
        $h[substr($key,0,1)] = $value ;
    }

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

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

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

    my %bad = () ;
    my $key = '';
    for (my $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 174, keys %bad == 0 ;
    ok 175, 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
    my $value = 'fred';
    $warned = '';
    $status = $db->put(undef, $value) ;
    ok 176, $status == 0
      or print "# put failed - status $status\n";
    ok 177, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    print "# db_ver $DB_File::db_ver\n";
    $value = '' ;
    $status = $db->get(undef, $value) ;
    ok 178, $status == 0
	or print "# get failed - status $status\n" ;
    ok(179, $db->get(undef, $value) == 0) or print "# get failed\n" ;
    ok 180, $value eq 'fred' or print "# got [$value]\n" ;
    ok 181, $warned eq '' 
      or print "# Caught warning [$warned]\n" ;
    $warned = '';

    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(182, $a =~ /^Use of uninitialized value /);
    $a = '';
    splice(@tied, $offset);
    ok(183, $a =~ /^Use of uninitialized value in splice/);

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

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

    no warnings 'uninitialized';
    $a = '';
    splice(@a, 0, $length);
    ok(188, $a eq '');
    $a = '';
    splice(@tied, 0, $length);
    ok(189, $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(190, !$splice_end_array || $a =~ /^splice\(\) offset past end of array/);

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

    ok(193, 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 = 194;
my $failed = 0;
my $tmp = "dbr$$";
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+\.$//;
	# only built-in splice identifies name of uninit value
	s/(uninitialized value) \$\w+/$1/;
    }

    # 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);

    unlink $tmp;

    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;
}