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