File Coverage

blib/lib/Tie/Hash/TwoWay.pm

Criterion	Covered	Total	%
statement	56	64	87.5
branch	16	24	66.6
condition	6	18	33.3
subroutine	12	14	85.7
pod			n/a
total	90	120	75.0

# DESCRIPTION Tie::Hash::TwoWay is a Perl module for associative
#  two-way mapping between two disjoint sets.  Elements of the sets
#  are treated as hash keys.
#
# AUTHOR
#   Teodor Zlatanov
#
# COPYRIGHT
#   Copyright (C) 2001, 2005 Gold Software Systems
#
#   This script is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#

package Tie::Hash::TwoWay;

require 5.005_62;
use strict;
use vars qw($VERSION @ISA);
use Tie::Hash;
use Carp;

use constant PRIMARY   => 0;
use constant SECONDARY => 1;

$VERSION = sprintf "%d.%02d", '$Revision 1.8 $' =~ /(\d+)\.(\d+)/;
@ISA = qw/Tie::StdHash/;

# Preloaded methods go here.

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

 if (ref $value eq 'ARRAY')		# array refs can be recognized
 {
  $val_array_ref = $value;
 }
 else			# everything else gets converted to array refs
 {
  $val_array_ref = [ $value ];
 }

 # add the values in the passed array to the primary and secondary hashes
 foreach my $value (@$val_array_ref)
 {
  $self->{SECONDARY}->{$value}->{$key} = 1;
  $self->{PRIMARY}->{$key}->{$value} = 1;
 }

 return 1;
}

# return the primary or secondary key, in that order (duplicate keys
# are not detected here)
sub FETCH
{
 my ($self, $key) = @_;

 exists $self->{PRIMARY}->{$key} &&
  return $self->{PRIMARY}->{$key};

 exists $self->{SECONDARY}->{$key} &&
  return $self->{SECONDARY}->{$key};

 return undef;
}

# return the primary or secondary key existence, in that order
# (duplicate keys are not detected here)
sub EXISTS
{
 my ($self, $key) = @_;

 return undef unless (exists $self->{PRIMARY} &&
		      exists $self->{SECONDARY});

 return (exists $self->{PRIMARY}->{$key} ||
	 exists $self->{SECONDARY}->{$key});
}

# delete the primary or secondary key, in that order (duplicate keys
# are not detected here)
sub DELETE
{
 my ($self, $key) = @_;

 return undef unless (exists $self->{PRIMARY} &&
		      exists $self->{SECONDARY});

 # make sure to delete reverse associations as well
 if (exists $self->{PRIMARY}->{$key})
 {

  foreach (keys %{$self->{SECONDARY}})
  {
   delete $self->{SECONDARY}->{$_}->{$key};
   delete $self->{SECONDARY}->{$_}
    unless scalar keys %{$self->{SECONDARY}->{$_}};
  }

  return delete $self->{PRIMARY}->{$key};
 }

 if (exists $self->{SECONDARY}->{$key})
 {

  foreach (keys %{$self->{PRIMARY}})
  {
   delete $self->{PRIMARY}->{$_}->{$key};
   delete $self->{PRIMARY}->{$_}
    unless scalar keys %{$self->{PRIMARY}->{$_}};
  }

  return delete $self->{SECONDARY}->{$key};
 }

}

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

 %$self = ();				# clear the whole hash

 return 1;
}

sub FIRSTKEY
{
 my ($self) = @_;

 return undef unless (exists $self->{PRIMARY} &&
		      exists $self->{SECONDARY});

 return each %{$self->{PRIMARY}};
}

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

 return undef unless (exists $self->{PRIMARY} &&
		      exists $self->{SECONDARY});

 return each %{$self->{PRIMARY}};
}

sub SCALAR
{
 my ($self) = @_;

 return undef unless (exists $self->{PRIMARY} &&
		      exists $self->{SECONDARY});

 return $self->{SECONDARY};
}

1;
__END__