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