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