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