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.04';
  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
  22     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
  23         my $mi = $attr->associated_class->get_meta_instance;
  24         my $slot_name = sprintf "'%s'", $attr->slots;
  25         my $inv = '$_[0]';
  26     my $code = 'sub { '
  27     . $self->_inline_pre_body(@_)
  28     . 'if (scalar(@_) == 2) {'
  29         . $self->_inline_check_required
  30         . $self->_inline_check_coercion
  31         . $self->_inline_check_constraint($value_name)
  32                 . $self->_inline_store($inv, $value_name)
  33                 . $self->_inline_trigger($inv, $value_name)
  34     . ' }'
  35     . $self->_inline_check_lazy
  36     . $self->_inline_post_body(@_)
  37     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
  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
  56     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
  57         my $inv = '$_[0]';
  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
  84     my $code = 'sub {'
  85     . $self->_inline_pre_body(@_)
  86     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  87     . $self->_inline_check_lazy
  88     . $self->_inline_post_body(@_)
  89     . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
  90     . '}';
  91
  92     # NOTE:
  93     # set up the environment
  94     my $type_constraint = $attr->type_constraint
  95                                 ? $attr->type_constraint->_compiled_type_constraint
  96                                 : undef;
  97
  98     my $sub = eval $code;
  99     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
 100     return $sub;
 101 }
 102
 103 *generate_reader_method   = \&generate_reader_method_inline;
 104 *generate_writer_method   = \&generate_writer_method_inline;
 105 *generate_accessor_method = \&generate_accessor_method_inline;
 106
 107 sub _inline_pre_body { '' }
 108 sub _inline_post_body { '' }
 109
 110 sub _inline_check_constraint {
 111         my ($self, $value) = @_;
 112
 113         my $attr = $self->associated_attribute;
 114
 115         return '' unless $attr->has_type_constraint;
 116
 117         return sprintf <<'EOF', $value, $value, $value, $value, $value, $value
 118 defined($type_constraint->(%s))
 119         || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
 120        . $attr->type_constraint->name . ") with "
 121        . (defined(%s) ? (overload::Overloaded(%s) ? overload::StrVal(%s) : %s) : "undef")
 122   if defined(%s);
 123 EOF
 124 }
 125
 126 sub _inline_check_coercion {
 127         my $attr = (shift)->associated_attribute;
 128
 129         return '' unless $attr->should_coerce;
 130     return 'my $val = $attr->type_constraint->coerce($_[1]);'
 131 }
 132
 133 sub _inline_check_required {
 134         my $attr = (shift)->associated_attribute;
 135
 136         return '' unless $attr->is_required;
 137     return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 138 }
 139
 140 sub _inline_check_lazy {
 141         my $attr = (shift)->associated_attribute;
 142
 143         return '' unless $attr->is_lazy;
 144
 145         if ($attr->has_type_constraint) {
 146             # NOTE:
 147             # this could probably be cleaned
 148             # up and streamlined a little more
 149             return 'unless (exists $_[0]->{$attr_name}) {' .
 150                    '    if ($attr->has_default) {' .
 151                    '        my $default = $attr->default($_[0]);' .
 152                    ($attr->should_coerce
 153                        ? '$default = $attr->type_constraint->coerce($default);'
 154                        : '') .
 155                '        (defined($type_constraint->($default)))' .
 156                '                || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
 157                '               . $attr->type_constraint->name . ") with " . (defined($default) ? (overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' .
 158                '          if defined($default);' .
 159                    '        $_[0]->{$attr_name} = $default; ' .
 160                    '    }' .
 161                    '    else {' .
 162                '        $_[0]->{$attr_name} = undef;' .
 163                    '    }' .
 164                    '}';
 165         }
 166     return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
 167          . 'unless exists $_[0]->{$attr_name};';
 168 }
 169
 170
 171 sub _inline_store {
 172         my ($self, $instance, $value) = @_;
 173         my $attr = $self->associated_attribute;
 174
 175         my $mi = $attr->associated_class->get_meta_instance;
 176         my $slot_name = sprintf "'%s'", $attr->slots;
 177
 178     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 179         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 180             if $attr->is_weak_ref;
 181     return $code;
 182 }
 183
 184 sub _inline_trigger {
 185         my ($self, $instance, $value) = @_;
 186         my $attr = $self->associated_attribute;
 187         return '' unless $attr->has_trigger;
 188         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 189 }
 190
 191 sub _inline_get {
 192         my ($self, $instance) = @_;
 193         my $attr = $self->associated_attribute;
 194
 195         my $mi = $attr->associated_class->get_meta_instance;
 196         my $slot_name = sprintf "'%s'", $attr->slots;
 197
 198     return $mi->inline_get_slot_value($instance, $slot_name);
 199 }
 200
 201 sub _inline_auto_deref {
 202     my ( $self, $ref_value ) = @_;
 203         my $attr = $self->associated_attribute;
 204
 205     return $ref_value unless $attr->should_auto_deref;
 206
 207     my $type_constraint = $attr->type_constraint;
 208
 209     my $sigil;
 210     if ($type_constraint->is_a_type_of('ArrayRef')) {
 211         $sigil = '@';
 212     }
 213     elsif ($type_constraint->is_a_type_of('HashRef')) {
 214         $sigil = '%';
 215     }
 216     else {
 217         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 218     }
 219
 220     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 221 }
 222
 223 1;
 224
 225 __END__
 226
 227 =pod
 228
 229 =head1 NAME
 230
 231 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 232
 233 =head1 DESCRIPTION
 234
 235 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 236 responsibility is to generate the accessor methods for attributes. It
 237 can handle both closure based accessors, as well as inlined source based
 238 accessors.
 239
 240 This is a fairly new addition to the MOP, but this will play an important
 241 role in the optimization strategy we are currently following.
 242
 243 =head1 METHODS
 244
 245 =over 4
 246
 247 =item B<generate_accessor_method>
 248
 249 =item B<generate_reader_method>
 250
 251 =item B<generate_writer_method>
 252
 253 =item B<generate_accessor_method_inline>
 254
 255 =item B<generate_reader_method_inline>
 256
 257 =item B<generate_writer_method_inline>
 258
 259 =back
 260
 261 =head1 BUGS
 262
 263 All complex software has bugs lurking in it, and this module is no
 264 exception. If you find a bug please either email me, or add the bug
 265 to cpan-RT.
 266
 267 =head1 AUTHOR
 268
 269 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 270
 271 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 272
 273 =head1 COPYRIGHT AND LICENSE
 274
 275 Copyright 2006, 2007 by Infinity Interactive, Inc.
 276
 277 L<http://www.iinteractive.com>
 278
 279 This library is free software; you can redistribute it and/or modify
 280 it under the same terms as Perl itself.
 281
 282 =cut