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.71_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     );
  40
  41     return $self;
  42 }
  43
  44 sub _new {
  45     my $class = shift;
  46     my $options = @_ == 1 ? $_[0] : {@_};
  47
  48     bless $options, $class;
  49 }
  50
  51 sub immutable_metaclass {
  52     my $self = shift;
  53
  54     $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
  55
  56     return $self->{'immutable_metaclass'};
  57 }
  58
  59 sub metaclass           { (shift)->{'metaclass'}           }
  60 sub options             { (shift)->{'options'}             }
  61
  62 sub create_immutable_metaclass {
  63     my $self = shift;
  64
  65     # NOTE:
  66     # The immutable version of the
  67     # metaclass is just a anon-class
  68     # which shadows the methods
  69     # appropriately
  70     $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
  71         superclasses => [ blessed($self->metaclass) ],
  72         methods      => $self->create_methods_for_immutable_metaclass,
  73     );
  74 }
  75
  76
  77 my %DEFAULT_METHODS = (
  78     # I don't really understand this, but removing it breaks tests (groditi)
  79     meta => sub {
  80         my $self = shift;
  81         # if it is not blessed, then someone is asking
  82         # for the meta of Class::MOP::Immutable
  83         return Class::MOP::Class->initialize($self) unless blessed($self);
  84         # otherwise, they are asking for the metaclass
  85         # which has been made immutable, which is itself
  86         # except in the cases where it is a metaclass itself
  87         # that has been made immutable and for that we need
  88         # to dig a bit ...
  89         if ($self->isa('Class::MOP::Class')) {
  90             return $self->{'___original_class'}->meta;
  91         }
  92         else {
  93             return $self;
  94         }
  95     },
  96     is_mutable     => sub { 0  },
  97     is_immutable   => sub { 1  },
  98     make_immutable => sub { () },
  99 );
 100
 101 # NOTE:
 102 # this will actually convert the
 103 # existing metaclass to an immutable
 104 # version of itself
 105 sub make_metaclass_immutable {
 106     my ($self, $metaclass, $options) = @_;
 107
 108     my %options = (
 109         inline_accessors   => 1,
 110         inline_constructor => 1,
 111         inline_destructor  => 0,
 112         constructor_name   => 'new',
 113         debug              => 0,
 114         %$options,
 115     );
 116
 117     %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
 118
 119     $self->_inline_accessors( $metaclass, \%options );
 120     $self->_inline_constructor( $metaclass, \%options );
 121     $self->_inline_destructor( $metaclass, \%options );
 122     $self->_check_memoized_methods( $metaclass, \%options );
 123
 124     $metaclass->{'___original_class'} = blessed($metaclass);
 125     bless $metaclass => $self->immutable_metaclass->name;
 126 }
 127
 128 sub _inline_accessors {
 129     my ( $self, $metaclass, $options ) = @_;
 130
 131     return unless $options->{inline_accessors};
 132
 133     foreach my $attr_name ( $metaclass->get_attribute_list ) {
 134         $metaclass->get_attribute($attr_name)->install_accessors(1);
 135     }
 136 }
 137
 138 sub _inline_constructor {
 139     my ( $self, $metaclass, $options ) = @_;
 140
 141     return unless $options->{inline_constructor};
 142
 143     return
 144         unless $options->{replace_constructor}
 145             or !$metaclass->has_method( $options->{constructor_name} );
 146
 147     my $constructor_class = $options->{constructor_class}
 148         || 'Class::MOP::Method::Constructor';
 149
 150     my $constructor = $constructor_class->new(
 151         options      => $options,
 152         metaclass    => $metaclass,
 153         is_inline    => 1,
 154         package_name => $metaclass->name,
 155         name         => $options->{constructor_name},
 156     );
 157
 158     $metaclass->add_method( $options->{constructor_name} => $constructor )
 159         if $constructor->can_be_inlined;
 160 }
 161
 162 sub _inline_destructor {
 163     my ( $self, $metaclass, $options ) = @_;
 164
 165     return unless $options->{inline_destructor};
 166
 167     ( exists $options->{destructor_class} )
 168         || confess "The 'inline_destructor' option is present, but "
 169         . "no destructor class was specified";
 170
 171     my $destructor_class = $options->{destructor_class};
 172
 173     return unless $destructor_class->is_needed($metaclass);
 174
 175     my $destructor = $destructor_class->new(
 176         options      => $options,
 177         metaclass    => $metaclass,
 178         package_name => $metaclass->name,
 179         name         => 'DESTROY'
 180     );
 181
 182     return unless $destructor->is_needed;
 183
 184     $metaclass->add_method( 'DESTROY' => $destructor )
 185 }
 186
 187 sub _check_memoized_methods {
 188     my ( $self, $metaclass, $options ) = @_;
 189
 190     my $memoized_methods = $self->options->{memoize};
 191     foreach my $method_name ( keys %{$memoized_methods} ) {
 192         my $type = $memoized_methods->{$method_name};
 193
 194         ( $metaclass->can($method_name) )
 195             || confess "Could not find the method '$method_name' in "
 196             . $metaclass->name;
 197     }
 198 }
 199
 200 sub create_methods_for_immutable_metaclass {
 201     my $self = shift;
 202
 203     my %methods   = %DEFAULT_METHODS;
 204     my $metaclass = $self->metaclass;
 205     my $meta      = $metaclass->meta;
 206
 207     $methods{get_mutable_metaclass_name}
 208         = sub { (shift)->{'___original_class'} };
 209
 210     $methods{immutable_transformer} = sub {$self};
 211
 212     return {
 213         %DEFAULT_METHODS,
 214         $self->_make_read_only_methods( $metaclass, $meta ),
 215         $self->_make_uncallable_methods( $metaclass, $meta ),
 216         $self->_make_memoized_methods( $metaclass, $meta ),
 217         $self->_make_wrapped_methods( $metaclass, $meta ),
 218         get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
 219         immutable_transformer      => sub {$self},
 220     };
 221 }
 222
 223 sub _make_read_only_methods {
 224     my ( $self, $metaclass, $meta ) = @_;
 225
 226     my %methods;
 227     foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
 228         my $method = $meta->find_method_by_name($read_only_method);
 229
 230         ( defined $method )
 231             || confess "Could not find the method '$read_only_method' in "
 232             . $metaclass->name;
 233
 234         $methods{$read_only_method} = sub {
 235             confess "This method is read-only" if scalar @_ > 1;
 236             goto &{ $method->body };
 237         };
 238     }
 239
 240     return %methods;
 241 }
 242
 243 sub _make_uncallable_methods {
 244     my ( $self, $metaclass, $meta ) = @_;
 245
 246     my %methods;
 247     foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
 248         $methods{$cannot_call_method} = sub {
 249             confess
 250                 "This method ($cannot_call_method) cannot be called on an immutable instance";
 251         };
 252     }
 253
 254     return %methods;
 255 }
 256
 257 sub _make_memoized_methods {
 258     my ( $self, $metaclass, $meta ) = @_;
 259
 260     my %methods;
 261
 262     my $memoized_methods = $self->options->{memoize};
 263     foreach my $method_name ( keys %{$memoized_methods} ) {
 264         my $type   = $memoized_methods->{$method_name};
 265         my $key    = '___' . $method_name;
 266         my $method = $meta->find_method_by_name($method_name);
 267
 268         if ( $type eq 'ARRAY' ) {
 269             $methods{$method_name} = sub {
 270                 @{ $_[0]->{$key} } = $method->execute( $_[0] )
 271                     if !exists $_[0]->{$key};
 272                 return @{ $_[0]->{$key} };
 273             };
 274         }
 275         elsif ( $type eq 'HASH' ) {
 276             $methods{$method_name} = sub {
 277                 %{ $_[0]->{$key} } = $method->execute( $_[0] )
 278                     if !exists $_[0]->{$key};
 279                 return %{ $_[0]->{$key} };
 280             };
 281         }
 282         elsif ( $type eq 'SCALAR' ) {
 283             $methods{$method_name} = sub {
 284                 $_[0]->{$key} = $method->execute( $_[0] )
 285                     if !exists $_[0]->{$key};
 286                 return $_[0]->{$key};
 287             };
 288         }
 289     }
 290
 291     return %methods;
 292 }
 293
 294 sub _make_wrapped_methods {
 295     my ( $self, $metaclass, $meta ) = @_;
 296
 297     my %methods;
 298
 299     my $wrapped_methods = $self->options->{wrapped};
 300
 301     foreach my $method_name ( keys %{$wrapped_methods} ) {
 302         my $method = $meta->find_method_by_name($method_name);
 303
 304         ( defined $method )
 305             || confess "Could not find the method '$method_name' in "
 306             . $metaclass->name;
 307
 308         my $wrapper = $wrapped_methods->{$method_name};
 309
 310         $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
 311     }
 312
 313     return %methods;
 314 }
 315
 316 sub make_metaclass_mutable {
 317     my ($self, $immutable, $options) = @_;
 318
 319     my %options = %$options;
 320
 321     my $original_class = $immutable->get_mutable_metaclass_name;
 322     delete $immutable->{'___original_class'} ;
 323     bless $immutable => $original_class;
 324
 325     my $memoized_methods = $self->options->{memoize};
 326     foreach my $method_name (keys %{$memoized_methods}) {
 327         my $type = $memoized_methods->{$method_name};
 328
 329         ($immutable->can($method_name))
 330           || confess "Could not find the method '$method_name' in " . $immutable->name;
 331         if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
 332             delete $immutable->{'___' . $method_name};
 333         }
 334     }
 335
 336     if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
 337         $immutable->remove_method('DESTROY')
 338           if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
 339     }
 340
 341     # NOTE:
 342     # 14:01 <@stevan> nah,. you shouldnt
 343     # 14:01 <@stevan> they are just inlined
 344     # 14:01 <@stevan> which is the default in Moose anyway
 345     # 14:02 <@stevan> and adding new attributes will just DWIM
 346     # 14:02 <@stevan> and you really cant change an attribute anyway
 347     # if ($options{inline_accessors}) {
 348     #     foreach my $attr_name ($immutable->get_attribute_list) {
 349     #         my $attr = $immutable->get_attribute($attr_name);
 350     #         $attr->remove_accessors;
 351     #         $attr->install_accessors(0);
 352     #     }
 353     # }
 354
 355     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
 356     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
 357     # 14:27 <@stevan> so I am not worried
 358     if ($options{inline_constructor}  && $immutable->has_method($options{constructor_name})) {
 359         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
 360         $immutable->remove_method( $options{constructor_name}  )
 361           if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
 362     }
 363 }
 364
 365 1;
 366
 367 __END__
 368
 369 =pod
 370
 371 =head1 NAME
 372
 373 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 374
 375 =head1 SYNOPSIS
 376
 377     use Class::MOP::Immutable;
 378
 379     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 380         read_only   => [qw/superclasses/],
 381         cannot_call => [qw/
 382             add_method
 383             alias_method
 384             remove_method
 385             add_attribute
 386             remove_attribute
 387             add_package_symbol
 388             remove_package_symbol
 389         /],
 390         memoize     => {
 391             class_precedence_list             => 'ARRAY',
 392             compute_all_applicable_attributes => 'ARRAY',
 393             get_meta_instance                 => 'SCALAR',
 394             get_method_map                    => 'SCALAR',
 395         }
 396     });
 397
 398     $immutable_metaclass->make_metaclass_immutable(@_)
 399
 400 =head1 DESCRIPTION
 401
 402 This is basically a module for applying a transformation on a given
 403 metaclass. Current features include making methods read-only,
 404 making methods un-callable and memoizing methods (in a type specific
 405 way too).
 406
 407 This module is not for the feint of heart, it does some whacky things
 408 to the metaclass in order to make it immutable. If you are just curious,
 409 I suggest you turn back now, there is nothing to see here.
 410
 411 =head1 METHODS
 412
 413 =over 4
 414
 415 =item B<new ($metaclass, \%options)>
 416
 417 Given a C<$metaclass> and a set of C<%options> this module will
 418 prepare an immutable version of the C<$metaclass>, which can then
 419 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 420 method.
 421
 422 =item B<options>
 423
 424 Returns the options HASH set in C<new>.
 425
 426 =item B<metaclass>
 427
 428 Returns the metaclass set in C<new>.
 429
 430 =item B<immutable_metaclass>
 431
 432 Returns the immutable metaclass created within C<new>.
 433
 434 =back
 435
 436 =over 4
 437
 438 =item B<create_immutable_metaclass>
 439
 440 This will create the immutable version of the C<$metaclass>, but will
 441 not actually change the original metaclass.
 442
 443 =item B<create_methods_for_immutable_metaclass>
 444
 445 This will create all the methods for the immutable metaclass based
 446 on the C<%options> passed into C<new>.
 447
 448 =item B<make_metaclass_immutable (%options)>
 449
 450 This will actually change the C<$metaclass> into the immutable version.
 451
 452 =item B<make_metaclass_mutable (%options)>
 453
 454 This will change the C<$metaclass> into the mutable version by reversing
 455 the immutable process. C<%options> should be the same options that were
 456 given to make_metaclass_immutable.
 457
 458 =back
 459
 460 =head1 AUTHORS
 461
 462 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 463
 464 =head1 COPYRIGHT AND LICENSE
 465
 466 Copyright 2006-2008 by Infinity Interactive, Inc.
 467
 468 L<http://www.iinteractive.com>
 469
 470 This library is free software; you can redistribute it and/or modify
 471 it under the same terms as Perl itself.
 472
 473 =cut