2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.61';
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' ],
83 $options->{$pair->[0]} = $pair->[1] unless exists $options->{$pair->[0]};
86 my %options = %$options;
88 if ($options{inline_accessors}) {
89 foreach my $attr_name ($metaclass->get_attribute_list) {
90 # inline the accessors
91 $metaclass->get_attribute($attr_name)
92 ->install_accessors(1);
96 if ($options{inline_constructor}) {
97 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
98 $metaclass->add_method(
99 $options{constructor_name},
100 $constructor_class->new(
101 options => \%options,
102 metaclass => $metaclass,
104 package_name => $metaclass->name,
105 name => $options{constructor_name}
107 ) unless $metaclass->has_method($options{constructor_name});
110 if ($options{inline_destructor}) {
111 (exists $options{destructor_class})
112 || confess "The 'inline_destructor' option is present, but "
113 . "no destructor class was specified";
115 my $destructor_class = $options{destructor_class};
118 # we allow the destructor to determine
119 # if it is needed or not before we actually
120 # create the destructor too
122 if ($destructor_class->is_needed($metaclass)) {
123 my $destructor = $destructor_class->new(
124 options => \%options,
125 metaclass => $metaclass,
126 package_name => $metaclass->name,
130 $metaclass->add_method('DESTROY' => $destructor)
132 # we allow the destructor to determine
133 # if it is needed or not, it can perform
134 # all sorts of checks because it has the
136 if $destructor->is_needed;
140 my $memoized_methods = $self->options->{memoize};
141 foreach my $method_name (keys %{$memoized_methods}) {
142 my $type = $memoized_methods->{$method_name};
144 ($metaclass->can($method_name))
145 || confess "Could not find the method '$method_name' in " . $metaclass->name;
147 if ($type eq 'ARRAY') {
148 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
150 elsif ($type eq 'HASH') {
151 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
153 elsif ($type eq 'SCALAR') {
154 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
158 $metaclass->{'___original_class'} = blessed($metaclass);
159 bless $metaclass => $self->immutable_metaclass->name;
162 sub make_metaclass_mutable {
163 my ($self, $immutable, $options) = @_;
165 my %options = %$options;
167 my $original_class = $immutable->get_mutable_metaclass_name;
168 delete $immutable->{'___original_class'} ;
169 bless $immutable => $original_class;
171 my $memoized_methods = $self->options->{memoize};
172 foreach my $method_name (keys %{$memoized_methods}) {
173 my $type = $memoized_methods->{$method_name};
175 ($immutable->can($method_name))
176 || confess "Could not find the method '$method_name' in " . $immutable->name;
177 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
178 delete $immutable->{'___' . $method_name};
182 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
183 $immutable->remove_method('DESTROY')
184 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
188 # 14:01 <@stevan> nah,. you shouldnt
189 # 14:01 <@stevan> they are just inlined
190 # 14:01 <@stevan> which is the default in Moose anyway
191 # 14:02 <@stevan> and adding new attributes will just DWIM
192 # 14:02 <@stevan> and you really cant change an attribute anyway
193 # if ($options{inline_accessors}) {
194 # foreach my $attr_name ($immutable->get_attribute_list) {
195 # my $attr = $immutable->get_attribute($attr_name);
196 # $attr->remove_accessors;
197 # $attr->install_accessors(0);
201 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
202 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
203 # 14:27 <@stevan> so I am not worried
204 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
205 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
206 $immutable->remove_method( $options{constructor_name} )
207 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
211 sub create_methods_for_immutable_metaclass {
214 my %methods = %DEFAULT_METHODS;
216 foreach my $read_only_method (@{$self->options->{read_only}}) {
217 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
220 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
222 $methods{$read_only_method} = sub {
223 confess "This method is read-only" if scalar @_ > 1;
224 goto &{$method->body}
228 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
229 $methods{$cannot_call_method} = sub {
230 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
234 my $memoized_methods = $self->options->{memoize};
235 foreach my $method_name (keys %{$memoized_methods}) {
236 my $type = $memoized_methods->{$method_name};
237 if ($type eq 'ARRAY') {
238 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
240 elsif ($type eq 'HASH') {
241 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
243 elsif ($type eq 'SCALAR') {
244 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
248 my $wrapped_methods = $self->options->{wrapped};
250 foreach my $method_name (keys %{ $wrapped_methods }) {
251 my $method = $self->metaclass->meta->find_method_by_name($method_name);
254 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
256 my $wrapper = $wrapped_methods->{$method_name};
258 $methods{$method_name} = sub { $wrapper->($method, @_) };
261 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
263 $methods{immutable_transformer} = sub { $self };
276 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
280 use Class::MOP::Immutable;
282 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
283 read_only => [qw/superclasses/],
291 remove_package_symbol
294 class_precedence_list => 'ARRAY',
295 compute_all_applicable_attributes => 'ARRAY',
296 get_meta_instance => 'SCALAR',
297 get_method_map => 'SCALAR',
301 $immutable_metaclass->make_metaclass_immutable(@_)
305 This is basically a module for applying a transformation on a given
306 metaclass. Current features include making methods read-only,
307 making methods un-callable and memoizing methods (in a type specific
310 This module is not for the feint of heart, it does some whacky things
311 to the metaclass in order to make it immutable. If you are just curious,
312 I suggest you turn back now, there is nothing to see here.
318 =item B<new ($metaclass, \%options)>
320 Given a C<$metaclass> and a set of C<%options> this module will
321 prepare an immutable version of the C<$metaclass>, which can then
322 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
327 Returns the options HASH set in C<new>.
331 Returns the metaclass set in C<new>.
333 =item B<immutable_metaclass>
335 Returns the immutable metaclass created within C<new>.
341 =item B<create_immutable_metaclass>
343 This will create the immutable version of the C<$metaclass>, but will
344 not actually change the original metaclass.
346 =item B<create_methods_for_immutable_metaclass>
348 This will create all the methods for the immutable metaclass based
349 on the C<%options> passed into C<new>.
351 =item B<make_metaclass_immutable (%options)>
353 This will actually change the C<$metaclass> into the immutable version.
355 =item B<make_metaclass_mutable (%options)>
357 This will change the C<$metaclass> into the mutable version by reversing
358 the immutable process. C<%options> should be the same options that were
359 given to make_metaclass_immutable.
365 Stevan Little E<lt>stevan@iinteractive.comE<gt>
367 =head1 COPYRIGHT AND LICENSE
369 Copyright 2006-2008 by Infinity Interactive, Inc.
371 L<http://www.iinteractive.com>
373 This library is free software; you can redistribute it and/or modify
374 it under the same terms as Perl itself.