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 # methods which can *not* be called
27 confess "Cannot call method '$meth' on an immutable instance";
31 sub get_package_symbol {
32 my ($self, $variable) = @_;
33 my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
34 return *{$self->namespace->{$name}}{$type}
35 if exists $self->namespace->{$name};
37 # we have to do this here in order to preserve
38 # perl's autovivification of variables. However
39 # we do cut off direct access to add_package_symbol
41 $self->Class::MOP::Package::add_package_symbol($variable);
45 # superclasses is an accessor, so
46 # it just cannot be changed
49 (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
50 @{$class->get_package_symbol('@ISA')};
56 sub is_immutable { 1 }
58 sub make_immutable { () }
60 sub make_metaclass_immutable {
61 my ($class, $metaclass, %options) = @_;
64 # i really need the // (defined-or) operator here
65 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
66 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
67 $options{constructor_name} = 'new' unless exists $options{constructor_name};
68 $options{debug} = 0 unless exists $options{debug};
70 my $meta_instance = $metaclass->get_meta_instance;
71 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
72 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
73 $metaclass->{'___get_meta_instance'} = $meta_instance;
74 $metaclass->{'___original_class'} = blessed($metaclass);
76 if ($options{inline_accessors}) {
77 foreach my $attr_name ($metaclass->get_attribute_list) {
78 my $attr = $metaclass->get_attribute($attr_name);
79 $attr->install_accessors(1); # inline the accessors
83 if ($options{inline_constructor}) {
84 $metaclass->add_method(
85 $options{constructor_name},
86 $class->_generate_inline_constructor(
89 $metaclass->{'___compute_all_applicable_attributes'}
94 # now cache the method map ...
95 $metaclass->{'___method_map'} = $metaclass->get_method_map;
97 bless $metaclass => $class;
100 sub _generate_inline_constructor {
101 my ($class, $options, $meta_instance, $attrs) = @_;
103 # the %options should also include a both
104 # a call 'initializer' and call 'SUPER::'
105 # options, which should cover approx 90%
106 # of the possible use cases (even if it
107 # requires some adaption on the part of
108 # the author, after all, nothing is free)
109 my $source = 'sub {';
110 $source .= "\n" . 'my ($class, %params) = @_;';
111 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
112 $source .= ";\n" . (join ";\n" => map {
113 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
114 } 0 .. (@$attrs - 1));
115 $source .= ";\n" . 'return $instance';
116 $source .= ";\n" . '}';
117 warn $source if $options->{debug};
118 my $code = eval $source;
119 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
123 sub _generate_slot_initializer {
124 my ($class, $meta_instance, $attrs, $index) = @_;
125 my $attr = $attrs->[$index];
127 if ($attr->has_default) {
129 # default values can either be CODE refs
130 # in which case we need to call them. Or
131 # they can be scalars (strings/numbers)
132 # in which case we can just deal with them
133 # in the code we eval.
134 if ($attr->is_default_a_coderef) {
135 $default = '$attrs->[' . $index . ']->default($instance)';
138 $default = $attrs->[$index]->default;
139 # make sure to quote strings ...
140 unless (looks_like_number($default)) {
141 $default = "'$default'";
145 $meta_instance->inline_set_slot_value(
147 ("'" . $attr->name . "'"),
148 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
154 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
155 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
156 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
157 sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
158 sub get_method_map { (shift)->{'___method_map'} }
168 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
175 __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
176 __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
180 $class->meta->new_object(@_);
189 __PACKAGE__->meta->make_immutable(); # close the class
193 Class::MOP offers many benefits to object oriented development but it
194 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
195 the typical hand coded Perl classes. This is because just about
196 I<everything> is recalculated on the fly, and nothing is cached. The
197 reason this is so, is because Perl itself allows you to modify virtually
198 everything at runtime. Class::MOP::Class::Immutable offers an alternative
201 By making your class immutable, you are promising that you will not
202 modify your inheritence tree or the attributes of any classes in
203 that tree. Since runtime modifications like this are fairly atypical
204 (and usually recomended against), this is not usally a very hard promise
205 to make. For making this promise you are given a wide range of
206 optimization options which bring speed close to (and sometimes above)
207 those of typical hand coded Perl.
215 This will return a B<Class::MOP::Class> instance which is related
220 =head2 Introspection and Construction
224 =item B<make_metaclass_immutable>
226 The arguments to C<Class::MOP::Class::make_immutable> are passed
227 to this method, which
231 =item I<inline_accessors (Bool)>
233 =item I<inline_constructor (Bool)>
235 =item I<debug (Bool)>
237 =item I<constructor_name (Str)>
241 =item B<is_immutable>
245 =item B<make_immutable>
247 =item B<get_mutable_metaclass_name>
251 =head2 Methods which will die if you touch them.
255 =item B<add_attribute>
259 =item B<add_package_symbol>
261 =item B<alias_method>
263 =item B<remove_attribute>
265 =item B<remove_method>
267 =item B<remove_package_symbol>
271 =head2 Methods which work slightly differently.
275 =item B<superclasses>
277 This method becomes read-only in an immutable class.
279 =item B<get_package_symbol>
281 This method must handle package variable autovivification
282 correctly, while still disallowing C<add_package_symbol>.
286 =head2 Cached methods
290 =item B<class_precedence_list>
292 =item B<compute_all_applicable_attributes>
294 =item B<get_meta_instance>
296 =item B<get_method_map>
302 Stevan Little E<lt>stevan@iinteractive.comE<gt>
304 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
306 =head1 COPYRIGHT AND LICENSE
308 Copyright 2006 by Infinity Interactive, Inc.
310 L<http://www.iinteractive.com>
312 This library is free software; you can redistribute it and/or modify
313 it under the same terms as Perl itself.