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.65';
   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     my $slot_name = sprintf "'%s'", $attr->slots;
 221
 222     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 223     $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 224         if $attr->is_weak_ref;
 225     return $code;
 226 }
 227
 228 sub _inline_trigger {
 229     my ($self, $instance, $value) = @_;
 230     my $attr = $self->associated_attribute;
 231     return '' unless $attr->has_trigger;
 232     return sprintf('$attr->trigger->(%s, %s);', $instance, $value);
 233 }
 234
 235 sub _inline_get {
 236     my ($self, $instance) = @_;
 237     my $attr = $self->associated_attribute;
 238
 239     my $mi = $attr->associated_class->get_meta_instance;
 240     my $slot_name = sprintf "'%s'", $attr->slots;
 241
 242     return $mi->inline_get_slot_value($instance, $slot_name);
 243 }
 244
 245 sub _inline_access {
 246     my ($self, $instance) = @_;
 247     my $attr = $self->associated_attribute;
 248
 249     my $mi = $attr->associated_class->get_meta_instance;
 250     my $slot_name = sprintf "'%s'", $attr->slots;
 251
 252     return $mi->inline_slot_access($instance, $slot_name);
 253 }
 254
 255 sub _inline_has {
 256     my ($self, $instance) = @_;
 257     my $attr = $self->associated_attribute;
 258
 259     my $mi = $attr->associated_class->get_meta_instance;
 260     my $slot_name = sprintf "'%s'", $attr->slots;
 261
 262     return $mi->inline_is_slot_initialized($instance, $slot_name);
 263 }
 264
 265 sub _inline_auto_deref {
 266     my ( $self, $ref_value ) = @_;
 267         my $attr = $self->associated_attribute;
 268
 269     return $ref_value unless $attr->should_auto_deref;
 270
 271     my $type_constraint = $attr->type_constraint;
 272
 273     my $sigil;
 274     if ($type_constraint->is_a_type_of('ArrayRef')) {
 275         $sigil = '@';
 276     }
 277     elsif ($type_constraint->is_a_type_of('HashRef')) {
 278         $sigil = '%';
 279     }
 280     else {
 281         $self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", type_constraint => $type_constraint );
 282     }
 283
 284     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 285 }
 286
 287 1;
 288
 289 __END__
 290
 291 =pod
 292
 293 =head1 NAME
 294
 295 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 296
 297 =head1 DESCRIPTION
 298
 299 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 300 responsibility is to generate the accessor methods for attributes. It
 301 can handle both closure based accessors, as well as inlined source based
 302 accessors.
 303
 304 This is a fairly new addition to the MOP, but this will play an important
 305 role in the optimization strategy we are currently following.
 306
 307 =head1 METHODS
 308
 309 =over 4
 310
 311 =item B<generate_accessor_method>
 312
 313 =item B<generate_reader_method>
 314
 315 =item B<generate_writer_method>
 316
 317 =item B<generate_predicate_method>
 318
 319 =item B<generate_clearer_method>
 320
 321 =item B<generate_accessor_method_inline>
 322
 323 =item B<generate_reader_method_inline>
 324
 325 =item B<generate_writer_method_inline>
 326
 327 =back
 328
 329 =head1 BUGS
 330
 331 All complex software has bugs lurking in it, and this module is no
 332 exception. If you find a bug please either email me, or add the bug
 333 to cpan-RT.
 334
 335 =head1 AUTHOR
 336
 337 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 338
 339 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 340
 341 =head1 COPYRIGHT AND LICENSE
 342
 343 Copyright 2006-2008 by Infinity Interactive, Inc.
 344
 345 L<http://www.iinteractive.com>
 346
 347 This library is free software; you can redistribute it and/or modify
 348 it under the same terms as Perl itself.
 349
 350 =cut