lib/Moose/Meta/Method/Accessor.pm

   1
   2 use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/trunk/lib';
   3
   4 package Moose::Meta::Method::Accessor;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Carp 'confess';
  10
  11 our $VERSION = '0.01';
  12
  13 use base 'Moose::Meta::Method',
  14          'Class::MOP::Method::Accessor';
  15
  16 ## generators
  17
  18 sub generate_accessor_method {
  19     my $self      = shift;
  20     my $attr      = $self->associated_attribute;
  21     my $attr_name = $attr->name;
  22
  23     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
  24         my $mi = $attr->associated_class->get_meta_instance;
  25         my $slot_name = sprintf "'%s'", $attr->slots;
  26         my $inv = '$_[0]';
  27     my $code = 'sub { '
  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     . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
  37     . ' }';
  38
  39     # NOTE:
  40     # set up the environment
  41     my $type_constraint = $attr->type_constraint
  42                                 ? $attr->type_constraint->_compiled_type_constraint
  43                                 : undef;
  44
  45     my $sub = eval $code;
  46     confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
  47     return $sub;
  48 }
  49
  50 sub generate_writer_method {
  51     my $self      = shift;
  52     my $attr      = $self->associated_attribute;
  53     my $attr_name = $attr->name;
  54
  55     my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
  56         my $inv = '$_[0]';
  57     my $code = 'sub { '
  58     . $self->_inline_check_required
  59     . $self->_inline_check_coercion
  60         . $self->_inline_check_constraint($value_name)
  61         . $self->_inline_store($inv, $value_name)
  62         . $self->_inline_trigger($inv, $value_name)
  63     . ' }';
  64
  65     # NOTE:
  66     # set up the environment
  67     my $type_constraint = $attr->type_constraint
  68                                 ? $attr->type_constraint->_compiled_type_constraint
  69                                 : undef;
  70
  71     my $sub = eval $code;
  72     confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
  73     return $sub;
  74 }
  75
  76 sub generate_reader_method {
  77     my $self      = shift;
  78     my $attr      = $self->associated_attribute;
  79     my $attr_name = $attr->name;
  80
  81     my $code = 'sub {'
  82     . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
  83     . $self->_inline_check_lazy
  84     . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
  85     . '}';
  86     my $sub = eval $code;
  87     confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
  88     return $sub;
  89 }
  90
  91 #sub generate_predicate_method {
  92 #    my $self      = shift;
  93 #    my $attr      = $self->associated_attribute;
  94 #    my $attr_name = $attr->name;
  95 #}
  96 #
  97 #sub generate_clearer_method {
  98 #    my $self      = shift;
  99 #    my $attr      = $self->associated_attribute;
 100 #    my $attr_name = $attr->name;
 101 #}
 102
 103 ## Inline methods
 104
 105 *generate_accessor_method_inline  = \&generate_accessor_method;
 106 *generate_reader_method_inline    = \&generate_reader_method;
 107 *generate_writer_method_inline    = \&generate_writer_method;
 108 #*generate_predicate_method_inline = \&generate_predicate_method;
 109 #*generate_clearer_method_inline   = \&generate_clearer_method;
 110
 111 ## ... private helpers
 112
 113 sub _inline_check_constraint {
 114         my ($self, $value) = @_;
 115
 116         my $attr = $self->associated_attribute;
 117
 118         return '' unless $attr->has_type_constraint;
 119
 120         # FIXME - remove 'unless defined($value) - constraint Undef
 121         return sprintf <<'EOF', $value, $value, $value, $value
 122 defined($type_constraint->(%s))
 123         || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
 124        . $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
 125   if defined(%s);
 126 EOF
 127 }
 128
 129 sub _inline_check_coercion {
 130         my $attr = (shift)->associated_attribute;
 131
 132         return '' unless $attr->should_coerce;
 133     return 'my $val = $attr->type_constraint->coerce($_[1]);'
 134 }
 135
 136 sub _inline_check_required {
 137         my $attr = (shift)->associated_attribute;
 138
 139         return '' unless $attr->is_required;
 140     return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
 141 }
 142
 143 sub _inline_check_lazy {
 144         my $attr = (shift)->associated_attribute;
 145
 146         return '' unless $attr->is_lazy;
 147
 148         if ($attr->has_type_constraint) {
 149             # NOTE:
 150             # this could probably be cleaned
 151             # up and streamlined a little more
 152             return 'unless (exists $_[0]->{$attr_name}) {' .
 153                    '    if ($attr->has_default) {' .
 154                    '        my $default = $attr->default($_[0]);' .
 155                '        (defined($type_constraint->($default)))' .
 156                '                || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
 157                '               . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
 158                '          if defined($default);' .
 159                    '        $_[0]->{$attr_name} = $default; ' .
 160                    '    }' .
 161                    '    else {' .
 162                '        $_[0]->{$attr_name} = undef;' .
 163                    '    }' .
 164                    '}';
 165         }
 166     return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
 167          . 'unless exists $_[0]->{$attr_name};';
 168 }
 169
 170
 171 sub _inline_store {
 172         my ($self, $instance, $value) = @_;
 173         my $attr = $self->associated_attribute;
 174
 175         my $mi = $attr->associated_class->get_meta_instance;
 176         my $slot_name = sprintf "'%s'", $attr->slots;
 177
 178     my $code = $mi->inline_set_slot_value($instance, $slot_name, $value)    . ";";
 179         $code   .= $mi->inline_weaken_slot_value($instance, $slot_name, $value) . ";"
 180             if $attr->is_weak_ref;
 181     return $code;
 182 }
 183
 184 sub _inline_trigger {
 185         my ($self, $instance, $value) = @_;
 186         my $attr = $self->associated_attribute;
 187         return '' unless $attr->has_trigger;
 188         return sprintf('$attr->trigger->(%s, %s, $attr);', $instance, $value);
 189 }
 190
 191 sub _inline_get {
 192         my ($self, $instance) = @_;
 193         my $attr = $self->associated_attribute;
 194
 195         my $mi = $attr->associated_class->get_meta_instance;
 196         my $slot_name = sprintf "'%s'", $attr->slots;
 197
 198     return $mi->inline_get_slot_value($instance, $slot_name);
 199 }
 200
 201 sub _inline_auto_deref {
 202     my ( $self, $ref_value ) = @_;
 203         my $attr = $self->associated_attribute;
 204
 205     return $ref_value unless $attr->should_auto_deref;
 206
 207     my $type_constraint = $attr->type_constraint;
 208
 209     my $sigil;
 210     if ($type_constraint->is_a_type_of('ArrayRef')) {
 211         $sigil = '@';
 212     }
 213     elsif ($type_constraint->is_a_type_of('HashRef')) {
 214         $sigil = '%';
 215     }
 216     else {
 217         confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
 218     }
 219
 220     "(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
 221 }
 222
 223 1;
 224
 225 __END__
 226
 227 =pod
 228
 229 =head1 NAME
 230
 231 =head1 SYNOPOSIS
 232
 233 =head1 DESCRIPTION
 234
 235 =head1 METHODS
 236
 237 =over 4
 238
 239 =item B<generate_accessor_method>
 240
 241 =item B<generate_accessor_method_inline>
 242
 243 =item B<generate_reader_method>
 244
 245 =item B<generate_reader_method_inline>
 246
 247 =item B<generate_writer_method>
 248
 249 =item B<generate_writer_method_inline>
 250
 251 =back
 252
 253 =head1 BUGS
 254
 255 All complex software has bugs lurking in it, and this module is no
 256 exception. If you find a bug please either email me, or add the bug
 257 to cpan-RT.
 258
 259 =head1 AUTHOR
 260
 261 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 262
 263 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 264
 265 =head1 COPYRIGHT AND LICENSE
 266
 267 Copyright 2006 by Infinity Interactive, Inc.
 268
 269 L<http://www.iinteractive.com>
 270
 271 This library is free software; you can redistribute it and/or modify
 272 it under the same terms as Perl itself.
 273
 274 =cut