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