Tie::RegexpHash - Use regular expressions as hash keys

  use Tie::RegexpHash;

  my %hash;

  tie %hash, 'Tie::RegexpHash';

  $hash{ qr/^5(\s+|-)?gal(\.|lons?)?/i } = '5-GAL';

  $hash{'5 gal'};     # returns "5-GAL"
  $hash{'5GAL'};      # returns "5-GAL"
  $hash{'5  gallon'}; # also returns "5-GAL"

  my $rehash = Tie::RegexpHash->new();

  $rehash->add( qr/\d+(\.\d+)?/, "contains a number" );
  $rehash->add( qr/s$/,          "ends with an \`s\'" );

  $rehash->match( "foo 123" );  # returns "contains a number"
  $rehash->match( "examples" ); # returns "ends with an `s'"

package Tie::RegexpHash;

require 5.005;
use strict;

use vars qw( $VERSION @ISA );

@ISA = qw( );

# our %EXPORT_TAGS = ( 'all' => [ qw( ) ] );
# our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
# our @EXPORT = qw();

$VERSION = '0.15';

use Carp;

sub new

# Creates a new 'Tie::RegexpHash' object. We use an underlying array rather
# than a hash because we want to search through the hash keys in the order
# that they were added.
#
# See the _find() and add() routines for more details.

  {
    my ($class) = @_;

    my $self = {
      KEYS   => [ ], # array of Regexp keys
      VALUES => [ ], # array of corresponding values
      COUNT  => 0,   # the number of hash/key pairs (is this necessary?)
    };

    bless $self, $class;
  }

sub _convert_key

# Embed any modifiers used with qr// in the pattern.

  {
    my ($key) = shift;

    my ($flags,$pat) = ($key =~ /^\(\?([ismx]{0,4})-[ismx]*:(.*)\)$/);
    ($key = qr/(?$flags:$pat)/) if $flags;
    return $key;
  }
    
sub _find

# Sequentially goes through the hash keys for Regexps which match the given
# key and returns the index. If the hash is empty, or a matching key was not
# found, returns undef.

  {
    my ($self, $key) = @_;

    unless ($self->{COUNT})
      {
	return;
      }

    if (ref($key) eq 'Regexp')
      {
	my $i = 0;
        $key = _convert_key($key); 
	while  (($i < $self->{COUNT}) and ($key ne $self->{KEYS}->[ $i ])) {
	    $i++;
	  }

	if ($i == $self->{COUNT})
	  {
	    return;
	  }
	else
	  {
	    return $i;
	  }

      }
    else
      {
	my $i = 0;
	while  (($i < $self->{COUNT}) and ($key !~ m/$self->{KEYS}->[ $i ]/)) {
	  $i++;
	}

	if ($i == $self->{COUNT})
	  {
	    return;
	  }
	else
	  {
	    return $i;
	  }
      }
  }

sub add

# If a key exists the value will be replaced. (If the Regexps are not the same
# but match, a warning is displayed.) If the key is new, then a new key/value
# pair is added.

  {
    my ($self, $key, $value) = @_;

    ($key = _convert_key($key)) if (ref($key) eq 'Regexp');

    my $index = _find $self, $key;
    if (defined($index))
      {
	if ($key ne $self->{KEYS}->[ $index ])
	  {
		carp "\'$key\' is not the same as \'",
		  $self->{KEYS}->[$index], "\'";
	  }
	$self->{VALUES}->[ $index ] = $value;
      }
    else
      {
	$index = $self->{COUNT}++;

        ($key = qr/$key/) unless (ref($key) eq 'Regexp');

	$self->{KEYS}->[ $index ]   = $key;
	$self->{VALUES}->[ $index ] = $value;
      }

  }


sub match_exists

# Does a key exist or does it match any Regexp keys?

  {
    my ($self, $key) = @_;
    return defined( _find $self, $key );
  }

sub match

# Returns the value of a key or any matches to Regexp keys.

  {
    my ($self, $key) = @_;

    my $index = _find $self, $key;

    if (defined($index))
      {
	return $self->{VALUES}->[ $index ];
      }
    else
      {
	return;
      }
  }

sub remove

# Removes a key or Regexp key and associated value from the hash. If the key
# is not the same as the Regexp, a warning is displayed.

  {
    my ($self, $key) = @_;

    ($key = _convert_key($key)) if (ref($key) eq 'Regexp');

    my $index = _find $self, $key;

    if (defined($index))
      {

	if ($key ne $self->{KEYS}->[ $index ])
	  {
		carp "'`$key\' is not the same as '`",
		  $self->{KEYS}->[$index], "\'";
	  }

	my $value = $self->{VALUES}->[ $index ];
	splice @{ $self->{KEYS} },   $index, 1;
	splice @{ $self->{VALUES} }, $index, 1;
	$self->{COUNT}--;
	return $value;
      }
    else
      {
	   	carp "Cannot delete a nonexistent key: \`$key\'";
	return;
      }

  }

sub clear

# Clears the hash.

  {
    my ($self) = @_;

    $self->{KEYS}   = [ ];
    $self->{VALUES} = [ ];
    $self->{COUNT}  = 0;

  }

BEGIN
  {
    # make aliases...
    no strict;
    *TIEHASH = \ &new;
    *STORE   = \ &add;
    *EXISTS  = \ &match_exists;
    *FETCH   = \ &match;
    *DELETE  = \ &remove;
    *CLEAR   = \ &clear;
  }

sub FIRSTKEY

# Returns the first key

  {
    my ($self) = @_;

    unless ($self->{COUNT})
      {
	return;
      }

    return $self->{KEYS}->[0];

  }

sub NEXTKEY

# Returns the next key

  {
    my ($self, $lastkey) = @_;

    unless ($self->{COUNT})
      {
	return;
      }

    my $index = _find $self, $lastkey;

    unless (defined($index))
      {
	confess "Invalid \$lastkey";
      }

    $index++;

    if ($index == $self->{COUNT})
      {
	return;
      }
    else
      {
	return $self->{KEYS}->[ $index ];
      }

  }

sub STORABLE_freeze

# serialize object

  {
    my ($self, $cloning) = @_;

    my @keystrings;
    {
      local *_;
      @keystrings = map { join(':',
          ($_ =~ /^\(\?([ismx]{0,4})-[ismx]*:(.*)\)$/)); } @{$self->{KEYS}};
    }

    my $sref = {
      KEYSTRINGS => \@keystrings,
      VALUES     => $self->{VALUES},
      COUNT      => $self->{COUNT},
    };

    return (0,$sref);
  }

sub STORABLE_thaw

# deserialize

  {
    my($self, $cloning, $serialized, $sref) = @_;

    $self->{KEYS}   = [ ];
    $self->{VALUES} = $sref->{VALUES};
    $self->{COUNT}  = $sref->{COUNT};

    {
      local *_;
      @{$self->{KEYS}} = map {
           my ($flags,$pat) = ($_ =~ /^([ismx]{0,4}):(.*)$/);
           $pat = ($flags) ? "(?$flags:$pat)" : $pat;
           qr/$pat/;
      } @{$sref->{KEYSTRINGS}};
    }
  }

1;
__END__