Checking in changes prior to tagging of version 0.92.

[gitmo/Mouse.git] / Moose-t-failing / 200_examples / 006_example_Protomoose.t

#!/usr/local/bin/perl
# This is automatically generated by author/import-moose-test.pl.
# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
use t::lib::MooseCompat;

use strict;
use warnings;

use Test::More;
$TODO = q{Mouse is not yet completed};

=pod

This is an example of making Mouse behave
more like a prototype based object system.

Why?

Well cause merlyn asked if it could :)

=cut

## ------------------------------------------------------------------
## make some metaclasses

{
    package ProtoMouse::Meta::Instance;
    use Mouse;

    BEGIN { extends 'Mouse::Meta::Instance' };

    # NOTE:
    # do not let things be inlined by
    # the attribute or accessor generator
    sub is_inlinable { 0 }
}

{
    package ProtoMouse::Meta::Method::Accessor;
    use Mouse;

    BEGIN { extends 'Mouse::Meta::Method' };

    # customize the accessors to always grab
    # the correct instance in the accessors

    sub find_instance {
        my ($self, $candidate, $accessor_type) = @_;

        my $instance = $candidate;
        my $attr     = $self->associated_attribute;

        # if it is a class calling it ...
        unless (blessed($instance)) {
            # then grab the class prototype
            $instance = $attr->associated_class->prototype_instance;
        }
        # if its an instance ...
        else {
            # and there is no value currently
            # associated with the instance and
            # we are trying to read it, then ...
            if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
                # again, defer the prototype in
                # the class in which is was defined
                $instance = $attr->associated_class->prototype_instance;
            }
            # otherwise, you want to assign
            # to your local copy ...
        }
        return $instance;
    }

    sub _generate_accessor_method {
        my $self = shift;
        my $attr = $self->associated_attribute;
        return sub {
            if (scalar(@_) == 2) {
                $attr->set_value(
                    $self->find_instance($_[0], 'w'),
                    $_[1]
                );
            }
            $attr->get_value($self->find_instance($_[0], 'r'));
        };
    }

    sub _generate_reader_method {
        my $self = shift;
        my $attr = $self->associated_attribute;
        return sub {
            confess "Cannot assign a value to a read-only accessor" if @_ > 1;
            $attr->get_value($self->find_instance($_[0], 'r'));
        };
    }

    sub _generate_writer_method {
        my $self = shift;
        my $attr = $self->associated_attribute;
        return sub {
            $attr->set_value(
                $self->find_instance($_[0], 'w'),
                $_[1]
            );
        };
    }

    # deal with these later ...
    sub generate_predicate_method {}
    sub generate_clearer_method {}

}

{
    package ProtoMouse::Meta::Attribute;
    use Mouse;

    BEGIN { extends 'Mouse::Meta::Attribute' };

    sub accessor_metaclass { 'ProtoMouse::Meta::Method::Accessor' }
}

{
    package ProtoMouse::Meta::Class;
    use Mouse;

    BEGIN { extends 'Mouse::Meta::Class' };

    has 'prototype_instance' => (
        is        => 'rw',
        isa       => 'Object',
        predicate => 'has_prototypical_instance',
        lazy      => 1,
        default   => sub { (shift)->new_object }
    );

    sub initialize {
        # NOTE:
        # I am not sure why 'around' does
        # not work here, have to investigate
        # it later - SL
        (shift)->SUPER::initialize(@_,
            instance_metaclass  => 'ProtoMouse::Meta::Instance',
            attribute_metaclass => 'ProtoMouse::Meta::Attribute',
        );
    }

    around 'construct_instance' => sub {
        my $next = shift;
        my $self = shift;
        # NOTE:
        # we actually have to do this here
        # to tie-the-knot, if you take it
        # out, then you get deep recursion
        # several levels deep :)
        $self->prototype_instance($next->($self, @_))
            unless $self->has_prototypical_instance;
        return $self->prototype_instance;
    };

}

{
    package ProtoMouse::Object;
    use metaclass 'ProtoMouse::Meta::Class';
    use Mouse;

    sub new {
        my $prototype = blessed($_[0])
            ? $_[0]
            : $_[0]->meta->prototype_instance;
        my (undef, %params) = @_;
        my $self = $prototype->meta->clone_object($prototype, %params);
        $self->BUILDALL(\%params);
        return $self;
    }
}

## ------------------------------------------------------------------
## make some classes now

{
    package Foo;
    use Mouse;

    extends 'ProtoMouse::Object';

    has 'bar' => (is => 'rw');
}

{
    package Bar;
    use Mouse;

    extends 'Foo';

    has 'baz' => (is => 'rw');
}

## ------------------------------------------------------------------

## ------------------------------------------------------------------
## Check that metaclasses are working/inheriting properly

foreach my $class (qw/ProtoMouse::Object Foo Bar/) {
    isa_ok($class->meta,
    'ProtoMouse::Meta::Class',
    '... got the right metaclass for ' . $class . ' ->');

    is($class->meta->instance_metaclass,
    'ProtoMouse::Meta::Instance',
    '... got the right instance meta for ' . $class);

    is($class->meta->attribute_metaclass,
    'ProtoMouse::Meta::Attribute',
    '... got the right attribute meta for ' . $class);
}

## ------------------------------------------------------------------

# get the prototype for Foo
my $foo_prototype = Foo->meta->prototype_instance;
isa_ok($foo_prototype, 'Foo');

# set a value in the prototype
$foo_prototype->bar(100);
is($foo_prototype->bar, 100, '... got the value stored in the prototype');

# the "class" defers to the
# the prototype when asked
# about attributes
is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');

# now make an instance, which
# is basically a clone of the
# prototype
my $foo = Foo->new;
isa_ok($foo, 'Foo');

# the instance is *not* the prototype
isnt($foo, $foo_prototype, '... got a new instance of Foo');

# but it has the same values ...
is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');

# we can even change the values
# in the instance
$foo->bar(300);
is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');

# and not change the one in the prototype
is($foo_prototype->bar, 100, '... got the value stored in the prototype');
is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');

## subclasses

# now we can check that the subclass
# will seek out the correct prototypical
# value from it's "parent"
is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');

# we can then also set it's local attrs
Bar->baz(50);
is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');

# now we clone the Bar prototype
my $bar = Bar->new;
isa_ok($bar, 'Bar');
isa_ok($bar, 'Foo');

# and we see that we got the right values
# in the instance/clone
is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');

# nowe we can change the value
$bar->bar(200);
is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');

# and all our original and
# prototypical values are still
# the same
is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');

done_testing;