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