view release on metacpan or  search on metacpan

t/db-btree.t  view on Meta::CPAN

# Now try an in memory file
my $Y;
ok(72, $Y = tie(%h, 'DB_File',undef, O_RDWR|O_CREAT, 0640, $DB_BTREE ));

# fd with an in memory file should return failure
$status = $Y->fd ;
ok(73, $status == -1 );


undef $Y ;
untie %h ;

# Duplicate keys
my $bt = DB_File::BTREEINFO->new();
$bt->{flags} = R_DUP ;
my ($YY, %hh);
ok(74, $YY = tie(%hh, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ;

$hh{'Wall'} = 'Larry' ;
$hh{'Wall'} = 'Stone' ; # Note the duplicate key
$hh{'Wall'} = 'Brick' ; # Note the duplicate key
$hh{'Wall'} = 'Brick' ; # Note the duplicate key and value
$hh{'Smith'} = 'John' ;
$hh{'mouse'} = 'mickey' ;

# first work in scalar context
ok(75, scalar $YY->get_dup('Unknown') == 0 );
ok(76, scalar $YY->get_dup('Smith') == 1 );
ok(77, scalar $YY->get_dup('Wall') == 4 );

# now in list context
my @unknown = $YY->get_dup('Unknown') ;
ok(78, "@unknown" eq "" );

my @smith = $YY->get_dup('Smith') ;
ok(79, "@smith" eq "John" );

{
my @wall = $YY->get_dup('Wall') ;
my %wall ;
@wall{@wall} = @wall ;
ok(80, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
}

# hash
my %unknown = $YY->get_dup('Unknown', 1) ;
ok(81, keys %unknown == 0 );

my %smith = $YY->get_dup('Smith', 1) ;
ok(82, keys %smith == 1 && $smith{'John'}) ;

my %wall = $YY->get_dup('Wall', 1) ;
ok(83, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
                && $wall{'Brick'} == 2);

undef $YY ;
untie %hh ;
unlink $Dfile;


# test multiple callbacks
my $Dfile1 = "btree1" ;
my $Dfile2 = "btree2" ;
my $Dfile3 = "btree3" ;

my $dbh1 = DB_File::BTREEINFO->new();
$dbh1->{compare} = sub {
        no warnings 'numeric' ;
        $_[0] <=> $_[1] } ;

my $dbh2 = DB_File::BTREEINFO->new();
$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;

my $dbh3 = DB_File::BTREEINFO->new();
$dbh3->{compare} = sub { length $_[0] <=> length $_[1] } ;


my (%g, %k);
tie(%h, 'DB_File',$Dfile1, O_RDWR|O_CREAT, 0640, $dbh1 ) or die $!;
tie(%g, 'DB_File',$Dfile2, O_RDWR|O_CREAT, 0640, $dbh2 ) or die $!;
tie(%k, 'DB_File',$Dfile3, O_RDWR|O_CREAT, 0640, $dbh3 ) or die $!;

my @Keys = qw( 0123 12 -1234 9 987654321 def  ) ;
my (@srt_1, @srt_2, @srt_3);
{
  no warnings 'numeric' ;
  @srt_1 = sort { $a <=> $b } @Keys ;
}
@srt_2 = sort { $a cmp $b } @Keys ;
@srt_3 = sort { length $a <=> length $b } @Keys ;

foreach (@Keys) {
    $h{$_} = 1 ;
    $g{$_} = 1 ;
    $k{$_} = 1 ;
}

sub ArrayCompare
{
    my($a, $b) = @_ ;

    return 0 if @$a != @$b ;

    foreach (0 .. @$a - 1)
    {
        return 0 unless $$a[$_] eq $$b[$_];
    }

    1 ;
}

ok(84, ArrayCompare (\@srt_1, [keys %h]) );
ok(85, ArrayCompare (\@srt_2, [keys %g]) );
ok(86, ArrayCompare (\@srt_3, [keys %k]) );

untie %h ;
untie %g ;
untie %k ;
unlink $Dfile1, $Dfile2, $Dfile3 ;

# clear

t/db-btree.t  view on Meta::CPAN

    ok(157, $h{'Alpha_ABC'} == 2);
    ok(158, $h{'Alpha_DEF'} == 5);

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

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

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

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

{
    # now an error to pass 'compare' a non-code reference
    my $dbh = DB_File::BTREEINFO->new();

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

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

}


#{
#    # recursion detection in btree
#    my %hash ;
#    unlink $Dfile;
#    my $dbh = DB_File::BTREEINFO->new();
#    $dbh->{compare} = sub { $hash{3} = 4 ; length $_[0] } ;
#
#
#    my (%h);
#    ok(164, tie(%hash, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh ) );
#
#    eval {     $hash{1} = 2;
#               $hash{4} = 5;
#        };
#
#    ok(165, $@ =~ /^DB_File btree_compare: recursion detected/);
#    {
#        no warnings;
#        untie %hash;
#    }
#    unlink $Dfile;
#}
ok(164,1);
ok(165,1);

{
    # Check that two callbacks don't interact
    my %hash1 ;
    my %hash2 ;
    my $h1_count = 0;
    my $h2_count = 0;
    unlink $Dfile, $Dfile2;
    my $dbh1 = DB_File::BTREEINFO->new();
    $dbh1->{compare} = sub { ++ $h1_count ; $_[0] cmp $_[1] } ;

    my $dbh2 = DB_File::BTREEINFO->new();
    $dbh2->{compare} = sub { ;++ $h2_count ; $_[0] cmp $_[1] } ;



    my (%h);
    ok(166, tie(%hash1, 'DB_File',$Dfile, O_RDWR|O_CREAT, 0640, $dbh1 ) );
    ok(167, 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(168, $h1_count > 0);
    ok(169, $h1_count == $h2_count);

    ok(170, safeUntie \%hash1);
    ok(171, safeUntie \%hash2);
    unlink $Dfile, $Dfile2;
}

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

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

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

   $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(173, $h{"fred"} eq "joe");

   eval { my @r= grep { $h{$_} } (1, 2, 3) };
   ok (174, ! $@);


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