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