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