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 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Moose::Meta::Method',
  14          'Class::MOP::Method::Accessor';
  15
  16 ## Inline method generators
  17
  18 sub _eval_code {
  19     my ( $self, $code ) = @_;
  20
  21     # NOTE:
  22     # set up the environment
  23     my $attr        = $self->associated_attribute;
  24     my $attr_name   = $attr->name;
  25
  26     my $type_constraint_obj  = $attr->type_constraint;
  27     my $type_constraint_name = $type_constraint_obj && $type_constraint_obj->name;
  28     my $type_constraint      = $type_constraint_obj
  29                                    ? $type_constraint_obj->_compiled_type_constraint
  30                                    : undef;
  31
  32     #warn "code for $attr_name =>\n" . $code . "\n";
  33     my $sub = eval $code;
  34     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  35     return $sub;
  36
  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     . 'confess "Cannot assign a value to a read-only accessor" 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
 113 sub _inline_pre_body  { '' }
 114 sub _inline_post_body { '' }
 115
 116 sub _inline_check_constraint {
 117     my ($self, $value) = @_;
 118
 119     my $attr = $self->associated_attribute;
 120     my $attr_name = $attr->name;
 121
 122     return '' unless $attr->has_type_constraint;
 123
 124     my $type_constraint_name = $attr->type_constraint->name;
 125
 126     # FIXME
 127     # This sprintf is insanely annoying, we should
 128     # fix it someday - SL
 129     return sprintf <<'EOF', $value, $attr_name, $value, $value,
 130 $type_constraint->(%s)
 131         || confess "Attribute (%s) does not pass the type constraint because: "
 132        . $type_constraint_obj->get_message(%s);
 133 EOF
 134 }
 135
 136 sub _inline_check_coercion {
 137     my $attr = (shift)->associated_attribute;
 138
 139     return '' unless $attr->should_coerce;
 140     return '$val = $attr->type_constraint->coerce($_[1]);'
 141 }
 142
 143 sub _inline_check_required {
 144     my $attr = (shift)->associated_attribute;
 145
 146     my $attr_name = $attr->name;
 147
 148     return '' unless $attr->is_required;
 149     return qq{(\@_ >= 2) || confess "Attribute ($attr_name) is required, so cannot be set to undef";} # defined $_[1] is not good enough
 150 }
 151
 152 sub _inline_check_lazy {
 153     my ($self, $instance) = @_;
 154
 155     my $attr = $self->associated_attribute;
 156
 157     return '' unless $attr->is_lazy;
 158
 159     my $slot_access = $self->_inline_access($instance, $attr->name);
 160
 161     my $slot_exists = $self->_inline_has($instance, $attr->name);
 162
 163     my $code = 'unless (' . $slot_exists . ') {' . "\n";
 164     if ($attr->has_type_constraint) {
 165         if ($attr->has_default || $attr->has_builder) {
 166             if ($attr->has_default) {
 167                 $code .= '    my $default = $attr->default(' . $instance . ');'."\n";
 168             }
 169             elsif ($attr->has_builder) {
 170                 $code .= '    my $default;'."\n".
 171                          '    if(my $builder = '.$instance.'->can($attr->builder)){ '."\n".
 172                          '        $default = '.$instance.'->$builder; '. "\n    } else {\n" .
 173                          '        confess((Scalar::Util::blessed('.$instance.') || '.$instance.')." does not support builder method '.
 174                          '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
 175             }
 176             $code .= '    $default = $type_constraint_obj->coerce($default);'."\n"  if $attr->should_coerce;
 177             $code .= '    ($type_constraint->($default))' .
 178                      '            || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("' .
 179                      '           . $type_constraint_name . ") with " . (defined($default) ? overload::StrVal($default) : "undef");'
 180                      . "\n";
 181             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, '$default') . "\n";
 182         }
 183         else {
 184             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
 185         }
 186
 187     } else {
 188         if ($attr->has_default) {
 189             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, ('$attr->default(' . $instance . ')')) . "\n";
 190         }
 191         elsif ($attr->has_builder) {
 192             $code .= '    if (my $builder = '.$instance.'->can($attr->builder)) { ' . "\n"
 193                   .  '       ' . $self->_inline_init_slot($attr, $instance, $slot_access, ($instance . '->$builder'))
 194                      . "\n    } else {\n" .
 195                      '        confess((Scalar::Util::blessed('.$instance.') || '.$instance.')." does not support builder method '.
 196                      '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
 197         }
 198         else {
 199             $code .= '    ' . $self->_inline_init_slot($attr, $instance, $slot_access, 'undef') . "\n";
 200         }
 201     }
 202     $code .= "}\n";
 203     return $code;
 204 }
 205
 206 sub _inline_init_slot {
 207     my ($self, $attr, $inv, $slot_access, $value) = @_;
 208     if ($attr->has_initializer) {
 209         return ('$attr->set_initial_value(' . $inv . ', ' . $value . ');');
 210     }
 211     else {
 212         return ($slot_access . ' = ' . $value . ';');
 213     }
 214 }
 215
 216 sub _inline_store {
 217     my ($self, $instance, $value) = @_;
 218     my $attr = $self->associated_attribute;
 219
 220     my $mi = $attr->associated_class->get_meta_instance;
 221     my $slot_name = sprintf "'%s'", $attr->slots;
 222
 223     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 224     $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 225         if $attr->is_weak_ref;
 226     return $code;
 227 }
 228
 229 sub _inline_trigger {
 230     my ($self, $instance, $value) = @_;
 231     my $attr = $self->associated_attribute;
 232     return '' unless $attr->has_trigger;
 233     return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 234 }
 235
 236 sub _inline_get {
 237     my ($self, $instance) = @_;
 238     my $attr = $self->associated_attribute;
 239
 240     my $mi = $attr->associated_class->get_meta_instance;
 241     my $slot_name = sprintf "'%s'", $attr->slots;
 242
 243     return $mi->inline_get_slot_value($instance, $slot_name);
 244 }
 245
 246 sub _inline_access {
 247     my ($self, $instance) = @_;
 248     my $attr = $self->associated_attribute;
 249
 250     my $mi = $attr->associated_class->get_meta_instance;
 251     my $slot_name = sprintf "'%s'", $attr->slots;
 252
 253     return $mi->inline_slot_access($instance, $slot_name);
 254 }
 255
 256 sub _inline_has {
 257     my ($self, $instance) = @_;
 258     my $attr = $self->associated_attribute;
 259
 260     my $mi = $attr->associated_class->get_meta_instance;
 261     my $slot_name = sprintf "'%s'", $attr->slots;
 262
 263     return $mi->inline_is_slot_initialized($instance, $slot_name);
 264 }
 265
 266 sub _inline_auto_deref {
 267     my ( $self, $ref_value ) = @_;
 268         my $attr = $self->associated_attribute;
 269
 270     return $ref_value unless $attr->should_auto_deref;
 271
 272     my $type_constraint = $attr->type_constraint;
 273
 274     my $sigil;
 275     if ($type_constraint->is_a_type_of('ArrayRef')) {
 276         $sigil = '@';
 277     }
 278     elsif ($type_constraint->is_a_type_of('HashRef')) {
 279         $sigil = '%';
 280     }
 281     else {
 282         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 283     }
 284
 285     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 286 }
 287
 288 1;
 289
 290 __END__
 291
 292 =pod
 293
 294 =head1 NAME
 295
 296 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 297
 298 =head1 DESCRIPTION
 299
 300 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 301 responsibility is to generate the accessor methods for attributes. It
 302 can handle both closure based accessors, as well as inlined source based
 303 accessors.
 304
 305 This is a fairly new addition to the MOP, but this will play an important
 306 role in the optimization strategy we are currently following.
 307
 308 =head1 METHODS
 309
 310 =over 4
 311
 312 =item B<generate_accessor_method>
 313
 314 =item B<generate_reader_method>
 315
 316 =item B<generate_writer_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