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