#!/usr/bin/perl -w
use strict;
use IO::Handle; autoflush stdout 1; autoflush STDERR 1;

# First write some support code: a hash (associative array) which has
# a 'parent' field, so if a key isn't found it will look in the
# parents.
#
package Tie::Hash::Parented;
use Tie::Hash;
use base 'Tie::StdHash';
sub FETCH {
    my ($this, $key) = @_;
    return $this->{$key} if exists $this->{$key};
    my $parent = $this->{parent};
    return $parent->{$key} if $parent;
    return undef;
}
# FIRSTKEY, NEXTKEY just iterate through bottom-level hash.
sub EXISTS {
    my ($this, $key) = @_;
    return 1 if exists $this->{$key};
    my $parent = $this->{parent};
    return exists $parent->{$key} if $parent;
    return 0;
}
# DELETE as normal, does not delete from parents.
sub CLEAR {
    my $this = shift;
    %$this = (parent => $this->{parent});
}

# Now a small wrapper to turn a hash with keys into a class with
# methods.
#
package Class::Hash_Methods;
use Carp;
our $AUTOLOAD;
sub AUTOLOAD {
    my ($self, @args) = @_;
    (my $name = $AUTOLOAD) =~ s/.*://;
    return if $name eq 'DESTROY';
    croak "cannot do method $name" if not $self->{$name};
    $self->{$name}->($self, @args);
}

# Finally we can build the Self-style 'object' as an instance of this
# class.  It has two standard methods, clone() and set_parent().
#
package Self_Emul;
my $Object = bless { clone => sub {
			 my $this = shift;
			 my %r; tie %r, 'Tie::Hash::Parented';
			 %r = %{$this};
			 my $r = \%r;
			 bless $r, 'Class::Hash_Methods';
			 return $r;
		     },
		     set_parent => sub {
			 my ($this, $p) = @_;
			 $this->{parent} = $p;
		     }
		   }, 'Class::Hash_Methods';

# Demonstration.

# Creating new objects is always done by cloning an existing one.
# Here we make a point object from the root Object.
#
my $point = $Object->clone();

# Setting fields is done with this syntax, it doesn't match very well
# with the syntax for calling methods, but never mind.
#
$point->{get_x} = sub { 3 };
$point->{get_y} = sub { 4 };
$point->{print} = sub {
    my $self = shift;
    print 'point: ', $self->get_x(), ', ', $self->get_y(), "\n";
};

# Now we can call the print() method we just defined.
$point->print();

# So far our point object has been readonly.  Let's inherit from it
# and make a version with 'set' accessors.  This is a slightly odd
# thing to do since the accessors will change the methods in the
# point_rw and not touch its parent.
#
my $point_rw = $Object->clone();
$point_rw->set_parent($point);

print 'point_rw = '; $point_rw->print();
$point_rw->{set_x} = sub {
    my ($self, $x) = @_;
    die if not defined $x;
    $self->{get_x} = sub { $x }; # closure
};
$point_rw->{set_y} = sub {
    my ($self, $y) = @_;
    $self->{get_y} = sub { $y }; # closure
};
# We could write to automatically generate these get and set methods
# if we felt like it.
#

# Set x in the point_rw.  But this does not affect the get_x field in
# the parent.
$point_rw->set_x(5);
print 'after set_x(), point_rw = '; $point_rw->print();
print 'but original point = '; $point->print();

print "changing parent of point_rw so its parent is just Object\n";
$point_rw->set_parent($Object);
print "since we called set_x(), we can call get_x(): ", $point_rw->get_x(), "\n";
print "...but there is no get_y() field: "; $point_rw->get_y();