File Coverage

blib/lib/Algorithm/MinPerfHashTwoLevel.pm

Criterion	Covered	Total	%
statement	66	80	82.5
branch	17	32	53.1
condition	9	15	60.0
subroutine	14	16	87.5
pod	2	7	28.5
total	108	150	72.0

package Algorithm::MinPerfHashTwoLevel;
use strict;
use warnings;
our $VERSION = '0.15';
our $DEFAULT_VARIANT = 5;

use Exporter qw(import);
use Carp ();

no warnings "portable";
my %constant;
BEGIN {
    %constant= (
        MPH_F_FILTER_UNDEF          =>  (1<<0),
        MPH_F_DETERMINISTIC         =>  (1<<1),
       #MPH_F_NO_DEDUPE             =>  (1<<2),
       #MPH_F_VALIDATE              =>  (1<<3),
        MAX_VARIANT                 =>  5,
        MIN_VARIANT                 =>  5,
        STADTX_HASH_SEED_BYTES      => 16,
        STADTX_HASH_STATE_BYTES     => 32,
    );
}
use constant \%constant;

our %EXPORT_TAGS = (
    'all' => [
        '$DEFAULT_VARIANT',
        'MAX_VARIANT',
        'MIN_VARIANT',
        qw(
            seed_state
            hash_with_state
        ), sort keys %constant
    ],
    'flags' => [ sort grep /MPH_F_/, keys %constant ],
);

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw();


require XSLoader;
XSLoader::load('Algorithm::MinPerfHashTwoLevel', $VERSION);

# Preloaded methods go here.

use Carp ();

sub new {
    my ($class,%opts)= @_;
    my $seed= delete($opts{seed});
    delete($opts{state}) and warn "ignoring 'state' parameter";

    my $o= bless \%opts, $class;

    $o->set_seed($seed) if $seed;

    $o->{variant}= $DEFAULT_VARIANT unless defined $o->{variant};
    $o->{variant}= int(0+$o->{variant});

    $o->{compute_flags} ||= 0;
    $o->{compute_flags} += MPH_F_FILTER_UNDEF
        if delete $o->{filter_undef};
    $o->{compute_flags} += MPH_F_DETERMINISTIC
        if delete $o->{deterministic} or delete $o->{canonical};

    die "Unknown variant '$o->{variant}' in constructor new(), max known is "
        . MAX_VARIANT . " default is " . $DEFAULT_VARIANT
        if $o->{variant} > MAX_VARIANT;
    die "Unknown variant '$o->{variant}' in constructor new(), min known is "
        . MIN_VARIANT . " default is " . $DEFAULT_VARIANT
        if $o->{variant} < MIN_VARIANT;

    return $o;
}

sub compute {
    my ($self, $source_hash)= @_;
    if ($source_hash) {
        $self->{source_hash}= $source_hash;
    } else {
        $source_hash= $self->{source_hash};
    }
    my $debug= $self->{debug} ||= 0;

    # reuse the constructor seed.
    $self->_seed($self->{constructor_seed});

    # find the number of keys we have to deal with
    my $max_tries= $self->{max_tries} || 10;
    my @failed_seeds;
    $self->{failed_seeds}= \@failed_seeds;

    for my $counter ( 1 .. $max_tries ) {
        my $seed= $self->get_seed; # ensure we have a seed set up (must be called before compute_xs)
        my $state= $self->get_state; # ensure we have a state set up (must be called before compute_xs)
        delete $self->{buckets};

        printf "MPH2L compute attempt #%2d/%2d for hash with %6d keys - using seed: %s (state: %s)\n",
            $counter,
            $max_tries,
            0+keys(%$source_hash),
            unpack("H*",$seed),
            unpack("H*",$state),
            if $debug;

        my $bad_idx= compute_xs($self)
            or return $self->{buckets};

        push @failed_seeds, $seed;
        if ($counter < $max_tries) {
            $self->re_seed();
        }
    }

    if ( $max_tries == 1 ) {
        die sprintf "Failed to compute minimal perfect hash using seed %s", unpack "H*", $failed_seeds[0];
    } else {
        Carp::confess(
            sprintf "Failed to compute minimal perfect hash after %d tries. Seeds tried: %s",
                $max_tries, join(" ", map { unpack "H*", $_ } @failed_seeds)
        );
    }
    # NOT REACHED.
}

sub re_seed {
    my $self= shift;

    my $source= $self->get_state();
    return $self->_seed(substr($source,0,STADTX_HASH_SEED_BYTES) ^ substr($source,STADTX_HASH_SEED_BYTES));
}


sub _seed {
    my $self= shift;
    if (@_) {
        my $seed= shift;
        Carp::confess(sprintf "Seed should be undef, or a string exactly %d bytes long, not %d bytes",
            STADTX_HASH_SEED_BYTES,length($seed))
            if defined($seed) and length($seed) != 16;
        $self->{seed}= $seed;
        delete $self->{state};
    }
    if ( !defined $self->{seed} ) {
                       #1234567812345678
        $self->{seed}= "MinPerfHash2Levl";
        delete $self->{state};
    }
    return $self->{seed};
}

sub set_seed {
    my ($self,$value)= @_;
    my $seed= $self->_seed($value);
    return $self->{constructor_seed}= $seed;
}

sub get_seed {
    my ($self)= @_;
    return $self->_seed();
}


sub get_state {
    my $self= shift;
    return $self->{state} ||= seed_state($self->_seed());
}

sub get_failed_seeds {
    my $self= shift;
    return @{$self->{failed_seeds}||[]};
}

1;
__END__