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 add_method { confess 'Cannot call method "add_method" on an immutable instance' }
17 sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' }
18 sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' }
20 sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' }
21 sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' }
23 sub add_package_symbol { confess 'Cannot call method "add_package_symbol" on an immutable instance' }
24 sub remove_package_symbol { confess 'Cannot call method "remove_package_symbol" on an immutable instance' }
27 # superclasses is an accessor, so
28 # it just cannot be changed
31 (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
33 @{$class->name . '::ISA'};
39 sub is_immutable { 1 }
41 sub make_immutable { () }
43 sub make_metaclass_immutable {
44 my ($class, $metaclass, %options) = @_;
47 # i really need the // (defined-or) operator here
48 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
49 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
50 $options{constructor_name} = 'new' unless exists $options{constructor_name};
51 $options{debug} = 0 unless exists $options{debug};
53 my $meta_instance = $metaclass->get_meta_instance;
54 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
55 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
56 $metaclass->{'___get_meta_instance'} = $meta_instance;
57 $metaclass->{'___original_class'} = blessed($metaclass);
59 if ($options{inline_accessors}) {
60 foreach my $attr_name ($metaclass->get_attribute_list) {
61 my $attr = $metaclass->get_attribute($attr_name);
62 $attr->install_accessors(1); # inline the accessors
66 if ($options{inline_constructor}) {
67 $metaclass->add_method(
68 $options{constructor_name},
69 $class->_generate_inline_constructor(
72 $metaclass->{'___compute_all_applicable_attributes'}
77 bless $metaclass => $class;
80 sub _generate_inline_constructor {
81 my ($class, $options, $meta_instance, $attrs) = @_;
83 # the %options should also include a both
84 # a call 'initializer' and call 'SUPER::'
85 # options, which should cover approx 90%
86 # of the possible use cases (even if it
87 # requires some adaption on the part of
88 # the author, after all, nothing is free)
90 $source .= "\n" . 'my ($class, %params) = @_;';
91 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
92 $source .= ";\n" . (join ";\n" => map {
93 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
94 } 0 .. (@$attrs - 1));
95 $source .= ";\n" . 'return $instance';
96 $source .= ";\n" . '}';
97 warn $source if $options->{debug};
98 my $code = eval $source;
99 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
103 sub _generate_slot_initializer {
104 my ($class, $meta_instance, $attrs, $index) = @_;
105 my $attr = $attrs->[$index];
107 if ($attr->has_default) {
108 if ($attr->is_default_a_coderef) {
109 $default = '$attrs->[' . $index . ']->default($instance)';
112 $default = $attrs->[$index]->default;
113 unless (looks_like_number($default)) {
114 $default = "'$default'";
117 # we should use Data::Dumper to
118 # output any ref's here, obviously
119 # we cannot handle Scalar refs, but
120 # it should work for Array and Hash
124 $meta_instance->inline_set_slot_value(
126 ("'" . $attr->name . "'"),
127 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
133 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
134 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
135 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
136 sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
146 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
153 __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
154 __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
158 $class->meta->new_object(@_);
167 __PACKAGE__->meta->make_immutable(); # close the class
171 Class::MOP offers many benefits to object oriented development but it
172 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
173 the typical hand coded Perl classes. This is because just about
174 I<everything> is recalculated on the fly, and nothing is cached. The
175 reason this is so, is because Perl itself allows you to modify virtually
176 everything at runtime. Class::MOP::Class::Immutable offers an alternative
179 By making your class immutable, you are promising that you will not
180 modify your inheritence tree or the attributes of any classes in
181 that tree. Since runtime modifications like this are fairly atypical
182 (and usually recomended against), this is not usally a very hard promise
183 to make. For making this promise you are given a wide range of
184 optimization options which bring speed close to (and sometimes above)
185 those of typical hand coded Perl.
193 This will return a B<Class::MOP::Class> instance which is related
198 =head2 Introspection and Construction
202 =item B<make_metaclass_immutable>
204 The arguments to C<Class::MOP::Class::make_immutable> are passed
205 to this method, which
209 =item I<inline_accessors (Bool)>
211 =item I<inline_constructor (Bool)>
213 =item I<debug (Bool)>
215 =item I<constructor_name (Str)>
219 =item B<is_immutable>
223 =item B<make_immutable>
225 =item B<get_mutable_metaclass_name>
229 =head2 Methods which will die if you touch them.
233 =item B<add_attribute>
237 =item B<add_package_symbol>
239 =item B<alias_method>
241 =item B<remove_attribute>
243 =item B<remove_method>
245 =item B<remove_package_symbol>
247 =item B<superclasses>
251 =head2 Cached methods
255 =item B<class_precedence_list>
257 =item B<compute_all_applicable_attributes>
259 =item B<get_meta_instance>
265 Stevan Little E<lt>stevan@iinteractive.comE<gt>
267 =head1 COPYRIGHT AND LICENSE
269 Copyright 2006 by Infinity Interactive, Inc.
271 L<http://www.iinteractive.com>
273 This library is free software; you can redistribute it and/or modify
274 it under the same terms as Perl itself.