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