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