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.73';
  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 is basically a module for applying a transformation on a given
 410 metaclass. Current features include making methods read-only,
 411 making methods un-callable and memoizing methods (in a type specific
 412 way too).
 413
 414 This module is not for the feint of heart, it does some whacky things
 415 to the metaclass in order to make it immutable. If you are just curious,
 416 I suggest you turn back now, there is nothing to see here.
 417
 418 =head1 METHODS
 419
 420 =over 4
 421
 422 =item B<new ($metaclass, \%options)>
 423
 424 Given a C<$metaclass> and a set of C<%options> this module will
 425 prepare an immutable version of the C<$metaclass>, which can then
 426 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 427 method.
 428
 429 =item B<options>
 430
 431 Returns the options HASH set in C<new>.
 432
 433 =item B<metaclass>
 434
 435 Returns the metaclass set in C<new>.
 436
 437 =item B<immutable_metaclass>
 438
 439 Returns the immutable metaclass created within C<new>.
 440
 441 =back
 442
 443 =over 4
 444
 445 =item B<create_immutable_metaclass>
 446
 447 This will create the immutable version of the C<$metaclass>, but will
 448 not actually change the original metaclass.
 449
 450 =item B<create_methods_for_immutable_metaclass>
 451
 452 This will create all the methods for the immutable metaclass based
 453 on the C<%options> passed into C<new>.
 454
 455 =item B<make_metaclass_immutable (%options)>
 456
 457 This will actually change the C<$metaclass> into the immutable version.
 458
 459 =item B<make_metaclass_mutable (%options)>
 460
 461 This will change the C<$metaclass> into the mutable version by reversing
 462 the immutable process. C<%options> should be the same options that were
 463 given to make_metaclass_immutable.
 464
 465 =item B<inlined_constructor>
 466
 467 If the constructor was inlined, this returns the constructor method
 468 object that was created to do this.
 469
 470 =back
 471
 472 =head1 AUTHORS
 473
 474 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 475
 476 =head1 COPYRIGHT AND LICENSE
 477
 478 Copyright 2006-2008 by Infinity Interactive, Inc.
 479
 480 L<http://www.iinteractive.com>
 481
 482 This library is free software; you can redistribute it and/or modify
 483 it under the same terms as Perl itself.
 484
 485 =cut