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