2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.64';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use base 'Class::MOP::Object';
18 my ($class, $metaclass, $options) = @_;
21 '$!metaclass' => $metaclass,
22 '%!options' => $options,
23 '$!immutable_metaclass' => undef,
27 # we initialize the immutable
28 # version of the metaclass here
29 $self->create_immutable_metaclass;
34 sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
35 sub metaclass { (shift)->{'$!metaclass'} }
36 sub options { (shift)->{'%!options'} }
38 sub create_immutable_metaclass {
42 # The immutable version of the
43 # metaclass is just a anon-class
44 # which shadows the methods
46 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
47 superclasses => [ blessed($self->metaclass) ],
48 methods => $self->create_methods_for_immutable_metaclass,
53 my %DEFAULT_METHODS = (
54 # I don't really understand this, but removing it breaks tests (groditi)
57 # if it is not blessed, then someone is asking
58 # for the meta of Class::MOP::Immutable
59 return Class::MOP::Class->initialize($self) unless blessed($self);
60 # otherwise, they are asking for the metaclass
61 # which has been made immutable, which is itself
64 is_mutable => sub { 0 },
65 is_immutable => sub { 1 },
66 make_immutable => sub { () },
70 # this will actually convert the
71 # existing metaclass to an immutable
73 sub make_metaclass_immutable {
74 my ($self, $metaclass, $options) = @_;
77 inline_accessors => 1,
78 inline_constructor => 1,
79 inline_destructor => 0,
80 constructor_name => 'new',
85 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
87 if ($options{inline_accessors}) {
88 foreach my $attr_name ($metaclass->get_attribute_list) {
89 # inline the accessors
90 $metaclass->get_attribute($attr_name)
91 ->install_accessors(1);
95 if ($options{inline_constructor}) {
96 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
97 $metaclass->add_method(
98 $options{constructor_name},
99 $constructor_class->new(
100 options => \%options,
101 metaclass => $metaclass,
103 package_name => $metaclass->name,
104 name => $options{constructor_name}
106 ) unless $metaclass->has_method($options{constructor_name});
109 if ($options{inline_destructor}) {
110 (exists $options{destructor_class})
111 || confess "The 'inline_destructor' option is present, but "
112 . "no destructor class was specified";
114 my $destructor_class = $options{destructor_class};
117 # we allow the destructor to determine
118 # if it is needed or not before we actually
119 # create the destructor too
121 if ($destructor_class->is_needed($metaclass)) {
122 my $destructor = $destructor_class->new(
123 options => \%options,
124 metaclass => $metaclass,
125 package_name => $metaclass->name,
129 $metaclass->add_method('DESTROY' => $destructor)
131 # we allow the destructor to determine
132 # if it is needed or not, it can perform
133 # all sorts of checks because it has the
135 if $destructor->is_needed;
139 my $memoized_methods = $self->options->{memoize};
140 foreach my $method_name (keys %{$memoized_methods}) {
141 my $type = $memoized_methods->{$method_name};
143 ($metaclass->can($method_name))
144 || confess "Could not find the method '$method_name' in " . $metaclass->name;
146 if ($type eq 'ARRAY') {
147 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
149 elsif ($type eq 'HASH') {
150 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
152 elsif ($type eq 'SCALAR') {
153 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
157 $metaclass->{'___original_class'} = blessed($metaclass);
158 bless $metaclass => $self->immutable_metaclass->name;
161 sub make_metaclass_mutable {
162 my ($self, $immutable, $options) = @_;
164 my %options = %$options;
166 my $original_class = $immutable->get_mutable_metaclass_name;
167 delete $immutable->{'___original_class'} ;
168 bless $immutable => $original_class;
170 my $memoized_methods = $self->options->{memoize};
171 foreach my $method_name (keys %{$memoized_methods}) {
172 my $type = $memoized_methods->{$method_name};
174 ($immutable->can($method_name))
175 || confess "Could not find the method '$method_name' in " . $immutable->name;
176 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
177 delete $immutable->{'___' . $method_name};
181 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
182 $immutable->remove_method('DESTROY')
183 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
187 # 14:01 <@stevan> nah,. you shouldnt
188 # 14:01 <@stevan> they are just inlined
189 # 14:01 <@stevan> which is the default in Moose anyway
190 # 14:02 <@stevan> and adding new attributes will just DWIM
191 # 14:02 <@stevan> and you really cant change an attribute anyway
192 # if ($options{inline_accessors}) {
193 # foreach my $attr_name ($immutable->get_attribute_list) {
194 # my $attr = $immutable->get_attribute($attr_name);
195 # $attr->remove_accessors;
196 # $attr->install_accessors(0);
200 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
201 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
202 # 14:27 <@stevan> so I am not worried
203 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
204 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
205 $immutable->remove_method( $options{constructor_name} )
206 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
210 sub create_methods_for_immutable_metaclass {
213 my %methods = %DEFAULT_METHODS;
215 foreach my $read_only_method (@{$self->options->{read_only}}) {
216 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
219 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
221 $methods{$read_only_method} = sub {
222 confess "This method is read-only" if scalar @_ > 1;
223 goto &{$method->body}
227 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
228 $methods{$cannot_call_method} = sub {
229 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
233 my $memoized_methods = $self->options->{memoize};
234 foreach my $method_name (keys %{$memoized_methods}) {
235 my $type = $memoized_methods->{$method_name};
236 if ($type eq 'ARRAY') {
237 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
239 elsif ($type eq 'HASH') {
240 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
242 elsif ($type eq 'SCALAR') {
243 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
247 my $wrapped_methods = $self->options->{wrapped};
249 foreach my $method_name (keys %{ $wrapped_methods }) {
250 my $method = $self->metaclass->meta->find_method_by_name($method_name);
253 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
255 my $wrapper = $wrapped_methods->{$method_name};
257 $methods{$method_name} = sub { $wrapper->($method, @_) };
260 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
262 $methods{immutable_transformer} = sub { $self };
275 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
279 use Class::MOP::Immutable;
281 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
282 read_only => [qw/superclasses/],
290 remove_package_symbol
293 class_precedence_list => 'ARRAY',
294 compute_all_applicable_attributes => 'ARRAY',
295 get_meta_instance => 'SCALAR',
296 get_method_map => 'SCALAR',
300 $immutable_metaclass->make_metaclass_immutable(@_)
304 This is basically a module for applying a transformation on a given
305 metaclass. Current features include making methods read-only,
306 making methods un-callable and memoizing methods (in a type specific
309 This module is not for the feint of heart, it does some whacky things
310 to the metaclass in order to make it immutable. If you are just curious,
311 I suggest you turn back now, there is nothing to see here.
317 =item B<new ($metaclass, \%options)>
319 Given a C<$metaclass> and a set of C<%options> this module will
320 prepare an immutable version of the C<$metaclass>, which can then
321 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
326 Returns the options HASH set in C<new>.
330 Returns the metaclass set in C<new>.
332 =item B<immutable_metaclass>
334 Returns the immutable metaclass created within C<new>.
340 =item B<create_immutable_metaclass>
342 This will create the immutable version of the C<$metaclass>, but will
343 not actually change the original metaclass.
345 =item B<create_methods_for_immutable_metaclass>
347 This will create all the methods for the immutable metaclass based
348 on the C<%options> passed into C<new>.
350 =item B<make_metaclass_immutable (%options)>
352 This will actually change the C<$metaclass> into the immutable version.
354 =item B<make_metaclass_mutable (%options)>
356 This will change the C<$metaclass> into the mutable version by reversing
357 the immutable process. C<%options> should be the same options that were
358 given to make_metaclass_immutable.
364 Stevan Little E<lt>stevan@iinteractive.comE<gt>
366 =head1 COPYRIGHT AND LICENSE
368 Copyright 2006-2008 by Infinity Interactive, Inc.
370 L<http://www.iinteractive.com>
372 This library is free software; you can redistribute it and/or modify
373 it under the same terms as Perl itself.