2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
11 use Sub::Name 'subname';
13 our $VERSION = '0.06';
14 our $AUTHORITY = 'cpan:STEVAN';
16 use base 'Class::MOP::Object';
19 my ($class, $metaclass, $options) = @_;
22 '$!metaclass' => $metaclass,
23 '%!options' => $options,
24 '$!immutable_metaclass' => undef,
28 # we initialize the immutable
29 # version of the metaclass here
30 $self->create_immutable_metaclass;
35 sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
36 sub metaclass { (shift)->{'$!metaclass'} }
37 sub options { (shift)->{'%!options'} }
39 sub create_immutable_metaclass {
43 # The immutable version of the
44 # metaclass is just a anon-class
45 # which shadows the methods
47 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
48 superclasses => [ blessed($self->metaclass) ],
49 methods => $self->create_methods_for_immutable_metaclass,
54 my %DEFAULT_METHODS = (
55 # I don't really understand this, but removing it breaks tests (groditi)
58 # if it is not blessed, then someone is asking
59 # for the meta of Class::MOP::Immutable
60 return Class::MOP::Class->initialize($self) unless blessed($self);
61 # otherwise, they are asking for the metaclass
62 # which has been made immutable, which is itself
65 is_mutable => sub { 0 },
66 is_immutable => sub { 1 },
67 make_immutable => sub { () },
71 # this will actually convert the
72 # existing metaclass to an immutable
74 sub make_metaclass_immutable {
75 my ($self, $metaclass, $options) = @_;
78 [ inline_accessors => 1 ],
79 [ inline_constructor => 1 ],
80 [ inline_destructor => 0 ],
81 [ constructor_name => 'new' ],
84 $options->{$pair->[0]} = $pair->[1] unless exists $options->{$pair->[0]};
87 my %options = %$options;
89 if ($options{inline_accessors}) {
90 foreach my $attr_name ($metaclass->get_attribute_list) {
91 # inline the accessors
92 $metaclass->get_attribute($attr_name)
93 ->install_accessors(1);
97 if ($options{inline_constructor}) {
98 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
99 $metaclass->add_method(
100 $options{constructor_name},
101 $constructor_class->new(
102 options => \%options,
103 metaclass => $metaclass,
106 ) unless $metaclass->has_method($options{constructor_name});
109 if ($options{inline_destructor}) {
110 (exists $options{destructor_class})
111 || confess "The 'inline_destructor' option is present, but "
112 . "no destructor class was specified";
114 my $destructor_class = $options{destructor_class};
116 my $destructor = $destructor_class->new(
117 options => \%options,
118 metaclass => $metaclass,
121 $metaclass->add_method('DESTROY' => $destructor)
123 # we allow the destructor to determine
124 # if it is needed or not, it can perform
125 # all sorts of checks because it has the
127 if $destructor->is_needed;
130 my $memoized_methods = $self->options->{memoize};
131 foreach my $method_name (keys %{$memoized_methods}) {
132 my $type = $memoized_methods->{$method_name};
134 ($metaclass->can($method_name))
135 || confess "Could not find the method '$method_name' in " . $metaclass->name;
137 if ($type eq 'ARRAY') {
138 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
140 elsif ($type eq 'HASH') {
141 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
143 elsif ($type eq 'SCALAR') {
144 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
148 $metaclass->{'___original_class'} = blessed($metaclass);
149 bless $metaclass => $self->immutable_metaclass->name;
152 sub make_metaclass_mutable {
153 my ($self, $immutable, $options) = @_;
155 my %options = %$options;
157 my $original_class = $immutable->get_mutable_metaclass_name;
158 delete $immutable->{'___original_class'} ;
159 bless $immutable => $original_class;
161 my $memoized_methods = $self->options->{memoize};
162 foreach my $method_name (keys %{$memoized_methods}) {
163 my $type = $memoized_methods->{$method_name};
165 ($immutable->can($method_name))
166 || confess "Could not find the method '$method_name' in " . $immutable->name;
167 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
168 delete $immutable->{'___' . $method_name};
172 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
173 $immutable->remove_method('DESTROY')
174 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
178 # 14:01 <@stevan> nah,. you shouldnt
179 # 14:01 <@stevan> they are just inlined
180 # 14:01 <@stevan> which is the default in Moose anyway
181 # 14:02 <@stevan> and adding new attributes will just DWIM
182 # 14:02 <@stevan> and you really cant change an attribute anyway
183 # if ($options{inline_accessors}) {
184 # foreach my $attr_name ($immutable->get_attribute_list) {
185 # my $attr = $immutable->get_attribute($attr_name);
186 # $attr->remove_accessors;
187 # $attr->install_accessors(0);
191 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
192 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
193 # 14:27 <@stevan> so I am not worried
194 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
195 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
196 $immutable->remove_method( $options{constructor_name} )
197 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
201 sub create_methods_for_immutable_metaclass {
204 my %methods = %DEFAULT_METHODS;
206 foreach my $read_only_method (@{$self->options->{read_only}}) {
207 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
210 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
212 $methods{$read_only_method} = sub {
213 confess "This method is read-only" if scalar @_ > 1;
214 goto &{$method->body}
218 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
219 $methods{$cannot_call_method} = sub {
220 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
224 my $memoized_methods = $self->options->{memoize};
225 foreach my $method_name (keys %{$memoized_methods}) {
226 my $type = $memoized_methods->{$method_name};
227 if ($type eq 'ARRAY') {
228 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
230 elsif ($type eq 'HASH') {
231 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
233 elsif ($type eq 'SCALAR') {
234 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
238 my $wrapped_methods = $self->options->{wrapped};
240 foreach my $method_name (keys %{ $wrapped_methods }) {
241 my $method = $self->metaclass->meta->find_method_by_name($method_name);
244 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
246 my $wrapper = $wrapped_methods->{$method_name};
248 $methods{$method_name} = sub { $wrapper->($method, @_) };
251 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
253 $methods{immutable_transformer} = sub { $self };
266 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
270 use Class::MOP::Immutable;
272 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
273 read_only => [qw/superclasses/],
281 remove_package_symbol
284 class_precedence_list => 'ARRAY',
285 compute_all_applicable_attributes => 'ARRAY',
286 get_meta_instance => 'SCALAR',
287 get_method_map => 'SCALAR',
291 $immutable_metaclass->make_metaclass_immutable(@_)
295 This is basically a module for applying a transformation on a given
296 metaclass. Current features include making methods read-only,
297 making methods un-callable and memoizing methods (in a type specific
300 This module is not for the feint of heart, it does some whacky things
301 to the metaclass in order to make it immutable. If you are just curious,
302 I suggest you turn back now, there is nothing to see here.
308 =item B<new ($metaclass, \%options)>
310 Given a C<$metaclass> and a set of C<%options> this module will
311 prepare an immutable version of the C<$metaclass>, which can then
312 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
317 Returns the options HASH set in C<new>.
321 Returns the metaclass set in C<new>.
323 =item B<immutable_metaclass>
325 Returns the immutable metaclass created within C<new>.
331 =item B<create_immutable_metaclass>
333 This will create the immutable version of the C<$metaclass>, but will
334 not actually change the original metaclass.
336 =item B<create_methods_for_immutable_metaclass>
338 This will create all the methods for the immutable metaclass based
339 on the C<%options> passed into C<new>.
341 =item B<make_metaclass_immutable (%options)>
343 This will actually change the C<$metaclass> into the immutable version.
345 =item B<make_metaclass_mutable (%options)>
347 This will change the C<$metaclass> into the mutable version by reversing
348 the immutable process. C<%options> should be the same options that were
349 given to make_metaclass_immutable.
355 Stevan Little E<lt>stevan@iinteractive.comE<gt>
357 =head1 COPYRIGHT AND LICENSE
359 Copyright 2006-2008 by Infinity Interactive, Inc.
361 L<http://www.iinteractive.com>
363 This library is free software; you can redistribute it and/or modify
364 it under the same terms as Perl itself.