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