2 package Class::MOP::Class::Immutable;
8 use Scalar::Util 'blessed', 'looks_like_number';
10 our $VERSION = '0.01';
12 use base 'Class::MOP::Class';
14 # methods which can *not* be called
16 sub reinitialize { confess 'Cannot call method "reinitialize" on an immutable instance' }
18 sub add_method { confess 'Cannot call method "add_method" on an immutable instance' }
19 sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' }
20 sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' }
22 sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' }
23 sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' }
25 sub add_package_symbol { confess 'Cannot call method "add_package_symbol" on an immutable instance' }
26 sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" on an immutable instance' }
29 # superclasses is an accessor, so
30 # it just cannot be changed
33 (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
35 @{$class->name . '::ISA'};
41 sub is_immutable { 1 }
43 sub make_immutable { () }
45 sub make_metaclass_immutable {
46 my ($class, $metaclass, %options) = @_;
48 $options{inline_accessors} ||= 1;
49 $options{inline_constructor} ||= 1;
50 $options{constructor_name} ||= 'new';
52 my $meta_instance = $metaclass->get_meta_instance;
53 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
54 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
55 $metaclass->{'___get_meta_instance'} = $meta_instance;
56 $metaclass->{'___original_class'} = blessed($metaclass);
58 if ($options{inline_accessors}) {
59 foreach my $attr_name ($metaclass->get_attribute_list) {
60 my $attr = $metaclass->get_attribute($attr_name);
61 $attr->install_accessors(1); # inline the accessors
65 if ($options{inline_constructor}) {
66 $metaclass->add_method(
67 $options{constructor_name},
68 $class->_generate_inline_constructor(
71 $metaclass->{'___compute_all_applicable_attributes'}
76 bless $metaclass => $class;
79 sub _generate_inline_constructor {
80 my ($class, $options, $meta_instance, $attrs) = @_;
82 # the %options should also include a both
83 # a call 'initializer' and call 'SUPER::'
84 # options, which should cover approx 90%
85 # of the possible use cases (even if it
86 # requires some adaption on the part of
87 # the author, after all, nothing is free)
89 $source .= "\n" . 'my ($class, %params) = @_;';
90 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
91 $source .= ";\n" . (join ";\n" => map {
92 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
93 } 0 .. (@$attrs - 1));
94 $source .= ";\n" . 'return $instance';
95 $source .= ";\n" . '}';
96 warn $source if $options->{debug};
97 my $code = eval $source;
98 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
102 sub _generate_slot_initializer {
103 my ($class, $meta_instance, $attrs, $index) = @_;
104 my $attr = $attrs->[$index];
106 if ($attr->has_default) {
107 if ($attr->is_default_a_coderef) {
108 $default = '$attrs->[' . $index . ']->default($instance)';
111 $default = $attrs->[$index]->default;
112 unless (looks_like_number($default)) {
113 $default = "'$default'";
116 # we should use Data::Dumper to
117 # output any ref's here, obviously
118 # we cannot handle Scalar refs, but
119 # it should work for Array and Hash
123 $meta_instance->inline_set_slot_value(
126 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
132 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
133 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
134 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
144 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
150 Class::MOP offers many benefits to object oriented development but it
151 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
152 the typical hand coded Perl classes. This is because just about
153 I<everything> is recalculated on the fly, and nothing is cached. The
154 reason this is so, is because Perl itself allows you to modify virtually
155 everything at runtime. Class::MOP::Class::Immutable offers an alternative
158 By making your class immutable, you are promising that you will not
159 modify your inheritence tree or the attributes of any classes in
160 that tree. Since runtime modifications like this are fairly atypical
161 (and usually recomended against), this is not usally a very hard promise
162 to make. For making this promise you are given a wide range of
163 optimization options which bring speed close to (and sometimes above)
164 those of typical hand coded Perl.
172 This will return a B<Class::MOP::Class> instance which is related
177 =head2 Methods which will die if you touch them.
181 =item B<add_attribute>
185 =item B<add_package_symbol>
187 =item B<alias_method>
189 =item B<reinitialize>
191 =item B<remove_attribute>
193 =item B<remove_method>
195 =item B<remove_package_symbol>
197 =item B<superclasses>
201 =head2 Cached methods
205 =item B<class_precedence_list>
207 =item B<compute_all_applicable_attributes>
209 =item B<get_meta_instance>
213 =head2 Introspection and Construction
217 =item B<is_immutable>
221 =item B<make_immutable>
223 =item B<make_metaclass_immutable>
229 Stevan Little E<lt>stevan@iinteractive.comE<gt>
231 =head1 COPYRIGHT AND LICENSE
233 Copyright 2006 by Infinity Interactive, Inc.
235 L<http://www.iinteractive.com>
237 This library is free software; you can redistribute it and/or modify
238 it under the same terms as Perl itself.