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