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.82';
  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     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     );
  32
  33     my $self = $class->_new(
  34         'metaclass'           => delete $options{metaclass},
  35         'options'             => \%options,
  36         'immutable_metaclass' => undef,
  37         'inlined_constructor' => undef,
  38     );
  39
  40     return $self;
  41 }
  42
  43 sub _new {
  44     my $class = shift;
  45     my $options = @_ == 1 ? $_[0] : {@_};
  46
  47     bless $options, $class;
  48 }
  49
  50 sub immutable_metaclass {
  51     my $self = shift;
  52
  53     return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass;
  54 }
  55
  56 sub metaclass           { (shift)->{'metaclass'}           }
  57 sub options             { (shift)->{'options'}             }
  58 sub inlined_constructor { (shift)->{'inlined_constructor'} }
  59
  60 sub _create_immutable_metaclass {
  61     my $self = shift;
  62
  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(
  66         superclasses => [ blessed($self->metaclass) ],
  67         methods      => $self->_create_methods_for_immutable_metaclass,
  68     );
  69 }
  70
  71 sub make_metaclass_immutable {
  72     my $self = shift;
  73
  74     $self->_inline_accessors;
  75     $self->_inline_constructor;
  76     $self->_inline_destructor;
  77     $self->_check_memoized_methods;
  78
  79     my $metaclass = $self->metaclass;
  80
  81     $metaclass->{'___original_class'} = blessed($metaclass);
  82     bless $metaclass => $self->immutable_metaclass->name;
  83 }
  84
  85 sub _inline_accessors {
  86     my $self = shift;
  87
  88     return unless $self->options->{inline_accessors};
  89
  90     foreach my $attr_name ( $self->metaclass->get_attribute_list ) {
  91         $self->metaclass->get_attribute($attr_name)->install_accessors(1);
  92     }
  93 }
  94
  95 sub _inline_constructor {
  96     my $self = shift;
  97
  98     return unless $self->options->{inline_constructor};
  99
 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     }
 112
 113     my $constructor_class = $self->options->{constructor_class};
 114
 115     my $constructor = $constructor_class->new(
 116         options      => $self->options,
 117         metaclass    => $self->metaclass,
 118         is_inline    => 1,
 119         package_name => $self->metaclass->name,
 120         name         => $self->options->{constructor_name},
 121     );
 122
 123     if (   $self->options->{replace_constructor}
 124         or $constructor->can_be_inlined ) {
 125         $self->metaclass->add_method(
 126             $self->options->{constructor_name} => $constructor );
 127         $self->{inlined_constructor} = $constructor;
 128     }
 129 }
 130
 131 sub _inline_destructor {
 132     my $self = shift;
 133
 134     return unless $self->options->{inline_destructor};
 135
 136     ( exists $self->options->{destructor_class} )
 137         || confess "The 'inline_destructor' option is present, but "
 138         . "no destructor class was specified";
 139
 140     my $destructor_class = $self->options->{destructor_class};
 141
 142     return unless $destructor_class->is_needed( $self->metaclass );
 143
 144     my $destructor = $destructor_class->new(
 145         options      => $self->options,
 146         metaclass    => $self->metaclass,
 147         package_name => $self->metaclass->name,
 148         name         => 'DESTROY'
 149     );
 150
 151     $self->metaclass->add_method( 'DESTROY' => $destructor );
 152 }
 153
 154 sub _check_memoized_methods {
 155     my $self = shift;
 156
 157     my $memoized_methods = $self->options->{memoize};
 158     foreach my $method_name ( keys %{$memoized_methods} ) {
 159         my $type = $memoized_methods->{$method_name};
 160
 161         ( $self->metaclass->can($method_name) )
 162             || confess "Could not find the method '$method_name' in "
 163             . $self->metaclass->name;
 164     }
 165 }
 166 my %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')) {
 179             return Class::MOP::class_of($self->{'___original_class'});
 180         }
 181         else {
 182             return $self;
 183         }
 184     },
 185     is_mutable     => sub { 0  },
 186     is_immutable   => sub { 1  },
 187     make_immutable => sub { () },
 188 );
 189
 190 sub _create_methods_for_immutable_metaclass {
 191     my $self = shift;
 192
 193     my $metaclass = $self->metaclass;
 194     my $meta      = Class::MOP::class_of($metaclass);
 195
 196     return {
 197         %DEFAULT_METHODS,
 198         $self->_make_read_only_methods,
 199         $self->_make_uncallable_methods,
 200         $self->_make_memoized_methods,
 201         $self->_make_wrapped_methods,
 202         get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
 203         immutable_transformer      => sub {$self},
 204     };
 205 }
 206
 207 sub _make_read_only_methods {
 208     my $self = shift;
 209
 210     my $metameta = Class::MOP::class_of($self->metaclass);
 211
 212     my %methods;
 213     foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
 214         my $method = $metameta->find_method_by_name($read_only_method);
 215
 216         ( defined $method )
 217             || confess "Could not find the method '$read_only_method' in "
 218             . $self->metaclass->name;
 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
 229 sub _make_uncallable_methods {
 230     my $self = shift;
 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
 243 sub _make_memoized_methods {
 244     my $self = shift;
 245
 246     my %methods;
 247
 248     my $metameta = Class::MOP::class_of($self->metaclass);
 249
 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;
 254         my $method = $metameta->find_method_by_name($method_name);
 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
 282 sub _make_wrapped_methods {
 283     my $self = shift;
 284
 285     my %methods;
 286
 287     my $wrapped_methods = $self->options->{wrapped};
 288
 289     my $metameta = Class::MOP::class_of($self->metaclass);
 290
 291     foreach my $method_name ( keys %{$wrapped_methods} ) {
 292         my $method = $metameta->find_method_by_name($method_name);
 293
 294         ( defined $method )
 295             || confess "Could not find the method '$method_name' in "
 296             . $self->metaclass->name;
 297
 298         my $wrapper = $wrapped_methods->{$method_name};
 299
 300         $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
 301     }
 302
 303     return %methods;
 304 }
 305
 306 sub make_metaclass_mutable {
 307     my $self = shift;
 308
 309     my $metaclass = $self->metaclass;
 310
 311     my $original_class = $metaclass->get_mutable_metaclass_name;
 312     delete $metaclass->{'___original_class'};
 313     bless $metaclass => $original_class;
 314
 315     my $memoized_methods = $self->options->{memoize};
 316     foreach my $method_name ( keys %{$memoized_methods} ) {
 317         my $type = $memoized_methods->{$method_name};
 318
 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 };
 324         }
 325     }
 326
 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};
 332     }
 333
 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
 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} );
 362             $self->{inlined_constructor} = undef;
 363         }
 364     }
 365 }
 366
 367 1;
 368
 369 __END__
 370
 371 =pod
 372
 373 =head1 NAME
 374
 375 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 376
 377 =head1 SYNOPSIS
 378
 379     use Class::MOP::Immutable;
 380
 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
 390             remove_package_symbol
 391         /],
 392         memoize     => {
 393             class_precedence_list => 'ARRAY',
 394             get_all_attributes    => 'ARRAY',
 395             get_meta_instance     => 'SCALAR',
 396             get_method_map        => 'SCALAR',
 397         }
 398     });
 399
 400     $immutable_metaclass->make_metaclass_immutable;
 401
 402 =head1 DESCRIPTION
 403
 404 This class encapsulates the logic behind immutabilization.
 405
 406 This class provides generic immutabilization logic. Decisions about
 407 I<what> gets transformed are up to the caller.
 408
 409 Immutabilization allows for a number of transformations. It can ask
 410 the calling metaclass to inline methods such as the constructor,
 411 destructor, or accessors. It can memoize metaclass accessors
 412 themselves. It can also turn read-write accessors in the metaclass
 413 into read-only methods, and make attempting to set these values an
 414 error. Finally, it can make some methods throw an exception when they
 415 are called. This is used to disable methods that can alter the class.
 416
 417 =head1 METHODS
 418
 419 =over 4
 420
 421 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
 422
 423 This method takes a metaclass object (typically a L<Class::MOP::Class>
 424 object) and a hash of options.
 425
 426 It returns a new transformer, but does not actually do any
 427 transforming yet.
 428
 429 This method accepts the following options:
 430
 431 =over 8
 432
 433 =item * inline_accessors
 434
 435 =item * inline_constructor
 436
 437 =item * inline_destructor
 438
 439 These are all booleans indicating whether the specified method(s)
 440 should be inlined.
 441
 442 By default, accessors and the constructor are inlined, but not the
 443 destructor.
 444
 445 =item * replace_constructor
 446
 447 This is a boolean indicating whether an existing constructor should be
 448 replaced when inlining a constructor. This defaults to false.
 449
 450 =item * constructor_name
 451
 452 This is the constructor method name. This defaults to "new".
 453
 454 =item * constructor_class
 455
 456 The name of the method metaclass for constructors. It will be used to
 457 generate the inlined constructor. This defaults to
 458 "Class::MOP::Method::Constructor".
 459
 460 =item * destructor_class
 461
 462 The name of the method metaclass for destructors. It will be used to
 463 generate the inlined destructor. This defaults to
 464 "Class::MOP::Method::Denstructor".
 465
 466 =item * memoize
 467
 468 This option takes a hash reference. They keys are method names to be
 469 memoized, and the values are the type of data the method returns. This
 470 can be one of "SCALAR", "ARRAY", or "HASH".
 471
 472 =item * read_only
 473
 474 This option takes an array reference of read-write methods which will
 475 be made read-only. After they are transformed, attempting to set them
 476 will throw an error.
 477
 478 =item * cannot_call
 479
 480 This option takes an array reference of methods which cannot be called
 481 after immutabilization. Attempting to call these methods will throw an
 482 error.
 483
 484 =item * wrapped
 485
 486 This option takes a hash reference. The keys are method names and the
 487 body is a subroutine reference which will wrap the named method. This
 488 allows you to do some sort of custom transformation to a method.
 489
 490 =back
 491
 492 =item B<< $transformer->options >>
 493
 494 Returns a hash reference of the options passed to C<new>.
 495
 496 =item B<< $transformer->metaclass >>
 497
 498 Returns the metaclass object passed to C<new>.
 499
 500 =item B<< $transformer->immutable_metaclass >>
 501
 502 Returns the immutable metaclass object that is created by the
 503 transformation process.
 504
 505 =item B<< $transformer->inlined_constructor >>
 506
 507 If the constructor was inlined, this returns the constructor method
 508 object that was created to do this.
 509
 510 =item B<< $transformer->make_metaclass_immutable >>
 511
 512 Makes the transformer's metaclass immutable.
 513
 514 =item B<< $transformer->make_metaclass_mutable >>
 515
 516 Makes the transformer's metaclass mutable.
 517
 518 =back
 519
 520 =head1 AUTHORS
 521
 522 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 523
 524 =head1 COPYRIGHT AND LICENSE
 525
 526 Copyright 2006-2009 by Infinity Interactive, Inc.
 527
 528 L<http://www.iinteractive.com>
 529
 530 This library is free software; you can redistribute it and/or modify
 531 it under the same terms as Perl itself.
 532
 533 =cut