#!/usr/bin/perl

use strict;
use warnings;

## ----------------------------------------------------------------------------
## Mini Meta-Model with explicit EigenClasses
## ----------------------------------------------------------------------------
## This is an extension of the Mini-MetaModel which adds explicit Eigenclasses
## to all Classes created. See Method_Dispatch_w_EigenClasses.jpg in this 
## same directory for a visual explaination of this. 
## ----------------------------------------------------------------------------

use Test::More tests => 46;

{
    use Hash::Util 'lock_keys';

    # Every instance should have a unique ID
    my $instance_counter = 0;

    # Input: reference to class and a slurpy attr hash
    sub ::create_opaque_instance ($%) {
        my ($class, %attrs) = @_;
        my $instance = bless {
            'id'    => ++$instance_counter,
            'class' => $class,
            'attrs' => \%attrs,
        }, 'Dispatchable';
        lock_keys(%{$instance});
        return $instance;
    }

    # Accessors for the inside of the opaque structure
    sub ::opaque_instance_id    ($) : lvalue { shift->{id}       }
    sub ::opaque_instance_class ($) : lvalue { ${shift->{class}} }     
    sub ::opaque_instance_attrs ($) : lvalue { shift->{attrs}    }
}

{
    package Dispatchable;
    use Carp 'confess';

    sub isa { our $AUTOLOAD = 'isa'; goto &AUTOLOAD; }
    sub can { our $AUTOLOAD = 'can'; goto &AUTOLOAD; }

    sub AUTOLOAD {
        my $label = (split '::', our $AUTOLOAD)[-1];
        return if $label eq 'DESTROY';

        my $class = ::opaque_instance_class($_[0]);

        while (defined $class) {
            my $method = ::opaque_instance_attrs($class)->{'%:methods'}{$label};
            goto &$method if $method;

            # try again in the superclass
            $class = $class->superclass;
        }

        confess "No method found for '$label'";
    }
}

# The 'Class' class -- placed here so ::create_class can refer to it
my $Class;

sub ::create_class (%) {
    my (%attrs) = @_;
    return ::create_opaque_instance(
        # < a Class object is an instance of the Class class >
        \$Class,
        (
            '$:name'        => '',
            '$:superclass'  => undef,
            '%:attributes'  => [],
            '%:methods'     => {},
            # and override anything here ...
            %attrs,
        )
    );
}

# create this here so we can refer to it,.. 
my $EigenClass;

# The 'Class' class
$Class = ::create_class(
    '$:name'    => 'Class',
    '%:methods' => {
        'new' => sub ($%) {
            my ($class, %attrs) = @_;
            if ($class != $EigenClass) {
                my $eigenclass = $EigenClass->new(
                    '$:name' => 'EigenClass[' . 
                                    ($attrs{'$:name'} || 'i' . $class->name) . 
                                ']'
                );
                if (defined $attrs{'$:superclass'}) {
                    $eigenclass->superclass(
                        ::opaque_instance_class($attrs{'$:superclass'})
                    );                
                }
                else {
                    $eigenclass->superclass($class);
                }
                $class = $eigenclass;                
            }
            return ::create_opaque_instance(\$class, %attrs);
        },         
        'name' => sub ($) {
            ::opaque_instance_attrs(shift)->{'$:name'}
        },
        'id' => sub ($) {
            ::opaque_instance_id(shift)
        },        
        'class' => sub ($) {
            return ::opaque_instance_class(shift) if $_[0] == $Class;
            return ::opaque_instance_class(shift)->superclass;
        },                       
        'class_precendence_list' => sub ($) {
            my ($self) = @_;
            my @cpl = ($self);
            my $current = $self;
            while (my $super = $current->superclass) {
                push @cpl => $super;
                $current = $super;
            }
            return @cpl;
        },
        'superclass' => sub ($;$) {
            my $self = shift;
            ::opaque_instance_attrs($self)->{'$:superclass'} = shift if @_;
            ::opaque_instance_attrs($self)->{'$:superclass'};
        },
        'get_method' => sub ($$) {
            my ($self, $label) = @_;
            ::opaque_instance_attrs($self)->{'%:methods'}->{$label};
        },
        'add_method' => sub ($$$) {
            my ($self, $label, $method) = @_;
            ::opaque_instance_attrs($self)->{'%:methods'}->{$label} = $method;
        },               
    },
);

# The 'EigenClass' class
$EigenClass = ::create_class(
    '$:name'       => 'EigenClass',
    '$:superclass' => $Class,
);

# The 'Object' class
my $Object = $Class->new(
    '$:name'    => 'Object',
    '%:methods' => {
        'id' => sub ($) {
            ::opaque_instance_id(shift)
        },
        'class' => sub ($) {
            return ::opaque_instance_class(shift)->superclass;
        },
        'add_singleton_method' => sub ($$$) {
            my ($self, $label, $method) = @_;
            ::opaque_instance_class($self)->add_method($label, $method);
        },          
    },
);

# < Class is a subclass of Object >
::opaque_instance_attrs($Class)->{'$:superclass'} = $Object;

## ----------------------------------------------------------------------------
## BOOTSTRAPPING COMPLETE
## ----------------------------------------------------------------------------

# Utility to test that "No method found" error is raised

sub fails_ok (&$) {
    my ($code, $desc) = @_;
    local $@; eval { &$code };
    like($@, qr/No method found/, $desc);
}

# Begins testing

is($Class->id, 1, '... $Class is the first id');
is($Class->class, $Class, '... $Class refs to itself');
is($Class->name, 'Class', '... $Class got the right method return value');
is($Class->superclass, $Object, '... $Class is now a subclass of $Object');
is_deeply(
    [ $Class->class_precendence_list ], 
    [ $Class, $Object ], 
    '... $Class class_precendence_list');

is($Object->id, 4, '... $Object is the second id');
is($Object->class, $Class, '... $Object class slot is $Class');
is($Object->name, 'Object', '... $Object got the right method return value');
is($Object->superclass, undef, '... $Object got the right method return value');
is_deeply(
    [ $Object->class_precendence_list ], 
    [ $Object ], 
    '... $Object class_precendence_list');

## test adding a class method (as a signleton method on the class instance)

$Object->add_singleton_method('singleton_test_on_object' => sub { 
    '&Object::singleton_test_on_object'
});

is($Object->singleton_test_on_object(), 
   '&Object::singleton_test_on_object',
   '... got the right return value from Object singleton/class method');

$Object->add_singleton_method('another_singleton_test_on_object' => sub { 
   '&Object::another_singleton_test_on_object'
});

is($Object->another_singleton_test_on_object(), 
   '&Object::another_singleton_test_on_object',
   '... got the right return value from another Object singleton/class method');
   
is($Object->singleton_test_on_object(), 
  '&Object::singleton_test_on_object',
  '... still got the right return value from first Object singleton/class method');   

## make class

my $Foo = $Class->new(
    '$:name'       => 'Foo',
    '$:superclass' => $Object,
    '%:methods'    => {
        'foo' => sub ($) { 'Foo->foo' },
        'bar' => sub ($) { 'Foo->bar' },
    },
);

is($Foo->id, 6, '... $Foo is the fourth id');
is($Foo->name, 'Foo', '... $Foo got the right method return value');
is($Foo->superclass, $Object, '... $Foo got the right method return value');
is_deeply(
    [ $Foo->class_precendence_list ], 
    [ $Foo, $Object ], 
    '... $Foo class_precendence_list');

fails_ok { $Foo->bar } '... metaclass calling instance method fails';

## does Foo get Object's singleton methods ..

is($Foo->another_singleton_test_on_object(), 
   '&Object::another_singleton_test_on_object',
   '... got the right return value from another Object singleton/class method called by Foo');

is($Foo->singleton_test_on_object(), 
  '&Object::singleton_test_on_object',
  '... still got the right return value from first Object singleton/class method called by Foo');  

$Foo->add_singleton_method('singleton_test_on_Foo' => sub { 
 '&Foo::singleton_test_on_Foo'
});

is($Foo->singleton_test_on_Foo(), 
  '&Foo::singleton_test_on_Foo',
  '... still got the right return value from Foo singleton/class method');  
  
fails_ok { $Object->singleton_test_on_Foo() } '... Object cannot call singleton method defined in Foo';  

## make instances

my $iFoo = $Foo->new;
is($iFoo->id, 8, '... $iFoo is the fourth id');

# try to call the Class method
fails_ok { $iFoo->name } '... instance calling metaclass method fails';

fails_ok { $iFoo->another_singleton_test_on_object } '... instance calling metaclass singleton method fails';
fails_ok { $iFoo->singleton_test_on_object } '... instance calling metaclass singleton method fails';

is($iFoo->foo, 'Foo->foo', '... $iFoo got the right method return value');
is($iFoo->bar, 'Foo->bar', '... $iFoo got the right method return value');

$iFoo->add_singleton_method('test_iFoo_singleton_method' => sub { 
   '$iFoo::test_iFoo_singleton_method' 
});

is($iFoo->test_iFoo_singleton_method(), 
   '$iFoo::test_iFoo_singleton_method',
   '... got the right return value from $iFoo singleton method');
   
$iFoo->add_singleton_method('another_test_iFoo_singleton_method' => sub { 
  '$iFoo::another_test_iFoo_singleton_method' 
});

is($iFoo->another_test_iFoo_singleton_method(), 
  '$iFoo::another_test_iFoo_singleton_method',
  '... got the right return value from another $iFoo singleton method');   

is($iFoo->test_iFoo_singleton_method(), 
 '$iFoo::test_iFoo_singleton_method',
 '... still got the right return value from $iFoo singleton method');

## make subclasses

my $Bar = $Class->new(
    '$:name'       => 'Bar',
    '$:superclass' => $Foo,
    '%:methods'    => {
        'bar' => sub ($) { 'Bar->bar' },
        'baz' => sub ($) { 'Bar->baz' },
    },
);

is($Bar->id, 10, '... $Bar is the fifth id');
is($Bar->name, 'Bar', '... $Bar got the right method return value');
is($Bar->superclass, $Foo, '... $Bar got the right method return value');
is_deeply(
    [ $Bar->class_precendence_list ], 
    [ $Bar, $Foo, $Object ], 
    '... $Bar class_precendence_list');
    
## does Bar get Object's singleton methods ..

is($Bar->another_singleton_test_on_object(), 
   '&Object::another_singleton_test_on_object',
   '... got the right return value from another Object singleton/class method called by Bar');

is($Bar->singleton_test_on_object(), 
  '&Object::singleton_test_on_object',
  '... still got the right return value from first Object singleton/class method called by Bar');      
  
is($Bar->singleton_test_on_Foo(), 
   '&Foo::singleton_test_on_Foo',
   '... still got the right return value from Foo singleton/class method called by Bar');   

## make instances of subclasses

my $iBar = $Bar->new;
is($iBar->id, 12, '... $iBar is the sixth id');
is($iBar->class, $Bar, '... $iBar refs to $Bar');

# try to call the Class method
fails_ok { $iBar->name } '... instance calling metaclass method fails';
fails_ok { $iBar->another_singleton_test_on_object } '... instance calling metaclass singleton method fails';
fails_ok { $iBar->singleton_test_on_object } '... instance calling metaclass singleton method fails';

is($iBar->foo, 'Foo->foo', '... $iBar calls superclass foo');
is($iBar->bar, 'Bar->bar', '... $iBar calls overridden bar');
is($iBar->baz, 'Bar->baz', '... $iBar calls new method baz');