# Using "tie".

use Tie::Hash::Inheriting ();

{
   tie(my %data, 'Tie::Hash::Inheriting');

   %data = (
      Colour  => 'blue',
      Entries => {
         Flowers => {
            Dahlia => { Smell  => 'nice' },
            Rose   => { Colour => 'red'  },
         },
      },
   );

   print
      $data{'Entries'}{'Flowers'}{'Rose'  }{'Colour'}, $/,  # red
      $data{'Entries'}{'Flowers'}{'Dahlia'}{'Colour'}, $/;  # blue

   untie(%data);  # Free mem. %data going out of scope is not enough.
}

##</code><code>##

# Using objects.

use Hash::Inherting ();

{
   my $data = Hash::Inheriting->new();

   %$data = (
      Colour  => 'blue',
      Entries => {
         Flowers => {
            Dahlia => { Smell  => 'nice' },
            Rose   => { Colour => 'red'  },
         },
      },
   );

   print
      $data->{'Entries'}{'Flowers'}{'Rose'  }{'Colour'}, $/,  # red
      $data->{'Entries'}{'Flowers'}{'Dahlia'}{'Colour'}, $/;  # blue
}

##</code><code>##

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]} }

##</code><code>##

use Tie::Hash::Inheriting ();

package Hash::Inheriting;

sub new {
   my ($class) = @_;
   my $self = bless({}, $class);
   tie(%$self, "Tie::$class");
   return $self;
}

sub DESTROY {
   my ($self) = @_;
   untie(%$self);
}