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