2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.02';
13 our $AUTHORITY = 'cpan:STEVAN';
16 my ($class, $metaclass, $options) = @_;
19 '$!metaclass' => $metaclass,
20 '%!options' => $options,
21 '$!immutable_metaclass' => undef,
25 # we initialize the immutable
26 # version of the metaclass here
27 $self->create_immutable_metaclass;
32 sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
33 sub metaclass { (shift)->{'$!metaclass'} }
34 sub options { (shift)->{'%!options'} }
36 sub create_immutable_metaclass {
40 # The immutable version of the
41 # metaclass is just a anon-class
42 # which shadows the methods
44 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
45 superclasses => [ blessed($self->metaclass) ],
46 methods => $self->create_methods_for_immutable_metaclass,
51 my %DEFAULT_METHODS = (
52 # I don't really understand this, but removing it breaks tests (groditi)
55 # if it is not blessed, then someone is asking
56 # for the meta of Class::MOP::Class::Immutable
57 return Class::MOP::Class->initialize($self) unless blessed($self);
58 # otherwise, they are asking for the metaclass
59 # which has been made immutable, which is itself
62 is_mutable => sub { 0 },
63 is_immutable => sub { 1 },
64 make_immutable => sub { () },
68 # this will actually convert the
69 # existing metaclass to an immutable
71 sub make_metaclass_immutable {
72 my ($self, $metaclass, %options) = @_;
74 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
75 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
76 $options{inline_destructor} = 0 unless exists $options{inline_destructor};
77 $options{constructor_name} = 'new' unless exists $options{constructor_name};
78 $options{debug} = 0 unless exists $options{debug};
80 if ($options{inline_accessors}) {
81 foreach my $attr_name ($metaclass->get_attribute_list) {
82 # inline the accessors
83 $metaclass->get_attribute($attr_name)
84 ->install_accessors(1);
88 if ($options{inline_constructor}) {
89 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
90 $metaclass->add_method(
91 $options{constructor_name},
92 $constructor_class->new(
94 metaclass => $metaclass,
96 ) unless $metaclass->has_method($options{constructor_name});
99 if ($options{inline_destructor}) {
100 (exists $options{destructor_class})
101 || confess "The 'inline_destructor' option is present, but "
102 . "no destructor class was specified";
104 my $destructor_class = $options{destructor_class};
106 my $destructor = $destructor_class->new(
107 options => \%options,
108 metaclass => $metaclass,
111 $metaclass->add_method('DESTROY' => $destructor)
113 # we allow the destructor to determine
114 # if it is needed or not, it can perform
115 # all sorts of checks because it has the
117 if $destructor->is_needed;
120 my $memoized_methods = $self->options->{memoize};
121 foreach my $method_name (keys %{$memoized_methods}) {
122 my $type = $memoized_methods->{$method_name};
124 ($metaclass->can($method_name))
125 || confess "Could not find the method '$method_name' in " . $metaclass->name;
127 if ($type eq 'ARRAY') {
128 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
130 elsif ($type eq 'HASH') {
131 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
133 elsif ($type eq 'SCALAR') {
134 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
138 $metaclass->{'___original_class'} = blessed($metaclass);
139 bless $metaclass => $self->immutable_metaclass->name;
142 sub make_metaclass_mutable {
143 my ($self, $immutable, %options) = @_;
145 my $original_class = $immutable->get_mutable_metaclass_name;
146 delete $immutable->{'___original_class'} ;
147 bless $immutable => $original_class;
149 my $memoized_methods = $self->options->{memoize};
150 foreach my $method_name (keys %{$memoized_methods}) {
151 my $type = $memoized_methods->{$method_name};
153 ($immutable->can($method_name))
154 || confess "Could not find the method '$method_name' in " . $immutable->name;
155 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
156 delete $immutable->{'___' . $method_name};
160 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
161 $immutable->remove_method('DESTROY')
162 if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class};
166 # 14:01 <@stevan> nah,. you shouldnt
167 # 14:01 <@stevan> they are just inlined
168 # 14:01 <@stevan> which is the default in Moose anyway
169 # 14:02 <@stevan> and adding new attributes will just DWIM
170 # 14:02 <@stevan> and you really cant change an attribute anyway
171 # if ($options{inline_accessors}) {
172 # foreach my $attr_name ($immutable->get_attribute_list) {
173 # my $attr = $immutable->get_attribute($attr_name);
174 # $attr->remove_accessors;
175 # $attr->install_accessors(0);
179 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
180 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
181 # 14:27 <@stevan> so I am not worried
182 $options{constructor_name} = 'new' unless exists $options{constructor_name};
183 if ($options{inline_constructor}) {
184 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
185 $immutable->remove_method( $options{constructor_name} )
186 if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class;
190 sub create_methods_for_immutable_metaclass {
193 my %methods = %DEFAULT_METHODS;
195 foreach my $read_only_method (@{$self->options->{read_only}}) {
196 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
199 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
201 $methods{$read_only_method} = sub {
202 confess "This method is read-only" if scalar @_ > 1;
203 goto &{$method->body}
207 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
208 $methods{$cannot_call_method} = sub {
209 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
213 my $memoized_methods = $self->options->{memoize};
214 foreach my $method_name (keys %{$memoized_methods}) {
215 my $type = $memoized_methods->{$method_name};
216 if ($type eq 'ARRAY') {
217 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
219 elsif ($type eq 'HASH') {
220 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
222 elsif ($type eq 'SCALAR') {
223 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
227 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
240 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
244 use Class::MOP::Immutable;
246 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
247 read_only => [qw/superclasses/],
255 remove_package_symbol
258 class_precedence_list => 'ARRAY',
259 compute_all_applicable_attributes => 'ARRAY',
260 get_meta_instance => 'SCALAR',
261 get_method_map => 'SCALAR',
265 $immutable_metaclass->make_metaclass_immutable(@_)
269 This is basically a module for applying a transformation on a given
270 metaclass. Current features include making methods read-only,
271 making methods un-callable and memoizing methods (in a type specific
274 This module is fairly new to the MOP, and quite possibly will be
275 expanded and further generalized as the need arises.
281 =item B<new ($metaclass, \%options)>
283 Given a C<$metaclass> and a set of C<%options> this module will
284 prepare an immutable version of the C<$metaclass>, which can then
285 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
290 Returns the options HASH set in C<new>.
294 Returns the metaclass set in C<new>.
296 =item B<immutable_metaclass>
298 Returns the immutable metaclass created within C<new>.
304 =item B<create_immutable_metaclass>
306 This will create the immutable version of the C<$metaclass>, but will
307 not actually change the original metaclass.
309 =item B<create_methods_for_immutable_metaclass>
311 This will create all the methods for the immutable metaclass based
312 on the C<%options> passed into C<new>.
314 =item B<make_metaclass_immutable (%options)>
316 This will actually change the C<$metaclass> into the immutable version.
318 =item B<make_metaclass_mutable (%options)>
320 This will change the C<$metaclass> into the mutable version by reversing
321 the immutable process. C<%options> should be the same options that were
322 given to make_metaclass_immutable.
328 Stevan Little E<lt>stevan@iinteractive.comE<gt>
330 =head1 COPYRIGHT AND LICENSE
332 Copyright 2006, 2007 by Infinity Interactive, Inc.
334 L<http://www.iinteractive.com>
336 This library is free software; you can redistribute it and/or modify
337 it under the same terms as Perl itself.