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         # NOTE:
 109         # default values can either be CODE refs
 110         # in which case we need to call them. Or
 111         # they can be scalars (strings/numbers)
 112         # in which case we can just deal with them
 113         # in the code we eval.
 114         if ($attr->is_default_a_coderef) {
 115             $default = '$attrs->[' . $index . ']->default($instance)';
 116         }
 117         else {
 118             $default = $attrs->[$index]->default;
 119             # make sure to quote strings ...
 120             unless (looks_like_number($default)) {
 121                 $default = "'$default'";
 122             }
 123         }
 124     }
 125     $meta_instance->inline_set_slot_value(
 126         '$instance',
 127         ("'" . $attr->name . "'"),
 128         ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
 129     )
 130 }
 131
 132 # cached methods
 133
 134 sub get_meta_instance                 {   (shift)->{'___get_meta_instance'}                  }
 135 sub class_precedence_list             { @{(shift)->{'___class_precedence_list'}}             }
 136 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
 137 sub get_mutable_metaclass_name        {   (shift)->{'___original_class'}                     }
 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 =item B<get_mutable_metaclass_name>
 227
 228 =back
 229
 230 =head2 Methods which will die if you touch them.
 231
 232 =over 4
 233
 234 =item B<add_attribute>
 235
 236 =item B<add_method>
 237
 238 =item B<add_package_symbol>
 239
 240 =item B<alias_method>
 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 AUTHORS
 265
 266 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 267
 268 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 269
 270 =head1 COPYRIGHT AND LICENSE
 271
 272 Copyright 2006 by Infinity Interactive, Inc.
 273
 274 L<http://www.iinteractive.com>
 275
 276 This library is free software; you can redistribute it and/or modify
 277 it under the same terms as Perl itself.
 278
 279 =cut