lib/Moose/Meta/Method/Accessor.pm

   1
   2 package Moose::Meta::Method::Accessor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp 'confess';
   8
   9 our $VERSION   = '0.56';
  10 our $AUTHORITY = 'cpan:STEVAN';
  11
  12 use base 'Moose::Meta::Method',
  13          'Class::MOP::Method::Accessor';
  14
  15 ## Inline method generators
  16
  17 sub _eval_code {
  18     my ( $self, $code ) = @_;
  19
  20     # NOTE:
  21     # set up the environment
  22     my $attr        = $self->associated_attribute;
  23     my $attr_name   = $attr->name;
  24
  25     my $type_constraint_obj  = $attr->type_constraint;
  26     my $type_constraint_name = $type_constraint_obj && $type_constraint_obj->name;
  27     my $type_constraint      = $type_constraint_obj
  28                                    ? $type_constraint_obj->_compiled_type_constraint
  29                                    : undef;
  30
  31     #warn "code for $attr_name =>\n" . $code . "\n";
  32     my $sub = eval $code;
  33     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  34     return $sub;
  35
  36 }
  37
  38 sub generate_accessor_method_inline {
  39     my $self        = $_[0];
  40     my $attr        = $self->associated_attribute;
  41     my $attr_name   = $attr->name;
  42     my $inv         = '$_[0]';
  43     my $slot_access = $self->_inline_access($inv, $attr_name);
  44     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  45
  46     $self->_eval_code('sub { ' . "\n"
  47     . $self->_inline_pre_body(@_) . "\n"
  48     . 'if (scalar(@_) >= 2) {' . "\n"
  49         . $self->_inline_copy_value . "\n"
  50         . $self->_inline_check_required . "\n"
  51         . $self->_inline_check_coercion . "\n"
  52         . $self->_inline_check_constraint($value_name) . "\n"
  53         . $self->_inline_store($inv, $value_name) . "\n"
  54         . $self->_inline_trigger($inv, $value_name) . "\n"
  55     . ' }' . "\n"
  56     . $self->_inline_check_lazy . "\n"
  57     . $self->_inline_post_body(@_) . "\n"
  58     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
  59     . ' }');
  60 }
  61
  62 sub generate_writer_method_inline {
  63     my $self        = $_[0];
  64     my $attr        = $self->associated_attribute;
  65     my $attr_name   = $attr->name;
  66     my $inv         = '$_[0]';
  67     my $slot_access = $self->_inline_get($inv, $attr_name);
  68     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  69
  70     $self->_eval_code('sub { '
  71     . $self->_inline_pre_body(@_)
  72     . $self->_inline_copy_value
  73     . $self->_inline_check_required
  74     . $self->_inline_check_coercion
  75     . $self->_inline_check_constraint($value_name)
  76     . $self->_inline_store($inv, $value_name)
  77     . $self->_inline_post_body(@_)
  78     . $self->_inline_trigger($inv, $value_name)
  79     . ' }');
  80 }
  81
  82 sub generate_reader_method_inline {
  83     my $self        = $_[0];
  84     my $attr        = $self->associated_attribute;
  85     my $attr_name   = $attr->name;
  86     my $inv         = '$_[0]';
  87     my $slot_access = $self->_inline_get($inv, $attr_name);
  88
  89     $self->_eval_code('sub {'
  90     . $self->_inline_pre_body(@_)
  91     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  92     . $self->_inline_check_lazy
  93     . $self->_inline_post_body(@_)
  94     . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
  95     . '}');
  96 }
  97
  98 sub _inline_copy_value {
  99     return '' unless shift->_value_needs_copy;
 100     return 'my $val = $_[1];'
 101 }
 102
 103 sub _value_needs_copy {
 104     my $attr = (shift)->associated_attribute;
 105     return $attr->should_coerce;
 106 }
 107
 108 sub generate_reader_method { shift->generate_reader_method_inline(@_) }
 109 sub generate_writer_method { shift->generate_writer_method_inline(@_) }
 110 sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
 111
 112 sub _inline_pre_body  { '' }
 113 sub _inline_post_body { '' }
 114
 115 sub _inline_check_constraint {
 116     my ($self, $value) = @_;
 117
 118     my $attr = $self->associated_attribute;
 119     my $attr_name = $attr->name;
 120
 121     return '' unless $attr->has_type_constraint;
 122
 123     my $type_constraint_name = $attr->type_constraint->name;
 124
 125     # FIXME
 126     # This sprintf is insanely annoying, we should
 127     # fix it someday - SL
 128     return sprintf <<'EOF', $value, $attr_name, $value, $value,
 129 $type_constraint->(%s)
 130         || confess "Attribute (%s) does not pass the type constraint because: "
 131        . $type_constraint_obj->get_message(%s);
 132 EOF
 133 }
 134
 135 sub _inline_check_coercion {
 136     my $attr = (shift)->associated_attribute;
 137
 138     return '' unless $attr->should_coerce;
 139     return '$val = $attr->type_constraint->coerce($_[1]);'
 140 }
 141
 142 sub _inline_check_required {
 143     my $attr = (shift)->associated_attribute;
 144
 145     my $attr_name = $attr->name;
 146
 147     return '' unless $attr->is_required;
 148     return qq{(\@_ >= 2) || confess "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 = $_[0];
 153     my $attr = $self->associated_attribute;
 154
 155     return '' unless $attr->is_lazy;
 156
 157     my $inv         = '$_[0]';
 158     my $slot_access = $self->_inline_access($inv, $attr->name);
 159
 160     my $slot_exists = $self->_inline_has($inv, $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(' . $inv . ');'."\n";
 167             }
 168             elsif ($attr->has_builder) {
 169                 $code .= '    my $default;'."\n".
 170                          '    if(my $builder = '.$inv.'->can($attr->builder)){ '."\n".
 171                          '        $default = '.$inv.'->$builder; '. "\n    } else {\n" .
 172                          '        confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
 173                          '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
 174             }
 175             $code .= '    $default = $type_constraint_obj->coerce($default);'."\n"  if $attr->should_coerce;
 176             $code .= '    ($type_constraint->($default))' .
 177                      '            || confess "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, $inv, $slot_access, '$default') . "\n";
 181         }
 182         else {
 183             $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, 'undef') . "\n";
 184         }
 185
 186     } else {
 187         if ($attr->has_default) {
 188             $code .= '    ' . $self->_inline_init_slot($attr, $inv, $slot_access, ('$attr->default(' . $inv . ')')) . "\n";
 189         }
 190         elsif ($attr->has_builder) {
 191             $code .= '    if (my $builder = '.$inv.'->can($attr->builder)) { ' . "\n"
 192                   .  '       ' . $self->_inline_init_slot($attr, $inv, $slot_access, ($inv . '->$builder'))
 193                      . "\n    } else {\n" .
 194                      '        confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
 195                      '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
 196         }
 197         else {
 198             $code .= '    ' . $self->_inline_init_slot($attr, $inv, $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, $attr);', $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         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 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_accessor_method_inline>
 318
 319 =item B<generate_reader_method_inline>
 320
 321 =item B<generate_writer_method_inline>
 322
 323 =back
 324
 325 =head1 BUGS
 326
 327 All complex software has bugs lurking in it, and this module is no
 328 exception. If you find a bug please either email me, or add the bug
 329 to cpan-RT.
 330
 331 =head1 AUTHOR
 332
 333 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 334
 335 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 336
 337 =head1 COPYRIGHT AND LICENSE
 338
 339 Copyright 2006-2008 by Infinity Interactive, Inc.
 340
 341 L<http://www.iinteractive.com>
 342
 343 This library is free software; you can redistribute it and/or modify
 344 it under the same terms as Perl itself.
 345
 346 =cut