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->_memoize_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     $metaclass->add_method(
 151         $options->{constructor_name},
 152         $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
 161 }
 162
 163 sub _inline_destructor {
 164     my ( $self, $metaclass, $options ) = @_;
 165
 166     return unless $options->{inline_destructor};
 167
 168     ( exists $options->{destructor_class} )
 169         || confess "The 'inline_destructor' option is present, but "
 170         . "no destructor class was specified";
 171
 172     my $destructor_class = $options->{destructor_class};
 173
 174     return unless $destructor_class->is_needed($metaclass);
 175
 176     my $destructor = $destructor_class->new(
 177         options      => $options,
 178         metaclass    => $metaclass,
 179         package_name => $metaclass->name,
 180         name         => 'DESTROY'
 181     );
 182
 183     return unless $destructor->is_needed;
 184
 185     $metaclass->add_method( 'DESTROY' => $destructor )
 186 }
 187
 188 sub _memoize_methods {
 189     my ( $self, $metaclass, $options ) = @_;
 190
 191     my $memoized_methods = $self->options->{memoize};
 192     foreach my $method_name ( keys %{$memoized_methods} ) {
 193         my $type = $memoized_methods->{$method_name};
 194
 195         ( $metaclass->can($method_name) )
 196             || confess "Could not find the method '$method_name' in "
 197             . $metaclass->name;
 198     }
 199 }
 200
 201 sub make_metaclass_mutable {
 202     my ($self, $immutable, $options) = @_;
 203
 204     my %options = %$options;
 205
 206     my $original_class = $immutable->get_mutable_metaclass_name;
 207     delete $immutable->{'___original_class'} ;
 208     bless $immutable => $original_class;
 209
 210     my $memoized_methods = $self->options->{memoize};
 211     foreach my $method_name (keys %{$memoized_methods}) {
 212         my $type = $memoized_methods->{$method_name};
 213
 214         ($immutable->can($method_name))
 215           || confess "Could not find the method '$method_name' in " . $immutable->name;
 216         if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
 217             delete $immutable->{'___' . $method_name};
 218         }
 219     }
 220
 221     if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
 222         $immutable->remove_method('DESTROY')
 223           if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
 224     }
 225
 226     # NOTE:
 227     # 14:01 <@stevan> nah,. you shouldnt
 228     # 14:01 <@stevan> they are just inlined
 229     # 14:01 <@stevan> which is the default in Moose anyway
 230     # 14:02 <@stevan> and adding new attributes will just DWIM
 231     # 14:02 <@stevan> and you really cant change an attribute anyway
 232     # if ($options{inline_accessors}) {
 233     #     foreach my $attr_name ($immutable->get_attribute_list) {
 234     #         my $attr = $immutable->get_attribute($attr_name);
 235     #         $attr->remove_accessors;
 236     #         $attr->install_accessors(0);
 237     #     }
 238     # }
 239
 240     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
 241     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
 242     # 14:27 <@stevan> so I am not worried
 243     if ($options{inline_constructor}  && $immutable->has_method($options{constructor_name})) {
 244         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
 245         $immutable->remove_method( $options{constructor_name}  )
 246           if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
 247     }
 248 }
 249
 250 sub create_methods_for_immutable_metaclass {
 251     my $self = shift;
 252
 253     my %methods = %DEFAULT_METHODS;
 254     my $metaclass = $self->metaclass;
 255     my $meta = $metaclass->meta;
 256
 257     foreach my $read_only_method (@{$self->options->{read_only}}) {
 258         my $method = $meta->find_method_by_name($read_only_method);
 259
 260         (defined $method)
 261             || confess "Could not find the method '$read_only_method' in " . $metaclass->name;
 262
 263         $methods{$read_only_method} = sub {
 264             confess "This method is read-only" if scalar @_ > 1;
 265             goto &{$method->body}
 266         };
 267     }
 268
 269     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 270         $methods{$cannot_call_method} = sub {
 271             confess "This method ($cannot_call_method) cannot be called on an immutable instance";
 272         };
 273     }
 274
 275     my $memoized_methods = $self->options->{memoize};
 276     foreach my $method_name (keys %{$memoized_methods}) {
 277         my $type = $memoized_methods->{$method_name};
 278         my $key = '___' . $method_name;
 279         my $method = $meta->find_method_by_name($method_name);
 280
 281         if ($type eq 'ARRAY') {
 282             $methods{$method_name} = sub {
 283                 @{$_[0]->{$key}} = $method->execute($_[0])
 284                     if !exists $_[0]->{$key};
 285                 return @{$_[0]->{$key}};
 286             };
 287         }
 288         elsif ($type eq 'HASH') {
 289             $methods{$method_name} = sub {
 290                 %{$_[0]->{$key}} = $method->execute($_[0])
 291                     if !exists $_[0]->{$key};
 292                 return %{$_[0]->{$key}};
 293             };
 294         }
 295         elsif ($type eq 'SCALAR') {
 296             $methods{$method_name} = sub {
 297                 $_[0]->{$key} = $method->execute($_[0])
 298                     if !exists $_[0]->{$key};
 299                 return $_[0]->{$key};
 300             };
 301         }
 302     }
 303
 304     my $wrapped_methods = $self->options->{wrapped};
 305
 306     foreach my $method_name (keys %{ $wrapped_methods }) {
 307         my $method = $meta->find_method_by_name($method_name);
 308
 309         (defined $method)
 310             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 311
 312         my $wrapper = $wrapped_methods->{$method_name};
 313
 314         $methods{$method_name} = sub { $wrapper->($method, @_) };
 315     }
 316
 317     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 318
 319     $methods{immutable_transformer} = sub { $self };
 320
 321     return \%methods;
 322 }
 323
 324 1;
 325
 326 __END__
 327
 328 =pod
 329
 330 =head1 NAME
 331
 332 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 333
 334 =head1 SYNOPSIS
 335
 336     use Class::MOP::Immutable;
 337
 338     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 339         read_only   => [qw/superclasses/],
 340         cannot_call => [qw/
 341             add_method
 342             alias_method
 343             remove_method
 344             add_attribute
 345             remove_attribute
 346             add_package_symbol
 347             remove_package_symbol
 348         /],
 349         memoize     => {
 350             class_precedence_list             => 'ARRAY',
 351             compute_all_applicable_attributes => 'ARRAY',
 352             get_meta_instance                 => 'SCALAR',
 353             get_method_map                    => 'SCALAR',
 354         }
 355     });
 356
 357     $immutable_metaclass->make_metaclass_immutable(@_)
 358
 359 =head1 DESCRIPTION
 360
 361 This is basically a module for applying a transformation on a given
 362 metaclass. Current features include making methods read-only,
 363 making methods un-callable and memoizing methods (in a type specific
 364 way too).
 365
 366 This module is not for the feint of heart, it does some whacky things
 367 to the metaclass in order to make it immutable. If you are just curious,
 368 I suggest you turn back now, there is nothing to see here.
 369
 370 =head1 METHODS
 371
 372 =over 4
 373
 374 =item B<new ($metaclass, \%options)>
 375
 376 Given a C<$metaclass> and a set of C<%options> this module will
 377 prepare an immutable version of the C<$metaclass>, which can then
 378 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 379 method.
 380
 381 =item B<options>
 382
 383 Returns the options HASH set in C<new>.
 384
 385 =item B<metaclass>
 386
 387 Returns the metaclass set in C<new>.
 388
 389 =item B<immutable_metaclass>
 390
 391 Returns the immutable metaclass created within C<new>.
 392
 393 =back
 394
 395 =over 4
 396
 397 =item B<create_immutable_metaclass>
 398
 399 This will create the immutable version of the C<$metaclass>, but will
 400 not actually change the original metaclass.
 401
 402 =item B<create_methods_for_immutable_metaclass>
 403
 404 This will create all the methods for the immutable metaclass based
 405 on the C<%options> passed into C<new>.
 406
 407 =item B<make_metaclass_immutable (%options)>
 408
 409 This will actually change the C<$metaclass> into the immutable version.
 410
 411 =item B<make_metaclass_mutable (%options)>
 412
 413 This will change the C<$metaclass> into the mutable version by reversing
 414 the immutable process. C<%options> should be the same options that were
 415 given to make_metaclass_immutable.
 416
 417 =back
 418
 419 =head1 AUTHORS
 420
 421 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 422
 423 =head1 COPYRIGHT AND LICENSE
 424
 425 Copyright 2006-2008 by Infinity Interactive, Inc.
 426
 427 L<http://www.iinteractive.com>
 428
 429 This library is free software; you can redistribute it and/or modify
 430 it under the same terms as Perl itself.
 431
 432 =cut