Commit | Line | Data |
857f87a7 |
1 | |
2 | package Class::MOP::Class::Immutable; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
817c7cd5 |
7 | use Class::MOP::Method::Constructor; |
8 | |
857f87a7 |
9 | use Carp 'confess'; |
817c7cd5 |
10 | use Scalar::Util 'blessed'; |
857f87a7 |
11 | |
b1897d4d |
12 | our $VERSION = '0.03'; |
f0480c45 |
13 | our $AUTHORITY = 'cpan:STEVAN'; |
857f87a7 |
14 | |
15 | use base 'Class::MOP::Class'; |
16 | |
dc76a410 |
17 | # enforce the meta-circularity here |
18 | # and hide the Immutable part |
19 | |
20 | sub meta { |
21 | my $self = shift; |
22 | # if it is not blessed, then someone is asking |
23 | # for the meta of Class::MOP::Class::Immutable |
24 | return Class::MOP::Class->initialize($self) unless blessed($self); |
25 | # otherwise, they are asking for the metaclass |
26 | # which has been made immutable, which is itself |
27 | return $self; |
28 | } |
29 | |
857f87a7 |
30 | # methods which can *not* be called |
b1897d4d |
31 | for my $meth (qw( |
32 | add_method |
33 | alias_method |
34 | remove_method |
35 | add_attribute |
36 | remove_attribute |
37 | add_package_symbol |
38 | remove_package_symbol |
39 | )) { |
40 | no strict 'refs'; |
41 | *{$meth} = sub { |
42 | confess "Cannot call method '$meth' on an immutable instance"; |
43 | }; |
44 | } |
857f87a7 |
45 | |
b6164407 |
46 | sub get_package_symbol { |
47 | my ($self, $variable) = @_; |
48 | my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); |
49 | return *{$self->namespace->{$name}}{$type} |
50 | if exists $self->namespace->{$name}; |
51 | # NOTE: |
52 | # we have to do this here in order to preserve |
53 | # perl's autovivification of variables. However |
54 | # we do cut off direct access to add_package_symbol |
55 | # as shown above. |
56 | $self->Class::MOP::Package::add_package_symbol($variable); |
57 | } |
58 | |
857f87a7 |
59 | # NOTE: |
60 | # superclasses is an accessor, so |
61 | # it just cannot be changed |
62 | sub superclasses { |
63 | my $class = shift; |
64 | (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance'; |
a5e51f0b |
65 | @{$class->get_package_symbol('@ISA')}; |
857f87a7 |
66 | } |
67 | |
68 | # predicates |
69 | |
70 | sub is_mutable { 0 } |
71 | sub is_immutable { 1 } |
72 | |
73 | sub make_immutable { () } |
74 | |
75 | sub make_metaclass_immutable { |
c0cbf4d9 |
76 | my ($class, $metaclass, %options) = @_; |
77 | |
4d47b77f |
78 | # NOTE: |
79 | # i really need the // (defined-or) operator here |
80 | $options{inline_accessors} = 1 unless exists $options{inline_accessors}; |
81 | $options{inline_constructor} = 1 unless exists $options{inline_constructor}; |
82 | $options{constructor_name} = 'new' unless exists $options{constructor_name}; |
83 | $options{debug} = 0 unless exists $options{debug}; |
c0cbf4d9 |
84 | |
85 | my $meta_instance = $metaclass->get_meta_instance; |
86 | $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; |
87 | $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; |
88 | $metaclass->{'___get_meta_instance'} = $meta_instance; |
89 | $metaclass->{'___original_class'} = blessed($metaclass); |
90 | |
91 | if ($options{inline_accessors}) { |
92 | foreach my $attr_name ($metaclass->get_attribute_list) { |
817c7cd5 |
93 | # inline the accessors |
94 | $metaclass->get_attribute($attr_name) |
95 | ->install_accessors(1); |
c0cbf4d9 |
96 | } |
97 | } |
98 | |
99 | if ($options{inline_constructor}) { |
817c7cd5 |
100 | my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; |
c0cbf4d9 |
101 | $metaclass->add_method( |
102 | $options{constructor_name}, |
817c7cd5 |
103 | $constructor_class->new( |
104 | options => \%options, |
105 | meta_instance => $meta_instance, |
106 | attributes => $metaclass->{'___compute_all_applicable_attributes'} |
107 | ) |
c0cbf4d9 |
108 | ); |
109 | } |
ce2ae40f |
110 | |
111 | # now cache the method map ... |
112 | $metaclass->{'___method_map'} = $metaclass->get_method_map; |
c0cbf4d9 |
113 | |
857f87a7 |
114 | bless $metaclass => $class; |
115 | } |
116 | |
c0cbf4d9 |
117 | # cached methods |
118 | |
119 | sub get_meta_instance { (shift)->{'___get_meta_instance'} } |
120 | sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} } |
121 | sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} } |
373a16ae |
122 | sub get_mutable_metaclass_name { (shift)->{'___original_class'} } |
ce2ae40f |
123 | sub get_method_map { (shift)->{'___method_map'} } |
c0cbf4d9 |
124 | |
857f87a7 |
125 | 1; |
126 | |
127 | __END__ |
128 | |
129 | =pod |
130 | |
131 | =head1 NAME |
132 | |
133 | Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class |
134 | |
135 | =head1 SYNOPSIS |
136 | |
be960ba1 |
137 | package Point; |
138 | use metaclass; |
139 | |
140 | __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); |
141 | __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); |
142 | |
143 | sub new { |
144 | my $class = shift; |
145 | $class->meta->new_object(@_); |
146 | } |
147 | |
148 | sub clear { |
149 | my $self = shift; |
150 | $self->x(0); |
151 | $self->y(0); |
152 | } |
153 | |
154 | __PACKAGE__->meta->make_immutable(); # close the class |
155 | |
857f87a7 |
156 | =head1 DESCRIPTION |
157 | |
c0cbf4d9 |
158 | Class::MOP offers many benefits to object oriented development but it |
159 | comes at a cost. Pure Class::MOP classes can be quite a bit slower than |
160 | the typical hand coded Perl classes. This is because just about |
161 | I<everything> is recalculated on the fly, and nothing is cached. The |
162 | reason this is so, is because Perl itself allows you to modify virtually |
163 | everything at runtime. Class::MOP::Class::Immutable offers an alternative |
164 | to this. |
165 | |
166 | By making your class immutable, you are promising that you will not |
167 | modify your inheritence tree or the attributes of any classes in |
168 | that tree. Since runtime modifications like this are fairly atypical |
169 | (and usually recomended against), this is not usally a very hard promise |
170 | to make. For making this promise you are given a wide range of |
171 | optimization options which bring speed close to (and sometimes above) |
172 | those of typical hand coded Perl. |
173 | |
857f87a7 |
174 | =head1 METHODS |
175 | |
176 | =over 4 |
177 | |
178 | =item B<meta> |
179 | |
180 | This will return a B<Class::MOP::Class> instance which is related |
181 | to this class. |
182 | |
183 | =back |
184 | |
4d47b77f |
185 | =head2 Introspection and Construction |
186 | |
187 | =over 4 |
188 | |
189 | =item B<make_metaclass_immutable> |
190 | |
be960ba1 |
191 | The arguments to C<Class::MOP::Class::make_immutable> are passed |
192 | to this method, which |
193 | |
4d47b77f |
194 | =over 4 |
195 | |
196 | =item I<inline_accessors (Bool)> |
197 | |
198 | =item I<inline_constructor (Bool)> |
199 | |
200 | =item I<debug (Bool)> |
201 | |
202 | =item I<constructor_name (Str)> |
203 | |
204 | =back |
205 | |
206 | =item B<is_immutable> |
207 | |
208 | =item B<is_mutable> |
209 | |
210 | =item B<make_immutable> |
211 | |
373a16ae |
212 | =item B<get_mutable_metaclass_name> |
213 | |
4d47b77f |
214 | =back |
215 | |
2243a22b |
216 | =head2 Methods which will die if you touch them. |
217 | |
218 | =over 4 |
219 | |
220 | =item B<add_attribute> |
221 | |
222 | =item B<add_method> |
223 | |
58d75218 |
224 | =item B<add_package_symbol> |
2243a22b |
225 | |
226 | =item B<alias_method> |
227 | |
2243a22b |
228 | =item B<remove_attribute> |
229 | |
230 | =item B<remove_method> |
231 | |
58d75218 |
232 | =item B<remove_package_symbol> |
2243a22b |
233 | |
b6164407 |
234 | =back |
235 | |
236 | =head2 Methods which work slightly differently. |
237 | |
238 | =over 4 |
239 | |
2243a22b |
240 | =item B<superclasses> |
241 | |
b6164407 |
242 | This method becomes read-only in an immutable class. |
243 | |
244 | =item B<get_package_symbol> |
245 | |
246 | This method must handle package variable autovivification |
247 | correctly, while still disallowing C<add_package_symbol>. |
248 | |
2243a22b |
249 | =back |
250 | |
251 | =head2 Cached methods |
252 | |
857f87a7 |
253 | =over 4 |
254 | |
2243a22b |
255 | =item B<class_precedence_list> |
256 | |
257 | =item B<compute_all_applicable_attributes> |
258 | |
259 | =item B<get_meta_instance> |
260 | |
ce2ae40f |
261 | =item B<get_method_map> |
262 | |
2243a22b |
263 | =back |
264 | |
1a09d9cc |
265 | =head1 AUTHORS |
857f87a7 |
266 | |
267 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
268 | |
1a09d9cc |
269 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
270 | |
857f87a7 |
271 | =head1 COPYRIGHT AND LICENSE |
272 | |
273 | Copyright 2006 by Infinity Interactive, Inc. |
274 | |
275 | L<http://www.iinteractive.com> |
276 | |
277 | This library is free software; you can redistribute it and/or modify |
278 | it under the same terms as Perl itself. |
279 | |
280 | =cut |