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.09';
  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                                 ? (
  29                                     $type_constraint_obj->has_hand_optimized_type_constraint
  30                                         ? $type_constraint_obj->hand_optimized_type_constraint
  31                                         : $type_constraint_obj->_compiled_type_constraint
  32                                     )
  33                                 : undef;
  34
  35     my $sub = eval $code;
  36     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  37     return $sub;
  38
  39 }
  40
  41 sub generate_accessor_method_inline {
  42     my $self        = $_[0];
  43     my $attr        = $self->associated_attribute;
  44     my $attr_name   = $attr->name;
  45     my $inv         = '$_[0]';
  46     my $slot_access = $self->_inline_access($inv, $attr_name);
  47     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  48
  49     $self->_eval_code('sub { ' . "\n"
  50     . $self->_inline_pre_body(@_) . "\n"
  51     . 'if (scalar(@_) >= 2) {' . "\n"
  52         . $self->_inline_copy_value . "\n"
  53         . $self->_inline_check_required . "\n"
  54         . $self->_inline_check_coercion . "\n"
  55         . $self->_inline_check_constraint($value_name) . "\n"
  56         . $self->_inline_store($inv, $value_name) . "\n"
  57         . $self->_inline_trigger($inv, $value_name) . "\n"
  58     . ' }' . "\n"
  59     . $self->_inline_check_lazy . "\n"
  60     . $self->_inline_post_body(@_) . "\n"
  61     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
  62     . ' }');
  63 }
  64
  65 sub generate_writer_method_inline {
  66     my $self        = $_[0];
  67     my $attr        = $self->associated_attribute;
  68     my $attr_name   = $attr->name;
  69     my $inv         = '$_[0]';
  70     my $slot_access = $self->_inline_get($inv, $attr_name);
  71     my $value_name  = $self->_value_needs_copy ? '$val' : '$_[1]';
  72
  73     $self->_eval_code('sub { '
  74     . $self->_inline_pre_body(@_)
  75     . $self->_inline_copy_value
  76     . $self->_inline_check_required
  77     . $self->_inline_check_coercion
  78     . $self->_inline_check_constraint($value_name)
  79     . $self->_inline_store($inv, $value_name)
  80     . $self->_inline_post_body(@_)
  81     . $self->_inline_trigger($inv, $value_name)
  82     . ' }');
  83 }
  84
  85 sub generate_reader_method_inline {
  86     my $self        = $_[0];
  87     my $attr        = $self->associated_attribute;
  88     my $attr_name   = $attr->name;
  89     my $inv         = '$_[0]';
  90     my $slot_access = $self->_inline_get($inv, $attr_name);
  91
  92     $self->_eval_code('sub {'
  93     . $self->_inline_pre_body(@_)
  94     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  95     . $self->_inline_check_lazy
  96     . $self->_inline_post_body(@_)
  97     . 'return ' . $self->_inline_auto_deref( $slot_access ) . ';'
  98     . '}');
  99 }
 100
 101 sub _inline_copy_value {
 102     return '' unless shift->_value_needs_copy;
 103     return 'my $val = $_[1];'
 104 }
 105
 106 sub _value_needs_copy {
 107     my $attr = (shift)->associated_attribute;
 108     return $attr->should_coerce;
 109 }
 110
 111 sub generate_reader_method { shift->generate_reader_method_inline(@_) }
 112 sub generate_writer_method { shift->generate_writer_method_inline(@_) }
 113 sub generate_accessor_method { shift->generate_accessor_method_inline(@_) }
 114
 115 sub _inline_pre_body  { '' }
 116 sub _inline_post_body { '' }
 117
 118 sub _inline_check_constraint {
 119     my ($self, $value) = @_;
 120
 121     my $attr = $self->associated_attribute;
 122
 123     return '' unless $attr->has_type_constraint;
 124
 125     # FIXME
 126     # This sprintf is insanely annoying, we should
 127     # fix it someday - SL
 128     return sprintf <<'EOF', $value, $value, $value, $value, $value, $value, $value
 129 $type_constraint->(%s)
 130         || confess "Attribute (" . $attr_name . ") does not pass the type constraint ("
 131        . $type_constraint_name . ") with "
 132        . (defined(%s) ? overload::StrVal(%s) : "undef")
 133   if defined(%s);
 134 EOF
 135 }
 136
 137 sub _inline_check_coercion {
 138     my $attr = (shift)->associated_attribute;
 139
 140     return '' unless $attr->should_coerce;
 141     return '$val = $attr->type_constraint->coerce($_[1]);'
 142 }
 143
 144 sub _inline_check_required {
 145     my $attr = (shift)->associated_attribute;
 146
 147     return '' unless $attr->is_required;
 148     return '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