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 use base 'Moose::Meta::Method',
  10          'Class::MOP::Method::Accessor';
  11
  12 sub _error_thrower {
  13     my $self = shift;
  14     return $self->associated_attribute
  15         if ref($self) && defined($self->associated_attribute);
  16     return $self->SUPER::_error_thrower;
  17 }
  18
  19 sub _compile_code {
  20     my $self = shift;
  21     my @args = @_;
  22     try {
  23         $self->SUPER::_compile_code(@args);
  24     }
  25     catch {
  26         $self->throw_error(
  27             'Could not create writer for '
  28           . "'" . $self->associated_attribute->name . "' "
  29           . 'because ' . $_,
  30             error => $_,
  31         );
  32     };
  33 }
  34
  35 sub _eval_environment {
  36     my $self = shift;
  37
  38     my $env = { };
  39
  40     my $attr = $self->associated_attribute;
  41
  42     $env->{'$trigger'} = \($attr->trigger)
  43         if $attr->has_trigger;
  44     $env->{'$default'} = \($attr->default)
  45         if $attr->has_default;
  46
  47     if ($attr->has_type_constraint) {
  48         my $tc_obj = $attr->type_constraint;
  49
  50         # is this going to be an issue? it's currently only used for the tc
  51         # message. is there a way to inline that too?
  52         $env->{'$type_constraint_obj'} = \$tc_obj;
  53
  54         $env->{'$type_constraint'} = \(
  55             $tc_obj->_compiled_type_constraint
  56         ) unless $tc_obj->can_be_inlined;
  57         $env->{'$type_coercion'} = \(
  58             $tc_obj->coercion->_compiled_type_coercion
  59         ) if $tc_obj->has_coercion;
  60
  61         $env = { %$env, %{ $tc_obj->inline_environment } };
  62     }
  63
  64     # XXX ugh, fix these
  65     $env->{'$attr'} = \$attr
  66         if $attr->has_initializer && $attr->is_lazy;
  67     $env->{'$meta'} = \$self;
  68
  69     return $env;
  70 }
  71
  72 sub _instance_is_inlinable {
  73     my $self = shift;
  74     return $self->associated_attribute->associated_class->instance_metaclass->is_inlinable;
  75 }
  76
  77 sub _generate_reader_method {
  78     my $self = shift;
  79     $self->_instance_is_inlinable ? $self->_generate_reader_method_inline(@_)
  80                                   : $self->SUPER::_generate_reader_method(@_);
  81 }
  82
  83 sub _generate_writer_method {
  84     my $self = shift;
  85     $self->_instance_is_inlinable ? $self->_generate_writer_method_inline(@_)
  86                                   : $self->SUPER::_generate_writer_method(@_);
  87 }
  88
  89 sub _generate_accessor_method {
  90     my $self = shift;
  91     $self->_instance_is_inlinable ? $self->_generate_accessor_method_inline(@_)
  92                                   : $self->SUPER::_generate_accessor_method(@_);
  93 }
  94
  95 sub _generate_predicate_method {
  96     my $self = shift;
  97     $self->_instance_is_inlinable ? $self->_generate_predicate_method_inline(@_)
  98                                   : $self->SUPER::_generate_predicate_method(@_);
  99 }
 100
 101 sub _generate_clearer_method {
 102     my $self = shift;
 103     $self->_instance_is_inlinable ? $self->_generate_clearer_method_inline(@_)
 104                                   : $self->SUPER::_generate_clearer_method(@_);
 105 }
 106
 107 sub _writer_value_needs_copy {
 108     shift->associated_attribute->_writer_value_needs_copy(@_);
 109 }
 110
 111 sub _inline_tc_code {
 112     shift->associated_attribute->_inline_tc_code(@_);
 113 }
 114
 115 sub _inline_check_coercion {
 116     shift->associated_attribute->_inline_check_coercion(@_);
 117 }
 118
 119 sub _inline_check_constraint {
 120     shift->associated_attribute->_inline_check_constraint(@_);
 121 }
 122
 123 sub _inline_check_lazy {
 124     shift->associated_attribute->_inline_check_lazy(@_);
 125 }
 126
 127 sub _inline_store_value {
 128     shift->associated_attribute->_inline_instance_set(@_) . ';';
 129 }
 130
 131 sub _inline_get_old_value_for_trigger {
 132     shift->associated_attribute->_inline_get_old_value_for_trigger(@_);
 133 }
 134
 135 sub _inline_trigger {
 136     shift->associated_attribute->_inline_trigger(@_);
 137 }
 138
 139 sub _get_value {
 140     shift->associated_attribute->_inline_instance_get(@_);
 141 }
 142
 143 sub _has_value {
 144     shift->associated_attribute->_inline_instance_has(@_);
 145 }
 146
 147 1;
 148
 149 # ABSTRACT: A Moose Method metaclass for accessors
 150
 151 __END__
 152
 153 =pod
 154
 155 =head1 DESCRIPTION
 156
 157 This class is a subclass of L<Class::MOP::Method::Accessor> that
 158 provides additional Moose-specific functionality, all of which is
 159 private.
 160
 161 To understand this class, you should read the the
 162 L<Class::MOP::Method::Accessor> documentation.
 163
 164 =head1 BUGS
 165
 166 See L<Moose/BUGS> for details on reporting bugs.
 167
 168 =cut