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.11';
  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     my $sub = eval $code;
  32     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  33     return $sub;
  34
  35 }
  36
  37 sub generate_accessor_method_inline {
  38     my $self        = $_[0];
  39     my $attr        = $self->associated_attribute;
  40     my $attr_name   = $attr->name;
  41     my $inv         = '$_[0]';
  42     my $slot_access = $self->_inline_access($inv, $attr_name);
  43     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  44
  45     $self->_eval_code('sub { ' . "\n"
  46     . $self->_inline_pre_body(@_) . "\n"
  47     . 'if (scalar(@_) >= 2) {' . "\n"
  48         . $self->_inline_copy_value . "\n"
  49         . $self->_inline_check_required . "\n"
  50         . $self->_inline_check_coercion . "\n"
  51         . $self->_inline_check_constraint($value_name) . "\n"
  52         . $self->_inline_store($inv, $value_name) . "\n"
  53         . $self->_inline_trigger($inv, $value_name) . "\n"
  54     . ' }' . "\n"
  55     . $self->_inline_check_lazy . "\n"
  56     . $self->_inline_post_body(@_) . "\n"
  57     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
  58     . ' }');
  59 }
  60
  61 sub generate_writer_method_inline {
  62     my $self        = $_[0];
  63     my $attr        = $self->associated_attribute;
  64     my $attr_name   = $attr->name;
  65     my $inv         = '$_[0]';
  66     my $slot_access = $self->_inline_get($inv, $attr_name);
  67     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  68
  69     $self->_eval_code('sub { '
  70     . $self->_inline_pre_body(@_)
  71     . $self->_inline_copy_value
  72     . $self->_inline_check_required
  73     . $self->_inline_check_coercion
  74     . $self->_inline_check_constraint($value_name)
  75     . $self->_inline_store($inv, $value_name)
  76     . $self->_inline_post_body(@_)
  77     . $self->_inline_trigger($inv, $value_name)
  78     . ' }');
  79 }
  80
  81 sub generate_reader_method_inline {
  82     my $self        = $_[0];
  83     my $attr        = $self->associated_attribute;
  84     my $attr_name   = $attr->name;
  85     my $inv         = '$_[0]';
  86     my $slot_access = $self->_inline_get($inv, $attr_name);
  87
  88     $self->_eval_code('sub {'
  89     . $self->_inline_pre_body(@_)
  90     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  91     . $self->_inline_check_lazy
  92     . $self->_inline_post_body(@_)
  93     . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
  94     . '}');
  95 }
  96
  97 sub _inline_copy_value {
  98     return '' unless shift->_value_needs_copy;
  99     return 'my $val = $_[1];'
 100 }
 101
 102 sub _value_needs_copy {
 103     my $attr = (shift)->associated_attribute;
 104     return $attr->should_coerce;
 105 }
 106
 107 sub generate_reader_method { shift->generate_reader_method_inline(@_) }
 108 sub generate_writer_method { shift->generate_writer_method_inline(@_) }
 109 sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
 110
 111 sub _inline_pre_body  { '' }
 112 sub _inline_post_body { '' }
 113
 114 sub _inline_check_constraint {
 115     my ($self, $value) = @_;
 116
 117     my $attr = $self->associated_attribute;
 118     my $attr_name = $attr->name;
 119
 120     return '' unless $attr->has_type_constraint;
 121
 122     my $type_constraint_name = $attr->type_constraint->name;
 123
 124     # FIXME
 125     # This sprintf is insanely annoying, we should
 126     # fix it someday - SL
 127     return sprintf <<'EOF', $value, $attr_name, $type_constraint_name, $value, $value, $value, $value, $value, $value
 128 $type_constraint->(%s)
 129         || confess "Attribute (%s) does not pass the type constraint (%s) with "
 130        . (defined(%s) ? overload::StrVal(%s) : "undef")
 131   if defined(%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{defined(\$_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";}
 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                      '          if defined($default);' . "\n" .
 180                      '        ' . $slot_access . ' = $default; ' . "\n";
 181         }
 182         else {
 183             $code .= '    ' . $slot_access . " = undef; \n";
 184         }
 185
 186     } else {
 187         if ($attr->has_default) {
 188             $code .= '    '.$slot_access.' = $attr->default(' . $inv . ');'."\n";
 189         }
 190         elsif ($attr->has_builder) {
 191             $code .= '    if(my $builder = '.$inv.'->can($attr->builder)){ '."\n".
 192                      '        '.$slot_access.' = '.$inv.'->$builder; '. "\n    } else {\n" .
 193                      '        confess(Scalar::Util::blessed('.$inv.')." does not support builder method '.
 194                      '\'".$attr->builder."\' for attribute \'" . $attr->name . "\'");'. "\n    }";
 195         }
 196         else {
 197             $code .= '    ' . $slot_access . " = undef; \n";
 198         }
 199     }
 200     $code .= "}\n";
 201     return $code;
 202 }
 203
 204
 205 sub _inline_store {
 206     my ($self, $instance, $value) = @_;
 207     my $attr = $self->associated_attribute;
 208
 209     my $mi = $attr->associated_class->get_meta_instance;
 210     my $slot_name = sprintf "'%s'", $attr->slots;
 211
 212     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 213     $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 214         if $attr->is_weak_ref;
 215     return $code;
 216 }
 217
 218 sub _inline_trigger {
 219     my ($self, $instance, $value) = @_;
 220     my $attr = $self->associated_attribute;
 221     return '' unless $attr->has_trigger;
 222     return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 223 }
 224
 225 sub _inline_get {
 226     my ($self, $instance) = @_;
 227     my $attr = $self->associated_attribute;
 228
 229     my $mi = $attr->associated_class->get_meta_instance;
 230     my $slot_name = sprintf "'%s'", $attr->slots;
 231
 232     return $mi->inline_get_slot_value($instance, $slot_name);
 233 }
 234
 235 sub _inline_access {
 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_slot_access($instance, $slot_name);
 243 }
 244
 245 sub _inline_has {
 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_is_slot_initialized($instance, $slot_name);
 253 }
 254
 255 sub _inline_auto_deref {
 256     my ( $self, $ref_value ) = @_;
 257         my $attr = $self->associated_attribute;
 258
 259     return $ref_value unless $attr->should_auto_deref;
 260
 261     my $type_constraint = $attr->type_constraint;
 262
 263     my $sigil;
 264     if ($type_constraint->is_a_type_of('ArrayRef')) {
 265         $sigil = '@';
 266     }
 267     elsif ($type_constraint->is_a_type_of('HashRef')) {
 268         $sigil = '%';
 269     }
 270     else {
 271         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 272     }
 273
 274     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 275 }
 276
 277 1;
 278
 279 __END__
 280
 281 =pod
 282
 283 =head1 NAME
 284
 285 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 286
 287 =head1 DESCRIPTION
 288
 289 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 290 responsibility is to generate the accessor methods for attributes. It
 291 can handle both closure based accessors, as well as inlined source based
 292 accessors.
 293
 294 This is a fairly new addition to the MOP, but this will play an important
 295 role in the optimization strategy we are currently following.
 296
 297 =head1 METHODS
 298
 299 =over 4
 300
 301 =item B<generate_accessor_method>
 302
 303 =item B<generate_reader_method>
 304
 305 =item B<generate_writer_method>
 306
 307 =item B<generate_accessor_method_inline>
 308
 309 =item B<generate_reader_method_inline>
 310
 311 =item B<generate_writer_method_inline>
 312
 313 =back
 314
 315 =head1 BUGS
 316
 317 All complex software has bugs lurking in it, and this module is no
 318 exception. If you find a bug please either email me, or add the bug
 319 to cpan-RT.
 320
 321 =head1 AUTHOR
 322
 323 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 324
 325 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 326
 327 =head1 COPYRIGHT AND LICENSE
 328
 329 Copyright 2006-2008 by Infinity Interactive, Inc.
 330
 331 L<http://www.iinteractive.com>
 332
 333 This library is free software; you can redistribute it and/or modify
 334 it under the same terms as Perl itself.
 335
 336 =cut