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.05';
  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_get($inv, $attr_name);
  23     my $value_name  = $attr->should_coerce ? '$val' : '$_[1]';
  24
  25     my $code = 'sub { '
  26     . $self->_inline_pre_body(@_)
  27     . 'if (scalar(@_) == 2) {'
  28         . $self->_inline_check_required
  29         . $self->_inline_check_coercion
  30         . $self->_inline_check_constraint($value_name)
  31                 . $self->_inline_store($inv, $value_name)
  32                 . $self->_inline_trigger($inv, $value_name)
  33     . ' }'
  34     . $self->_inline_check_lazy
  35     . $self->_inline_post_body(@_)
  36     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
  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_get($inv, $attr->name);
 153
 154         if ($attr->has_type_constraint) {
 155             # NOTE:
 156             # this could probably be cleaned
 157             # up and streamlined a little more
 158             return 'unless (exists ' . $slot_access . ') {' .
 159                    '    if ($attr->has_default) {' .
 160                    '        my $default = $attr->default(' . $inv . ');' .
 161                    ($attr->should_coerce
 162                        ? '$default = $attr->type_constraint->coerce($default);'
 163                        : '') .
 164                '        (defined($type_constraint->($default)))' .
 165                '                || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
 166                '               . $attr->type_constraint->name . ") with " . (defined($default) ? (Scalar::Util::blessed($default) && overload::Overloaded($default) ? overload::StrVal($default) : $default) : "undef")' .
 167                '          if defined($default);' .
 168                    '        ' . $slot_access . ' = $default; ' .
 169                    '    }' .
 170                    '    else {' .
 171                '        ' . $slot_access . ' = undef;' .
 172                    '    }' .
 173                    '}';
 174         }
 175     return $slot_access . ' = ($attr->has_default ? $attr->default(' . $inv . ') : undef)'
 176          . 'unless exists ' . $slot_access . ';';
 177 }
 178
 179
 180 sub _inline_store {
 181         my ($self, $instance, $value) = @_;
 182         my $attr = $self->associated_attribute;
 183
 184         my $mi = $attr->associated_class->get_meta_instance;
 185         my $slot_name = sprintf "'%s'", $attr->slots;
 186
 187     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 188         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 189             if $attr->is_weak_ref;
 190     return $code;
 191 }
 192
 193 sub _inline_trigger {
 194         my ($self, $instance, $value) = @_;
 195         my $attr = $self->associated_attribute;
 196         return '' unless $attr->has_trigger;
 197         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 198 }
 199
 200 sub _inline_get {
 201         my ($self, $instance) = @_;
 202         my $attr = $self->associated_attribute;
 203
 204         my $mi = $attr->associated_class->get_meta_instance;
 205         my $slot_name = sprintf "'%s'", $attr->slots;
 206
 207     return $mi->inline_get_slot_value($instance, $slot_name);
 208 }
 209
 210 sub _inline_auto_deref {
 211     my ( $self, $ref_value ) = @_;
 212         my $attr = $self->associated_attribute;
 213
 214     return $ref_value unless $attr->should_auto_deref;
 215
 216     my $type_constraint = $attr->type_constraint;
 217
 218     my $sigil;
 219     if ($type_constraint->is_a_type_of('ArrayRef')) {
 220         $sigil = '@';
 221     }
 222     elsif ($type_constraint->is_a_type_of('HashRef')) {
 223         $sigil = '%';
 224     }
 225     else {
 226         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 227     }
 228
 229     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 230 }
 231
 232 1;
 233
 234 __END__
 235
 236 =pod
 237
 238 =head1 NAME
 239
 240 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 241
 242 =head1 DESCRIPTION
 243
 244 This is a subclass of L<Class::MOP::Method::Accessor> and it's primary
 245 responsibility is to generate the accessor methods for attributes. It
 246 can handle both closure based accessors, as well as inlined source based
 247 accessors.
 248
 249 This is a fairly new addition to the MOP, but this will play an important
 250 role in the optimization strategy we are currently following.
 251
 252 =head1 METHODS
 253
 254 =over 4
 255
 256 =item B<generate_accessor_method>
 257
 258 =item B<generate_reader_method>
 259
 260 =item B<generate_writer_method>
 261
 262 =item B<generate_accessor_method_inline>
 263
 264 =item B<generate_reader_method_inline>
 265
 266 =item B<generate_writer_method_inline>
 267
 268 =back
 269
 270 =head1 BUGS
 271
 272 All complex software has bugs lurking in it, and this module is no
 273 exception. If you find a bug please either email me, or add the bug
 274 to cpan-RT.
 275
 276 =head1 AUTHOR
 277
 278 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 279
 280 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 281
 282 =head1 COPYRIGHT AND LICENSE
 283
 284 Copyright 2006, 2007 by Infinity Interactive, Inc.
 285
 286 L<http://www.iinteractive.com>
 287
 288 This library is free software; you can redistribute it and/or modify
 289 it under the same terms as Perl itself.
 290
 291 =cut