package Tie::Hash::Inheriting;

sub IDX_HASH   () { 0 }
sub IDX_PARENT () { 1 }

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

   if (ref($val) eq 'HASH' && !tied(%$val)) {
      # It's a hash ref.
      # It's a hash ref that isn't blessed.
      # It's a hash ref to a hash that isn't tied.

      my %tied_hash;
      tie(%tied_hash, 'Tie::Hash::Inheriting', $self);
      %tied_hash = %$val;
      $val = \%tied_hash;
   }

   my $hash = $self->[IDX_HASH];
   return $hash->{$key} = $val;
}

sub EXISTS {
   my ($self, $key) = @_;
   my ($hash, $parent) = @$self;
   return 1 if exists $hash->{$key};
   return undef unless $parent;
   return $parent->EXISTS($key);
}

sub FETCH {
   my ($self, $key) = @_;
   my ($hash, $parent) = @$self;
   return $hash->{$key} if exists $hash->{$key};
   return undef unless $parent;
   return $parent->FETCH($key);
}

sub UNTIE {
   my ($self, $count) = @_;
   $self->_untie() unless $count > 1;
}

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

   my $hash = $self->[IDX_HASH];

   foreach my $key (keys(%$hash)) {
      my $val = $hash->{$key};
      if (ref($val) eq 'HASH') {
         my $tied = tied(%$val);
         if (UNIVERSAL::isa($tied, __PACKAGE__)) {
            $tied->_untie();
         }
      }
      undef($hash->{$key});
   }
}

# From package Tie::ExtraHash in newer versions of Tie/Hash.pm.
sub TIEHASH  { my $p = shift; bless [{}, @_], $p }
sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} }
sub NEXTKEY  { each %{$_[0][0]} }
sub DELETE   { delete $_[0][0]->{$_[1]} }
sub CLEAR    { %{$_[0][0]} = () }
sub SCALAR   { scalar %{$_[0][0]} }