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