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.62_02';
   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
 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_accessor_method_inline>
 315
 316 =item B<generate_reader_method_inline>
 317
 318 =item B<generate_writer_method_inline>
 319
 320 =back
 321
 322 =head1 BUGS
 323
 324 All complex software has bugs lurking in it, and this module is no
 325 exception. If you find a bug please either email me, or add the bug
 326 to cpan-RT.
 327
 328 =head1 AUTHOR
 329
 330 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 331
 332 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 333
 334 =head1 COPYRIGHT AND LICENSE
 335
 336 Copyright 2006-2008 by Infinity Interactive, Inc.
 337
 338 L<http://www.iinteractive.com>
 339
 340 This library is free software; you can redistribute it and/or modify
 341 it under the same terms as Perl itself.
 342
 343 =cut