6 use Test::More no_plan => 1;
10 This is an example of making Moose behave
11 more like a prototype based object system.
15 Well cause merlyn asked if it could :)
19 ## ------------------------------------------------------------------
20 ## make some metaclasses
23 package ProtoMoose::Meta::Instance;
26 BEGIN { extends 'Moose::Meta::Instance' };
29 # do not let things be inlined by
30 # the attribute or accessor generator
31 sub is_inlinable { 0 }
35 package ProtoMoose::Meta::Method::Accessor;
38 BEGIN { extends 'Moose::Meta::Method::Accessor' };
40 # customize the accessors to always grab
41 # the correct instance in the accessors
44 my ($self, $canidate, $accessor_type) = @_;
46 my $instance = $canidate;
47 my $attr = $self->associated_attribute;
49 # if it is a class calling it ...
50 unless (blessed($instance)) {
51 # then grab the class prototype
52 $instance = $attr->associated_class->prototype_instance;
54 # if its an instance ...
56 # and there is no value currently
57 # associated with the instance and
58 # we are trying to read it, then ...
59 if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
60 # again, defer the prototype in
61 # the class in which is was defined
62 $instance = $attr->associated_class->prototype_instance;
64 # otherwise, you want to assign
65 # to your local copy ...
70 sub generate_accessor_method {
72 my $attr = $self->associated_attribute;
74 if (scalar(@_) == 2) {
76 $self->find_instance($_[0], 'w'),
80 $attr->get_value($self->find_instance($_[0], 'r'));
84 sub generate_reader_method {
86 my $attr = $self->associated_attribute;
88 confess "Cannot assign a value to a read-only accessor" if @_ > 1;
89 $attr->get_value($self->find_instance($_[0], 'r'));
93 sub generate_writer_method {
95 my $attr = $self->associated_attribute;
98 $self->find_instance($_[0], 'w'),
104 # deal with these later ...
105 sub generate_predicate_method {}
106 sub generate_clearer_method {}
111 package ProtoMoose::Meta::Attribute;
114 BEGIN { extends 'Moose::Meta::Attribute' };
116 sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' }
120 package ProtoMoose::Meta::Class;
123 BEGIN { extends 'Moose::Meta::Class' };
125 has 'prototype_instance' => (
128 predicate => 'has_prototypical_instance',
130 default => sub { (shift)->new_object }
135 # I am not sure why 'around' does
136 # not work here, have to investigate
138 (shift)->SUPER::initialize(@_,
139 instance_metaclass => 'ProtoMoose::Meta::Instance',
140 attribute_metaclass => 'ProtoMoose::Meta::Attribute',
144 around 'construct_instance' => sub {
148 # we actually have to do this here
149 # to tie-the-knot, if you take it
150 # out, then you get deep recursion
151 # several levels deep :)
152 $self->prototype_instance($next->($self, @_))
153 unless $self->has_prototypical_instance;
154 return $self->prototype_instance;
160 package ProtoMoose::Object;
161 use metaclass 'ProtoMoose::Meta::Class';
165 my $prototype = blessed($_[0])
167 : $_[0]->meta->prototype_instance;
168 my (undef, %params) = @_;
169 my $self = $prototype->meta->clone_object($prototype, %params);
170 $self->BUILDALL(\%params);
175 ## ------------------------------------------------------------------
176 ## make some classes now
182 extends 'ProtoMoose::Object';
184 has 'bar' => (is => 'rw');
193 has 'baz' => (is => 'rw');
196 ## ------------------------------------------------------------------
198 ## ------------------------------------------------------------------
199 ## Check that metaclasses are working/inheriting properly
201 foreach my $class (qw/ProtoMoose::Object Foo Bar/) {
203 'ProtoMoose::Meta::Class',
204 '... got the right metaclass for ' . $class . ' ->');
206 is($class->meta->instance_metaclass,
207 'ProtoMoose::Meta::Instance',
208 '... got the right instance meta for ' . $class);
210 is($class->meta->attribute_metaclass,
211 'ProtoMoose::Meta::Attribute',
212 '... got the right attribute meta for ' . $class);
215 ## ------------------------------------------------------------------
217 # get the prototype for Foo
218 my $foo_prototype = Foo->meta->prototype_instance;
219 isa_ok($foo_prototype, 'Foo');
221 # set a value in the prototype
222 $foo_prototype->bar(100);
223 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
225 # the "class" defers to the
226 # the prototype when asked
228 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
230 # now make an instance, which
231 # is basically a clone of the
236 # the instance is *not* the prototype
237 isnt($foo, $foo_prototype, '... got a new instance of Foo');
239 # but it has the same values ...
240 is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');
242 # we can even change the values
245 is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');
247 # and not change the one in the prototype
248 is($foo_prototype->bar, 100, '... got the value stored in the prototype');
249 is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
253 # now we can check that the subclass
254 # will seek out the correct prototypical
255 # value from it's "parent"
256 is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
258 # we can then also set it's local attrs
260 is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');
262 # now we clone the Bar prototype
267 # and we see that we got the right values
268 # in the instance/clone
269 is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
270 is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');
272 # nowe we can change the value
274 is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');
276 # and all our original and
277 # prototypical values are still
279 is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
280 is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
281 is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');