2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.67';
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,
42 # we initialize the immutable
43 # version of the metaclass here
45 $self->create_immutable_metaclass;
52 my $options = @_ == 1 ? $_[0] : {@_};
54 bless $options, $class;
57 sub immutable_metaclass { (shift)->{'immutable_metaclass'} }
58 sub metaclass { (shift)->{'metaclass'} }
59 sub options { (shift)->{'options'} }
61 sub create_immutable_metaclass {
65 # The immutable version of the
66 # metaclass is just a anon-class
67 # which shadows the methods
69 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
70 superclasses => [ blessed($self->metaclass) ],
71 methods => $self->create_methods_for_immutable_metaclass,
76 my %DEFAULT_METHODS = (
77 # I don't really understand this, but removing it breaks tests (groditi)
80 # if it is not blessed, then someone is asking
81 # for the meta of Class::MOP::Immutable
82 return Class::MOP::Class->initialize($self) unless blessed($self);
83 # otherwise, they are asking for the metaclass
84 # which has been made immutable, which is itself
85 # except in the cases where it is a metaclass itself
86 # that has been made immutable and for that we need
88 if ($self->isa('Class::MOP::Class')) {
89 return $self->{'___original_class'}->meta;
95 is_mutable => sub { 0 },
96 is_immutable => sub { 1 },
97 make_immutable => sub { () },
101 # this will actually convert the
102 # existing metaclass to an immutable
104 sub make_metaclass_immutable {
105 my ($self, $metaclass, $options) = @_;
108 inline_accessors => 1,
109 inline_constructor => 1,
110 inline_destructor => 0,
111 constructor_name => 'new',
116 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
118 if ($options{inline_accessors}) {
119 foreach my $attr_name ($metaclass->get_attribute_list) {
120 # inline the accessors
121 $metaclass->get_attribute($attr_name)
122 ->install_accessors(1);
126 if ($options{inline_constructor}) {
127 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
128 $metaclass->add_method(
129 $options{constructor_name},
130 $constructor_class->new(
131 options => \%options,
132 metaclass => $metaclass,
134 package_name => $metaclass->name,
135 name => $options{constructor_name}
137 ) if $options{replace_constructor} or !$metaclass->has_method($options{constructor_name});
140 if ($options{inline_destructor}) {
141 (exists $options{destructor_class})
142 || confess "The 'inline_destructor' option is present, but "
143 . "no destructor class was specified";
145 my $destructor_class = $options{destructor_class};
148 # we allow the destructor to determine
149 # if it is needed or not before we actually
150 # create the destructor too
152 if ($destructor_class->is_needed($metaclass)) {
153 my $destructor = $destructor_class->new(
154 options => \%options,
155 metaclass => $metaclass,
156 package_name => $metaclass->name,
160 $metaclass->add_method('DESTROY' => $destructor)
162 # we allow the destructor to determine
163 # if it is needed or not, it can perform
164 # all sorts of checks because it has the
166 if $destructor->is_needed;
170 my $memoized_methods = $self->options->{memoize};
171 foreach my $method_name (keys %{$memoized_methods}) {
172 my $type = $memoized_methods->{$method_name};
174 ($metaclass->can($method_name))
175 || confess "Could not find the method '$method_name' in " . $metaclass->name;
177 if ($type eq 'ARRAY') {
178 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
180 elsif ($type eq 'HASH') {
181 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
183 elsif ($type eq 'SCALAR') {
184 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
188 $metaclass->{'___original_class'} = blessed($metaclass);
189 bless $metaclass => $self->immutable_metaclass->name;
192 sub make_metaclass_mutable {
193 my ($self, $immutable, $options) = @_;
195 my %options = %$options;
197 my $original_class = $immutable->get_mutable_metaclass_name;
198 delete $immutable->{'___original_class'} ;
199 bless $immutable => $original_class;
201 my $memoized_methods = $self->options->{memoize};
202 foreach my $method_name (keys %{$memoized_methods}) {
203 my $type = $memoized_methods->{$method_name};
205 ($immutable->can($method_name))
206 || confess "Could not find the method '$method_name' in " . $immutable->name;
207 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
208 delete $immutable->{'___' . $method_name};
212 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
213 $immutable->remove_method('DESTROY')
214 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
218 # 14:01 <@stevan> nah,. you shouldnt
219 # 14:01 <@stevan> they are just inlined
220 # 14:01 <@stevan> which is the default in Moose anyway
221 # 14:02 <@stevan> and adding new attributes will just DWIM
222 # 14:02 <@stevan> and you really cant change an attribute anyway
223 # if ($options{inline_accessors}) {
224 # foreach my $attr_name ($immutable->get_attribute_list) {
225 # my $attr = $immutable->get_attribute($attr_name);
226 # $attr->remove_accessors;
227 # $attr->install_accessors(0);
231 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
232 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
233 # 14:27 <@stevan> so I am not worried
234 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
235 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
236 $immutable->remove_method( $options{constructor_name} )
237 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
241 sub create_methods_for_immutable_metaclass {
244 my %methods = %DEFAULT_METHODS;
246 foreach my $read_only_method (@{$self->options->{read_only}}) {
247 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
250 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
252 $methods{$read_only_method} = sub {
253 confess "This method is read-only" if scalar @_ > 1;
254 goto &{$method->body}
258 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
259 $methods{$cannot_call_method} = sub {
260 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
264 my $memoized_methods = $self->options->{memoize};
265 foreach my $method_name (keys %{$memoized_methods}) {
266 my $type = $memoized_methods->{$method_name};
267 if ($type eq 'ARRAY') {
268 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
270 elsif ($type eq 'HASH') {
271 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
273 elsif ($type eq 'SCALAR') {
274 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
278 my $wrapped_methods = $self->options->{wrapped};
280 foreach my $method_name (keys %{ $wrapped_methods }) {
281 my $method = $self->metaclass->meta->find_method_by_name($method_name);
284 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
286 my $wrapper = $wrapped_methods->{$method_name};
288 $methods{$method_name} = sub { $wrapper->($method, @_) };
291 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
293 $methods{immutable_transformer} = sub { $self };
306 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
310 use Class::MOP::Immutable;
312 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
313 read_only => [qw/superclasses/],
321 remove_package_symbol
324 class_precedence_list => 'ARRAY',
325 compute_all_applicable_attributes => 'ARRAY',
326 get_meta_instance => 'SCALAR',
327 get_method_map => 'SCALAR',
331 $immutable_metaclass->make_metaclass_immutable(@_)
335 This is basically a module for applying a transformation on a given
336 metaclass. Current features include making methods read-only,
337 making methods un-callable and memoizing methods (in a type specific
340 This module is not for the feint of heart, it does some whacky things
341 to the metaclass in order to make it immutable. If you are just curious,
342 I suggest you turn back now, there is nothing to see here.
348 =item B<new ($metaclass, \%options)>
350 Given a C<$metaclass> and a set of C<%options> this module will
351 prepare an immutable version of the C<$metaclass>, which can then
352 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
357 Returns the options HASH set in C<new>.
361 Returns the metaclass set in C<new>.
363 =item B<immutable_metaclass>
365 Returns the immutable metaclass created within C<new>.
371 =item B<create_immutable_metaclass>
373 This will create the immutable version of the C<$metaclass>, but will
374 not actually change the original metaclass.
376 =item B<create_methods_for_immutable_metaclass>
378 This will create all the methods for the immutable metaclass based
379 on the C<%options> passed into C<new>.
381 =item B<make_metaclass_immutable (%options)>
383 This will actually change the C<$metaclass> into the immutable version.
385 =item B<make_metaclass_mutable (%options)>
387 This will change the C<$metaclass> into the mutable version by reversing
388 the immutable process. C<%options> should be the same options that were
389 given to make_metaclass_immutable.
395 Stevan Little E<lt>stevan@iinteractive.comE<gt>
397 =head1 COPYRIGHT AND LICENSE
399 Copyright 2006-2008 by Infinity Interactive, Inc.
401 L<http://www.iinteractive.com>
403 This library is free software; you can redistribute it and/or modify
404 it under the same terms as Perl itself.