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