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