2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.06';
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};
117 my $destructor = $destructor_class->new(
118 options => \%options,
119 metaclass => $metaclass,
120 package_name => $metaclass->name,
124 $metaclass->add_method('DESTROY' => $destructor)
126 # we allow the destructor to determine
127 # if it is needed or not, it can perform
128 # all sorts of checks because it has the
130 if $destructor->is_needed;
133 my $memoized_methods = $self->options->{memoize};
134 foreach my $method_name (keys %{$memoized_methods}) {
135 my $type = $memoized_methods->{$method_name};
137 ($metaclass->can($method_name))
138 || confess "Could not find the method '$method_name' in " . $metaclass->name;
140 if ($type eq 'ARRAY') {
141 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
143 elsif ($type eq 'HASH') {
144 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
146 elsif ($type eq 'SCALAR') {
147 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
151 $metaclass->{'___original_class'} = blessed($metaclass);
152 bless $metaclass => $self->immutable_metaclass->name;
155 sub make_metaclass_mutable {
156 my ($self, $immutable, $options) = @_;
158 my %options = %$options;
160 my $original_class = $immutable->get_mutable_metaclass_name;
161 delete $immutable->{'___original_class'} ;
162 bless $immutable => $original_class;
164 my $memoized_methods = $self->options->{memoize};
165 foreach my $method_name (keys %{$memoized_methods}) {
166 my $type = $memoized_methods->{$method_name};
168 ($immutable->can($method_name))
169 || confess "Could not find the method '$method_name' in " . $immutable->name;
170 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
171 delete $immutable->{'___' . $method_name};
175 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
176 $immutable->remove_method('DESTROY')
177 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
181 # 14:01 <@stevan> nah,. you shouldnt
182 # 14:01 <@stevan> they are just inlined
183 # 14:01 <@stevan> which is the default in Moose anyway
184 # 14:02 <@stevan> and adding new attributes will just DWIM
185 # 14:02 <@stevan> and you really cant change an attribute anyway
186 # if ($options{inline_accessors}) {
187 # foreach my $attr_name ($immutable->get_attribute_list) {
188 # my $attr = $immutable->get_attribute($attr_name);
189 # $attr->remove_accessors;
190 # $attr->install_accessors(0);
194 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
195 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
196 # 14:27 <@stevan> so I am not worried
197 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
198 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
199 $immutable->remove_method( $options{constructor_name} )
200 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
204 sub create_methods_for_immutable_metaclass {
207 my %methods = %DEFAULT_METHODS;
209 foreach my $read_only_method (@{$self->options->{read_only}}) {
210 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
213 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
215 $methods{$read_only_method} = sub {
216 confess "This method is read-only" if scalar @_ > 1;
217 goto &{$method->body}
221 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
222 $methods{$cannot_call_method} = sub {
223 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
227 my $memoized_methods = $self->options->{memoize};
228 foreach my $method_name (keys %{$memoized_methods}) {
229 my $type = $memoized_methods->{$method_name};
230 if ($type eq 'ARRAY') {
231 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
233 elsif ($type eq 'HASH') {
234 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
236 elsif ($type eq 'SCALAR') {
237 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
241 my $wrapped_methods = $self->options->{wrapped};
243 foreach my $method_name (keys %{ $wrapped_methods }) {
244 my $method = $self->metaclass->meta->find_method_by_name($method_name);
247 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
249 my $wrapper = $wrapped_methods->{$method_name};
251 $methods{$method_name} = sub { $wrapper->($method, @_) };
254 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
256 $methods{immutable_transformer} = sub { $self };
269 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
273 use Class::MOP::Immutable;
275 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
276 read_only => [qw/superclasses/],
284 remove_package_symbol
287 class_precedence_list => 'ARRAY',
288 compute_all_applicable_attributes => 'ARRAY',
289 get_meta_instance => 'SCALAR',
290 get_method_map => 'SCALAR',
294 $immutable_metaclass->make_metaclass_immutable(@_)
298 This is basically a module for applying a transformation on a given
299 metaclass. Current features include making methods read-only,
300 making methods un-callable and memoizing methods (in a type specific
303 This module is not for the feint of heart, it does some whacky things
304 to the metaclass in order to make it immutable. If you are just curious,
305 I suggest you turn back now, there is nothing to see here.
311 =item B<new ($metaclass, \%options)>
313 Given a C<$metaclass> and a set of C<%options> this module will
314 prepare an immutable version of the C<$metaclass>, which can then
315 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
320 Returns the options HASH set in C<new>.
324 Returns the metaclass set in C<new>.
326 =item B<immutable_metaclass>
328 Returns the immutable metaclass created within C<new>.
334 =item B<create_immutable_metaclass>
336 This will create the immutable version of the C<$metaclass>, but will
337 not actually change the original metaclass.
339 =item B<create_methods_for_immutable_metaclass>
341 This will create all the methods for the immutable metaclass based
342 on the C<%options> passed into C<new>.
344 =item B<make_metaclass_immutable (%options)>
346 This will actually change the C<$metaclass> into the immutable version.
348 =item B<make_metaclass_mutable (%options)>
350 This will change the C<$metaclass> into the mutable version by reversing
351 the immutable process. C<%options> should be the same options that were
352 given to make_metaclass_immutable.
358 Stevan Little E<lt>stevan@iinteractive.comE<gt>
360 =head1 COPYRIGHT AND LICENSE
362 Copyright 2006-2008 by Infinity Interactive, Inc.
364 L<http://www.iinteractive.com>
366 This library is free software; you can redistribute it and/or modify
367 it under the same terms as Perl itself.