lib/Moose/Meta/Method/Accessor.pm

   1
   2 package Moose::Meta::Method::Accessor;
   3
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION   = '0.63';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 use base 'Moose::Meta::Method',
  12          'Class::MOP::Method::Accessor';
  13
  14 sub _error_thrower {
  15     my $self = shift;
  16     ( ref $self && $self->associated_attribute ) || $self->SUPER::_error_thrower();
  17 }
  18
  19 sub _eval_code {
  20     my ( $self, $code ) = @_;
  21
  22     # NOTE:
  23     # set up the environment
  24     my $attr = $self->associated_attribute;
  25     my $type_constraint_obj = $attr->type_constraint;
  26     my $environment = {
  27         '$attr' => \$attr,
  28         '$attr_name' => \$attr->name,
  29         '$meta' => \$self,
  30         '$type_constraint_obj' => \$type_constraint_obj,
  31         '$type_constraint_name' => \($type_constraint_obj && $type_constraint_obj->name),
  32         '$type_constraint' => \($type_constraint_obj
  33                                    ? $type_constraint_obj->_compiled_type_constraint
  34                                    : undef),
  35     };
  36
  37     #warn "code for $attr_name =>\n" . $code . "\n";
  38     my $sub = $self->_eval_closure($environment, $code);
  39     $self->throw_error("Could not create writer for '${\$self->associated_attribute->name}' because $@ \n code: $code", error => $@, data => $code ) if $@;
  40     return $sub;
  41
  42 }
  43
  44 sub generate_accessor_method_inline {
  45     my $self        = $_[0];
  46     my $attr        = $self->associated_attribute;
  47     my $attr_name   = $attr->name;
  48     my $inv         = '$_[0]';
  49     my $slot_access = $self->_inline_access($inv, $attr_name);
  50     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  51
  52     $self->_eval_code('sub { ' . "\n"
  53     . $self->_inline_pre_body(@_) . "\n"
  54     . 'if (scalar(@_) >= 2) {' . "\n"
  55         . $self->_inline_copy_value . "\n"
  56         . $self->_inline_check_required . "\n"
  57         . $self->_inline_check_coercion . "\n"
  58         . $self->_inline_check_constraint($value_name) . "\n"
  59         . $self->_inline_store($inv, $value_name) . "\n"
  60         . $self->_inline_trigger($inv, $value_name) . "\n"
  61     . ' }' . "\n"
  62     . $self->_inline_check_lazy($inv) . "\n"
  63     . $self->_inline_post_body(@_) . "\n"
  64     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
  65     . ' }');
  66 }
  67
  68 sub generate_writer_method_inline {
  69     my $self        = $_[0];
  70     my $attr        = $self->associated_attribute;
  71     my $attr_name   = $attr->name;
  72     my $inv         = '$_[0]';
  73     my $slot_access = $self->_inline_get($inv, $attr_name);
  74     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  75
  76     $self->_eval_code('sub { '
  77     . $self->_inline_pre_body(@_)
  78     . $self->_inline_copy_value
  79     . $self->_inline_check_required
  80     . $self->_inline_check_coercion
  81     . $self->_inline_check_constraint($value_name)
  82     . $self->_inline_store($inv, $value_name)
  83     . $self->_inline_post_body(@_)
  84     . $self->_inline_trigger($inv, $value_name)
  85     . ' }');
  86 }
  87
  88 sub generate_reader_method_inline {
  89     my $self        = $_[0];
  90     my $attr        = $self->associated_attribute;
  91     my $attr_name   = $attr->name;
  92     my $inv         = '$_[0]';
  93     my $slot_access = $self->_inline_get($inv, $attr_name);
  94
  95     $self->_eval_code('sub {'
  96     . $self->_inline_pre_body(@_)
  97     . $self->_inline_throw_error('"Cannot assign a value to a read-only accessor"', 'data => \@_') . ' if @_ > 1;'
  98     . $self->_inline_check_lazy($inv)
  99     . $self->_inline_post_body(@_)
 100     . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
 101     . '}');
 102 }
 103
 104 sub _inline_copy_value {
 105     return '' unless shift->_value_needs_copy;
 106     return 'my $val = $_[1];'
 107 }
 108
 109 sub _value_needs_copy {
 110     my $attr = (shift)->associated_attribute;
 111     return $attr->should_coerce;
 112 }
 113
 114 sub generate_reader_method { shift->generate_reader_method_inline(@_) }
 115 sub generate_writer_method { shift->generate_writer_method_inline(@_) }
 116 sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
 117 sub generate_predicate_method { shift->generate_predicate_method_inline(@_) }
 118 sub generate_clearer_method { shift->generate_clearer_method_inline(@_) }
 119
 120 sub _inline_pre_body  { '' }
 121 sub _inline_post_body { '' }
 122
 123 sub _inline_check_constraint {
 124     my ($self, $value) = @_;
 125
 126     my $attr = $self->associated_attribute;
 127     my $attr_name = $attr->name;
 128
 129     return '' unless $attr->has_type_constraint;
 130
 131     my $type_constraint_name = $attr->type_constraint->name;
 132
 133     qq{\$type_constraint->($value) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) does not pass the type constraint because: " . \$type_constraint_obj->get_message($value)}, "data => $value") . ";";
 134 }
 135
 136 sub _inline_check_coercion {
 137     my $attr = (shift)->associated_attribute;
 138
 139     return '' unless $attr->should_coerce;
 140     return '$val = $attr->type_constraint->coerce($_[1]);'
 141 }
 142
 143 sub _inline_check_required {
 144     my $self = shift;
 145     my $attr = $self->associated_attribute;
 146
 147     my $attr_name = $attr->name;
 148
 149     return '' unless $attr->is_required;
 150     return qq{(\@_ >= 2) || } . $self->_inline_throw_error(qq{"Attribute ($attr_name) is required, so cannot be set to undef"}) . ';' # defined $_[1] is not good enough
 151 }
 152
 153 sub _inline_check_lazy {
 154     my ($self, $instance) = @_;
 155
 156     my $attr = $self->associated_attribute;
 157
 158     return '' unless $attr->is_lazy;
 159
 160     my $slot_access = $self->_inline_access($instance, $attr->name);
 161
 162     my $slot_exists = $self->_inline_has($instance, $attr->name);
 163
 164     my $code = 'unless (' . $slot_exists . ') {' . "\n";
 165     if ($attr->has_type_constraint) {
 166         if ($attr->has_default || $attr->has_builder) {
 167             if ($attr->has_default) {
 168                 $code .= '    my $default = $attr->default(' . $instance . ');'."\n";
 169             }
 170             elsif ($attr->has_builder) {
 171                 $code .= '    my $default;'."\n".
 172                          '    if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
 173                          '        $default = '.$instance.'->$builder; '. "\n    } else {\n" .
 174                          '        ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name') .
 175                          ';'. "\n    }";
 176             }
 177             $code .= '    $default = $type_constraint_obj->coerce($default);'."\n"  if $attr->should_coerce;
 178             $code .= '    ($type_constraint->($default))' .
 179                      '            || ' . $self->_inline_throw_error('"Attribute (" . $attr_name . ") does not pass the type constraint ("' .
 180                      '           . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef")' ) . ';'
 181                      . "\n";
 182             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
 183         }
 184         else {
 185             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
 186         }
 187
 188     } else {
 189         if ($attr->has_default) {
 190             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";
 191         }
 192         elsif ($attr->has_builder) {
 193             $code .= '    if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
 194                   .  '       ' . $self->_inline_init_slot($attr, $instance, $slot_access, ($instance . '->$builder'))
 195                   .  "\n    } else {\n"
 196                   .  '        ' . $self->_inline_throw_error(q{sprintf "%s does not support builder method '%s' for attribute '%s'", ref(} . $instance . ') || '.$instance.', $attr->builder, $attr->name')
 197                   .  ';'. "\n    }";
 198         }
 199         else {
 200             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
 201         }
 202     }
 203     $code .= "}\n";
 204     return $code;
 205 }
 206
 207 sub _inline_init_slot {
 208     my ($self, $attr, $inv, $slot_access, $value) = @_;
 209     if ($attr->has_initializer) {
 210         return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
 211     }
 212     else {
 213         return ($slot_access . ' = ' . $value . ';');
 214     }
 215 }
 216
 217 sub _inline_store {
 218     my ($self, $instance, $value) = @_;
 219     my $attr = $self->associated_attribute;
 220
 221     my $mi = $attr->associated_class->get_meta_instance;
 222     my $slot_name = sprintf "'%s'", $attr->slots;
 223
 224     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 225     $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 226         if $attr->is_weak_ref;
 227     return $code;
 228 }
 229
 230 sub _inline_trigger {
 231     my ($self, $instance, $value) = @_;
 232     my $attr = $self->associated_attribute;
 233     return '' unless $attr->has_trigger;
 234     return sprintf('$attr->trigger->(%s, %s);', $instance, $value);
 235 }
 236
 237 sub _inline_get {
 238     my ($self, $instance) = @_;
 239     my $attr = $self->associated_attribute;
 240
 241     my $mi = $attr->associated_class->get_meta_instance;
 242     my $slot_name = sprintf "'%s'", $attr->slots;
 243
 244     return $mi->inline_get_slot_value($instance, $slot_name);
 245 }
 246
 247 sub _inline_access {
 248     my ($self, $instance) = @_;
 249     my $attr = $self->associated_attribute;
 250
 251     my $mi = $attr->associated_class->get_meta_instance;
 252     my $slot_name = sprintf "'%s'", $attr->slots;
 253
 254     return $mi->inline_slot_access($instance, $slot_name);
 255 }
 256
 257 sub _inline_has {
 258     my ($self, $instance) = @_;
 259     my $attr = $self->associated_attribute;
 260
 261     my $mi = $attr->associated_class->get_meta_instance;
 262     my $slot_name = sprintf "'%s'", $attr->slots;
 263
 264     return $mi->inline_is_slot_initialized($instance, $slot_name);
 265 }
 266
 267 sub _inline_auto_deref {
 268     my ( $self, $ref_value ) = @_;
 269         my $attr = $self->associated_attribute;
 270
 271     return $ref_value unless $attr->should_auto_deref;
 272
 273     my $type_constraint = $attr->type_constraint;
 274
 275     my $sigil;
 276     if ($type_constraint->is_a_type_of('ArrayRef')) {
 277         $sigil = '@';
 278     }
 279     elsif ($type_constraint->is_a_type_of('HashRef')) {
 280         $sigil = '%';
 281     }
 282     else {
 283         $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
 284     }
 285
 286     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 287 }
 288
 289 1;
 290
 291 __END__
 292
 293 =pod
 294
 295 =head1 NAME
 296
 297 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 298
 299 =head1 DESCRIPTION
 300
 301 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 302 responsibility is to generate the accessor methods for attributes. It
 303 can handle both closure based accessors, as well as inlined source based
 304 accessors.
 305
 306 This is a fairly new addition to the MOP, but this will play an important
 307 role in the optimization strategy we are currently following.
 308
 309 =head1 METHODS
 310
 311 =over 4
 312
 313 =item B<generate_accessor_method>
 314
 315 =item B<generate_reader_method>
 316
 317 =item B<generate_writer_method>
 318
 319 =item B<generate_predicate_method>
 320
 321 =item B<generate_clearer_method>
 322
 323 =item B<generate_accessor_method_inline>
 324
 325 =item B<generate_reader_method_inline>
 326
 327 =item B<generate_writer_method_inline>
 328
 329 =back
 330
 331 =head1 BUGS
 332
 333 All complex software has bugs lurking in it, and this module is no
 334 exception. If you find a bug please either email me, or add the bug
 335 to cpan-RT.
 336
 337 =head1 AUTHOR
 338
 339 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 340
 341 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 342
 343 =head1 COPYRIGHT AND LICENSE
 344
 345 Copyright 2006-2008 by Infinity Interactive, Inc.
 346
 347 L<http://www.iinteractive.com>
 348
 349 This library is free software; you can redistribute it and/or modify
 350 it under the same terms as Perl itself.
 351
 352 =cut