Pass @_ from deprecation wrapper
[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
c6e75cb3 12our $VERSION = '0.81';
d519662a 13$VERSION = eval $VERSION;
c23184fc 14our $AUTHORITY = 'cpan:STEVAN';
15
d7b2249e 16use base 'Class::MOP::Object';
17
0ac992ee 18sub new {
1ae8e211 19 my ($class, @args) = @_;
0ac992ee 20
44d6ea77 21 unshift @args, 'metaclass' if @args % 2 == 1;
22
23 my %options = (
24 inline_accessors => 1,
25 inline_constructor => 1,
26 inline_destructor => 0,
27 constructor_name => 'new',
28 constructor_class => 'Class::MOP::Method::Constructor',
29 debug => 0,
30 @args,
31 );
1ae8e211 32
0bfc85b8 33 my $self = $class->_new(
44d6ea77 34 'metaclass' => delete $options{metaclass},
35 'options' => \%options,
8683db0e 36 'immutable_metaclass' => undef,
ec845081 37 'inlined_constructor' => undef,
0bfc85b8 38 );
0ac992ee 39
c23184fc 40 return $self;
41}
42
0bfc85b8 43sub _new {
44 my $class = shift;
45 my $options = @_ == 1 ? $_[0] : {@_};
46
47 bless $options, $class;
48}
49
76c20e30 50sub immutable_metaclass {
51 my $self = shift;
52
44d6ea77 53 return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass;
76c20e30 54}
55
8683db0e 56sub metaclass { (shift)->{'metaclass'} }
57sub options { (shift)->{'options'} }
c1809cb1 58sub inlined_constructor { (shift)->{'inlined_constructor'} }
c23184fc 59
44d6ea77 60sub _create_immutable_metaclass {
c23184fc 61 my $self = shift;
62
44d6ea77 63 # NOTE: The immutable version of the metaclass is just a
64 # anon-class which shadows the methods appropriately
65 return Class::MOP::Class->create_anon_class(
c23184fc 66 superclasses => [ blessed($self->metaclass) ],
44d6ea77 67 methods => $self->_create_methods_for_immutable_metaclass,
0ac992ee 68 );
c23184fc 69}
70
c23184fc 71sub make_metaclass_immutable {
44d6ea77 72 my $self = shift;
1a84e3f3 73
44d6ea77 74 $self->_inline_accessors;
75 $self->_inline_constructor;
76 $self->_inline_destructor;
77 $self->_check_memoized_methods;
0ac992ee 78
44d6ea77 79 my $metaclass = $self->metaclass;
75f173e5 80
81 $metaclass->{'___original_class'} = blessed($metaclass);
82 bless $metaclass => $self->immutable_metaclass->name;
83}
c23184fc 84
75f173e5 85sub _inline_accessors {
44d6ea77 86 my $self = shift;
75f173e5 87
44d6ea77 88 return unless $self->options->{inline_accessors};
75f173e5 89
44d6ea77 90 foreach my $attr_name ( $self->metaclass->get_attribute_list ) {
91 $self->metaclass->get_attribute($attr_name)->install_accessors(1);
0ac992ee 92 }
75f173e5 93}
0ac992ee 94
75f173e5 95sub _inline_constructor {
44d6ea77 96 my $self = shift;
75f173e5 97
44d6ea77 98 return unless $self->options->{inline_constructor};
75f173e5 99
78a0df3a 100 unless ($self->options->{replace_constructor}
101 or !$self->metaclass->has_method(
102 $self->options->{constructor_name}
103 )) {
104 my $class = $self->metaclass->name;
105 warn "Not inlining a constructor for $class since it defines"
106 . " its own constructor.\n"
107 . "If you are certain you don't need to inline your"
108 . " constructor, specify inline_constructor => 0 in your"
109 . " call to $class->meta->make_immutable\n";
110 return;
111 }
2690a5c0 112
44d6ea77 113 my $constructor_class = $self->options->{constructor_class};
2690a5c0 114
f0de47d9 115 my $constructor = $constructor_class->new(
44d6ea77 116 options => $self->options,
117 metaclass => $self->metaclass,
f0de47d9 118 is_inline => 1,
44d6ea77 119 package_name => $self->metaclass->name,
120 name => $self->options->{constructor_name},
2690a5c0 121 );
122
44d6ea77 123 if ( $self->options->{replace_constructor}
124 or $constructor->can_be_inlined ) {
125 $self->metaclass->add_method(
126 $self->options->{constructor_name} => $constructor );
ec845081 127 $self->{inlined_constructor} = $constructor;
c1809cb1 128 }
75f173e5 129}
130
131sub _inline_destructor {
44d6ea77 132 my $self = shift;
75f173e5 133
44d6ea77 134 return unless $self->options->{inline_destructor};
75f173e5 135
44d6ea77 136 ( exists $self->options->{destructor_class} )
75f173e5 137 || confess "The 'inline_destructor' option is present, but "
138 . "no destructor class was specified";
139
44d6ea77 140 my $destructor_class = $self->options->{destructor_class};
75f173e5 141
44d6ea77 142 return unless $destructor_class->is_needed( $self->metaclass );
75f173e5 143
2690a5c0 144 my $destructor = $destructor_class->new(
44d6ea77 145 options => $self->options,
146 metaclass => $self->metaclass,
147 package_name => $self->metaclass->name,
2690a5c0 148 name => 'DESTROY'
149 );
150
44d6ea77 151 $self->metaclass->add_method( 'DESTROY' => $destructor );
75f173e5 152}
153
bc79f8a3 154sub _check_memoized_methods {
44d6ea77 155 my $self = shift;
0ac992ee 156
c23184fc 157 my $memoized_methods = $self->options->{memoize};
75f173e5 158 foreach my $method_name ( keys %{$memoized_methods} ) {
c23184fc 159 my $type = $memoized_methods->{$method_name};
0ac992ee 160
44d6ea77 161 ( $self->metaclass->can($method_name) )
75f173e5 162 || confess "Could not find the method '$method_name' in "
44d6ea77 163 . $self->metaclass->name;
0ac992ee 164 }
c23184fc 165}
44d6ea77 166my %DEFAULT_METHODS = (
167 # I don't really understand this, but removing it breaks tests (groditi)
168 meta => sub {
169 my $self = shift;
170 # if it is not blessed, then someone is asking
171 # for the meta of Class::MOP::Immutable
172 return Class::MOP::Class->initialize($self) unless blessed($self);
173 # otherwise, they are asking for the metaclass
174 # which has been made immutable, which is itself
175 # except in the cases where it is a metaclass itself
176 # that has been made immutable and for that we need
177 # to dig a bit ...
178 if ($self->isa('Class::MOP::Class')) {
e473d0c6 179 return Class::MOP::class_of($self->{'___original_class'});
44d6ea77 180 }
181 else {
182 return $self;
183 }
184 },
185 is_mutable => sub { 0 },
186 is_immutable => sub { 1 },
187 make_immutable => sub { () },
188);
c23184fc 189
44d6ea77 190sub _create_methods_for_immutable_metaclass {
fd93a7b6 191 my $self = shift;
192
fd93a7b6 193 my $metaclass = $self->metaclass;
e473d0c6 194 my $meta = Class::MOP::class_of($metaclass);
fd93a7b6 195
fd93a7b6 196 return {
197 %DEFAULT_METHODS,
44d6ea77 198 $self->_make_read_only_methods,
199 $self->_make_uncallable_methods,
200 $self->_make_memoized_methods,
201 $self->_make_wrapped_methods,
fd93a7b6 202 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
203 immutable_transformer => sub {$self},
204 };
205}
206
207sub _make_read_only_methods {
44d6ea77 208 my $self = shift;
209
e473d0c6 210 my $metameta = Class::MOP::class_of($self->metaclass);
fd93a7b6 211
212 my %methods;
213 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
44d6ea77 214 my $method = $metameta->find_method_by_name($read_only_method);
fd93a7b6 215
216 ( defined $method )
217 || confess "Could not find the method '$read_only_method' in "
44d6ea77 218 . $self->metaclass->name;
fd93a7b6 219
220 $methods{$read_only_method} = sub {
221 confess "This method is read-only" if scalar @_ > 1;
222 goto &{ $method->body };
223 };
224 }
225
226 return %methods;
227}
228
229sub _make_uncallable_methods {
44d6ea77 230 my $self = shift;
fd93a7b6 231
232 my %methods;
233 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
234 $methods{$cannot_call_method} = sub {
235 confess
236 "This method ($cannot_call_method) cannot be called on an immutable instance";
237 };
238 }
239
240 return %methods;
241}
242
243sub _make_memoized_methods {
44d6ea77 244 my $self = shift;
fd93a7b6 245
246 my %methods;
247
e473d0c6 248 my $metameta = Class::MOP::class_of($self->metaclass);
44d6ea77 249
fd93a7b6 250 my $memoized_methods = $self->options->{memoize};
251 foreach my $method_name ( keys %{$memoized_methods} ) {
252 my $type = $memoized_methods->{$method_name};
253 my $key = '___' . $method_name;
44d6ea77 254 my $method = $metameta->find_method_by_name($method_name);
fd93a7b6 255
256 if ( $type eq 'ARRAY' ) {
257 $methods{$method_name} = sub {
258 @{ $_[0]->{$key} } = $method->execute( $_[0] )
259 if !exists $_[0]->{$key};
260 return @{ $_[0]->{$key} };
261 };
262 }
263 elsif ( $type eq 'HASH' ) {
264 $methods{$method_name} = sub {
265 %{ $_[0]->{$key} } = $method->execute( $_[0] )
266 if !exists $_[0]->{$key};
267 return %{ $_[0]->{$key} };
268 };
269 }
270 elsif ( $type eq 'SCALAR' ) {
271 $methods{$method_name} = sub {
272 $_[0]->{$key} = $method->execute( $_[0] )
273 if !exists $_[0]->{$key};
274 return $_[0]->{$key};
275 };
276 }
277 }
278
279 return %methods;
280}
281
282sub _make_wrapped_methods {
44d6ea77 283 my $self = shift;
fd93a7b6 284
285 my %methods;
286
287 my $wrapped_methods = $self->options->{wrapped};
288
e473d0c6 289 my $metameta = Class::MOP::class_of($self->metaclass);
44d6ea77 290
fd93a7b6 291 foreach my $method_name ( keys %{$wrapped_methods} ) {
44d6ea77 292 my $method = $metameta->find_method_by_name($method_name);
fd93a7b6 293
294 ( defined $method )
295 || confess "Could not find the method '$method_name' in "
44d6ea77 296 . $self->metaclass->name;
fd93a7b6 297
298 my $wrapper = $wrapped_methods->{$method_name};
299
300 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
301 }
302
303 return %methods;
304}
305
0ac992ee 306sub make_metaclass_mutable {
44d6ea77 307 my $self = shift;
229910b5 308
44d6ea77 309 my $metaclass = $self->metaclass;
0ac992ee 310
44d6ea77 311 my $original_class = $metaclass->get_mutable_metaclass_name;
312 delete $metaclass->{'___original_class'};
313 bless $metaclass => $original_class;
0ac992ee 314
315 my $memoized_methods = $self->options->{memoize};
44d6ea77 316 foreach my $method_name ( keys %{$memoized_methods} ) {
0ac992ee 317 my $type = $memoized_methods->{$method_name};
318
44d6ea77 319 ( $metaclass->can($method_name) )
320 || confess "Could not find the method '$method_name' in "
321 . $metaclass->name;
322 if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
323 delete $metaclass->{ '___' . $method_name };
0ac992ee 324 }
325 }
326
44d6ea77 327 if ( $self->options->{inline_destructor}
328 && $metaclass->has_method('DESTROY') ) {
329 $metaclass->remove_method('DESTROY')
330 if blessed( $metaclass->get_method('DESTROY') ) eq
331 $self->options->{destructor_class};
0ac992ee 332 }
333
b817e248 334 # NOTE:
335 # 14:01 <@stevan> nah,. you shouldnt
336 # 14:01 <@stevan> they are just inlined
337 # 14:01 <@stevan> which is the default in Moose anyway
338 # 14:02 <@stevan> and adding new attributes will just DWIM
339 # 14:02 <@stevan> and you really cant change an attribute anyway
340 # if ($options{inline_accessors}) {
341 # foreach my $attr_name ($immutable->get_attribute_list) {
342 # my $attr = $immutable->get_attribute($attr_name);
343 # $attr->remove_accessors;
344 # $attr->install_accessors(0);
345 # }
346 # }
347
348 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
349 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
350 # 14:27 <@stevan> so I am not worried
44d6ea77 351 if ( $self->options->{inline_constructor}
352 && $metaclass->has_method( $self->options->{constructor_name} ) ) {
353 my $constructor_class = $self->options->{constructor_class}
354 || 'Class::MOP::Method::Constructor';
355
356 if (
357 blessed(
358 $metaclass->get_method( $self->options->{constructor_name} )
359 ) eq $constructor_class
360 ) {
361 $metaclass->remove_method( $self->options->{constructor_name} );
ec845081 362 $self->{inlined_constructor} = undef;
c1809cb1 363 }
0ac992ee 364 }
365}
366
c23184fc 3671;
368
369__END__
370
371=pod
372
0ac992ee 373=head1 NAME
c23184fc 374
375Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
376
377=head1 SYNOPSIS
378
96e38ba6 379 use Class::MOP::Immutable;
0ac992ee 380
96e38ba6 381 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
382 read_only => [qw/superclasses/],
383 cannot_call => [qw/
384 add_method
385 alias_method
386 remove_method
387 add_attribute
388 remove_attribute
389 add_package_symbol
0ac992ee 390 remove_package_symbol
96e38ba6 391 /],
392 memoize => {
1d63737e 393 class_precedence_list => 'ARRAY',
394 get_all_attributes => 'ARRAY',
395 get_meta_instance => 'SCALAR',
396 get_method_map => 'SCALAR',
96e38ba6 397 }
0ac992ee 398 });
96e38ba6 399
44d6ea77 400 $immutable_metaclass->make_metaclass_immutable;
96e38ba6 401
c23184fc 402=head1 DESCRIPTION
403
1407d471 404This class encapsulates the logic behind immutabilization.
96e38ba6 405
1407d471 406This class provides generic immutabilization logic. Decisions about
407I<what> gets transformed are up to the caller.
408
409Immutabilization allows for a number of transformations. It can ask
410the calling metaclass to inline methods such as the constructor,
411destructor, or accessors. It can memoize metaclass accessors
412themselves. It can also turn read-write accessors in the metaclass
413into read-only methods, and make attempting to set these values an
414error. Finally, it can make some methods throw an exception when they
415are called. This is used to disable methods that can alter the class.
96e38ba6 416
c23184fc 417=head1 METHODS
418
419=over 4
420
1407d471 421=item B<< Class::MOP::Immutable->new($metaclass, %options) >>
96e38ba6 422
1407d471 423This method takes a metaclass object (typically a L<Class::MOP::Class>
424object) and a hash of options.
96e38ba6 425
1407d471 426It returns a new transformer, but does not actually do any
427transforming yet.
c23184fc 428
1407d471 429This method accepts the following options:
96e38ba6 430
1407d471 431=over 8
c23184fc 432
1407d471 433=item * inline_accessors
96e38ba6 434
1407d471 435=item * inline_constructor
c23184fc 436
1407d471 437=item * inline_destructor
96e38ba6 438
1407d471 439These are all booleans indicating whether the specified method(s)
440should be inlined.
c23184fc 441
1407d471 442By default, accessors and the constructor are inlined, but not the
443destructor.
444
445=item * replace_constructor
446
447This is a boolean indicating whether an existing constructor should be
448replaced when inlining a constructor. This defaults to false.
449
450=item * constructor_name
451
452This is the constructor method name. This defaults to "new".
453
454=item * constructor_class
455
456The name of the method metaclass for constructors. It will be used to
457generate the inlined constructor. This defaults to
458"Class::MOP::Method::Constructor".
459
460=item * destructor_class
c23184fc 461
1407d471 462The name of the method metaclass for destructors. It will be used to
463generate the inlined destructor. This defaults to
464"Class::MOP::Method::Denstructor".
c23184fc 465
1407d471 466=item * memoize
467
468This option takes a hash reference. They keys are method names to be
469memoized, and the values are the type of data the method returns. This
470can be one of "SCALAR", "ARRAY", or "HASH".
471
472=item * read_only
473
474This option takes an array reference of read-write methods which will
475be made read-only. After they are transformed, attempting to set them
476will throw an error.
477
478=item * cannot_call
479
480This option takes an array reference of methods which cannot be called
481after immutabilization. Attempting to call these methods will throw an
482error.
483
484=item * wrapped
485
486This option takes a hash reference. The keys are method names and the
487body is a subroutine reference which will wrap the named method. This
488allows you to do some sort of custom transformation to a method.
489
490=back
96e38ba6 491
1407d471 492=item B<< $transformer->options >>
c23184fc 493
1407d471 494Returns a hash reference of the options passed to C<new>.
96e38ba6 495
1407d471 496=item B<< $transformer->metaclass >>
c23184fc 497
1407d471 498Returns the metaclass object passed to C<new>.
96e38ba6 499
1407d471 500=item B<< $transformer->immutable_metaclass >>
0ac992ee 501
1407d471 502Returns the immutable metaclass object that is created by the
503transformation process.
0ac992ee 504
1407d471 505=item B<< $transformer->inlined_constructor >>
c1809cb1 506
ec845081 507If the constructor was inlined, this returns the constructor method
508object that was created to do this.
509
111205d6 510=item B<< $transformer->make_metaclass_immutable >>
511
512Makes the transformer's metaclass immutable.
513
514=item B<< $transformer->make_metaclass_mutable >>
515
516Makes the transformer's metaclass mutable.
517
c23184fc 518=back
519
520=head1 AUTHORS
521
522Stevan Little E<lt>stevan@iinteractive.comE<gt>
523
524=head1 COPYRIGHT AND LICENSE
525
070bb6c9 526Copyright 2006-2009 by Infinity Interactive, Inc.
c23184fc 527
528L<http://www.iinteractive.com>
529
530This library is free software; you can redistribute it and/or modify
0ac992ee 531it under the same terms as Perl itself.
c23184fc 532
533=cut