2 package Class::MOP::Class::Immutable;
8 use Scalar::Util 'blessed', 'looks_like_number';
10 our $VERSION = '0.02';
11 our $AUTHORITY = 'cpan:STEVAN';
13 use base 'Class::MOP::Class';
15 # methods which can *not* be called
17 sub add_method { confess 'Cannot call method "add_method" on an immutable instance' }
18 sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' }
19 sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' }
21 sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' }
22 sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' }
24 sub add_package_symbol { confess 'Cannot call method "add_package_symbol" on an immutable instance' }
25 sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" on an immutable instance' }
27 sub get_package_symbol {
28 my ($self, $variable) = @_;
29 my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
30 return *{$self->namespace->{$name}}{$type}
31 if exists $self->namespace->{$name};
33 # we have to do this here in order to preserve
34 # perl's autovivification of variables. However
35 # we do cut off direct access to add_package_symbol
37 $self->Class::MOP::Package::add_package_symbol($variable);
41 # superclasses is an accessor, so
42 # it just cannot be changed
45 (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
46 @{$class->get_package_symbol('@ISA')};
52 sub is_immutable { 1 }
54 sub make_immutable { () }
56 sub make_metaclass_immutable {
57 my ($class, $metaclass, %options) = @_;
60 # i really need the // (defined-or) operator here
61 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
62 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
63 $options{constructor_name} = 'new' unless exists $options{constructor_name};
64 $options{debug} = 0 unless exists $options{debug};
66 my $meta_instance = $metaclass->get_meta_instance;
67 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
68 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
69 $metaclass->{'___get_meta_instance'} = $meta_instance;
70 $metaclass->{'___original_class'} = blessed($metaclass);
72 if ($options{inline_accessors}) {
73 foreach my $attr_name ($metaclass->get_attribute_list) {
74 my $attr = $metaclass->get_attribute($attr_name);
75 $attr->install_accessors(1); # inline the accessors
79 if ($options{inline_constructor}) {
80 $metaclass->add_method(
81 $options{constructor_name},
82 $class->_generate_inline_constructor(
85 $metaclass->{'___compute_all_applicable_attributes'}
90 # now cache the method map ...
91 $metaclass->{'___method_map'} = $metaclass->get_method_map;
93 bless $metaclass => $class;
96 sub _generate_inline_constructor {
97 my ($class, $options, $meta_instance, $attrs) = @_;
99 # the %options should also include a both
100 # a call 'initializer' and call 'SUPER::'
101 # options, which should cover approx 90%
102 # of the possible use cases (even if it
103 # requires some adaption on the part of
104 # the author, after all, nothing is free)
105 my $source = 'sub {';
106 $source .= "\n" . 'my ($class, %params) = @_;';
107 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
108 $source .= ";\n" . (join ";\n" => map {
109 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
110 } 0 .. (@$attrs - 1));
111 $source .= ";\n" . 'return $instance';
112 $source .= ";\n" . '}';
113 warn $source if $options->{debug};
114 my $code = eval $source;
115 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
119 sub _generate_slot_initializer {
120 my ($class, $meta_instance, $attrs, $index) = @_;
121 my $attr = $attrs->[$index];
123 if ($attr->has_default) {
125 # default values can either be CODE refs
126 # in which case we need to call them. Or
127 # they can be scalars (strings/numbers)
128 # in which case we can just deal with them
129 # in the code we eval.
130 if ($attr->is_default_a_coderef) {
131 $default = '$attrs->[' . $index . ']->default($instance)';
134 $default = $attrs->[$index]->default;
135 # make sure to quote strings ...
136 unless (looks_like_number($default)) {
137 $default = "'$default'";
141 $meta_instance->inline_set_slot_value(
143 ("'" . $attr->name . "'"),
144 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
150 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
151 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
152 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
153 sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
154 sub get_method_map { (shift)->{'___method_map'} }
164 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
171 __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
172 __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
176 $class->meta->new_object(@_);
185 __PACKAGE__->meta->make_immutable(); # close the class
189 Class::MOP offers many benefits to object oriented development but it
190 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
191 the typical hand coded Perl classes. This is because just about
192 I<everything> is recalculated on the fly, and nothing is cached. The
193 reason this is so, is because Perl itself allows you to modify virtually
194 everything at runtime. Class::MOP::Class::Immutable offers an alternative
197 By making your class immutable, you are promising that you will not
198 modify your inheritence tree or the attributes of any classes in
199 that tree. Since runtime modifications like this are fairly atypical
200 (and usually recomended against), this is not usally a very hard promise
201 to make. For making this promise you are given a wide range of
202 optimization options which bring speed close to (and sometimes above)
203 those of typical hand coded Perl.
211 This will return a B<Class::MOP::Class> instance which is related
216 =head2 Introspection and Construction
220 =item B<make_metaclass_immutable>
222 The arguments to C<Class::MOP::Class::make_immutable> are passed
223 to this method, which
227 =item I<inline_accessors (Bool)>
229 =item I<inline_constructor (Bool)>
231 =item I<debug (Bool)>
233 =item I<constructor_name (Str)>
237 =item B<is_immutable>
241 =item B<make_immutable>
243 =item B<get_mutable_metaclass_name>
247 =head2 Methods which will die if you touch them.
251 =item B<add_attribute>
255 =item B<add_package_symbol>
257 =item B<alias_method>
259 =item B<remove_attribute>
261 =item B<remove_method>
263 =item B<remove_package_symbol>
267 =head2 Methods which work slightly differently.
271 =item B<superclasses>
273 This method becomes read-only in an immutable class.
275 =item B<get_package_symbol>
277 This method must handle package variable autovivification
278 correctly, while still disallowing C<add_package_symbol>.
282 =head2 Cached methods
286 =item B<class_precedence_list>
288 =item B<compute_all_applicable_attributes>
290 =item B<get_meta_instance>
292 =item B<get_method_map>
298 Stevan Little E<lt>stevan@iinteractive.comE<gt>
300 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
302 =head1 COPYRIGHT AND LICENSE
304 Copyright 2006 by Infinity Interactive, Inc.
306 L<http://www.iinteractive.com>
308 This library is free software; you can redistribute it and/or modify
309 it under the same terms as Perl itself.