File Coverage

blib/lib/Algorithm/Toy/HashSC.pm

Criterion	Covered	Total	%
statement	78	78	100.0
branch	28	28	100.0
condition			n/a
subroutine	15	15	100.0
pod	8	8	100.0
total	129	129	100.0

# -*- Perl -*-
#
# Toy deterministic separate chain hash implementation, based on code in
# "Algorithms (4th Edition)" by Robert Sedgewick and Kevin Wayne. This
# code is not for any sort of use where performance is critical, or
# where malicious input may cause "Algorithmic Complexity Attacks" (see
# perlsec(1)).
#
# run perldoc(1) on this file for additional documentation

package Algorithm::Toy::HashSC;

use 5.010;
use strict;
use warnings;

use Carp qw/croak/;
use Moo;
use namespace::clean;
use Scalar::Util qw/looks_like_number/;

our $VERSION = '0.02';

##############################################################################
#
# ATTRIBUTES

# Each list should end up with ~N/M key-value pairs, assuming the input
# is not malicious, and that the hash function is perfect enough. "M"
# here is the modulus, and "N" is the number of key-value pairs added.
#
# Internally, it's an array of array of arrays, or something like that.
has _chain => (
    is      => 'rw',
    default => sub { [] },
);

has modulus => (
    is      => 'rw',
    default => sub { 7 },
    coerce  => sub {
        die 'modulus must be a positive integer > 1'
          if !defined $_[0]
          or !looks_like_number $_[0]
          or $_[0] < 2;
        return int $_[0];
    },
    trigger => sub {
        my ($self) = @_;
        # clobber extant hash (Moo does not provide old value, so cannot do
        # this only when the modulus changes, oh well)
        $self->_chain( [] ) unless $self->unsafe;
    },
);

# Boolean, disables various sanity checks if set to a true value (in
# particular whether the hash is cleared when the modulus is changed).
has unsafe => (
    is      => 'rw',
    default => sub { 0 },
    coerce  => sub { $_[0] ? 1 : 0 },
);

##############################################################################
#
# METHODS

sub clear_hash {
    my ($self) = @_;
    $self->_chain( [] );
    return $self;
}

sub get {
    my ( $self, $key ) = @_;
    croak "must provide key" if !defined $key;
    my $chain = $self->_chain->[ $self->hash($key) ];
    if ( defined $chain ) {
        for my $kvpair (@$chain) {
            return $kvpair->[1] if $key eq $kvpair->[0];
        }
    }
    return;
}

# Derives the index of the chain a particular key will be added to. The
# hashcode function, if available, should return something that ideally
# evenly distributes the given keys across the given modulus.
#
# Alternative: subclass this module and write yer own hash function.
sub hash {
    my ( $self, $key ) = @_;
    croak "must provide key" if !defined $key;
    my $code = 0;
    if ( $key->can('hashcode') ) {
        $code = $key->hashcode();
    } else {
        # this is pretty terrible...
        for my $n ( map ord, split //, $key ) {
            $code += $n;
        }
    }
    return abs( $code % $self->modulus );
}

sub keys {
    my ($self) = @_;
    my @keys;
    for my $chain ( @{ $self->_chain } ) {
        push @keys, map { $_->[0] } @$chain;
    }
    return @keys;
}

sub keys_in {
    my ( $self, $index ) = @_;
    croak "must provide index" if !defined $index;
    $index %= $self->modulus;    # this will int() any floating-point nums
    return map { $_->[0] } @{ $self->_chain->[$index] };
}

# Keys in the same chain (or bucket) as a given key
sub keys_with {
    my ( $self, $key ) = @_;
    croak "must provide key" if !defined $key;
    for my $chain ( @{ $self->_chain } ) {
        for my $kvpair (@$chain) {
            return map $_->[0], @$chain if $key eq $kvpair->[0];
        }
    }
    return;
}

sub put {
    my ( $self, $key, $value ) = @_;
    croak "must provide key" if !defined $key;
    my $chain = $self->_chain->[ $self->hash($key) ];
    if ( defined $chain ) {
        for my $kvpair (@$chain) {
            if ( $key eq $kvpair->[0] ) {
                $kvpair->[1] = $value;
                return $self;
            }
        }
    }
    push @{ $self->_chain->[ $self->hash($key) ] }, [ $key, $value ];
    return $self;
}

# a.k.a. delete but more indicative of the obtaining-a-value aspect
sub take {
    my ( $self, $key ) = @_;
    croak "must provide key" if !defined $key;
    my $chain = $self->_chain->[ $self->hash($key) ];
    if ( defined $chain ) {
        for my $i ( 0 .. $#$chain ) {
            if ( $key eq $chain->[$i][0] ) {
                my $kvpair = splice @$chain, $i, 1;
                return $kvpair->[1];
            }
        }
    }
    return;
}

1;
__END__