Commit | Line | Data |
edfe85eb |
1 | #!/usr/local/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
edfe85eb |
7 | |
8 | =pod |
9 | |
d03bd989 |
10 | This is an example of making Moose behave |
edfe85eb |
11 | more like a prototype based object system. |
12 | |
d03bd989 |
13 | Why? |
edfe85eb |
14 | |
15 | Well cause merlyn asked if it could :) |
16 | |
17 | =cut |
18 | |
19 | ## ------------------------------------------------------------------ |
20 | ## make some metaclasses |
21 | |
22 | { |
23 | package ProtoMoose::Meta::Instance; |
24 | use Moose; |
d03bd989 |
25 | |
edfe85eb |
26 | BEGIN { extends 'Moose::Meta::Instance' }; |
d03bd989 |
27 | |
edfe85eb |
28 | # NOTE: |
29 | # do not let things be inlined by |
30 | # the attribute or accessor generator |
31 | sub is_inlinable { 0 } |
32 | } |
33 | |
34 | { |
35 | package ProtoMoose::Meta::Method::Accessor; |
36 | use Moose; |
d03bd989 |
37 | |
edfe85eb |
38 | BEGIN { extends 'Moose::Meta::Method::Accessor' }; |
d03bd989 |
39 | |
40 | # customize the accessors to always grab |
9bac92f6 |
41 | # the correct instance in the accessors |
d03bd989 |
42 | |
9bac92f6 |
43 | sub find_instance { |
6549b0d1 |
44 | my ($self, $candidate, $accessor_type) = @_; |
d03bd989 |
45 | |
6549b0d1 |
46 | my $instance = $candidate; |
9bac92f6 |
47 | my $attr = $self->associated_attribute; |
d03bd989 |
48 | |
9bac92f6 |
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; |
53 | } |
54 | # if its an instance ... |
55 | else { |
d03bd989 |
56 | # and there is no value currently |
57 | # associated with the instance and |
9bac92f6 |
58 | # we are trying to read it, then ... |
59 | if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) { |
d03bd989 |
60 | # again, defer the prototype in |
9bac92f6 |
61 | # the class in which is was defined |
62 | $instance = $attr->associated_class->prototype_instance; |
63 | } |
d03bd989 |
64 | # otherwise, you want to assign |
9bac92f6 |
65 | # to your local copy ... |
66 | } |
67 | return $instance; |
68 | } |
d03bd989 |
69 | |
6a4a7c31 |
70 | sub _generate_accessor_method { |
9bac92f6 |
71 | my $self = shift; |
d03bd989 |
72 | my $attr = $self->associated_attribute; |
edfe85eb |
73 | return sub { |
9bac92f6 |
74 | if (scalar(@_) == 2) { |
75 | $attr->set_value( |
d03bd989 |
76 | $self->find_instance($_[0], 'w'), |
9bac92f6 |
77 | $_[1] |
78 | ); |
d03bd989 |
79 | } |
9bac92f6 |
80 | $attr->get_value($self->find_instance($_[0], 'r')); |
edfe85eb |
81 | }; |
82 | } |
83 | |
6a4a7c31 |
84 | sub _generate_reader_method { |
9bac92f6 |
85 | my $self = shift; |
d03bd989 |
86 | my $attr = $self->associated_attribute; |
9bac92f6 |
87 | return sub { |
edfe85eb |
88 | confess "Cannot assign a value to a read-only accessor" if @_ > 1; |
9bac92f6 |
89 | $attr->get_value($self->find_instance($_[0], 'r')); |
d03bd989 |
90 | }; |
edfe85eb |
91 | } |
92 | |
6a4a7c31 |
93 | sub _generate_writer_method { |
9bac92f6 |
94 | my $self = shift; |
d03bd989 |
95 | my $attr = $self->associated_attribute; |
edfe85eb |
96 | return sub { |
9bac92f6 |
97 | $attr->set_value( |
d03bd989 |
98 | $self->find_instance($_[0], 'w'), |
9bac92f6 |
99 | $_[1] |
100 | ); |
edfe85eb |
101 | }; |
102 | } |
103 | |
104 | # deal with these later ... |
105 | sub generate_predicate_method {} |
d03bd989 |
106 | sub generate_clearer_method {} |
107 | |
edfe85eb |
108 | } |
109 | |
110 | { |
111 | package ProtoMoose::Meta::Attribute; |
112 | use Moose; |
d03bd989 |
113 | |
edfe85eb |
114 | BEGIN { extends 'Moose::Meta::Attribute' }; |
115 | |
116 | sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' } |
117 | } |
118 | |
119 | { |
120 | package ProtoMoose::Meta::Class; |
121 | use Moose; |
d03bd989 |
122 | |
edfe85eb |
123 | BEGIN { extends 'Moose::Meta::Class' }; |
d03bd989 |
124 | |
9bac92f6 |
125 | has 'prototype_instance' => ( |
edfe85eb |
126 | is => 'rw', |
127 | isa => 'Object', |
9bac92f6 |
128 | predicate => 'has_prototypical_instance', |
edfe85eb |
129 | lazy => 1, |
130 | default => sub { (shift)->new_object } |
131 | ); |
d03bd989 |
132 | |
edfe85eb |
133 | sub initialize { |
134 | # NOTE: |
d03bd989 |
135 | # I am not sure why 'around' does |
edfe85eb |
136 | # not work here, have to investigate |
137 | # it later - SL |
d03bd989 |
138 | (shift)->SUPER::initialize(@_, |
edfe85eb |
139 | instance_metaclass => 'ProtoMoose::Meta::Instance', |
d03bd989 |
140 | attribute_metaclass => 'ProtoMoose::Meta::Attribute', |
edfe85eb |
141 | ); |
142 | } |
d03bd989 |
143 | |
edfe85eb |
144 | around 'construct_instance' => sub { |
145 | my $next = shift; |
146 | my $self = shift; |
147 | # NOTE: |
148 | # we actually have to do this here |
d03bd989 |
149 | # to tie-the-knot, if you take it |
150 | # out, then you get deep recursion |
edfe85eb |
151 | # several levels deep :) |
d03bd989 |
152 | $self->prototype_instance($next->($self, @_)) |
9bac92f6 |
153 | unless $self->has_prototypical_instance; |
154 | return $self->prototype_instance; |
edfe85eb |
155 | }; |
d03bd989 |
156 | |
9bac92f6 |
157 | } |
158 | |
159 | { |
160 | package ProtoMoose::Object; |
161 | use metaclass 'ProtoMoose::Meta::Class'; |
162 | use Moose; |
d03bd989 |
163 | |
9bac92f6 |
164 | sub new { |
d03bd989 |
165 | my $prototype = blessed($_[0]) |
166 | ? $_[0] |
9bac92f6 |
167 | : $_[0]->meta->prototype_instance; |
168 | my (undef, %params) = @_; |
9978e85e |
169 | my $self = $prototype->meta->clone_object($prototype, %params); |
170 | $self->BUILDALL(\%params); |
171 | return $self; |
9bac92f6 |
172 | } |
edfe85eb |
173 | } |
174 | |
175 | ## ------------------------------------------------------------------ |
176 | ## make some classes now |
177 | |
178 | { |
179 | package Foo; |
edfe85eb |
180 | use Moose; |
d03bd989 |
181 | |
9bac92f6 |
182 | extends 'ProtoMoose::Object'; |
d03bd989 |
183 | |
edfe85eb |
184 | has 'bar' => (is => 'rw'); |
185 | } |
186 | |
187 | { |
188 | package Bar; |
189 | use Moose; |
d03bd989 |
190 | |
edfe85eb |
191 | extends 'Foo'; |
d03bd989 |
192 | |
edfe85eb |
193 | has 'baz' => (is => 'rw'); |
194 | } |
195 | |
196 | ## ------------------------------------------------------------------ |
197 | |
9bac92f6 |
198 | ## ------------------------------------------------------------------ |
199 | ## Check that metaclasses are working/inheriting properly |
edfe85eb |
200 | |
9bac92f6 |
201 | foreach my $class (qw/ProtoMoose::Object Foo Bar/) { |
d03bd989 |
202 | isa_ok($class->meta, |
203 | 'ProtoMoose::Meta::Class', |
edfe85eb |
204 | '... got the right metaclass for ' . $class . ' ->'); |
205 | |
d03bd989 |
206 | is($class->meta->instance_metaclass, |
207 | 'ProtoMoose::Meta::Instance', |
edfe85eb |
208 | '... got the right instance meta for ' . $class); |
209 | |
d03bd989 |
210 | is($class->meta->attribute_metaclass, |
211 | 'ProtoMoose::Meta::Attribute', |
edfe85eb |
212 | '... got the right attribute meta for ' . $class); |
213 | } |
214 | |
215 | ## ------------------------------------------------------------------ |
216 | |
9bac92f6 |
217 | # get the prototype for Foo |
218 | my $foo_prototype = Foo->meta->prototype_instance; |
219 | isa_ok($foo_prototype, 'Foo'); |
220 | |
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'); |
224 | |
d03bd989 |
225 | # the "class" defers to the |
226 | # the prototype when asked |
9bac92f6 |
227 | # about attributes |
228 | is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)'); |
edfe85eb |
229 | |
d03bd989 |
230 | # now make an instance, which |
231 | # is basically a clone of the |
9bac92f6 |
232 | # prototype |
edfe85eb |
233 | my $foo = Foo->new; |
9bac92f6 |
234 | isa_ok($foo, 'Foo'); |
edfe85eb |
235 | |
9bac92f6 |
236 | # the instance is *not* the prototype |
237 | isnt($foo, $foo_prototype, '... got a new instance of Foo'); |
edfe85eb |
238 | |
9bac92f6 |
239 | # but it has the same values ... |
240 | is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)'); |
edfe85eb |
241 | |
d03bd989 |
242 | # we can even change the values |
243 | # in the instance |
9bac92f6 |
244 | $foo->bar(300); |
245 | is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)'); |
edfe85eb |
246 | |
9bac92f6 |
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)'); |
edfe85eb |
250 | |
d03bd989 |
251 | ## subclasses |
edfe85eb |
252 | |
9bac92f6 |
253 | # now we can check that the subclass |
d03bd989 |
254 | # will seek out the correct prototypical |
9bac92f6 |
255 | # value from it's "parent" |
256 | is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)'); |
edfe85eb |
257 | |
9bac92f6 |
258 | # we can then also set it's local attrs |
259 | Bar->baz(50); |
260 | is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)'); |
edfe85eb |
261 | |
9bac92f6 |
262 | # now we clone the Bar prototype |
263 | my $bar = Bar->new; |
264 | isa_ok($bar, 'Bar'); |
265 | isa_ok($bar, 'Foo'); |
266 | |
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)'); |
edfe85eb |
271 | |
9bac92f6 |
272 | # nowe we can change the value |
273 | $bar->bar(200); |
274 | is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)'); |
275 | |
d03bd989 |
276 | # and all our original and |
277 | # prototypical values are still |
9bac92f6 |
278 | # the same |
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)'); |
edfe85eb |
282 | |
a28e50e4 |
283 | done_testing; |