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