2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.71_01';
13 $VERSION = eval $VERSION;
14 our $AUTHORITY = 'cpan:STEVAN';
16 use base 'Class::MOP::Object';
19 my ($class, @args) = @_;
21 my ( $metaclass, $options );
25 ( $metaclass, $options ) = @args;
27 unshift @args, "metaclass" if @args % 2 == 1;
32 $metaclass = $options{metaclass};
35 my $self = $class->_new(
36 'metaclass' => $metaclass,
37 'options' => $options,
38 'immutable_metaclass' => undef,
46 my $options = @_ == 1 ? $_[0] : {@_};
48 bless $options, $class;
51 sub immutable_metaclass {
54 $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
56 return $self->{'immutable_metaclass'};
59 sub metaclass { (shift)->{'metaclass'} }
60 sub options { (shift)->{'options'} }
62 sub create_immutable_metaclass {
66 # The immutable version of the
67 # metaclass is just a anon-class
68 # which shadows the methods
70 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
71 superclasses => [ blessed($self->metaclass) ],
72 methods => $self->create_methods_for_immutable_metaclass,
77 my %DEFAULT_METHODS = (
78 # I don't really understand this, but removing it breaks tests (groditi)
81 # if it is not blessed, then someone is asking
82 # for the meta of Class::MOP::Immutable
83 return Class::MOP::Class->initialize($self) unless blessed($self);
84 # otherwise, they are asking for the metaclass
85 # which has been made immutable, which is itself
86 # except in the cases where it is a metaclass itself
87 # that has been made immutable and for that we need
89 if ($self->isa('Class::MOP::Class')) {
90 return $self->{'___original_class'}->meta;
96 is_mutable => sub { 0 },
97 is_immutable => sub { 1 },
98 make_immutable => sub { () },
102 # this will actually convert the
103 # existing metaclass to an immutable
105 sub make_metaclass_immutable {
106 my ($self, $metaclass, $options) = @_;
109 inline_accessors => 1,
110 inline_constructor => 1,
111 inline_destructor => 0,
112 constructor_name => 'new',
117 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
119 if ($options{inline_accessors}) {
120 foreach my $attr_name ($metaclass->get_attribute_list) {
121 # inline the accessors
122 $metaclass->get_attribute($attr_name)
123 ->install_accessors(1);
127 if ($options{inline_constructor}) {
128 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
129 $metaclass->add_method(
130 $options{constructor_name},
131 $constructor_class->new(
132 options => \%options,
133 metaclass => $metaclass,
135 package_name => $metaclass->name,
136 name => $options{constructor_name}
138 ) if $options{replace_constructor} or !$metaclass->has_method($options{constructor_name});
141 if ($options{inline_destructor}) {
142 (exists $options{destructor_class})
143 || confess "The 'inline_destructor' option is present, but "
144 . "no destructor class was specified";
146 my $destructor_class = $options{destructor_class};
149 # we allow the destructor to determine
150 # if it is needed or not before we actually
151 # create the destructor too
153 if ($destructor_class->is_needed($metaclass)) {
154 my $destructor = $destructor_class->new(
155 options => \%options,
156 metaclass => $metaclass,
157 package_name => $metaclass->name,
161 $metaclass->add_method('DESTROY' => $destructor)
163 # we allow the destructor to determine
164 # if it is needed or not, it can perform
165 # all sorts of checks because it has the
167 if $destructor->is_needed;
171 my $memoized_methods = $self->options->{memoize};
172 foreach my $method_name (keys %{$memoized_methods}) {
173 my $type = $memoized_methods->{$method_name};
175 ($metaclass->can($method_name))
176 || confess "Could not find the method '$method_name' in " . $metaclass->name;
179 $metaclass->{'___original_class'} = blessed($metaclass);
180 bless $metaclass => $self->immutable_metaclass->name;
183 sub make_metaclass_mutable {
184 my ($self, $immutable, $options) = @_;
186 my %options = %$options;
188 my $original_class = $immutable->get_mutable_metaclass_name;
189 delete $immutable->{'___original_class'} ;
190 bless $immutable => $original_class;
192 my $memoized_methods = $self->options->{memoize};
193 foreach my $method_name (keys %{$memoized_methods}) {
194 my $type = $memoized_methods->{$method_name};
196 ($immutable->can($method_name))
197 || confess "Could not find the method '$method_name' in " . $immutable->name;
198 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
199 delete $immutable->{'___' . $method_name};
203 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
204 $immutable->remove_method('DESTROY')
205 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
209 # 14:01 <@stevan> nah,. you shouldnt
210 # 14:01 <@stevan> they are just inlined
211 # 14:01 <@stevan> which is the default in Moose anyway
212 # 14:02 <@stevan> and adding new attributes will just DWIM
213 # 14:02 <@stevan> and you really cant change an attribute anyway
214 # if ($options{inline_accessors}) {
215 # foreach my $attr_name ($immutable->get_attribute_list) {
216 # my $attr = $immutable->get_attribute($attr_name);
217 # $attr->remove_accessors;
218 # $attr->install_accessors(0);
222 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
223 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
224 # 14:27 <@stevan> so I am not worried
225 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
226 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
227 $immutable->remove_method( $options{constructor_name} )
228 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
232 sub create_methods_for_immutable_metaclass {
235 my %methods = %DEFAULT_METHODS;
236 my $metaclass = $self->metaclass;
237 my $meta = $metaclass->meta;
239 foreach my $read_only_method (@{$self->options->{read_only}}) {
240 my $method = $meta->find_method_by_name($read_only_method);
243 || confess "Could not find the method '$read_only_method' in " . $metaclass->name;
245 $methods{$read_only_method} = sub {
246 confess "This method is read-only" if scalar @_ > 1;
247 goto &{$method->body}
251 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
252 $methods{$cannot_call_method} = sub {
253 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
257 my $memoized_methods = $self->options->{memoize};
258 foreach my $method_name (keys %{$memoized_methods}) {
259 my $type = $memoized_methods->{$method_name};
260 my $key = '___' . $method_name;
261 my $method = $meta->find_method_by_name($method_name);
263 if ($type eq 'ARRAY') {
264 $methods{$method_name} = sub {
265 @{$_[0]->{$key}} = $method->execute($_[0])
266 if !exists $_[0]->{$key};
267 return @{$_[0]->{$key}};
270 elsif ($type eq 'HASH') {
271 $methods{$method_name} = sub {
272 %{$_[0]->{$key}} = $method->execute($_[0])
273 if !exists $_[0]->{$key};
274 return %{$_[0]->{$key}};
277 elsif ($type eq 'SCALAR') {
278 $methods{$method_name} = sub {
279 $_[0]->{$key} = $method->execute($_[0])
280 if !exists $_[0]->{$key};
281 return $_[0]->{$key};
286 my $wrapped_methods = $self->options->{wrapped};
288 foreach my $method_name (keys %{ $wrapped_methods }) {
289 my $method = $meta->find_method_by_name($method_name);
292 || confess "Could not find the method '$method_name' in " . $metaclass->name;
294 my $wrapper = $wrapped_methods->{$method_name};
296 $methods{$method_name} = sub { $wrapper->($method, @_) };
299 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
301 $methods{immutable_transformer} = sub { $self };
314 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
318 use Class::MOP::Immutable;
320 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
321 read_only => [qw/superclasses/],
329 remove_package_symbol
332 class_precedence_list => 'ARRAY',
333 compute_all_applicable_attributes => 'ARRAY',
334 get_meta_instance => 'SCALAR',
335 get_method_map => 'SCALAR',
339 $immutable_metaclass->make_metaclass_immutable(@_)
343 This is basically a module for applying a transformation on a given
344 metaclass. Current features include making methods read-only,
345 making methods un-callable and memoizing methods (in a type specific
348 This module is not for the feint of heart, it does some whacky things
349 to the metaclass in order to make it immutable. If you are just curious,
350 I suggest you turn back now, there is nothing to see here.
356 =item B<new ($metaclass, \%options)>
358 Given a C<$metaclass> and a set of C<%options> this module will
359 prepare an immutable version of the C<$metaclass>, which can then
360 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
365 Returns the options HASH set in C<new>.
369 Returns the metaclass set in C<new>.
371 =item B<immutable_metaclass>
373 Returns the immutable metaclass created within C<new>.
379 =item B<create_immutable_metaclass>
381 This will create the immutable version of the C<$metaclass>, but will
382 not actually change the original metaclass.
384 =item B<create_methods_for_immutable_metaclass>
386 This will create all the methods for the immutable metaclass based
387 on the C<%options> passed into C<new>.
389 =item B<make_metaclass_immutable (%options)>
391 This will actually change the C<$metaclass> into the immutable version.
393 =item B<make_metaclass_mutable (%options)>
395 This will change the C<$metaclass> into the mutable version by reversing
396 the immutable process. C<%options> should be the same options that were
397 given to make_metaclass_immutable.
403 Stevan Little E<lt>stevan@iinteractive.comE<gt>
405 =head1 COPYRIGHT AND LICENSE
407 Copyright 2006-2008 by Infinity Interactive, Inc.
409 L<http://www.iinteractive.com>
411 This library is free software; you can redistribute it and/or modify
412 it under the same terms as Perl itself.