2 package Class::MOP::Class::Immutable;
8 use Scalar::Util 'blessed', 'looks_like_number';
10 our $VERSION = '0.03';
11 our $AUTHORITY = 'cpan:STEVAN';
13 use base 'Class::MOP::Class';
15 # enforce the meta-circularity here
16 # and hide the Immutable part
20 # if it is not blessed, then someone is asking
21 # for the meta of Class::MOP::Class::Immutable
22 return Class::MOP::Class->initialize($self) unless blessed($self);
23 # otherwise, they are asking for the metaclass
24 # which has been made immutable, which is itself
28 # methods which can *not* be called
40 confess "Cannot call method '$meth' on an immutable instance";
44 sub get_package_symbol {
45 my ($self, $variable) = @_;
46 my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
47 return *{$self->namespace->{$name}}{$type}
48 if exists $self->namespace->{$name};
50 # we have to do this here in order to preserve
51 # perl's autovivification of variables. However
52 # we do cut off direct access to add_package_symbol
54 $self->Class::MOP::Package::add_package_symbol($variable);
58 # superclasses is an accessor, so
59 # it just cannot be changed
62 (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
63 @{$class->get_package_symbol('@ISA')};
69 sub is_immutable { 1 }
71 sub make_immutable { () }
73 sub make_metaclass_immutable {
74 my ($class, $metaclass, %options) = @_;
77 # i really need the // (defined-or) operator here
78 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
79 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
80 $options{constructor_name} = 'new' unless exists $options{constructor_name};
81 $options{debug} = 0 unless exists $options{debug};
83 my $meta_instance = $metaclass->get_meta_instance;
84 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
85 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
86 $metaclass->{'___get_meta_instance'} = $meta_instance;
87 $metaclass->{'___original_class'} = blessed($metaclass);
89 if ($options{inline_accessors}) {
90 foreach my $attr_name ($metaclass->get_attribute_list) {
91 my $attr = $metaclass->get_attribute($attr_name);
92 $attr->install_accessors(1); # inline the accessors
96 if ($options{inline_constructor}) {
97 $metaclass->add_method(
98 $options{constructor_name},
99 $class->_generate_inline_constructor(
102 $metaclass->{'___compute_all_applicable_attributes'}
107 # now cache the method map ...
108 $metaclass->{'___method_map'} = $metaclass->get_method_map;
110 bless $metaclass => $class;
113 sub _generate_inline_constructor {
114 my ($class, $options, $meta_instance, $attrs) = @_;
116 # the %options should also include a both
117 # a call 'initializer' and call 'SUPER::'
118 # options, which should cover approx 90%
119 # of the possible use cases (even if it
120 # requires some adaption on the part of
121 # the author, after all, nothing is free)
122 my $source = 'sub {';
123 $source .= "\n" . 'my ($class, %params) = @_;';
124 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
125 $source .= ";\n" . (join ";\n" => map {
126 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
127 } 0 .. (@$attrs - 1));
128 $source .= ";\n" . 'return $instance';
129 $source .= ";\n" . '}';
130 warn $source if $options->{debug};
131 my $code = eval $source;
132 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
136 sub _generate_slot_initializer {
137 my ($class, $meta_instance, $attrs, $index) = @_;
138 my $attr = $attrs->[$index];
140 if ($attr->has_default) {
142 # default values can either be CODE refs
143 # in which case we need to call them. Or
144 # they can be scalars (strings/numbers)
145 # in which case we can just deal with them
146 # in the code we eval.
147 if ($attr->is_default_a_coderef) {
148 $default = '$attrs->[' . $index . ']->default($instance)';
151 $default = $attrs->[$index]->default;
152 # make sure to quote strings ...
153 unless (looks_like_number($default)) {
154 $default = "'$default'";
158 $meta_instance->inline_set_slot_value(
160 ("'" . $attr->name . "'"),
161 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
167 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
168 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
169 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
170 sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
171 sub get_method_map { (shift)->{'___method_map'} }
181 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
188 __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
189 __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
193 $class->meta->new_object(@_);
202 __PACKAGE__->meta->make_immutable(); # close the class
206 Class::MOP offers many benefits to object oriented development but it
207 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
208 the typical hand coded Perl classes. This is because just about
209 I<everything> is recalculated on the fly, and nothing is cached. The
210 reason this is so, is because Perl itself allows you to modify virtually
211 everything at runtime. Class::MOP::Class::Immutable offers an alternative
214 By making your class immutable, you are promising that you will not
215 modify your inheritence tree or the attributes of any classes in
216 that tree. Since runtime modifications like this are fairly atypical
217 (and usually recomended against), this is not usally a very hard promise
218 to make. For making this promise you are given a wide range of
219 optimization options which bring speed close to (and sometimes above)
220 those of typical hand coded Perl.
228 This will return a B<Class::MOP::Class> instance which is related
233 =head2 Introspection and Construction
237 =item B<make_metaclass_immutable>
239 The arguments to C<Class::MOP::Class::make_immutable> are passed
240 to this method, which
244 =item I<inline_accessors (Bool)>
246 =item I<inline_constructor (Bool)>
248 =item I<debug (Bool)>
250 =item I<constructor_name (Str)>
254 =item B<is_immutable>
258 =item B<make_immutable>
260 =item B<get_mutable_metaclass_name>
264 =head2 Methods which will die if you touch them.
268 =item B<add_attribute>
272 =item B<add_package_symbol>
274 =item B<alias_method>
276 =item B<remove_attribute>
278 =item B<remove_method>
280 =item B<remove_package_symbol>
284 =head2 Methods which work slightly differently.
288 =item B<superclasses>
290 This method becomes read-only in an immutable class.
292 =item B<get_package_symbol>
294 This method must handle package variable autovivification
295 correctly, while still disallowing C<add_package_symbol>.
299 =head2 Cached methods
303 =item B<class_precedence_list>
305 =item B<compute_all_applicable_attributes>
307 =item B<get_meta_instance>
309 =item B<get_method_map>
315 Stevan Little E<lt>stevan@iinteractive.comE<gt>
317 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
319 =head1 COPYRIGHT AND LICENSE
321 Copyright 2006 by Infinity Interactive, Inc.
323 L<http://www.iinteractive.com>
325 This library is free software; you can redistribute it and/or modify
326 it under the same terms as Perl itself.