lib/Class/MOP/Class/Immutable.pm

   1
   2 package Class::MOP::Class::Immutable;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'looks_like_number';
   9
  10 our $VERSION   = '0.03';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Class';
  14
  15 # enforce the meta-circularity here
  16 # and hide the Immutable part
  17
  18 sub meta {
  19     my $self = shift;
  20     # if it is not blessed, then someone is asking
  21     # for the meta of Class::MOP::Class::Immutable
  22     return Class::MOP::Class->initialize($self) unless blessed($self);
  23     # otherwise, they are asking for the metaclass
  24     # which has been made immutable, which is itself
  25     return $self;
  26 }
  27
  28 # methods which can *not* be called
  29 for my $meth (qw(
  30     add_method
  31     alias_method
  32     remove_method
  33     add_attribute
  34     remove_attribute
  35     add_package_symbol
  36     remove_package_symbol
  37 )) {
  38     no strict 'refs';
  39     *{$meth} = sub {
  40         confess "Cannot call method '$meth' on an immutable instance";
  41     };
  42 }
  43
  44 sub get_package_symbol {
  45     my ($self, $variable) = @_;
  46     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  47     return *{$self->namespace->{$name}}{$type}
  48         if exists $self->namespace->{$name};
  49     # NOTE:
  50     # we have to do this here in order to preserve
  51     # perl's autovivification of variables. However
  52     # we do cut off direct access to add_package_symbol
  53     # as shown above.
  54     $self->Class::MOP::Package::add_package_symbol($variable);
  55 }
  56
  57 # NOTE:
  58 # superclasses is an accessor, so
  59 # it just cannot be changed
  60 sub superclasses {
  61     my $class = shift;
  62     (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
  63     @{$class->get_package_symbol('@ISA')};
  64 }
  65
  66 # predicates
  67
  68 sub is_mutable   { 0 }
  69 sub is_immutable { 1 }
  70
  71 sub make_immutable { () }
  72
  73 sub make_metaclass_immutable {
  74     my ($class, $metaclass, %options) = @_;
  75
  76     # NOTE:
  77     # i really need the // (defined-or) operator here
  78     $options{inline_accessors}   = 1     unless exists $options{inline_accessors};
  79     $options{inline_constructor} = 1     unless exists $options{inline_constructor};
  80     $options{constructor_name}   = 'new' unless exists $options{constructor_name};
  81     $options{debug}              = 0     unless exists $options{debug};
  82
  83     my $meta_instance = $metaclass->get_meta_instance;
  84     $metaclass->{'___class_precedence_list'}             = [ $metaclass->class_precedence_list ];
  85     $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
  86     $metaclass->{'___get_meta_instance'}                 = $meta_instance;
  87     $metaclass->{'___original_class'}                    = blessed($metaclass);
  88
  89     if ($options{inline_accessors}) {
  90         foreach my $attr_name ($metaclass->get_attribute_list) {
  91             my $attr = $metaclass->get_attribute($attr_name);
  92             $attr->install_accessors(1); # inline the accessors
  93         }
  94     }
  95
  96     if ($options{inline_constructor}) {
  97         $metaclass->add_method(
  98             $options{constructor_name},
  99             $class->_generate_inline_constructor(
 100                 \%options,
 101                 $meta_instance,
 102                 $metaclass->{'___compute_all_applicable_attributes'}
 103             )
 104         );
 105     }
 106
 107     # now cache the method map ...
 108     $metaclass->{'___method_map'} = $metaclass->get_method_map;
 109
 110     bless $metaclass => $class;
 111 }
 112
 113 sub _generate_inline_constructor {
 114     my ($class, $options, $meta_instance, $attrs) = @_;
 115     # TODO:
 116     # the %options should also include a both
 117     # a call 'initializer' and call 'SUPER::'
 118     # options, which should cover approx 90%
 119     # of the possible use cases (even if it
 120     # requires some adaption on the part of
 121     # the author, after all, nothing is free)
 122     my $source = 'sub {';
 123     $source .= "\n" . 'my ($class, %params) = @_;';
 124     $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
 125     $source .= ";\n" . (join ";\n" => map {
 126         $class->_generate_slot_initializer($meta_instance, $attrs, $_)
 127     } 0 .. (@$attrs - 1));
 128     $source .= ";\n" . 'return $instance';
 129     $source .= ";\n" . '}';
 130     warn $source if $options->{debug};
 131     my $code = eval $source;
 132     confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
 133     return $code;
 134 }
 135
 136 sub _generate_slot_initializer {
 137     my ($class, $meta_instance, $attrs, $index) = @_;
 138     my $attr = $attrs->[$index];
 139     my $default;
 140     if ($attr->has_default) {
 141         # NOTE:
 142         # default values can either be CODE refs
 143         # in which case we need to call them. Or
 144         # they can be scalars (strings/numbers)
 145         # in which case we can just deal with them
 146         # in the code we eval.
 147         if ($attr->is_default_a_coderef) {
 148             $default = '$attrs->[' . $index . ']->default($instance)';
 149         }
 150         else {
 151             $default = $attrs->[$index]->default;
 152             # make sure to quote strings ...
 153             unless (looks_like_number($default)) {
 154                 $default = "'$default'";
 155             }
 156         }
 157     }
 158     $meta_instance->inline_set_slot_value(
 159         '$instance',
 160         ("'" . $attr->name . "'"),
 161         ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
 162     )
 163 }
 164
 165 # cached methods
 166
 167 sub get_meta_instance                 {   (shift)->{'___get_meta_instance'}                  }
 168 sub class_precedence_list             { @{(shift)->{'___class_precedence_list'}}             }
 169 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
 170 sub get_mutable_metaclass_name        {   (shift)->{'___original_class'}                     }
 171 sub get_method_map                    {   (shift)->{'___method_map'}                         }
 172
 173 1;
 174
 175 __END__
 176
 177 =pod
 178
 179 =head1 NAME
 180
 181 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
 182
 183 =head1 SYNOPSIS
 184
 185   package Point;
 186   use metaclass;
 187
 188   __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
 189   __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
 190
 191   sub new {
 192       my $class = shift;
 193       $class->meta->new_object(@_);
 194   }
 195
 196   sub clear {
 197       my $self = shift;
 198       $self->x(0);
 199       $self->y(0);
 200   }
 201
 202   __PACKAGE__->meta->make_immutable();  # close the class
 203
 204 =head1 DESCRIPTION
 205
 206 Class::MOP offers many benefits to object oriented development but it
 207 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
 208 the typical hand coded Perl classes. This is because just about
 209 I<everything> is recalculated on the fly, and nothing is cached. The
 210 reason this is so, is because Perl itself allows you to modify virtually
 211 everything at runtime. Class::MOP::Class::Immutable offers an alternative
 212 to this.
 213
 214 By making your class immutable, you are promising that you will not
 215 modify your inheritence tree or the attributes of any classes in
 216 that tree. Since runtime modifications like this are fairly atypical
 217 (and usually recomended against), this is not usally a very hard promise
 218 to make. For making this promise you are given a wide range of
 219 optimization options which bring speed close to (and sometimes above)
 220 those of typical hand coded Perl.
 221
 222 =head1 METHODS
 223
 224 =over 4
 225
 226 =item B<meta>
 227
 228 This will return a B<Class::MOP::Class> instance which is related
 229 to this class.
 230
 231 =back
 232
 233 =head2 Introspection and Construction
 234
 235 =over 4
 236
 237 =item B<make_metaclass_immutable>
 238
 239 The arguments to C<Class::MOP::Class::make_immutable> are passed
 240 to this method, which
 241
 242 =over 4
 243
 244 =item I<inline_accessors (Bool)>
 245
 246 =item I<inline_constructor (Bool)>
 247
 248 =item I<debug (Bool)>
 249
 250 =item I<constructor_name (Str)>
 251
 252 =back
 253
 254 =item B<is_immutable>
 255
 256 =item B<is_mutable>
 257
 258 =item B<make_immutable>
 259
 260 =item B<get_mutable_metaclass_name>
 261
 262 =back
 263
 264 =head2 Methods which will die if you touch them.
 265
 266 =over 4
 267
 268 =item B<add_attribute>
 269
 270 =item B<add_method>
 271
 272 =item B<add_package_symbol>
 273
 274 =item B<alias_method>
 275
 276 =item B<remove_attribute>
 277
 278 =item B<remove_method>
 279
 280 =item B<remove_package_symbol>
 281
 282 =back
 283
 284 =head2 Methods which work slightly differently.
 285
 286 =over 4
 287
 288 =item B<superclasses>
 289
 290 This method becomes read-only in an immutable class.
 291
 292 =item B<get_package_symbol>
 293
 294 This method must handle package variable autovivification
 295 correctly, while still disallowing C<add_package_symbol>.
 296
 297 =back
 298
 299 =head2 Cached methods
 300
 301 =over 4
 302
 303 =item B<class_precedence_list>
 304
 305 =item B<compute_all_applicable_attributes>
 306
 307 =item B<get_meta_instance>
 308
 309 =item B<get_method_map>
 310
 311 =back
 312
 313 =head1 AUTHORS
 314
 315 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 316
 317 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 318
 319 =head1 COPYRIGHT AND LICENSE
 320
 321 Copyright 2006 by Infinity Interactive, Inc.
 322
 323 L<http://www.iinteractive.com>
 324
 325 This library is free software; you can redistribute it and/or modify
 326 it under the same terms as Perl itself.
 327
 328 =cut