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