Commit | Line | Data |
38bf2a25 |
1 | use strict; |
2 | use warnings; |
3 | |
4 | use Test::More; |
5 | use Test::Fatal; |
6 | |
7 | use Scalar::Util; |
8 | |
9 | use Class::MOP; |
10 | |
11 | { |
12 | package Foo; |
13 | |
14 | use strict; |
15 | use warnings; |
16 | use metaclass; |
17 | |
18 | __PACKAGE__->meta->add_attribute('bar'); |
19 | |
20 | package Bar; |
21 | |
22 | use strict; |
23 | use warnings; |
24 | use metaclass; |
25 | |
26 | __PACKAGE__->meta->superclasses('Foo'); |
27 | |
28 | __PACKAGE__->meta->add_attribute('baz'); |
29 | |
30 | package Baz; |
31 | |
32 | use strict; |
33 | use warnings; |
34 | use metaclass; |
35 | |
36 | __PACKAGE__->meta->superclasses('Bar'); |
37 | |
38 | __PACKAGE__->meta->add_attribute('bah'); |
39 | } |
40 | |
41 | { |
42 | my $meta = Baz->meta; |
43 | is($meta->name, 'Baz', '... checking the Baz metaclass'); |
44 | my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; |
45 | # Since this has no default it won't be present yet, but it will |
46 | # be after the class is made immutable. |
47 | |
48 | is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable' ); |
49 | ok(!$meta->is_mutable, '... our class is no longer mutable'); |
50 | ok($meta->is_immutable, '... our class is now immutable'); |
51 | ok(!$meta->make_immutable, '... make immutable now returns nothing'); |
52 | ok($meta->get_method('new'), '... inlined constructor created'); |
53 | ok($meta->has_method('new'), '... inlined constructor created for sure'); |
54 | is_deeply([ map { $_->name } $meta->_inlined_methods ], [ 'new' ], '... really, i mean it'); |
55 | |
56 | is( exception { $meta->make_mutable; }, undef, '... changed Baz to be mutable' ); |
57 | ok($meta->is_mutable, '... our class is mutable'); |
58 | ok(!$meta->is_immutable, '... our class is not immutable'); |
59 | ok(!$meta->make_mutable, '... make mutable now returns nothing'); |
60 | ok(!$meta->get_method('new'), '... inlined constructor created'); |
61 | ok(!$meta->has_method('new'), '... inlined constructor removed for sure'); |
62 | |
63 | my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; |
64 | is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); |
65 | |
66 | isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); |
67 | |
68 | $meta->add_method('xyz', sub{'xxx'}); |
69 | is( Baz->xyz, 'xxx', '... method xyz works'); |
70 | |
71 | ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); |
72 | ok(Baz->can('fickle'), '... Baz can fickle'); |
73 | ok($meta->remove_attribute('fickle'), '... removed attribute'); |
74 | |
75 | my $reef = \ 'reef'; |
76 | $meta->add_package_symbol('$ref', $reef); |
77 | is($meta->get_package_symbol('$ref'), $reef, '... values match'); |
78 | is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); |
79 | isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); |
80 | |
81 | ok( my @supers = $meta->superclasses, '... got the superclasses okay'); |
82 | ok( $meta->superclasses('Foo'), '... set the superclasses'); |
83 | is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); |
84 | ok( $meta->superclasses( @supers ), '... reset superclasses'); |
85 | is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); |
86 | |
87 | ok( $meta->$_ , "... ${_} works") |
88 | for qw(get_meta_instance get_all_attributes |
89 | class_precedence_list ); |
90 | |
91 | is( exception {$meta->make_immutable; }, undef, '... changed Baz to be immutable again' ); |
92 | ok($meta->get_method('new'), '... inlined constructor recreated'); |
93 | } |
94 | |
95 | { |
96 | my $meta = Baz->meta; |
97 | |
98 | is( exception { $meta->make_immutable() }, undef, 'Changed Baz to be immutable' ); |
99 | is( exception { $meta->make_mutable() }, undef, '... changed Baz to be mutable' ); |
100 | is( exception { $meta->make_immutable() }, undef, '... changed Baz to be immutable' ); |
101 | |
102 | isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); |
103 | |
104 | isnt( exception { |
105 | $meta->add_attribute('fickle', accessor => 'fickle') |
106 | }, undef, '... exception thrown as expected' ); |
107 | isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); |
108 | |
109 | my $reef = \ 'reef'; |
110 | isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); |
111 | isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); |
112 | |
113 | ok( my @supers = $meta->superclasses, '... got the superclasses okay'); |
114 | isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); |
115 | |
116 | ok( $meta->$_ , "... ${_} works") |
117 | for qw(get_meta_instance get_all_attributes |
118 | class_precedence_list ); |
119 | } |
120 | |
121 | { |
122 | |
123 | ok(Baz->meta->is_immutable, 'Superclass is immutable'); |
124 | my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); |
125 | my %orig_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; |
126 | my @orig_meths = sort { $a->name cmp $b->name } $meta->get_all_methods; |
127 | ok($meta->is_anon_class, 'We have an anon metaclass'); |
128 | ok($meta->is_mutable, '... our anon class is mutable'); |
129 | ok(!$meta->is_immutable, '... our anon class is not immutable'); |
130 | |
131 | is( exception {$meta->make_immutable( |
132 | inline_accessor => 1, |
133 | inline_destructor => 0, |
134 | inline_constructor => 1, |
135 | ) |
136 | }, undef, '... changed class to be immutable' ); |
137 | ok(!$meta->is_mutable, '... our class is no longer mutable'); |
138 | ok($meta->is_immutable, '... our class is now immutable'); |
139 | ok(!$meta->make_immutable, '... make immutable now returns nothing'); |
140 | |
141 | is( exception { $meta->make_mutable }, undef, '... changed Baz to be mutable' ); |
142 | ok($meta->is_mutable, '... our class is mutable'); |
143 | ok(!$meta->is_immutable, '... our class is not immutable'); |
144 | ok(!$meta->make_mutable, '... make mutable now returns nothing'); |
145 | ok($meta->is_anon_class, '... still marked as an anon class'); |
146 | my $instance = $meta->new_object; |
147 | |
148 | my %new_keys = map { $_ => 1 } grep { !/^_/ } keys %$meta; |
149 | my @new_meths = sort { $a->name cmp $b->name } |
150 | $meta->get_all_methods; |
151 | is_deeply(\%orig_keys, \%new_keys, '... no extraneous hashkeys'); |
152 | is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); |
153 | |
154 | isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); |
155 | |
156 | $meta->add_method('xyz', sub{'xxx'}); |
157 | is( $instance->xyz , 'xxx', '... method xyz works'); |
158 | ok( $meta->remove_method('xyz'), '... removed method'); |
159 | |
160 | ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); |
161 | ok($instance->can('fickle'), '... instance can fickle'); |
162 | ok($meta->remove_attribute('fickle'), '... removed attribute'); |
163 | |
164 | my $reef = \ 'reef'; |
165 | $meta->add_package_symbol('$ref', $reef); |
166 | is($meta->get_package_symbol('$ref'), $reef, '... values match'); |
167 | is( exception { $meta->remove_package_symbol('$ref') }, undef, '... removed it' ); |
168 | isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); |
169 | |
170 | ok( my @supers = $meta->superclasses, '... got the superclasses okay'); |
171 | ok( $meta->superclasses('Foo'), '... set the superclasses'); |
172 | is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); |
173 | ok( $meta->superclasses( @supers ), '... reset superclasses'); |
174 | is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); |
175 | |
176 | ok( $meta->$_ , "... ${_} works") |
177 | for qw(get_meta_instance get_all_attributes |
178 | class_precedence_list ); |
179 | }; |
180 | |
181 | |
182 | #rerun the same tests on an anon class.. just cause we can. |
183 | { |
184 | my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); |
185 | |
186 | is( exception {$meta->make_immutable( |
187 | inline_accessor => 1, |
188 | inline_destructor => 0, |
189 | inline_constructor => 1, |
190 | ) |
191 | }, undef, '... changed class to be immutable' ); |
192 | is( exception { $meta->make_mutable() }, undef, '... changed class to be mutable' ); |
193 | is( exception {$meta->make_immutable }, undef, '... changed class to be immutable' ); |
194 | |
195 | isnt( exception { $meta->add_method('xyz', sub{'xxx'}) }, undef, '... exception thrown as expected' ); |
196 | |
197 | isnt( exception { |
198 | $meta->add_attribute('fickle', accessor => 'fickle') |
199 | }, undef, '... exception thrown as expected' ); |
200 | isnt( exception { $meta->remove_attribute('fickle') }, undef, '... exception thrown as expected' ); |
201 | |
202 | my $reef = \ 'reef'; |
203 | isnt( exception { $meta->add_package_symbol('$ref', $reef) }, undef, '... exception thrown as expected' ); |
204 | isnt( exception { $meta->remove_package_symbol('$ref') }, undef, '... exception thrown as expected' ); |
205 | |
206 | ok( my @supers = $meta->superclasses, '... got the superclasses okay'); |
207 | isnt( exception { $meta->superclasses('Foo') }, undef, '... set the superclasses' ); |
208 | |
209 | ok( $meta->$_ , "... ${_} works") |
210 | for qw(get_meta_instance get_all_attributes |
211 | class_precedence_list ); |
212 | } |
213 | |
214 | { |
215 | Foo->meta->make_immutable; |
216 | Bar->meta->make_immutable; |
217 | Bar->meta->make_mutable; |
218 | } |
219 | |
220 | done_testing; |