Commit | Line | Data |
550d56db |
1 | use strict; |
2 | use warnings; |
3 | |
86a4d873 |
4 | use Test::More; |
4920ae3d |
5 | use Test::Exception; |
550d56db |
6 | |
86a4d873 |
7 | use metaclass; |
550d56db |
8 | |
4920ae3d |
9 | my %metaclass_attrs = ( |
10 | 'Instance' => 'instance_metaclass', |
11 | 'Attribute' => 'attribute_metaclass', |
12 | 'Method' => 'method_metaclass', |
13 | 'Method::Wrapped' => 'wrapped_method_metaclass', |
14 | 'Method::Constructor' => 'constructor_class', |
15 | ); |
16 | |
550d56db |
17 | # meta classes |
4920ae3d |
18 | for my $suffix ('Class', keys %metaclass_attrs) { |
19 | Class::MOP::Class->create( |
20 | "Foo::Meta::$suffix", |
21 | superclasses => ["Class::MOP::$suffix"] |
22 | ); |
23 | Class::MOP::Class->create( |
24 | "Bar::Meta::$suffix", |
25 | superclasses => ["Class::MOP::$suffix"] |
26 | ); |
27 | Class::MOP::Class->create( |
28 | "FooBar::Meta::$suffix", |
29 | superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"] |
30 | ); |
31 | } |
32 | |
33 | # checking... |
34 | |
35 | lives_ok { |
36 | Foo::Meta::Class->create('Foo') |
37 | } '... Foo.meta => Foo::Meta::Class is compatible'; |
38 | lives_ok { |
39 | Bar::Meta::Class->create('Bar') |
40 | } '... Bar.meta => Bar::Meta::Class is compatible'; |
41 | |
42 | throws_ok { |
43 | Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) |
44 | } qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible'; |
45 | throws_ok { |
46 | Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) |
47 | } qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible'; |
48 | |
49 | lives_ok { |
50 | FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) |
51 | } '... FooBar.meta => FooBar::Meta::Class is compatible'; |
52 | lives_ok { |
53 | FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) |
54 | } '... FooBar2.meta => FooBar::Meta::Class is compatible'; |
55 | |
56 | Foo::Meta::Class->create( |
57 | 'Foo::All', |
58 | map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, |
59 | ); |
60 | |
61 | throws_ok { |
62 | Bar::Meta::Class->create( |
63 | 'Foo::All::Sub::Class', |
64 | superclasses => ['Foo::All'], |
65 | map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, |
66 | ) |
67 | } qr/compatible/, 'incompatible Class metaclass'; |
68 | for my $suffix (keys %metaclass_attrs) { |
69 | throws_ok { |
70 | Foo::Meta::Class->create( |
71 | "Foo::All::Sub::$suffix", |
72 | superclasses => ['Foo::All'], |
73 | (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), |
74 | $metaclass_attrs{$suffix} => "Bar::Meta::$suffix", |
75 | ) |
76 | } qr/compatible/, "incompatible $suffix metaclass"; |
77 | } |
78 | |
79 | # fixing... |
80 | |
81 | lives_ok { |
82 | Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) |
83 | } 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass'; |
84 | isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); |
85 | lives_ok { |
86 | Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) |
87 | } 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass'; |
88 | isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); |
89 | |
90 | lives_ok { |
91 | Class::MOP::Class->create( |
92 | 'Foo::All::Sub::CMOP::Class', |
93 | superclasses => ['Foo::All'], |
94 | map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs, |
95 | ) |
96 | } 'metaclass fixing works with other non-default metaclasses'; |
97 | isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class'); |
98 | |
99 | for my $suffix (keys %metaclass_attrs) { |
100 | lives_ok { |
101 | Foo::Meta::Class->create( |
102 | "Foo::All::Sub::CMOP::$suffix", |
103 | superclasses => ['Foo::All'], |
104 | (map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs), |
105 | $metaclass_attrs{$suffix} => "Class::MOP::$suffix", |
106 | ) |
107 | } "$metaclass_attrs{$suffix} fixing works with other non-default metaclasses"; |
108 | for my $suffix2 (keys %metaclass_attrs) { |
109 | my $method = $metaclass_attrs{$suffix2}; |
110 | isa_ok("Foo::All::Sub::CMOP::$suffix"->meta->$method, "Foo::Meta::$suffix2"); |
111 | } |
112 | } |
113 | |
114 | # initializing... |
115 | |
550d56db |
116 | { |
4920ae3d |
117 | package Foo::NoMeta; |
118 | } |
86a4d873 |
119 | |
4920ae3d |
120 | Class::MOP::Class->create('Foo::NoMeta::Sub', superclasses => ['Foo::NoMeta']); |
121 | ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); |
122 | isa_ok(Class::MOP::class_of('Foo::NoMeta'), 'Class::MOP::Class'); |
123 | isa_ok(Foo::NoMeta::Sub->meta, 'Class::MOP::Class'); |
86a4d873 |
124 | |
4920ae3d |
125 | { |
126 | package Foo::NoMeta2; |
550d56db |
127 | } |
4920ae3d |
128 | Foo::Meta::Class->create('Foo::NoMeta2::Sub', superclasses => ['Foo::NoMeta2']); |
129 | ok(!Foo::NoMeta->can('meta'), "non-cmop superclass doesn't get methods installed"); |
130 | isa_ok(Class::MOP::class_of('Foo::NoMeta2'), 'Class::MOP::Class'); |
131 | isa_ok(Foo::NoMeta2::Sub->meta, 'Foo::Meta::Class'); |
132 | |
b9f7897b |
133 | Foo::Meta::Class->create('Foo::WithMeta'); |
134 | { |
135 | package Foo::WithMeta::Sub; |
136 | use base 'Foo::WithMeta'; |
137 | } |
138 | Class::MOP::Class->create( |
139 | 'Foo::WithMeta::Sub::Sub', |
140 | superclasses => ['Foo::WithMeta::Sub'] |
141 | ); |
142 | |
143 | isa_ok(Class::MOP::class_of('Foo::WithMeta'), 'Foo::Meta::Class'); |
144 | isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub'), 'Foo::Meta::Class'); |
145 | isa_ok(Class::MOP::class_of('Foo::WithMeta::Sub::Sub'), 'Foo::Meta::Class'); |
146 | |
6b0ff0b1 |
147 | Foo::Meta::Class->create('Foo::WithMeta2'); |
148 | { |
149 | package Foo::WithMeta2::Sub; |
150 | use base 'Foo::WithMeta2'; |
151 | } |
152 | { |
153 | package Foo::WithMeta2::Sub::Sub; |
154 | use base 'Foo::WithMeta2::Sub'; |
155 | } |
156 | Class::MOP::Class->create( |
157 | 'Foo::WithMeta2::Sub::Sub::Sub', |
158 | superclasses => ['Foo::WithMeta2::Sub::Sub'] |
159 | ); |
160 | |
161 | isa_ok(Class::MOP::class_of('Foo::WithMeta2'), 'Foo::Meta::Class'); |
162 | isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub'), 'Foo::Meta::Class'); |
163 | isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub'), 'Foo::Meta::Class'); |
164 | isa_ok(Class::MOP::class_of('Foo::WithMeta2::Sub::Sub::Sub'), 'Foo::Meta::Class'); |
165 | |
166 | Class::MOP::Class->create( |
167 | 'Foo::Reverse::Sub::Sub', |
168 | superclasses => ['Foo::Reverse::Sub'], |
169 | ); |
170 | eval "package Foo::Reverse::Sub; use base 'Foo::Reverse';"; |
171 | Foo::Meta::Class->create( |
172 | 'Foo::Reverse', |
173 | ); |
174 | isa_ok(Class::MOP::class_of('Foo::Reverse'), 'Foo::Meta::Class'); |
57e6687d |
175 | { local $TODO = 'No idea how to handle case where parent class is created before children'; |
6b0ff0b1 |
176 | isa_ok(Class::MOP::class_of('Foo::Reverse::Sub'), 'Foo::Meta::Class'); |
177 | isa_ok(Class::MOP::class_of('Foo::Reverse::Sub::Sub'), 'Foo::Meta::Class'); |
178 | } |
179 | |
4920ae3d |
180 | # unsafe fixing... |
550d56db |
181 | |
4920ae3d |
182 | { |
183 | Class::MOP::Class->create( |
184 | 'Foo::Unsafe', |
185 | attribute_metaclass => 'Foo::Meta::Attribute', |
186 | ); |
187 | my $meta = Class::MOP::Class->create( |
188 | 'Foo::Unsafe::Sub', |
189 | ); |
190 | $meta->add_attribute(foo => reader => 'foo'); |
191 | throws_ok { $meta->superclasses('Foo::Unsafe') } |
192 | qr/compatibility.*pristine/, |
193 | "can't switch out the attribute metaclass of a class that already has attributes"; |
194 | } |
550d56db |
195 | |
3a9318e6 |
196 | # immutability... |
197 | |
198 | { |
199 | my $foometa = Foo::Meta::Class->create( |
200 | 'Foo::Immutable', |
201 | ); |
202 | $foometa->make_immutable; |
203 | my $barmeta = Class::MOP::Class->create( |
204 | 'Bar::Mutable', |
205 | ); |
206 | my $bazmeta = Class::MOP::Class->create( |
207 | 'Baz::Mutable', |
208 | ); |
209 | $bazmeta->superclasses($foometa->name); |
210 | lives_ok { $bazmeta->superclasses($barmeta->name) } |
211 | "can still set superclasses"; |
212 | ok(!$bazmeta->is_immutable, |
213 | "immutable superclass doesn't make this class immutable"); |
214 | lives_ok { $bazmeta->make_immutable } "can still make immutable"; |
215 | } |
216 | |
06ea51c7 |
217 | # nonexistent metaclasses |
218 | |
8b1cc359 |
219 | Class::MOP::Class->create( |
220 | 'Weird::Meta::Method::Destructor', |
221 | superclasses => ['Class::MOP::Method'], |
222 | ); |
06ea51c7 |
223 | |
224 | lives_ok { |
225 | Class::MOP::Class->create( |
226 | 'Weird::Class', |
227 | destructor_class => 'Weird::Meta::Method::Destructor', |
228 | ); |
229 | } "defined metaclass in child with defined metaclass in parent is fine"; |
230 | |
231 | is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
232 | "got the right destructor class"); |
233 | |
234 | lives_ok { |
235 | Class::MOP::Class->create( |
236 | 'Weird::Class::Sub', |
237 | superclasses => ['Weird::Class'], |
238 | destructor_class => undef, |
239 | ); |
240 | } "undef metaclass in child with defined metaclass in parent can be fixed"; |
241 | |
242 | is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
243 | "got the right destructor class"); |
244 | |
245 | lives_ok { |
246 | Class::MOP::Class->create( |
247 | 'Weird::Class::Sub2', |
248 | destructor_class => undef, |
249 | ); |
250 | } "undef metaclass in child with defined metaclass in parent can be fixed"; |
251 | |
252 | lives_ok { |
253 | Weird::Class::Sub2->meta->superclasses('Weird::Class'); |
254 | } "undef metaclass in child with defined metaclass in parent can be fixed"; |
255 | |
256 | is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
257 | "got the right destructor class"); |
258 | |
86a4d873 |
259 | done_testing; |