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