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, @args) = @_;
20 my ( $metaclass, $options );
24 ( $metaclass, $options ) = @args;
26 unshift @args, "metaclass" if @args % 2 == 1;
31 $metaclass = $options{metaclass};
34 # FIXME make a proper constructor using ->meta->new_object
36 'metaclass' => $metaclass,
37 'options' => $options,
38 'immutable_metaclass' => undef,
42 # we initialize the immutable
43 # version of the metaclass here
45 $self->create_immutable_metaclass;
50 sub immutable_metaclass { (shift)->{'immutable_metaclass'} }
51 sub metaclass { (shift)->{'metaclass'} }
52 sub options { (shift)->{'options'} }
54 sub create_immutable_metaclass {
58 # The immutable version of the
59 # metaclass is just a anon-class
60 # which shadows the methods
62 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
63 superclasses => [ blessed($self->metaclass) ],
64 methods => $self->create_methods_for_immutable_metaclass,
69 my %DEFAULT_METHODS = (
70 # I don't really understand this, but removing it breaks tests (groditi)
73 # if it is not blessed, then someone is asking
74 # for the meta of Class::MOP::Immutable
75 return Class::MOP::Class->initialize($self) unless blessed($self);
76 # otherwise, they are asking for the metaclass
77 # which has been made immutable, which is itself
78 # except in the cases where it is a metaclass itself
79 # that has been made immutable and for that we need
81 if ($self->isa('Class::MOP::Class')) {
82 return $self->{'___original_class'}->meta;
88 is_mutable => sub { 0 },
89 is_immutable => sub { 1 },
90 make_immutable => sub { () },
94 # this will actually convert the
95 # existing metaclass to an immutable
97 sub make_metaclass_immutable {
98 my ($self, $metaclass, $options) = @_;
101 inline_accessors => 1,
102 inline_constructor => 1,
103 inline_destructor => 0,
104 constructor_name => 'new',
109 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
111 if ($options{inline_accessors}) {
112 foreach my $attr_name ($metaclass->get_attribute_list) {
113 # inline the accessors
114 $metaclass->get_attribute($attr_name)
115 ->install_accessors(1);
119 if ($options{inline_constructor}) {
120 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
121 $metaclass->add_method(
122 $options{constructor_name},
123 $constructor_class->new(
124 options => \%options,
125 metaclass => $metaclass,
127 package_name => $metaclass->name,
128 name => $options{constructor_name}
130 ) unless $metaclass->has_method($options{constructor_name});
133 if ($options{inline_destructor}) {
134 (exists $options{destructor_class})
135 || confess "The 'inline_destructor' option is present, but "
136 . "no destructor class was specified";
138 my $destructor_class = $options{destructor_class};
141 # we allow the destructor to determine
142 # if it is needed or not before we actually
143 # create the destructor too
145 if ($destructor_class->is_needed($metaclass)) {
146 my $destructor = $destructor_class->new(
147 options => \%options,
148 metaclass => $metaclass,
149 package_name => $metaclass->name,
153 $metaclass->add_method('DESTROY' => $destructor)
155 # we allow the destructor to determine
156 # if it is needed or not, it can perform
157 # all sorts of checks because it has the
159 if $destructor->is_needed;
163 my $memoized_methods = $self->options->{memoize};
164 foreach my $method_name (keys %{$memoized_methods}) {
165 my $type = $memoized_methods->{$method_name};
167 ($metaclass->can($method_name))
168 || confess "Could not find the method '$method_name' in " . $metaclass->name;
170 if ($type eq 'ARRAY') {
171 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
173 elsif ($type eq 'HASH') {
174 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
176 elsif ($type eq 'SCALAR') {
177 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
181 $metaclass->{'___original_class'} = blessed($metaclass);
182 bless $metaclass => $self->immutable_metaclass->name;
185 sub make_metaclass_mutable {
186 my ($self, $immutable, $options) = @_;
188 my %options = %$options;
190 my $original_class = $immutable->get_mutable_metaclass_name;
191 delete $immutable->{'___original_class'} ;
192 bless $immutable => $original_class;
194 my $memoized_methods = $self->options->{memoize};
195 foreach my $method_name (keys %{$memoized_methods}) {
196 my $type = $memoized_methods->{$method_name};
198 ($immutable->can($method_name))
199 || confess "Could not find the method '$method_name' in " . $immutable->name;
200 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
201 delete $immutable->{'___' . $method_name};
205 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
206 $immutable->remove_method('DESTROY')
207 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
211 # 14:01 <@stevan> nah,. you shouldnt
212 # 14:01 <@stevan> they are just inlined
213 # 14:01 <@stevan> which is the default in Moose anyway
214 # 14:02 <@stevan> and adding new attributes will just DWIM
215 # 14:02 <@stevan> and you really cant change an attribute anyway
216 # if ($options{inline_accessors}) {
217 # foreach my $attr_name ($immutable->get_attribute_list) {
218 # my $attr = $immutable->get_attribute($attr_name);
219 # $attr->remove_accessors;
220 # $attr->install_accessors(0);
224 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
225 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
226 # 14:27 <@stevan> so I am not worried
227 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
228 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
229 $immutable->remove_method( $options{constructor_name} )
230 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
234 sub create_methods_for_immutable_metaclass {
237 my %methods = %DEFAULT_METHODS;
239 foreach my $read_only_method (@{$self->options->{read_only}}) {
240 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
243 || confess "Could not find the method '$read_only_method' in " . $self->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 if ($type eq 'ARRAY') {
261 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
263 elsif ($type eq 'HASH') {
264 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
266 elsif ($type eq 'SCALAR') {
267 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
271 my $wrapped_methods = $self->options->{wrapped};
273 foreach my $method_name (keys %{ $wrapped_methods }) {
274 my $method = $self->metaclass->meta->find_method_by_name($method_name);
277 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
279 my $wrapper = $wrapped_methods->{$method_name};
281 $methods{$method_name} = sub { $wrapper->($method, @_) };
284 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
286 $methods{immutable_transformer} = sub { $self };
299 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
303 use Class::MOP::Immutable;
305 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
306 read_only => [qw/superclasses/],
314 remove_package_symbol
317 class_precedence_list => 'ARRAY',
318 compute_all_applicable_attributes => 'ARRAY',
319 get_meta_instance => 'SCALAR',
320 get_method_map => 'SCALAR',
324 $immutable_metaclass->make_metaclass_immutable(@_)
328 This is basically a module for applying a transformation on a given
329 metaclass. Current features include making methods read-only,
330 making methods un-callable and memoizing methods (in a type specific
333 This module is not for the feint of heart, it does some whacky things
334 to the metaclass in order to make it immutable. If you are just curious,
335 I suggest you turn back now, there is nothing to see here.
341 =item B<new ($metaclass, \%options)>
343 Given a C<$metaclass> and a set of C<%options> this module will
344 prepare an immutable version of the C<$metaclass>, which can then
345 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
350 Returns the options HASH set in C<new>.
354 Returns the metaclass set in C<new>.
356 =item B<immutable_metaclass>
358 Returns the immutable metaclass created within C<new>.
364 =item B<create_immutable_metaclass>
366 This will create the immutable version of the C<$metaclass>, but will
367 not actually change the original metaclass.
369 =item B<create_methods_for_immutable_metaclass>
371 This will create all the methods for the immutable metaclass based
372 on the C<%options> passed into C<new>.
374 =item B<make_metaclass_immutable (%options)>
376 This will actually change the C<$metaclass> into the immutable version.
378 =item B<make_metaclass_mutable (%options)>
380 This will change the C<$metaclass> into the mutable version by reversing
381 the immutable process. C<%options> should be the same options that were
382 given to make_metaclass_immutable.
388 Stevan Little E<lt>stevan@iinteractive.comE<gt>
390 =head1 COPYRIGHT AND LICENSE
392 Copyright 2006-2008 by Infinity Interactive, Inc.
394 L<http://www.iinteractive.com>
396 This library is free software; you can redistribute it and/or modify
397 it under the same terms as Perl itself.