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