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