lib/Moose/Meta/Method/Accessor.pm

   1
   2 package Moose::Meta::Method::Accessor;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Try::Tiny;
   8
   9 our $VERSION   = '1.19';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Moose::Meta::Method',
  14          'Class::MOP::Method::Accessor';
  15
  16 sub _error_thrower {
  17     my $self = shift;
  18     return $self->associated_attribute
  19         if ref($self) && defined($self->associated_attribute);
  20     return $self->SUPER::_error_thrower;
  21 }
  22
  23 sub _compile_code {
  24     my $self = shift;
  25     my @args = @_;
  26     try {
  27         $self->SUPER::_compile_code(@args);
  28     }
  29     catch {
  30         $self->throw_error(
  31             'Could not create writer for '
  32           . "'" . $self->associated_attribute->name . "' "
  33           . 'because ' . $_,
  34             error => $_,
  35         );
  36     };
  37 }
  38
  39 sub _eval_environment {
  40     my $self = shift;
  41
  42     my $attr                = $self->associated_attribute;
  43     my $type_constraint_obj = $attr->type_constraint;
  44
  45     return {
  46         '$attr'                => \$attr,
  47         '$meta'                => \$self,
  48         '$type_constraint_obj' => \$type_constraint_obj,
  49         '$type_constraint'     => \(
  50               $type_constraint_obj
  51                   ? $type_constraint_obj->_compiled_type_constraint
  52                   : undef
  53         ),
  54     };
  55 }
  56
  57 sub _generate_accessor_method_inline {
  58     my $self        = shift;
  59
  60     my $inv         = '$_[0]';
  61     my $slot_access = $self->_get_value($inv);
  62     my $value       = $self->_value_needs_copy ? '$val' : '$_[1]';
  63     my $old         = '@old';
  64
  65     $self->_compile_code([
  66         'sub {',
  67             $self->_inline_pre_body(@_),
  68             'if (scalar(@_) >= 2) {',
  69                 $self->_inline_copy_value($value),
  70                 $self->_inline_check_required,
  71                 $self->_inline_tc_code($value),
  72                 $self->_inline_get_old_value_for_trigger($inv, $old),
  73                 $self->_inline_store_value($inv, $value),
  74                 $self->_inline_trigger($inv, $value, $old),
  75             '}',
  76             $self->_inline_check_lazy($inv),
  77             $self->_inline_post_body(@_),
  78             $self->_inline_return_auto_deref($slot_access),
  79         '}',
  80     ]);
  81 }
  82
  83 sub _generate_writer_method_inline {
  84     my $self        = shift;
  85
  86     my $inv   = '$_[0]';
  87     my $value = $self->_value_needs_copy ? '$val' : '$_[1]';
  88     my $old   = '@old';
  89
  90     $self->_compile_code([
  91         'sub {',
  92             $self->_inline_pre_body(@_),
  93             $self->_inline_copy_value($value),
  94             $self->_inline_check_required,
  95             $self->_inline_tc_code($value),
  96             $self->_inline_get_old_value_for_trigger($inv, $old),
  97             $self->_inline_store_value($inv, $value),
  98             $self->_inline_post_body(@_),
  99             $self->_inline_trigger($inv, $value, $old),
 100         '}',
 101     ]);
 102 }
 103
 104 sub _generate_reader_method_inline {
 105     my $self        = shift;
 106
 107     my $inv         = '$_[0]';
 108     my $slot_access = $self->_get_value($inv);
 109
 110     $self->_compile_code([
 111         'sub {',
 112             $self->_inline_pre_body(@_),
 113             'if (@_ > 1) {',
 114                 $self->_inline_throw_error(
 115                     '"Cannot assign a value to a read-only accessor"',
 116                     'data => \@_'
 117                 ) . ';',
 118             '}',
 119             $self->_inline_check_lazy($inv),
 120             $self->_inline_post_body(@_),
 121             $self->_inline_return_auto_deref($slot_access),
 122         '}',
 123     ]);
 124 }
 125
 126 sub _inline_copy_value {
 127     my $self = shift;
 128     my ($value) = @_;
 129
 130     return unless $self->_value_needs_copy;
 131     return 'my ' . $value . ' = $_[1];'
 132 }
 133
 134 sub _value_needs_copy {
 135     my $self = shift;
 136     return $self->associated_attribute->should_coerce;
 137 }
 138
 139 sub _instance_is_inlinable {
 140     my $self = shift;
 141     return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
 142 }
 143
 144 sub _generate_reader_method {
 145     my $self = shift;
 146     $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
 147                                   : $self->SUPER::_generate_reader_method(@_);
 148 }
 149
 150 sub _generate_writer_method {
 151     my $self = shift;
 152     $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
 153                                   : $self->SUPER::_generate_writer_method(@_);
 154 }
 155
 156 sub _generate_accessor_method {
 157     my $self = shift;
 158     $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
 159                                   : $self->SUPER::_generate_accessor_method(@_);
 160 }
 161
 162 sub _generate_predicate_method {
 163     my $self = shift;
 164     $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
 165                                   : $self->SUPER::_generate_predicate_method(@_);
 166 }
 167
 168 sub _generate_clearer_method {
 169     my $self = shift;
 170     $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
 171                                   : $self->SUPER::_generate_clearer_method(@_);
 172 }
 173
 174 sub _inline_pre_body  { return }
 175 sub _inline_post_body { return }
 176
 177 sub _inline_tc_code {
 178     my $self = shift;
 179     return (
 180         $self->_inline_check_coercion(@_),
 181         $self->_inline_check_constraint(@_),
 182     );
 183 }
 184
 185 sub _inline_check_constraint {
 186     my $self = shift;
 187     my ($value) = @_;
 188
 189     my $attr = $self->associated_attribute;
 190     return unless $attr->has_type_constraint;
 191
 192     my $attr_name = quotemeta($attr->name);
 193
 194     return (
 195         'if (!$type_constraint->(' . $value . ')) {',
 196             $self->_inline_throw_error(
 197                 '"Attribute (' . $attr_name . ') does not pass the type '
 198               . 'constraint because: " . '
 199               . '$type_constraint_obj->get_message(' . $value . ')',
 200                 'data => ' . $value
 201             ) . ';',
 202         '}',
 203     );
 204 }
 205
 206 sub _inline_check_coercion {
 207     my $self = shift;
 208     my ($value) = @_;
 209
 210     my $attr = $self->associated_attribute;
 211     return unless $attr->should_coerce && $attr->type_constraint->has_coercion;
 212
 213     return $value . ' = $type_constraint_obj->coerce(' . $value . ');';
 214 }
 215
 216 sub _inline_check_required {
 217     my $self = shift;
 218
 219     my $attr = $self->associated_attribute;
 220     return unless $attr->is_required;
 221
 222     my $attr_name = quotemeta($attr->name);
 223
 224     return (
 225         'if (@_ < 2) {',
 226             $self->_inline_throw_error(
 227                 '"Attribute (' . $attr_name . ') is required, so cannot '
 228               . 'be set to undef"' # defined $_[1] is not good enough
 229             ) . ';',
 230         '}',
 231     );
 232 }
 233
 234 sub _inline_check_lazy {
 235     my $self = shift;
 236     my ($instance, $default) = @_;
 237
 238     my $attr = $self->associated_attribute;
 239     return unless $attr->is_lazy;
 240
 241     my $slot_exists = $self->_has_value($instance);
 242
 243     return (
 244         'if (!' . $slot_exists . ') {',
 245             $self->_inline_init_from_default($instance, '$default', 'lazy'),
 246         '}',
 247     );
 248 }
 249
 250 sub _inline_init_from_default {
 251     my $self = shift;
 252     my ($instance, $default, $for_lazy) = @_;
 253
 254     my $attr = $self->associated_attribute;
 255     # XXX: should this throw an error instead?
 256     return $self->_inline_init_slot($attr, $instance, 'undef')
 257         unless $attr->has_default || $attr->has_builder;
 258
 259     return (
 260         $self->_inline_generate_default($instance, $default),
 261         # intentionally not using _inline_tc_code, since that can be overridden
 262         # to do things like possibly only do member tc checks, which isn't
 263         # appropriate for checking the result of a default
 264         $attr->has_type_constraint
 265             ? ($self->_inline_check_coercion($default, $for_lazy),
 266                $self->_inline_check_constraint($default, $for_lazy))
 267             : (),
 268         $self->_inline_init_slot($attr, $instance, $default),
 269     );
 270 }
 271
 272 sub _inline_generate_default {
 273     my $self = shift;
 274     my ($instance, $default) = @_;
 275
 276     my $attr = $self->associated_attribute;
 277
 278     if ($attr->has_default) {
 279         return 'my ' . $default . ' = $attr->default(' . $instance . ');';
 280     }
 281     elsif ($attr->has_builder) {
 282         return (
 283             'my ' . $default . ';',
 284             'if (my $builder = ' . $instance . '->can($attr->builder)) {',
 285                 $default . ' = ' . $instance . '->$builder;',
 286             '}',
 287             'else {',
 288                 'my $class = ref(' . $instance . ') || ' . $instance . ';',
 289                 'my $builder_name = $attr->builder;',
 290                 'my $attr_name = $attr->name;',
 291                 $self->_inline_throw_error(
 292                     '"$class does not support builder method '
 293                   . '\'$builder_name\' for attribute \'$attr_name\'"'
 294                 ) . ';',
 295             '}',
 296         );
 297     }
 298     else {
 299         $self->throw_error(
 300             "Can't generate a default for " . $attr->name
 301           . " since no default or builder was specified"
 302         );
 303     }
 304 }
 305
 306 sub _inline_init_slot {
 307     my $self = shift;
 308     my ($attr, $inv, $value) = @_;
 309
 310     if ($attr->has_initializer) {
 311         return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
 312     }
 313     else {
 314         return $self->_inline_store_value($inv, $value);
 315     }
 316 }
 317
 318 sub _inline_store_value {
 319     my $self = shift;
 320     my ($inv, $value) = @_;
 321
 322     return $self->_store_value($inv, $value) . ';';
 323 }
 324
 325 sub _inline_get_old_value_for_trigger {
 326     my $self = shift;
 327     my ($instance, $old) = @_;
 328
 329     my $attr = $self->associated_attribute;
 330     return unless $attr->has_trigger;
 331
 332     return (
 333         'my ' . $old . ' = ' . $self->_has_value($instance),
 334             '? ' . $self->_get_value($instance),
 335             ': ();',
 336     );
 337 }
 338
 339 sub _inline_trigger {
 340     my $self = shift;
 341     my ($instance, $value, $old) = @_;
 342
 343     my $attr = $self->associated_attribute;
 344     return unless $attr->has_trigger;
 345
 346     return '$attr->trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
 347 }
 348
 349 sub _inline_return_auto_deref {
 350     my $self = shift;
 351
 352     return 'return ' . $self->_auto_deref(@_) . ';';
 353 }
 354
 355 # expressions
 356
 357 sub _store_value {
 358     my $self = shift;
 359     my ($instance, $value) = @_;
 360
 361     return $self->associated_attribute->inline_set($instance, $value) . ';';
 362 }
 363
 364 sub _get_value {
 365     my ($self, $instance) = @_;
 366
 367     return $self->associated_attribute->inline_get($instance);
 368 }
 369
 370 sub _has_value {
 371     my ($self, $instance) = @_;
 372
 373     return $self->associated_attribute->inline_has($instance);
 374 }
 375
 376 sub _auto_deref {
 377     my $self = shift;
 378     my ($ref_value) = @_;
 379
 380     my $attr = $self->associated_attribute;
 381     return $ref_value unless $attr->should_auto_deref;
 382
 383     my $type_constraint = $attr->type_constraint;
 384
 385     my $sigil;
 386     if ($type_constraint->is_a_type_of('ArrayRef')) {
 387         $sigil = '@';
 388     }
 389     elsif ($type_constraint->is_a_type_of('HashRef')) {
 390         $sigil = '%';
 391     }
 392     else {
 393         $self->throw_error(
 394             'Can not auto de-reference the type constraint \''
 395           . $type_constraint->name
 396           . '\'',
 397             type_constraint => $type_constraint,
 398         );
 399     }
 400
 401     return 'wantarray '
 402              . '? ' . $sigil . '{ (' . $ref_value . ') || return } '
 403              . ': (' . $ref_value . ')';
 404 }
 405
 406 1;
 407
 408 __END__
 409
 410 =pod
 411
 412 =head1 NAME
 413
 414 Moose::Meta::Method::Accessor - A Moose Method metaclass for accessors
 415
 416 =head1 DESCRIPTION
 417
 418 This class is a subclass of L<Class::MOP::Method::Accessor> that
 419 provides additional Moose-specific functionality, all of which is
 420 private.
 421
 422 To understand this class, you should read the the
 423 L<Class::MOP::Method::Accessor> documentation.
 424
 425 =head1 BUGS
 426
 427 See L<Moose/BUGS> for details on reporting bugs.
 428
 429 =head1 AUTHOR
 430
 431 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 432
 433 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 434
 435 =head1 COPYRIGHT AND LICENSE
 436
 437 Copyright 2006-2010 by Infinity Interactive, Inc.
 438
 439 L<http://www.iinteractive.com>
 440
 441 This library is free software; you can redistribute it and/or modify
 442 it under the same terms as Perl itself.
 443
 444 =cut