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