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