File Coverage

blib/lib/Algorithm/Toy/HashSC.pm

Criterion	Covered	Total	%
statement	74	78	94.8
branch	18	28	64.2
condition			n/a
subroutine	15	15	100.0
pod	8	8	100.0
total	115	129	89.1

# -*- 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.01';

##############################################################################
#
# 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;
  if ( $key->can('hashcode') ) {
    $code = $key->hashcode();
  } else {
    # TODO is this adequate?
    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__