File Coverage

blib/lib/Tie/RegexpHash.pm

Criterion	Covered	Total	%
statement	94	117	80.3
branch	23	36	63.8
condition	6	6	100.0
subroutine	16	18	88.8
pod	6	8	75.0
total	145	185	78.3

package Tie::RegexpHash;

require 5.005;
use strict;

use vars qw( $VERSION @ISA );

$VERSION = '0.17';

use Carp;
use Data::Dumper;

# This is what stringified qrs seem to look like.
# It captures flags in $1 and pattern in $2
my $SERIALIZE_RE;

# To try to keep this working as far back as 5.5 we're using $]
if ($] < 5.013_006) {
    $SERIALIZE_RE = qr/^\(\?([ismx]{0,4})-[ismx]*:(.*)\)$/;
}
else {
    $SERIALIZE_RE = qr/^\(\?\^([ismx]{0,4}(?:-[ismx]{1,4})?):(.*)\)$/;
}

# This is what the serialized version looks like.
# It also captures flags in $1 and pattern in $2
my $DESERIALIZE_RE = qr/^([ismx]{0,4}):(.*)$/;

# 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.
sub new {
    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;
}

# Embed any modifiers used with qr// in the pattern.
sub _convert_key {
    my ($key) = shift;

    my ($flags,$pat) = ($key =~ $SERIALIZE_RE);
    ($key = qr/(?$flags:$pat)/) if $flags;
    return $key;
}

# 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.
sub _find {
    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;
        }
    }
}

# 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.
sub add {
    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;
    }
}


# Does a key exist or does it match any Regexp keys?
sub match_exists {
    my ($self, $key) = @_;
    return defined( _find $self, $key );
}

# Returns the value of a key or any matches to Regexp keys.
sub match {
    my ($self, $key) = @_;

    my $index = _find $self, $key;

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

# 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.
sub remove {
    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;
    }
}

# Clears the hash.
sub clear {
    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;
}

# Returns the first key
sub FIRSTKEY {
    my ($self) = @_;

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

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

}

# Returns the next key
sub NEXTKEY {
    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 ];
    }
}

# serialize object
sub STORABLE_freeze {
    my ($self, $cloning) = @_;

    my @keystrings;

    {
        local *_;
        @keystrings = map { join(':', ($_ =~ $SERIALIZE_RE)); } @{$self->{KEYS}};
    }

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

    return (0,$sref);
}

# deserialize
sub STORABLE_thaw {
    my($self, $cloning, $serialized, $sref) = @_;

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

    {
        local *_;
        @{$self->{KEYS}} = map {
             my ($flags,$pat) = ($_ =~ $DESERIALIZE_RE);
             $pat = ($flags) ? "(?$flags:$pat)" : $pat;
             qr/$pat/;
        } @{$sref->{KEYSTRINGS}};
    }
}

1;
__END__