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