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