lib/Mouse/Meta/Method/Accessor.pm

   1 package Mouse::Meta::Method::Accessor;
   2 use strict;
   3 use warnings;
   4 use Carp ();
   5
   6 # internal use only. do not call directly
   7 sub generate_accessor_method_inline {
   8     my ($class, $attribute) = @_;
   9
  10     my $name          = $attribute->name;
  11     my $default       = $attribute->default;
  12     my $constraint    = $attribute->type_constraint;
  13     my $builder       = $attribute->builder;
  14     my $trigger       = $attribute->trigger;
  15     my $is_weak       = $attribute->is_weak_ref;
  16     my $should_deref  = $attribute->should_auto_deref;
  17     my $should_coerce = $attribute->should_coerce;
  18
  19     my $compiled_type_constraint    = $constraint ? $constraint->{_compiled_type_constraint} : undef;
  20
  21     my $self  = '$_[0]';
  22     my $key   = $attribute->inlined_name;
  23
  24     my $accessor =
  25         '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
  26         "sub {\n";
  27     if ($attribute->_is_metadata eq 'rw') {
  28         $accessor .=
  29             '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
  30             'if (scalar(@_) >= 2) {' . "\n";
  31
  32         my $value = '$_[1]';
  33
  34         if ($constraint) {
  35             if ($should_coerce) {
  36                 $accessor .=
  37                     "\n".
  38                     '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
  39                     'my $val = Mouse::Util::TypeConstraints->typecast_constraints("'.$attribute->associated_class->name.'", $attribute->{type_constraint}, '.$value.');';
  40                 $value = '$val';
  41             }
  42             if ($compiled_type_constraint) {
  43                 $accessor .=
  44                     "\n".
  45                     '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
  46                     'unless ($compiled_type_constraint->('.$value.')) {
  47                         $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
  48                     }' . "\n";
  49             } else {
  50                 $accessor .=
  51                     "\n".
  52                     '#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
  53                     'unless ($constraint->check('.$value.')) {
  54                         $attribute->verify_type_constraint_error($name, '.$value.', $attribute->{type_constraint});
  55                     }' . "\n";
  56             }
  57         }
  58
  59         # if there's nothing left to do for the attribute we can return during
  60         # this setter
  61         $accessor .= 'return ' if !$is_weak && !$trigger && !$should_deref;
  62
  63         $accessor .= $self.'->{'.$key.'} = '.$value.';' . "\n";
  64
  65         if ($is_weak) {
  66             $accessor .= 'Scalar::Util::weaken('.$self.'->{'.$key.'}) if ref('.$self.'->{'.$key.'});' . "\n";
  67         }
  68
  69         if ($trigger) {
  70             $accessor .= '$trigger->('.$self.', '.$value.');' . "\n";
  71         }
  72
  73         $accessor .= "}\n";
  74     }
  75     else {
  76         $accessor .= 'Carp::confess("Cannot assign a value to a read-only accessor") if scalar(@_) >= 2;' . "\n";
  77     }
  78
  79     if ($attribute->is_lazy) {
  80         $accessor .= $self.'->{'.$key.'} = ';
  81
  82         $accessor .= $attribute->has_builder
  83                 ? $self.'->$builder'
  84                     : ref($default) eq 'CODE'
  85                     ? '$default->('.$self.')'
  86                     : '$default';
  87         $accessor .= ' if !exists '.$self.'->{'.$key.'};' . "\n";
  88     }
  89
  90     if ($should_deref) {
  91         if (ref($constraint) && $constraint->name =~ '^ArrayRef\b') {
  92             $accessor .= 'if (wantarray) {
  93                 return @{ '.$self.'->{'.$key.'} || [] };
  94             }';
  95         }
  96         else {
  97             $accessor .= 'if (wantarray) {
  98                 return %{ '.$self.'->{'.$key.'} || {} };
  99             }';
 100         }
 101     }
 102
 103     $accessor .= 'return '.$self.'->{'.$key.'};
 104     }';
 105
 106     my $sub = eval $accessor;
 107     Carp::confess($@) if $@;
 108     return $sub;
 109 }
 110
 111 1;