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