File Coverage

blib/lib/Tie/AliasHash.pm

Criterion	Covered	Total	%
statement	105	116	90.5
branch	28	36	77.7
condition	8	9	88.8
subroutine	20	21	95.2
pod	10	11	90.9
total	171	193	88.6

package Tie::AliasHash;

use strict;

use vars qw( @ISA @EXPORT_OK $VERSION );

require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw( allkeys );

$VERSION = '1.01';

#### constants

sub _HASH          () { 0 }
sub _ALIAS         () { 1 }
sub _ALIAS_REV     () { 2 }
sub _ALIAS_REV_IDX () { 3 }
sub _JOLLY         () { 4 }

#### data structure is:
#### $self = [
####     _HASH (the real hash)
####         realkey => value
####     _ALIAS (the aliases (forward lookup))
####         alias => realkey
####     _ALIAS_REV (the aliases (reverse lookup))
####         realkey => [alias1, alias2, aliasN]
####     _ALIAS_REV_IDX (the alias indices in _ALIAS_REV)
####         alias1 => 0
####         alias2 => 1
####         aliasN => N
####     _JOLLY (where unknown keys will be sent)
#### ]

#### tie stuff

sub TIEHASH {
	my($class, @aliases) = @_;
	my $self = bless [ {}, {}, {}, {}, undef ], $class;
	my($key, $alias);
	foreach $alias ( @aliases ) {
		if(ref($alias) eq "ARRAY") {
			$self->add_alias( @$alias );
		} else {
			if($^W) {
				warn( "Tie::AliasHash: argument '$alias' to hash is not an ARRAY ref!" );
			}
		}
	}
	return $self;
}

sub FETCH {
	my($self, $key) = @_;
	$key = $self->realkey($key) if $self->is_alias($key);
	$key = $self->[_JOLLY]
		if not $self->is_key($key)
		   and defined $self->[_JOLLY];
	return $self->[_HASH]->{$key};
}

sub STORE ($\@$) {
	my($self, $key, $value) = @_;
	my @keys;
	if( ref($key) eq "ARRAY" ) {
		@keys = @$key;
	} else {
		@keys = split( $;, $key);
	}
	$key = $keys[0] if scalar(@keys) > 1;
	$key = $self->realkey($key) if $self->is_alias($key);
	$key = $self->[_JOLLY] if not $self->is_key($key) and defined $self->[_JOLLY];
	$self->[_HASH]->{$key} = $value;
	if(@keys > 1) {
		$self->add_alias( @keys );
	}
}

sub FIRSTKEY {
	my($self) = @_;
	my @init = keys %{ $self->[_HASH] };
    my ($k, $v) = each %{ $self->[_HASH] };
	return $k;
}

sub NEXTKEY {
	my($self) = @_;
    my ($k, $v) = each %{ $self->[_HASH] };
	return $k;
}

sub EXISTS {
	my($self, $key) = @_;
	return ( $self->is_key($key)
	or       $self->is_alias($key) );
}

sub DELETE {
	my($self, $key) = @_;
	$key = $self->realkey($key) if $self->is_alias($key);
	$self->remove_aliases( $key );
	delete ${ $self->[_HASH] }{$key}
	if exists $self->[_HASH]->{$key};
}

sub CLEAR {
	my($self) = @_;
	$self->[_HASH] = {};
	$self->[_ALIAS] = {};
	$self->[_ALIAS_REV] = {};
	$self->[_ALIAS_REV_IDX] = {};
	$self->[_JOLLY] = undef;
}

#### methods

sub add_alias {
	my $self = shift;
	my $key = shift;
	$key = $self->realkey($key) if $self->is_alias($key);
	my $alias;
	while(defined( $alias = shift )) {
		$self->[_ALIAS]->{$alias} = $key;
		if(exists ${ $self->[_ALIAS_REV] }{$key}) {
			push( @{ $self->[_ALIAS_REV]->{$key} }, $alias );
			$self->[_ALIAS_REV_IDX]->{$alias} = $#{ $self->[_ALIAS_REV]->{$key} };
		} else {
			$self->[_ALIAS_REV]->{$key} = [ $alias ];
			$self->[_ALIAS_REV_IDX]->{$alias} = 0;
		}
	}
}

sub remove_alias {
	my($self, $alias) = @_;
	my $key = $self->realkey( $alias );
	delete ${ $self->[_ALIAS] }{$alias};
	splice(
		@{ $self->[_ALIAS_REV]->{$key} },
		$self->[_ALIAS_REV_IDX]->{$alias},
		1
	);
	delete ${ $self->[_ALIAS_REV_IDX] }{$alias};
}

sub remove_aliases {
	my($self, $key) = @_;
	my $alias;
	foreach $alias ( @{ $self->[_ALIAS_REV]->{$key} } ) {
		delete ${ $self->[_ALIAS] }{$alias};
		delete ${ $self->[_ALIAS_REV_IDX] }{$alias};
	}
	delete ${ $self->[_ALIAS_REV] }{$key};
}

sub aliases {
	my($self, $key) = @_;
	return @{ $self->[_ALIAS_REV]->{$key} };
}

sub remove {
	my($self, @keys) = @_;
	foreach my $key (@keys) {
		if( $self->is_alias( $key ) ) {
			$self->remove_alias( $key );
		} elsif( $self->is_key( $key ) ) {
			$self->remove_aliases( $key );
			delete ${ $self->[_HASH] }{$key};
		}
	}
}

sub allkeys(\%) {
	my $self = shift;
	$self = tied %{ $self } if ref $self eq "HASH";
	return (keys %{$self->[_HASH]}), (keys %{$self->[_ALIAS]});
}

sub realkey {
	my($self, $key) = @_;
	if($self->is_alias($key)) {
		return $self->[_ALIAS]->{$key};
	} elsif($self->is_key($key)) {
		return $key;
	} else {
		return undef;
	}
}

sub is_alias {
	my($self, $key) = @_;
	return exists ${ $self->[_ALIAS] }{$key};
}

sub is_key {
	my($self, $key) = @_;
	return exists ${ $self->[_HASH] }{$key};
}

sub set_jolly {
	my($self, $key) = @_;
	$self->[_JOLLY] = $key;
}

sub remove_jolly {
	my($self) = @_;
	$self->[_JOLLY] = undef;
}

1;

__END__