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