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 | |
46 | # NOTE: |
47 | # superclasses is an accessor, so |
48 | # it just cannot be changed |
49 | sub superclasses { |
50 | my $class = shift; |
51 | (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance'; |
a5e51f0b |
52 | @{$class->get_package_symbol('@ISA')}; |
857f87a7 |
53 | } |
54 | |
55 | # predicates |
56 | |
57 | sub is_mutable { 0 } |
58 | sub is_immutable { 1 } |
59 | |
60 | sub make_immutable { () } |
61 | |
62 | sub make_metaclass_immutable { |
c0cbf4d9 |
63 | my ($class, $metaclass, %options) = @_; |
64 | |
4d47b77f |
65 | # NOTE: |
66 | # i really need the // (defined-or) operator here |
67 | $options{inline_accessors} = 1 unless exists $options{inline_accessors}; |
68 | $options{inline_constructor} = 1 unless exists $options{inline_constructor}; |
69 | $options{constructor_name} = 'new' unless exists $options{constructor_name}; |
70 | $options{debug} = 0 unless exists $options{debug}; |
c0cbf4d9 |
71 | |
72 | my $meta_instance = $metaclass->get_meta_instance; |
73 | $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; |
74 | $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; |
75 | $metaclass->{'___get_meta_instance'} = $meta_instance; |
76 | $metaclass->{'___original_class'} = blessed($metaclass); |
77 | |
78 | if ($options{inline_accessors}) { |
79 | foreach my $attr_name ($metaclass->get_attribute_list) { |
817c7cd5 |
80 | # inline the accessors |
81 | $metaclass->get_attribute($attr_name) |
82 | ->install_accessors(1); |
c0cbf4d9 |
83 | } |
84 | } |
85 | |
86 | if ($options{inline_constructor}) { |
817c7cd5 |
87 | my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; |
c0cbf4d9 |
88 | $metaclass->add_method( |
89 | $options{constructor_name}, |
817c7cd5 |
90 | $constructor_class->new( |
91 | options => \%options, |
92 | meta_instance => $meta_instance, |
93 | attributes => $metaclass->{'___compute_all_applicable_attributes'} |
94 | ) |
c0cbf4d9 |
95 | ); |
96 | } |
ce2ae40f |
97 | |
98 | # now cache the method map ... |
a5ee59de |
99 | $metaclass->{'___get_method_map'} = $metaclass->get_method_map; |
c0cbf4d9 |
100 | |
857f87a7 |
101 | bless $metaclass => $class; |
102 | } |
103 | |
c0cbf4d9 |
104 | # cached methods |
105 | |
106 | sub get_meta_instance { (shift)->{'___get_meta_instance'} } |
107 | sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} } |
108 | sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} } |
373a16ae |
109 | sub get_mutable_metaclass_name { (shift)->{'___original_class'} } |
a5ee59de |
110 | sub get_method_map { (shift)->{'___get_method_map'} } |
c0cbf4d9 |
111 | |
857f87a7 |
112 | 1; |
113 | |
114 | __END__ |
115 | |
116 | =pod |
117 | |
118 | =head1 NAME |
119 | |
120 | Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class |
121 | |
122 | =head1 SYNOPSIS |
123 | |
be960ba1 |
124 | package Point; |
125 | use metaclass; |
126 | |
127 | __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10)); |
128 | __PACKAGE__->meta->add_attribute('y' => (accessor => 'y')); |
129 | |
130 | sub new { |
131 | my $class = shift; |
132 | $class->meta->new_object(@_); |
133 | } |
134 | |
135 | sub clear { |
136 | my $self = shift; |
137 | $self->x(0); |
138 | $self->y(0); |
139 | } |
140 | |
141 | __PACKAGE__->meta->make_immutable(); # close the class |
142 | |
857f87a7 |
143 | =head1 DESCRIPTION |
144 | |
c0cbf4d9 |
145 | Class::MOP offers many benefits to object oriented development but it |
146 | comes at a cost. Pure Class::MOP classes can be quite a bit slower than |
147 | the typical hand coded Perl classes. This is because just about |
148 | I<everything> is recalculated on the fly, and nothing is cached. The |
149 | reason this is so, is because Perl itself allows you to modify virtually |
150 | everything at runtime. Class::MOP::Class::Immutable offers an alternative |
151 | to this. |
152 | |
153 | By making your class immutable, you are promising that you will not |
154 | modify your inheritence tree or the attributes of any classes in |
155 | that tree. Since runtime modifications like this are fairly atypical |
156 | (and usually recomended against), this is not usally a very hard promise |
157 | to make. For making this promise you are given a wide range of |
158 | optimization options which bring speed close to (and sometimes above) |
159 | those of typical hand coded Perl. |
160 | |
857f87a7 |
161 | =head1 METHODS |
162 | |
163 | =over 4 |
164 | |
165 | =item B<meta> |
166 | |
167 | This will return a B<Class::MOP::Class> instance which is related |
168 | to this class. |
169 | |
170 | =back |
171 | |
4d47b77f |
172 | =head2 Introspection and Construction |
173 | |
174 | =over 4 |
175 | |
176 | =item B<make_metaclass_immutable> |
177 | |
be960ba1 |
178 | The arguments to C<Class::MOP::Class::make_immutable> are passed |
179 | to this method, which |
180 | |
4d47b77f |
181 | =over 4 |
182 | |
183 | =item I<inline_accessors (Bool)> |
184 | |
185 | =item I<inline_constructor (Bool)> |
186 | |
187 | =item I<debug (Bool)> |
188 | |
189 | =item I<constructor_name (Str)> |
190 | |
191 | =back |
192 | |
193 | =item B<is_immutable> |
194 | |
195 | =item B<is_mutable> |
196 | |
197 | =item B<make_immutable> |
198 | |
373a16ae |
199 | =item B<get_mutable_metaclass_name> |
200 | |
4d47b77f |
201 | =back |
202 | |
2243a22b |
203 | =head2 Methods which will die if you touch them. |
204 | |
205 | =over 4 |
206 | |
207 | =item B<add_attribute> |
208 | |
209 | =item B<add_method> |
210 | |
58d75218 |
211 | =item B<add_package_symbol> |
2243a22b |
212 | |
213 | =item B<alias_method> |
214 | |
2243a22b |
215 | =item B<remove_attribute> |
216 | |
217 | =item B<remove_method> |
218 | |
58d75218 |
219 | =item B<remove_package_symbol> |
2243a22b |
220 | |
b6164407 |
221 | =back |
222 | |
223 | =head2 Methods which work slightly differently. |
224 | |
225 | =over 4 |
226 | |
2243a22b |
227 | =item B<superclasses> |
228 | |
b6164407 |
229 | This method becomes read-only in an immutable class. |
230 | |
2243a22b |
231 | =back |
232 | |
233 | =head2 Cached methods |
234 | |
857f87a7 |
235 | =over 4 |
236 | |
2243a22b |
237 | =item B<class_precedence_list> |
238 | |
239 | =item B<compute_all_applicable_attributes> |
240 | |
241 | =item B<get_meta_instance> |
242 | |
ce2ae40f |
243 | =item B<get_method_map> |
244 | |
2243a22b |
245 | =back |
246 | |
1a09d9cc |
247 | =head1 AUTHORS |
857f87a7 |
248 | |
249 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
250 | |
1a09d9cc |
251 | Yuval Kogman E<lt>nothingmuch@woobling.comE<gt> |
252 | |
857f87a7 |
253 | =head1 COPYRIGHT AND LICENSE |
254 | |
255 | Copyright 2006 by Infinity Interactive, Inc. |
256 | |
257 | L<http://www.iinteractive.com> |
258 | |
259 | This library is free software; you can redistribute it and/or modify |
260 | it under the same terms as Perl itself. |
261 | |
262 | =cut |