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