2 # This is automatically generated by author/import-moose-test.pl.
3 # DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
4 use t::lib::MooseCompat;
10 $TODO = q{Mouse is not yet completed};
14 This is an example of making Mouse behave
15 more like a prototype based object system.
19 Well cause merlyn asked if it could :)
23 ## ------------------------------------------------------------------
24 ## make some metaclasses
27 package ProtoMouse::Meta::Instance;
30 BEGIN { extends 'Mouse::Meta::Instance' };
33 # do not let things be inlined by
34 # the attribute or accessor generator
35 sub is_inlinable { 0 }
39 package ProtoMouse::Meta::Method::Accessor;
42 BEGIN { extends 'Mouse::Meta::Method' };
44 # customize the accessors to always grab
45 # the correct instance in the accessors
48 my ($self, $candidate, $accessor_type) = @_;
50 my $instance = $candidate;
51 my $attr = $self->associated_attribute;
53 # if it is a class calling it ...
54 unless (blessed($instance)) {
55 # then grab the class prototype
56 $instance = $attr->associated_class->prototype_instance;
58 # if its an instance ...
60 # and there is no value currently
61 # associated with the instance and
62 # we are trying to read it, then ...
63 if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
64 # again, defer the prototype in
65 # the class in which is was defined
66 $instance = $attr->associated_class->prototype_instance;
68 # otherwise, you want to assign
69 # to your local copy ...
74 sub _generate_accessor_method {
76 my $attr = $self->associated_attribute;
78 if (scalar(@_) == 2) {
80 $self->find_instance($_[0], 'w'),
84 $attr->get_value($self->find_instance($_[0], 'r'));
88 sub _generate_reader_method {
90 my $attr = $self->associated_attribute;
92 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
93 $attr->get_value($self->find_instance($_[0], 'r'));
97 sub _generate_writer_method {
99 my $attr = $self->associated_attribute;
102 $self->find_instance($_[0], 'w'),
108 # deal with these later ...
109 sub generate_predicate_method {}
110 sub generate_clearer_method {}
115 package ProtoMouse::Meta::Attribute;
118 BEGIN { extends 'Mouse::Meta::Attribute' };
120 sub accessor_metaclass { 'ProtoMouse::Meta::Method::Accessor' }
124 package ProtoMouse::Meta::Class;
127 BEGIN { extends 'Mouse::Meta::Class' };
129 has 'prototype_instance' => (
132 predicate => 'has_prototypical_instance',
134 default => sub { (shift)->new_object }
139 # I am not sure why 'around' does
140 # not work here, have to investigate
142 (shift)->SUPER::initialize(@_,
143 instance_metaclass => 'ProtoMouse::Meta::Instance',
144 attribute_metaclass => 'ProtoMouse::Meta::Attribute',
148 around 'construct_instance' => sub {
152 # we actually have to do this here
153 # to tie-the-knot, if you take it
154 # out, then you get deep recursion
155 # several levels deep :)
156 $self->prototype_instance($next->($self, @_))
157 unless $self->has_prototypical_instance;
158 return $self->prototype_instance;
164 package ProtoMouse::Object;
165 use metaclass 'ProtoMouse::Meta::Class';
169 my $prototype = blessed($_[0])
171 : $_[0]->meta->prototype_instance;
172 my (undef, %params) = @_;
173 my $self = $prototype->meta->clone_object($prototype, %params);
174 $self->BUILDALL(\%params);
179 ## ------------------------------------------------------------------
180 ## make some classes now
186 extends 'ProtoMouse::Object';
188 has 'bar' => (is => 'rw');
197 has 'baz' => (is => 'rw');
200 ## ------------------------------------------------------------------
202 ## ------------------------------------------------------------------
203 ## Check that metaclasses are working/inheriting properly
205 foreach my $class (qw/ProtoMouse::Object Foo Bar/) {
207 'ProtoMouse::Meta::Class',
208 '... got the right metaclass for ' . $class . ' ->');
210 is($class->meta->instance_metaclass,
211 'ProtoMouse::Meta::Instance',
212 '... got the right instance meta for ' . $class);
214 is($class->meta->attribute_metaclass,
215 'ProtoMouse::Meta::Attribute',
216 '... got the right attribute meta for ' . $class);
219 ## ------------------------------------------------------------------
221 # get the prototype for Foo
222 my $foo_prototype = Foo->meta->prototype_instance;
223 isa_ok($foo_prototype, 'Foo');
225 # set a value in the prototype
226 $foo_prototype->bar(100);
227 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
229 # the "class" defers to the
230 # the prototype when asked
232 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
234 # now make an instance, which
235 # is basically a clone of the
240 # the instance is *not* the prototype
241 isnt($foo, $foo_prototype, '... got a new instance of Foo');
243 # but it has the same values ...
244 is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');
246 # we can even change the values
249 is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');
251 # and not change the one in the prototype
252 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
253 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
257 # now we can check that the subclass
258 # will seek out the correct prototypical
259 # value from it's "parent"
260 is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
262 # we can then also set it's local attrs
264 is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');
266 # now we clone the Bar prototype
271 # and we see that we got the right values
272 # in the instance/clone
273 is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
274 is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');
276 # nowe we can change the value
278 is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');
280 # and all our original and
281 # prototypical values are still
283 is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
284 is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
285 is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');