2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.65';
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
62 # except in the cases where it is a metaclass itself
63 # that has been made immutable and for that we need
65 if ($self->isa('Class::MOP::Class')) {
66 return $self->{'___original_class'}->meta;
72 is_mutable => sub { 0 },
73 is_immutable => sub { 1 },
74 make_immutable => sub { () },
78 # this will actually convert the
79 # existing metaclass to an immutable
81 sub make_metaclass_immutable {
82 my ($self, $metaclass, $options) = @_;
85 inline_accessors => 1,
86 inline_constructor => 1,
87 inline_destructor => 0,
88 constructor_name => 'new',
93 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
95 if ($options{inline_accessors}) {
96 foreach my $attr_name ($metaclass->get_attribute_list) {
97 # inline the accessors
98 $metaclass->get_attribute($attr_name)
99 ->install_accessors(1);
103 if ($options{inline_constructor}) {
104 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
105 $metaclass->add_method(
106 $options{constructor_name},
107 $constructor_class->new(
108 options => \%options,
109 metaclass => $metaclass,
111 package_name => $metaclass->name,
112 name => $options{constructor_name}
114 ) unless $metaclass->has_method($options{constructor_name});
117 if ($options{inline_destructor}) {
118 (exists $options{destructor_class})
119 || confess "The 'inline_destructor' option is present, but "
120 . "no destructor class was specified";
122 my $destructor_class = $options{destructor_class};
125 # we allow the destructor to determine
126 # if it is needed or not before we actually
127 # create the destructor too
129 if ($destructor_class->is_needed($metaclass)) {
130 my $destructor = $destructor_class->new(
131 options => \%options,
132 metaclass => $metaclass,
133 package_name => $metaclass->name,
137 $metaclass->add_method('DESTROY' => $destructor)
139 # we allow the destructor to determine
140 # if it is needed or not, it can perform
141 # all sorts of checks because it has the
143 if $destructor->is_needed;
147 my $memoized_methods = $self->options->{memoize};
148 foreach my $method_name (keys %{$memoized_methods}) {
149 my $type = $memoized_methods->{$method_name};
151 ($metaclass->can($method_name))
152 || confess "Could not find the method '$method_name' in " . $metaclass->name;
154 if ($type eq 'ARRAY') {
155 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
157 elsif ($type eq 'HASH') {
158 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
160 elsif ($type eq 'SCALAR') {
161 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
165 $metaclass->{'___original_class'} = blessed($metaclass);
166 bless $metaclass => $self->immutable_metaclass->name;
169 sub make_metaclass_mutable {
170 my ($self, $immutable, $options) = @_;
172 my %options = %$options;
174 my $original_class = $immutable->get_mutable_metaclass_name;
175 delete $immutable->{'___original_class'} ;
176 bless $immutable => $original_class;
178 my $memoized_methods = $self->options->{memoize};
179 foreach my $method_name (keys %{$memoized_methods}) {
180 my $type = $memoized_methods->{$method_name};
182 ($immutable->can($method_name))
183 || confess "Could not find the method '$method_name' in " . $immutable->name;
184 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
185 delete $immutable->{'___' . $method_name};
189 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
190 $immutable->remove_method('DESTROY')
191 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
195 # 14:01 <@stevan> nah,. you shouldnt
196 # 14:01 <@stevan> they are just inlined
197 # 14:01 <@stevan> which is the default in Moose anyway
198 # 14:02 <@stevan> and adding new attributes will just DWIM
199 # 14:02 <@stevan> and you really cant change an attribute anyway
200 # if ($options{inline_accessors}) {
201 # foreach my $attr_name ($immutable->get_attribute_list) {
202 # my $attr = $immutable->get_attribute($attr_name);
203 # $attr->remove_accessors;
204 # $attr->install_accessors(0);
208 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
209 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
210 # 14:27 <@stevan> so I am not worried
211 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
212 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
213 $immutable->remove_method( $options{constructor_name} )
214 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
218 sub create_methods_for_immutable_metaclass {
221 my %methods = %DEFAULT_METHODS;
223 foreach my $read_only_method (@{$self->options->{read_only}}) {
224 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
227 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
229 $methods{$read_only_method} = sub {
230 confess "This method is read-only" if scalar @_ > 1;
231 goto &{$method->body}
235 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
236 $methods{$cannot_call_method} = sub {
237 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
241 my $memoized_methods = $self->options->{memoize};
242 foreach my $method_name (keys %{$memoized_methods}) {
243 my $type = $memoized_methods->{$method_name};
244 if ($type eq 'ARRAY') {
245 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
247 elsif ($type eq 'HASH') {
248 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
250 elsif ($type eq 'SCALAR') {
251 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
255 my $wrapped_methods = $self->options->{wrapped};
257 foreach my $method_name (keys %{ $wrapped_methods }) {
258 my $method = $self->metaclass->meta->find_method_by_name($method_name);
261 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
263 my $wrapper = $wrapped_methods->{$method_name};
265 $methods{$method_name} = sub { $wrapper->($method, @_) };
268 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
270 $methods{immutable_transformer} = sub { $self };
283 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
287 use Class::MOP::Immutable;
289 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
290 read_only => [qw/superclasses/],
298 remove_package_symbol
301 class_precedence_list => 'ARRAY',
302 compute_all_applicable_attributes => 'ARRAY',
303 get_meta_instance => 'SCALAR',
304 get_method_map => 'SCALAR',
308 $immutable_metaclass->make_metaclass_immutable(@_)
312 This is basically a module for applying a transformation on a given
313 metaclass. Current features include making methods read-only,
314 making methods un-callable and memoizing methods (in a type specific
317 This module is not for the feint of heart, it does some whacky things
318 to the metaclass in order to make it immutable. If you are just curious,
319 I suggest you turn back now, there is nothing to see here.
325 =item B<new ($metaclass, \%options)>
327 Given a C<$metaclass> and a set of C<%options> this module will
328 prepare an immutable version of the C<$metaclass>, which can then
329 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
334 Returns the options HASH set in C<new>.
338 Returns the metaclass set in C<new>.
340 =item B<immutable_metaclass>
342 Returns the immutable metaclass created within C<new>.
348 =item B<create_immutable_metaclass>
350 This will create the immutable version of the C<$metaclass>, but will
351 not actually change the original metaclass.
353 =item B<create_methods_for_immutable_metaclass>
355 This will create all the methods for the immutable metaclass based
356 on the C<%options> passed into C<new>.
358 =item B<make_metaclass_immutable (%options)>
360 This will actually change the C<$metaclass> into the immutable version.
362 =item B<make_metaclass_mutable (%options)>
364 This will change the C<$metaclass> into the mutable version by reversing
365 the immutable process. C<%options> should be the same options that were
366 given to make_metaclass_immutable.
372 Stevan Little E<lt>stevan@iinteractive.comE<gt>
374 =head1 COPYRIGHT AND LICENSE
376 Copyright 2006-2008 by Infinity Interactive, Inc.
378 L<http://www.iinteractive.com>
380 This library is free software; you can redistribute it and/or modify
381 it under the same terms as Perl itself.