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