view release on metacpan or  search on metacpan

t/OnDisk.pl  view on Meta::CPAN

#########################

use strict;
use warnings;

use Test::More;
use File::Temp;
use Data::Dumper; $Data::Dumper::Sortkeys=1; $Data::Dumper::Useqq=1;

use Tie::Hash::MinPerfHashTwoLevel::OnDisk qw(MAX_VARIANT MIN_VARIANT);

sub slurp {
    my ($file_spec)= @_;
    open my $fh, "<", $file_spec
        or die "failed to read '$file_spec': $!";
    local $/;
    my $data= <$fh>;
    return $data;
}

sub files_eq {
    my ($lfile,$rfile)= @_;
    my $left= slurp($lfile);
    my $right= slurp($rfile);
    my $ret= (defined($left) == defined($right) and defined($right) and $left eq $right);
    if (!$ret) {
        diag (sprintf "'%s' is %s bytes '%s' is %s bytes",
            $lfile => length($left)//'undef', $rfile => length($right)//'undef');
        require Data::Dumper;
        diag Data::Dumper::qquote($left),"\n";
        diag Data::Dumper::qquote($right),"\n";

    }
    return $ret;
}

my $class= 'Tie::Hash::MinPerfHashTwoLevel::OnDisk';
plan tests => 2 + 1830 * (defined($ENV{VARIANT}) ? 1 : MAX_VARIANT - MIN_VARIANT + 1);

my $srand= $ENV{SRAND} ? srand(0+$ENV{SRAND}) : srand();
ok(defined($srand),"srand as expected: $srand");
my $eval_ok= eval {
    tie my(%fail), $class => $0;
    1;
};
my $error= !$eval_ok && $@;
ok($error,"it failed: $@");

my $tmpdir= File::Temp->newdir();

my $not_utf8= "not utf8: \x{DF}";
my $utf8_can_be_downgraded= "was utf8: \x{DF}";
utf8::upgrade($utf8_can_be_downgraded);
my $must_be_utf8= "is utf8: \x{100}"; # this can ONLY be represented as utf8
my @source_hashes= (
    simple => {
        foo => "bar",
        baz => "bop",
        fiz => "shmang",
        plop => "shwoosh",
    },
    large => { map { $_ => $_ } 1 .. 50000 },
    mixed_utf8 => {
        $not_utf8 => $not_utf8,
        $utf8_can_be_downgraded => $utf8_can_be_downgraded,
        $must_be_utf8 => $must_be_utf8,
        map { chr($_) => chr($_) } 240 .. 270,
    },
    pow2_08 =>
    { map { $_ => $_ } 1 .. 8 },
    pow2_16 =>
    { map { $_ => $_ } 1 .. 16 },
    pow2_32 =>
    { map { $_ => $_ } 1 .. 32 },
    pow2_64 =>
    { map { $_ => $_ } 1 .. 64 },

    chr_chr_utf8 =>
    { map { chr($_) => chr($_) } 256 .. 270 },
    chr_num_utf8 =>
    { map { chr($_) => $_ } 256 .. 270 },
    num_chr_utf8 =>
    { map { $_ => chr($_) } 256 .. 270 },
    mix_mix_utf8 =>
    { map { ($_ % 2 ? chr($_) : $_) => ($_ % 2 ? $_ : chr($_)) } 256 .. 270 },
    chr_mix_utf8 =>
    { map { chr($_)                 => ($_ % 2 ? $_ : chr($_)) } 256 .. 270 },
    num_mix_utf8 =>
    { map { $_                      => ($_ % 2 ? $_ : chr($_)) } 256 .. 270 },
    mix_num_utf8 =>
    { map { ($_ % 2 ? chr($_) : $_) => $_                      } 256 .. 270 },
    mix_chr_utf8 =>
    { map { ($_ % 2 ? chr($_) : $_) => chr($_)                 } 256 .. 270 },

);

my $rand_seed= join("",map chr(rand 256), 1..16);
foreach my $seed ("1234567812345678", undef, $rand_seed) {
    foreach my $idx (0 .. (@source_hashes/2)-1) {
        my $name= $source_hashes[$idx*2];
        my $source_hash= $source_hashes[$idx*2+1];
        foreach my $variant (defined($ENV{VARIANT}) ? ($ENV{VARIANT}) : (MIN_VARIANT .. MAX_VARIANT)) {
            foreach my $canonical (0 .. 1) {
                my $seed_str= !defined $seed ? "undef" : unpack("H*",$seed);
                my $title= "$name seed:$seed_str variant:$variant";
                my $test_fn= "test.$seed_str.$idx.$variant.$canonical.hash";
                my $test_file= "$tmpdir/$test_fn";
                my $corpus_file= ($canonical && (!$seed or $seed ne $rand_seed)) ? "t/corpus/$test_fn" : "";
                my $seed_arg= $seed;
                ok(1,"starting testset ($title)");
                #diag "building file $test_file";
                my $got_file;
                my $this_comment= "this is a comment: $title";
                my $eval_ok= eval {
                    $got_file= $class->make_file(
                        file        => $test_file,
                        source_hash => $source_hash,
                        comment     => $this_comment,
                        debug       => $ENV{TEST_VERBOSE},
                        seed        => \$seed_arg,
                        variant     => $variant,
                        canonical   => $canonical,
                    );
                    1;