lib/Class/MOP/Immutable.pm

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