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