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