File Coverage

blib/lib/Tie/Hash/MinPerfHashTwoLevel/OnDisk.pm

Criterion	Covered	Total	%
statement	97	114	85.0
branch	35	54	64.8
condition	11	17	64.7
subroutine	18	24	75.0
pod	5	6	83.3
total	166	215	77.2

package Tie::Hash::MinPerfHashTwoLevel::OnDisk;
use strict;
use warnings;
our $VERSION = '0.14';

# this also installs the XS routines we use into our namespace.
use Algorithm::MinPerfHashTwoLevel ( 'hash_with_state', '$DEFAULT_VARIANT', ':flags', 'MAX_VARIANT' );
use Exporter qw(import);
my %constants;
BEGIN {
    %constants= (
        MAGIC_STR               =>  "PH2L",
       #MPH_F_FILTER_UNDEF      =>  (1<<0),
       #MPH_F_DETERMINISTIC     =>  (1<<1),
        MPH_F_NO_DEDUPE         =>  (1<<2),
        MPH_F_VALIDATE          =>  (1<<3),
    );
}

use constant \%constants;
use Carp;

our %EXPORT_TAGS = (
    'all' => [ qw(mph2l_tied_hashref mph2l_make_file MAX_VARIANT), sort keys %constants ],
    'flags' => ['MPH_F_DETERMINISTIC', grep /MPH_F_/, sort keys %constants],
    'magic' => [grep /MAGIC/, sort keys %constants],
);

my $scalar_has_slash= scalar(%EXPORT_TAGS)=~m!/!;
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();

sub mph2l_tied_hashref {
    my ($file, %opts)= @_;
    tie my %tied, __PACKAGE__, $file, %opts;
    return \%tied;
}

sub mph2l_make_file {
    my ($file,%opts)= @_;
    return __PACKAGE__->make_file(file => $file, %opts);
}

sub mph2l_validate_file {
    my ($file, %opts)= @_;
    return __PACKAGE__->validate_file(file => $file, %opts);
}

sub new {
    my ($class, %opts)= @_;

    $opts{flags} ||= 0;
    $opts{flags} |= MPH_F_VALIDATE if $opts{validate};
    my $error;
    my $mount= mount_file($opts{file},$error,$opts{flags});
    my $error_rsv= delete $opts{error_rsv};
    if ($error_rsv) {
        $$error_rsv= $error;
    }
    if (!defined($mount)) {
        if ($error_rsv) {
            return;
        } else {
            die "Failed to mount file '$opts{file}': $error";
        }
    }
    $opts{mount}= $mount;
    return bless \%opts, $class;
}

sub TIEHASH {
    my ($class, $file, %opts)= @_;
    return $class->new( file => $file, %opts );
}

sub FETCH {
    my ($self, $key)= @_;
    my $value;
    fetch_by_key($self->{mount},$key,$value)
        or return;
    return $value;
}

sub EXISTS {
    my ($self, $key)= @_;
    return fetch_by_key($self->{mount},$key);
}

sub FIRSTKEY {
    my ($self)= @_;
    $self->{iter_idx}= 0;
    return $self->NEXTKEY();
}

sub NEXTKEY {
    my ($self, $lastkey)= @_;
    fetch_by_index($self->{mount},$self->{iter_idx}++,my $key);
    return $key;
}

sub SCALAR {
    my ($self)= @_;
    my $buckets= $self->get_hdr_num_buckets();
    if ($scalar_has_slash) {
        $buckets .= "/" . $buckets;
    }
    return $buckets;
}

sub UNTIE {
    my ($self)= @_;
}

sub DESTROY {
    my ($self)= @_;
    unmount_file($self->{mount}) if $self->{mount};
}

sub STORE {
    my ($self, $key, $value)= @_;
    confess __PACKAGE__ . " is readonly, STORE operations are not supported";
}

sub DELETE {
    my ($self, $key)= @_;
    confess __PACKAGE__ . " is readonly, DELETE operations are not supported";
}

sub CLEAR {
    my ($self)= @_;
    confess __PACKAGE__ . " is readonly, CLEAR operations are not supported";
}

sub make_file {
    my ($class, %opts)= @_;

    my $ofile= $opts{file}
        or die "file is a mandatory option to make_file";
    my $source_hash= $opts{source_hash}
        or die "source_hash is a mandatory option to make_file";
    $opts{comment}= "" unless defined $opts{comment};
    $opts{variant}= $DEFAULT_VARIANT unless defined $opts{variant};

    my $comment= $opts{comment}||"";
    my $debug= $opts{debug} || 0;
    my $variant= int($opts{variant});
    my $deterministic= $opts{canonical} || $opts{deterministic};
    delete $opts{canonical};
    delete $opts{deterministic};

                    #1234567812345678
    $opts{seed} = "MinPerfHash2Levl"
        if !defined($opts{seed}) and $deterministic;

    my $compute_flags= int($opts{compute_flags}||0);
    $compute_flags += MPH_F_NO_DEDUPE if delete $opts{no_dedupe};
    $compute_flags += MPH_F_DETERMINISTIC
        if $deterministic;
    $compute_flags += MPH_F_FILTER_UNDEF
        if delete $opts{filter_undef};

    die "Unknown file variant $variant"
        if $variant > MAX_VARIANT or $variant < 0;

    die "comment cannot contain null"
        if index($comment,"\0") >= 0;

    my $seed= $opts{seed};
    my $hasher= Algorithm::MinPerfHashTwoLevel->new(
        debug => $debug,
        seed => (ref $seed ? $$seed : $seed),
        variant => $variant,
        compute_flags => $compute_flags,
        max_tries => $opts{max_tries},
    );
    my $buckets= $hasher->compute($source_hash);
    my $buf_length= $hasher->{buf_length};
    my $state= $hasher->{state};
    my $buf= packed_xs($variant, $buf_length, $state, $comment, $compute_flags, @$buckets);
    $$seed= $hasher->get_seed if ref $seed;

    my $tmp_file= "$ofile.$$";
    open my $ofh, ">", $tmp_file
        or die "Failed to open $tmp_file for output";
    print $ofh $buf
        or die "failed to print to '$tmp_file': $!";
    close $ofh
        or die "failed to close '$tmp_file': $!";
    rename $tmp_file, $ofile
        or die "failed to rename '$tmp_file' to '$ofile': $!";
    return $ofile;
}

sub validate_file {
    my ($class, %opts)= @_;
    my $file= $opts{file}
        or die "file is a mandatory option to validate_file";
    my $verbose= $opts{verbose};
    my ($variant,$msg);

    my $error_sv;
    my $self= $class->new(file => $file, flags => MPH_F_VALIDATE, error_rsv => \$error_sv);
    if ($self) {
        $msg= sprintf "file '%s' is a valid '%s' file\n"
         . "  variant: %d\n"
         . "  keys: %d\n"
         . "  hash-state: %s\n"
         . "  table  checksum: %016x\n"
         . "  string checksum: %016x\n"
         . "  comment: %s"
         ,  $file,
            MAGIC_STR,
            $self->get_hdr_variant,
            $self->get_hdr_num_buckets,
            unpack("H*", $self->get_state),
            $self->get_hdr_table_checksum,
            $self->get_hdr_str_buf_checksum,
            $self->get_comment,
        ;
        $variant = $self->get_hdr_variant;
    } else {
        $msg= $error_sv;
    }
    if ($verbose) {
        if (defined $variant) {
            print $msg;
        } else {
            die $msg."\n";
        }
    }
    return ($variant, $msg);
}



1;
__END__