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