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