fixed documentation for predicate to match behaviour changed in 0.43
[gitmo/Class-MOP.git] / lib / Class / MOP / Immutable.pm
CommitLineData
c23184fc 1
2package Class::MOP::Immutable;
3
4use strict;
5use warnings;
6
7use Class::MOP::Method::Constructor;
8
9use Carp 'confess';
10use Scalar::Util 'blessed';
11
6ff0d647 12our $VERSION = '0.03';
c23184fc 13our $AUTHORITY = 'cpan:STEVAN';
14
0ac992ee 15sub new {
c23184fc 16 my ($class, $metaclass, $options) = @_;
0ac992ee 17
c23184fc 18 my $self = bless {
19 '$!metaclass' => $metaclass,
20 '%!options' => $options,
21 '$!immutable_metaclass' => undef,
22 } => $class;
0ac992ee 23
c23184fc 24 # NOTE:
0ac992ee 25 # we initialize the immutable
c23184fc 26 # version of the metaclass here
27 $self->create_immutable_metaclass;
0ac992ee 28
c23184fc 29 return $self;
30}
31
32sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
33sub metaclass { (shift)->{'$!metaclass'} }
34sub options { (shift)->{'%!options'} }
35
36sub create_immutable_metaclass {
37 my $self = shift;
38
39 # NOTE:
0ac992ee 40 # The immutable version of the
c23184fc 41 # metaclass is just a anon-class
0ac992ee 42 # which shadows the methods
c23184fc 43 # appropriately
44 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
45 superclasses => [ blessed($self->metaclass) ],
46 methods => $self->create_methods_for_immutable_metaclass,
0ac992ee 47 );
c23184fc 48}
49
d9586da2 50
c23184fc 51my %DEFAULT_METHODS = (
d9586da2 52 # I don't really understand this, but removing it breaks tests (groditi)
0ac992ee 53 meta => sub {
c23184fc 54 my $self = shift;
0ac992ee 55 # if it is not blessed, then someone is asking
c23184fc 56 # for the meta of Class::MOP::Class::Immutable
57 return Class::MOP::Class->initialize($self) unless blessed($self);
0ac992ee 58 # otherwise, they are asking for the metaclass
c23184fc 59 # which has been made immutable, which is itself
60 return $self;
61 },
d9586da2 62 is_mutable => sub { 0 },
63 is_immutable => sub { 1 },
64 make_immutable => sub { () },
c23184fc 65);
66
67# NOTE:
0ac992ee 68# this will actually convert the
69# existing metaclass to an immutable
c23184fc 70# version of itself
71sub make_metaclass_immutable {
229910b5 72 my ($self, $metaclass, $options) = @_;
73
74 foreach my $pair (
75 [ inline_accessors => 1 ],
76 [ inline_constructor => 1 ],
77 [ inline_destructor => 0 ],
78 [ constructor_name => 'new' ],
79 [ debug => 0 ],
80 ) {
81 $options->{$pair->[0]} = $pair->[1] unless exists $options->{$pair->[0]};
82 }
0ac992ee 83
229910b5 84 my %options = %$options;
0ac992ee 85
c23184fc 86 if ($options{inline_accessors}) {
87 foreach my $attr_name ($metaclass->get_attribute_list) {
88 # inline the accessors
89 $metaclass->get_attribute($attr_name)
0ac992ee 90 ->install_accessors(1);
91 }
c23184fc 92 }
93
0ac992ee 94 if ($options{inline_constructor}) {
c23184fc 95 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
c23184fc 96 $metaclass->add_method(
97 $options{constructor_name},
98 $constructor_class->new(
0ac992ee 99 options => \%options,
100 metaclass => $metaclass,
565f0cbb 101 is_inline => 1,
c23184fc 102 )
103 ) unless $metaclass->has_method($options{constructor_name});
0ac992ee 104 }
105
106 if ($options{inline_destructor}) {
c23184fc 107 (exists $options{destructor_class})
108 || confess "The 'inline_destructor' option is present, but "
109 . "no destructor class was specified";
0ac992ee 110
c23184fc 111 my $destructor_class = $options{destructor_class};
0ac992ee 112
c23184fc 113 my $destructor = $destructor_class->new(
114 options => \%options,
115 metaclass => $metaclass,
116 );
0ac992ee 117
118 $metaclass->add_method('DESTROY' => $destructor)
c23184fc 119 # NOTE:
0ac992ee 120 # we allow the destructor to determine
c23184fc 121 # if it is needed or not, it can perform
0ac992ee 122 # all sorts of checks because it has the
123 # metaclass instance
c23184fc 124 if $destructor->is_needed;
0ac992ee 125 }
126
c23184fc 127 my $memoized_methods = $self->options->{memoize};
128 foreach my $method_name (keys %{$memoized_methods}) {
129 my $type = $memoized_methods->{$method_name};
0ac992ee 130
c23184fc 131 ($metaclass->can($method_name))
0ac992ee 132 || confess "Could not find the method '$method_name' in " . $metaclass->name;
133
c23184fc 134 if ($type eq 'ARRAY') {
135 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
136 }
137 elsif ($type eq 'HASH') {
0ac992ee 138 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
c23184fc 139 }
140 elsif ($type eq 'SCALAR') {
141 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
142 }
0ac992ee 143 }
144
0ac992ee 145 $metaclass->{'___original_class'} = blessed($metaclass);
c23184fc 146 bless $metaclass => $self->immutable_metaclass->name;
147}
148
0ac992ee 149sub make_metaclass_mutable {
229910b5 150 my ($self, $immutable, $options) = @_;
151
152 my %options = %$options;
0ac992ee 153
154 my $original_class = $immutable->get_mutable_metaclass_name;
155 delete $immutable->{'___original_class'} ;
156 bless $immutable => $original_class;
157
158 my $memoized_methods = $self->options->{memoize};
159 foreach my $method_name (keys %{$memoized_methods}) {
160 my $type = $memoized_methods->{$method_name};
161
162 ($immutable->can($method_name))
163 || confess "Could not find the method '$method_name' in " . $immutable->name;
164 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
165 delete $immutable->{'___' . $method_name};
166 }
167 }
168
169 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
170 $immutable->remove_method('DESTROY')
171 if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class};
172 }
173
b817e248 174 # NOTE:
175 # 14:01 <@stevan> nah,. you shouldnt
176 # 14:01 <@stevan> they are just inlined
177 # 14:01 <@stevan> which is the default in Moose anyway
178 # 14:02 <@stevan> and adding new attributes will just DWIM
179 # 14:02 <@stevan> and you really cant change an attribute anyway
180 # if ($options{inline_accessors}) {
181 # foreach my $attr_name ($immutable->get_attribute_list) {
182 # my $attr = $immutable->get_attribute($attr_name);
183 # $attr->remove_accessors;
184 # $attr->install_accessors(0);
185 # }
186 # }
187
188 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
189 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
190 # 14:27 <@stevan> so I am not worried
0ac992ee 191 if ($options{inline_constructor}) {
192 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
193 $immutable->remove_method( $options{constructor_name} )
194 if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class;
195 }
196}
197
c23184fc 198sub create_methods_for_immutable_metaclass {
199 my $self = shift;
0ac992ee 200
c23184fc 201 my %methods = %DEFAULT_METHODS;
0ac992ee 202
c23184fc 203 foreach my $read_only_method (@{$self->options->{read_only}}) {
204 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
0ac992ee 205
c23184fc 206 (defined $method)
207 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
0ac992ee 208
c23184fc 209 $methods{$read_only_method} = sub {
210 confess "This method is read-only" if scalar @_ > 1;
211 goto &{$method->body}
212 };
213 }
0ac992ee 214
c23184fc 215 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
216 $methods{$cannot_call_method} = sub {
217 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
218 };
0ac992ee 219 }
220
c23184fc 221 my $memoized_methods = $self->options->{memoize};
c23184fc 222 foreach my $method_name (keys %{$memoized_methods}) {
223 my $type = $memoized_methods->{$method_name};
224 if ($type eq 'ARRAY') {
225 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
226 }
227 elsif ($type eq 'HASH') {
228 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
229 }
230 elsif ($type eq 'SCALAR') {
231 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
0ac992ee 232 }
233 }
234
235 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
236
c23184fc 237 return \%methods;
238}
239
2401;
241
242__END__
243
244=pod
245
0ac992ee 246=head1 NAME
c23184fc 247
248Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
249
250=head1 SYNOPSIS
251
96e38ba6 252 use Class::MOP::Immutable;
0ac992ee 253
96e38ba6 254 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
255 read_only => [qw/superclasses/],
256 cannot_call => [qw/
257 add_method
258 alias_method
259 remove_method
260 add_attribute
261 remove_attribute
262 add_package_symbol
0ac992ee 263 remove_package_symbol
96e38ba6 264 /],
265 memoize => {
266 class_precedence_list => 'ARRAY',
0ac992ee 267 compute_all_applicable_attributes => 'ARRAY',
268 get_meta_instance => 'SCALAR',
269 get_method_map => 'SCALAR',
96e38ba6 270 }
0ac992ee 271 });
96e38ba6 272
273 $immutable_metaclass->make_metaclass_immutable(@_)
274
c23184fc 275=head1 DESCRIPTION
276
0ac992ee 277This is basically a module for applying a transformation on a given
278metaclass. Current features include making methods read-only,
96e38ba6 279making methods un-callable and memoizing methods (in a type specific
0ac992ee 280way too).
96e38ba6 281
0ac992ee 282This module is fairly new to the MOP, and quite possibly will be
96e38ba6 283expanded and further generalized as the need arises.
284
c23184fc 285=head1 METHODS
286
287=over 4
288
96e38ba6 289=item B<new ($metaclass, \%options)>
290
0ac992ee 291Given a C<$metaclass> and a set of C<%options> this module will
292prepare an immutable version of the C<$metaclass>, which can then
293be applied to the C<$metaclass> using the C<make_metaclass_immutable>
96e38ba6 294method.
295
c23184fc 296=item B<options>
297
96e38ba6 298Returns the options HASH set in C<new>.
299
c23184fc 300=item B<metaclass>
301
96e38ba6 302Returns the metaclass set in C<new>.
303
c23184fc 304=item B<immutable_metaclass>
305
96e38ba6 306Returns the immutable metaclass created within C<new>.
307
c23184fc 308=back
309
310=over 4
311
312=item B<create_immutable_metaclass>
313
0ac992ee 314This will create the immutable version of the C<$metaclass>, but will
315not actually change the original metaclass.
96e38ba6 316
c23184fc 317=item B<create_methods_for_immutable_metaclass>
318
0ac992ee 319This will create all the methods for the immutable metaclass based
96e38ba6 320on the C<%options> passed into C<new>.
321
0ac992ee 322=item B<make_metaclass_immutable (%options)>
c23184fc 323
96e38ba6 324This will actually change the C<$metaclass> into the immutable version.
325
0ac992ee 326=item B<make_metaclass_mutable (%options)>
327
328This will change the C<$metaclass> into the mutable version by reversing
329the immutable process. C<%options> should be the same options that were
330given to make_metaclass_immutable.
331
c23184fc 332=back
333
334=head1 AUTHORS
335
336Stevan Little E<lt>stevan@iinteractive.comE<gt>
337
338=head1 COPYRIGHT AND LICENSE
339
2367814a 340Copyright 2006, 2007 by Infinity Interactive, Inc.
c23184fc 341
342L<http://www.iinteractive.com>
343
344This library is free software; you can redistribute it and/or modify
0ac992ee 345it under the same terms as Perl itself.
c23184fc 346
347=cut