File Coverage

blib/lib/Tie/InsideOut.pm

Criterion	Covered	Total	%
statement	147	148	99.3
branch	14	20	70.0
condition	6	11	54.5
subroutine	24	24	100.0
pod	0	2	0.0
total	191	205	93.1

package Tie::InsideOut;

use 5.006001;
use strict;
use warnings;

use Carp qw( croak );
use Scalar::Util qw( refaddr );

our $VERSION = '0.11';

our @ISA = qw( );

my %NameSpaces;               # default namespace for each hash
my %Keys;                     # tracks defined keys and namespaces

=begin internal

The %Keys hash is structured as follows:

  $Keys{$id}->{$key}->{$namespace}        = $hash_ref

C<$id> refers to the unique object identifier (returned by the L method).

C<$key> refers to the name of the hash key, qhich corresponds to the name of a hash
variable in the C<$namespace>.

C<$namespace> refers to the namespace that the value is in. Encapsulation means
that child classes can use the same key names without conflict.

C<$hash_ref> is a reference to the hash variable that contains the value. Which is
accessible:

  $Keys{$id}->{$key}->{$namespace}->{$id} = $value

We maintain a structure that incidcates where all of the keys are so that we can
clean up the data when the object is destroyed.  It also allows us to serialize
and deserialize data.

=end internal

=cut

sub TIEHASH {
  my $class  = shift || __PACKAGE__;

  my $scalar;
  my $self  = \$scalar;
  bless $self, $class;

  my $id    = $self->_get_id;
  {
    my $caller = shift || (caller)[0];
    no strict 'refs';
    $NameSpaces{$id} = $caller;
  }
  $self->CLEAR;

  return $self;
}

BEGIN {
  *new = \&TIEHASH;
}

sub DESTROY {
  my $self = shift;
  my $id   = $self->_get_id;

  $self->CLEAR;

  delete $Keys{$id};
  delete $NameSpaces{$id};
}

sub CLEAR {
  my $self = shift;
  my $id   = $self->_get_id;

  foreach my $key (keys %{$Keys{$id}}) {
    foreach my $namespace (keys %{$Keys{$id}->{$key}}) {
      delete $Keys{$id}->{$key}->{$namespace}->{$id};
      delete $Keys{$id}->{$key}->{$namespace};
    }
    delete $Keys{$id}->{$key};
  }
  $Keys{$id} = { };
}

sub SCALAR {
  my $self = shift;
  my $id   = $self->_get_id;
  return scalar (%{$Keys{$id}});
}

sub FETCH {
  my $self = shift;
  my $key  = shift;

  my ($id, $hash_ref) = $self->_validate_key($key);
  $hash_ref->{$id};
}

sub EXISTS {
  my $self = shift;
  my $key  = shift;

  my ($id, $hash_ref) = $self->_validate_key($key);
  exists $hash_ref->{$id};
}

# Being able to iterate over the keys is useful, but limited. After version
# 0.04, encapsulation is enforced.

sub FIRSTKEY {
  my $self = shift;
  my $id   = $self->_get_id;
  my $aux  = keys %{$Keys{$id}}; # reset each iterator
  return each %{$Keys{$id}};
}

sub NEXTKEY {
  my $self = shift;
  my $id   = $self->_get_id;
  return each %{$Keys{$id}};
}

sub DELETE {
  my $self = shift;
  my $key  = shift;

  my ($id, $hash_ref) = $self->_validate_key($key);
  delete $Keys{$id}->{$key};
  delete $hash_ref->{$id};
}

sub STORE {
  my $self = shift;
  my $key  = shift;
  my $val  = shift;

  my ($id, $hash_ref, $namespace)  = $self->_validate_key($key);
  $Keys{$id}->{$key}->{$namespace} = $hash_ref;
  $hash_ref->{$id}    = $val;
}

sub STORABLE_freeze {
  my $self = shift;
  my $deep = shift; # return if ($deep);
  my $id   = $self->_get_id;

  my $struc = { };
  my $refs  = [ $NameSpaces{$id}, $struc ];
  my $index = @$refs;

  foreach my $key (keys %{$Keys{$id}}) {
    foreach my $namespace (keys %{$Keys{$id}->{$key}}) {
      my $package = *{$Keys{$id}->{$key}->{$namespace}}{PACKAGE};
      $struc->{$key}->{$package} = $index;
      $refs->[$index++] = $Keys{$id}->{$key}->{$namespace}->{$id};
    }
  }

  return ($index, $refs);
}

sub STORABLE_thaw {
  my $self = shift;
  my $deep = shift; # return if ($deep);

  $self->CLEAR;
  my $id   = $self->_get_id;

  my ($size, $refs) = @_;

  $self->CLEAR if (exists $Keys{$id});

  $NameSpaces{$id} = $refs->[0] unless (defined $NameSpaces{$id}); # Storable just blesses
  croak("Namespaces do not match: ", $NameSpaces{$id}, " and ", $refs->[0]),
    unless ($NameSpaces{$id} eq $refs->[0]);

  no strict 'refs';

  my $struc = $refs->[1];
  foreach my $key (keys %$struc) {
    foreach my $namespace (keys %{$struc->{$key}}) {
      my $index = $struc->{$key}->{$namespace};
      croak "No namespace defined" if ($namespace eq "");

      my $hash_ref = *{$namespace."::"};
      if ((exists $hash_ref->{$key}) &&  (ref *{$hash_ref->{$key}}{HASH})) {
	$Keys{$id}->{$key}->{$namespace} = $hash_ref->{$key};
	$hash_ref->{$key}->{$id} = $refs->[$index];
      }
      else {
	croak "Symbol \%".$key." not defined in namespace ".$namespace;
      }
    }
  }
  return $self;
}

sub _get_id {
  my $self = shift;
  return refaddr($self);
}

sub _validate_key {
  my ($self, $key) = @_;
  my $id   = $self->_get_id;

  # We get the name of the subroutine that called us, and use its
  # namespace to look for the hash that contains the key value.

  # Warning: Perl documentation notes that the caller information may
  # be optimized away when the value is greater than 1.

  my $caller_namespace = (caller(2))[3];
  my $hash_ref;

  if (defined $caller_namespace) {
    no strict 'refs';

    # If we're in an eval, then we resort to using the caller package

    if ($caller_namespace eq "(eval)") {
      $caller_namespace = (caller(2))[0];
      $caller_namespace =~ s/\s(eval\(\s\d+)?\)$//; # remove eval
    }
    else {
      $caller_namespace =~ s/::(((?!::).)+)$//;
    }
    $hash_ref = *{$caller_namespace."::"};
  }
  else {
    croak "Cannot determine namespace of caller"
      unless (exists $NameSpaces{$id});
    no strict 'refs';
    $hash_ref = *{$NameSpaces{$id}."::"};
    $caller_namespace = *{$hash_ref}{PACKAGE};
  }

  if ((exists $hash_ref->{$key}) &&  (ref *{$hash_ref->{$key}}{HASH})) {
    return ($id, $hash_ref->{$key}, $caller_namespace);
  }
  else {

#     print STDERR "\n\x23 key=$key\n\x23",
#       join(" ", map {$_||""} (caller(0))), "\n\x23",
#       join(" ", map {$_||""} (caller(1))), "\n\x23",
#       join(" ", map {$_||""} (caller(2))), "\n\x23",
#       join(" ", map {$_||""} (caller(3))), "\n";

    my $err_msg = "Symbol \%".$key." not defined";
    if ($caller_namespace ne "main") {
      $err_msg .= " in namespace ".$caller_namespace;
    }
    croak $err_msg;
  }
}

1;
__END__