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) = @_;
49 # i really need the // (defined-or) operator here
50 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
51 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
52 $options{constructor_name} = 'new' unless exists $options{constructor_name};
53 $options{debug} = 0 unless exists $options{debug};
55 my $meta_instance = $metaclass->get_meta_instance;
56 $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
57 $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
58 $metaclass->{'___get_meta_instance'} = $meta_instance;
59 $metaclass->{'___original_class'} = blessed($metaclass);
61 if ($options{inline_accessors}) {
62 foreach my $attr_name ($metaclass->get_attribute_list) {
63 my $attr = $metaclass->get_attribute($attr_name);
64 $attr->install_accessors(1); # inline the accessors
68 if ($options{inline_constructor}) {
69 $metaclass->add_method(
70 $options{constructor_name},
71 $class->_generate_inline_constructor(
74 $metaclass->{'___compute_all_applicable_attributes'}
79 bless $metaclass => $class;
82 sub _generate_inline_constructor {
83 my ($class, $options, $meta_instance, $attrs) = @_;
85 # the %options should also include a both
86 # a call 'initializer' and call 'SUPER::'
87 # options, which should cover approx 90%
88 # of the possible use cases (even if it
89 # requires some adaption on the part of
90 # the author, after all, nothing is free)
92 $source .= "\n" . 'my ($class, %params) = @_;';
93 $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
94 $source .= ";\n" . (join ";\n" => map {
95 $class->_generate_slot_initializer($meta_instance, $attrs, $_)
96 } 0 .. (@$attrs - 1));
97 $source .= ";\n" . 'return $instance';
98 $source .= ";\n" . '}';
99 warn $source if $options->{debug};
100 my $code = eval $source;
101 confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
105 sub _generate_slot_initializer {
106 my ($class, $meta_instance, $attrs, $index) = @_;
107 my $attr = $attrs->[$index];
109 if ($attr->has_default) {
110 if ($attr->is_default_a_coderef) {
111 $default = '$attrs->[' . $index . ']->default($instance)';
114 $default = $attrs->[$index]->default;
115 unless (looks_like_number($default)) {
116 $default = "'$default'";
119 # we should use Data::Dumper to
120 # output any ref's here, obviously
121 # we cannot handle Scalar refs, but
122 # it should work for Array and Hash
126 $meta_instance->inline_set_slot_value(
129 ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
135 sub get_meta_instance { (shift)->{'___get_meta_instance'} }
136 sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
137 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
147 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
153 Class::MOP offers many benefits to object oriented development but it
154 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
155 the typical hand coded Perl classes. This is because just about
156 I<everything> is recalculated on the fly, and nothing is cached. The
157 reason this is so, is because Perl itself allows you to modify virtually
158 everything at runtime. Class::MOP::Class::Immutable offers an alternative
161 By making your class immutable, you are promising that you will not
162 modify your inheritence tree or the attributes of any classes in
163 that tree. Since runtime modifications like this are fairly atypical
164 (and usually recomended against), this is not usally a very hard promise
165 to make. For making this promise you are given a wide range of
166 optimization options which bring speed close to (and sometimes above)
167 those of typical hand coded Perl.
175 This will return a B<Class::MOP::Class> instance which is related
180 =head2 Introspection and Construction
184 =item B<make_metaclass_immutable>
188 =item I<inline_accessors (Bool)>
190 =item I<inline_constructor (Bool)>
192 =item I<debug (Bool)>
194 =item I<constructor_name (Str)>
198 =item B<is_immutable>
202 =item B<make_immutable>
206 =head2 Methods which will die if you touch them.
210 =item B<add_attribute>
214 =item B<add_package_symbol>
216 =item B<alias_method>
218 =item B<reinitialize>
220 =item B<remove_attribute>
222 =item B<remove_method>
224 =item B<remove_package_symbol>
226 =item B<superclasses>
230 =head2 Cached methods
234 =item B<class_precedence_list>
236 =item B<compute_all_applicable_attributes>
238 =item B<get_meta_instance>
244 Stevan Little E<lt>stevan@iinteractive.comE<gt>
246 =head1 COPYRIGHT AND LICENSE
248 Copyright 2006 by Infinity Interactive, Inc.
250 L<http://www.iinteractive.com>
252 This library is free software; you can redistribute it and/or modify
253 it under the same terms as Perl itself.