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 | |
133 | # unsafe fixing... |
550d56db |
134 | |
4920ae3d |
135 | { |
136 | Class::MOP::Class->create( |
137 | 'Foo::Unsafe', |
138 | attribute_metaclass => 'Foo::Meta::Attribute', |
139 | ); |
140 | my $meta = Class::MOP::Class->create( |
141 | 'Foo::Unsafe::Sub', |
142 | ); |
143 | $meta->add_attribute(foo => reader => 'foo'); |
144 | throws_ok { $meta->superclasses('Foo::Unsafe') } |
145 | qr/compatibility.*pristine/, |
146 | "can't switch out the attribute metaclass of a class that already has attributes"; |
147 | } |
550d56db |
148 | |
86a4d873 |
149 | done_testing; |