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',
18 for my $suffix ('Class', keys %metaclass_attrs) {
19 Class::MOP::Class->create(
21 superclasses => ["Class::MOP::$suffix"]
23 Class::MOP::Class->create(
25 superclasses => ["Class::MOP::$suffix"]
27 Class::MOP::Class->create(
28 "FooBar::Meta::$suffix",
29 superclasses => ["Foo::Meta::$suffix", "Bar::Meta::$suffix"]
36 Foo::Meta::Class->create('Foo')
37 }, undef, '... Foo.meta => Foo::Meta::Class is compatible' );
39 Bar::Meta::Class->create('Bar')
40 }, undef, '... Bar.meta => Bar::Meta::Class is compatible' );
43 Bar::Meta::Class->create('Foo::Foo', superclasses => ['Foo'])
44 }, qr/compatible/, '... Foo::Foo.meta => Bar::Meta::Class is not compatible' );
46 Foo::Meta::Class->create('Bar::Bar', superclasses => ['Bar'])
47 }, qr/compatible/, '... Bar::Bar.meta => Foo::Meta::Class is not compatible' );
50 FooBar::Meta::Class->create('FooBar', superclasses => ['Foo'])
51 }, undef, '... FooBar.meta => FooBar::Meta::Class is compatible' );
53 FooBar::Meta::Class->create('FooBar2', superclasses => ['Bar'])
54 }, undef, '... FooBar2.meta => FooBar::Meta::Class is compatible' );
56 Foo::Meta::Class->create(
58 map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
62 Bar::Meta::Class->create(
63 'Foo::All::Sub::Class',
64 superclasses => ['Foo::All'],
65 map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
67 }, qr/compatible/, 'incompatible Class metaclass' );
68 for my $suffix (keys %metaclass_attrs) {
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",
76 }, qr/compatible/, "incompatible $suffix metaclass" );
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');
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');
91 Class::MOP::Class->create(
92 'Foo::All::Sub::CMOP::Class',
93 superclasses => ['Foo::All'],
94 map { $metaclass_attrs{$_} => "Foo::Meta::$_" } keys %metaclass_attrs,
96 }, undef, 'metaclass fixing works with other non-default metaclasses' );
97 isa_ok(Foo::All::Sub::CMOP::Class->meta, 'Foo::Meta::Class');
99 for my $suffix (keys %metaclass_attrs) {
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",
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");
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');
126 package Foo::NoMeta2;
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');
133 Foo::Meta::Class->create('Foo::WithMeta');
135 package Foo::WithMeta::Sub;
136 use base 'Foo::WithMeta';
138 Class::MOP::Class->create(
139 'Foo::WithMeta::Sub::Sub',
140 superclasses => ['Foo::WithMeta::Sub']
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');
147 Foo::Meta::Class->create('Foo::WithMeta2');
149 package Foo::WithMeta2::Sub;
150 use base 'Foo::WithMeta2';
153 package Foo::WithMeta2::Sub::Sub;
154 use base 'Foo::WithMeta2::Sub';
156 Class::MOP::Class->create(
157 'Foo::WithMeta2::Sub::Sub::Sub',
158 superclasses => ['Foo::WithMeta2::Sub::Sub']
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');
166 Class::MOP::Class->create(
167 'Foo::Reverse::Sub::Sub',
168 superclasses => ['Foo::Reverse::Sub'],
170 eval "package Foo::Reverse::Sub; use base 'Foo::Reverse';";
171 Foo::Meta::Class->create(
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');
183 Class::MOP::Class->create(
185 attribute_metaclass => 'Foo::Meta::Attribute',
187 my $meta = Class::MOP::Class->create(
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" );
197 my $foometa = Foo::Meta::Class->create(
200 $foometa->make_immutable;
201 my $barmeta = Class::MOP::Class->create(
204 my $bazmeta = Class::MOP::Class->create(
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" );
214 # nonexistent metaclasses
216 Class::MOP::Class->create(
217 'Weird::Meta::Method::Destructor',
218 superclasses => ['Class::MOP::Method'],
222 Class::MOP::Class->create(
224 destructor_class => 'Weird::Meta::Method::Destructor',
226 }, undef, "defined metaclass in child with defined metaclass in parent is fine" );
228 is(Weird::Class->meta->destructor_class, 'Weird::Meta::Method::Destructor',
229 "got the right destructor class");
232 Class::MOP::Class->create(
234 superclasses => ['Weird::Class'],
235 destructor_class => undef,
237 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
239 is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
240 "got the right destructor class");
243 Class::MOP::Class->create(
244 'Weird::Class::Sub2',
245 destructor_class => undef,
247 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
250 Weird::Class::Sub2->meta->superclasses('Weird::Class');
251 }, undef, "undef metaclass in child with defined metaclass in parent can be fixed" );
253 is(Weird::Class::Sub->meta->destructor_class, 'Weird::Meta::Method::Destructor',
254 "got the right destructor class");