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