Commit | Line | Data |
38bf2a25 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Fatal; |
6 | |
7 | use metaclass; |
8 | |
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 | |
17 | # meta classes |
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 | is( exception { |
36 | Foo::Meta::Class->create('Foo') |
37 | }, undef, '... Foo.meta => Foo::Meta::Class is compatible' ); |
38 | is( exception { |
39 | Bar::Meta::Class->create('Bar') |
40 | }, undef, '... Bar.meta => Bar::Meta::Class is compatible' ); |
41 | |
42 | like( exception { |
43 | Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo']) |
44 | }, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' ); |
45 | like( exception { |
46 | Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar']) |
47 | }, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' ); |
48 | |
49 | is( exception { |
50 | FooBar::Meta::Class->create('FooBar', superclasses => ['Foo']) |
51 | }, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' ); |
52 | is( exception { |
53 | FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar']) |
54 | }, undef, '... 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 | like( exception { |
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 | like( exception { |
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 | is( exception { |
82 | Class::MOP::Class->create('Foo::Foo::CMOP', superclasses => ['Foo']) |
83 | }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); |
84 | isa_ok(Foo::Foo::CMOP->meta, 'Foo::Meta::Class'); |
85 | is( exception { |
86 | Class::MOP::Class->create('Bar::Bar::CMOP', superclasses => ['Bar']) |
87 | }, undef, 'metaclass fixing fixes a cmop metaclass, when the parent has a subclass' ); |
88 | isa_ok(Bar::Bar::CMOP->meta, 'Bar::Meta::Class'); |
89 | |
90 | is( exception { |
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 | }, undef, '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 | is( exception { |
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 | }, undef, "$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 | |
116 | { |
117 | package Foo::NoMeta; |
118 | } |
119 | |
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'); |
124 | |
125 | { |
126 | package Foo::NoMeta2; |
127 | } |
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 | |
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 | |
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'); |
175 | { local $TODO = 'No idea how to handle case where parent class is created before children'; |
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 | |
180 | # unsafe fixing... |
181 | |
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 | like( exception { $meta->superclasses('Foo::Unsafe') }, qr/compatibility.*pristine/, "can't switch out the attribute metaclass of a class that already has attributes" ); |
192 | } |
193 | |
194 | # immutability... |
195 | |
196 | { |
197 | my $foometa = Foo::Meta::Class->create( |
198 | 'Foo::Immutable', |
199 | ); |
200 | $foometa->make_immutable; |
201 | my $barmeta = Class::MOP::Class->create( |
202 | 'Bar::Mutable', |
203 | ); |
204 | my $bazmeta = Class::MOP::Class->create( |
205 | 'Baz::Mutable', |
206 | ); |
207 | $bazmeta->superclasses($foometa->name); |
208 | is( exception { $bazmeta->superclasses($barmeta->name) }, undef, "can still set superclasses" ); |
209 | ok(!$bazmeta->is_immutable, |
210 | "immutable superclass doesn't make this class immutable"); |
211 | is( exception { $bazmeta->make_immutable }, undef, "can still make immutable" ); |
212 | } |
213 | |
214 | # nonexistent metaclasses |
215 | |
216 | Class::MOP::Class->create( |
217 | 'Weird::Meta::Method::Destructor', |
218 | superclasses => ['Class::MOP::Method'], |
219 | ); |
220 | |
221 | is( exception { |
222 | Class::MOP::Class->create( |
223 | 'Weird::Class', |
224 | destructor_class => 'Weird::Meta::Method::Destructor', |
225 | ); |
226 | }, undef, "defined metaclass in child with defined metaclass in parent is fine" ); |
227 | |
228 | is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
229 | "got the right destructor class"); |
230 | |
231 | is( exception { |
232 | Class::MOP::Class->create( |
233 | 'Weird::Class::Sub', |
234 | superclasses => ['Weird::Class'], |
235 | destructor_class => undef, |
236 | ); |
237 | }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); |
238 | |
239 | is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
240 | "got the right destructor class"); |
241 | |
242 | is( exception { |
243 | Class::MOP::Class->create( |
244 | 'Weird::Class::Sub2', |
245 | destructor_class => undef, |
246 | ); |
247 | }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); |
248 | |
249 | is( exception { |
250 | Weird::Class::Sub2->meta->superclasses('Weird::Class'); |
251 | }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" ); |
252 | |
253 | is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor', |
254 | "got the right destructor class"); |
255 | |
256 | done_testing; |