lib/Moose/Meta/Method/Accessor/Native/Array/accessor.pm

   1 package Moose::Meta::Method::Accessor::Native::Array::accessor;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '1.13';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 use base qw(
  11     Moose::Meta::Method::Accessor::Native::Array::get
  12     Moose::Meta::Method::Accessor::Native::Array::set
  13 );
  14
  15 sub _generate_method {
  16     my $self = shift;
  17
  18     my $inv = '$self';
  19
  20     my $code = 'sub {';
  21     $code .= "\n" . $self->_inline_pre_body(@_);
  22
  23     $code .= "\n" . 'my $self = shift;';
  24
  25     $code .= "\n" . $self->_inline_curried_arguments;
  26
  27     $code .= "\n" . $self->_inline_check_lazy($inv);
  28
  29     my $slot_access = $self->_inline_get($inv);
  30
  31     # get
  32     $code .= "\n" . 'if ( @_ == 1 ) {';
  33
  34     $code .= "\n" . $self->_inline_check_var_is_valid_index('$_[0]');
  35
  36     $code .= "\n" . 'return ' . $self->_return_value($slot_access) . ';';
  37
  38     # set
  39     $code .= "\n" . '} else {';
  40
  41     $code .= "\n" . $self->_inline_check_argument_count;
  42
  43     $code
  44         .= "\n"
  45         . $self
  46         ->Moose::Meta::Method::Accessor::Native::Array::set::_inline_check_arguments;
  47
  48     my $new_values      = $self->_new_values($slot_access);
  49     my $potential_value = $self->_potential_value($slot_access);
  50
  51     $code .= "\n"
  52         . $self->_inline_tc_code(
  53         $new_values,
  54         $potential_value,
  55         $slot_access,
  56         );
  57
  58     $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv);
  59     $code .= "\n" . $self->_inline_capture_return_value($slot_access);
  60
  61     $code
  62         .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' );
  63
  64     $code .= "\n" . $self->_inline_post_body(@_);
  65     $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' );
  66
  67     $code .= "\n}";
  68     $code .= "\n}";
  69
  70     return $code;
  71 }
  72
  73 # If we get one argument we won't check the argument count
  74 sub _minimum_arguments {2}
  75 sub _maximum_arguments {2}
  76
  77 sub _adds_members {1}
  78
  79 sub _potential_value {
  80     my ( $self, $slot_access ) = @_;
  81
  82     return
  83         "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )";
  84 }
  85
  86 sub _new_values {'$_[1]'}
  87
  88 sub _eval_environment {
  89     my $self = shift;
  90
  91     my $env = $self->SUPER::_eval_environment;
  92
  93     return $env
  94         unless $self->_constraint_must_be_checked
  95             and $self->_check_new_members_only;
  96
  97     $env->{'$member_tc'}
  98         = \( $self->associated_attribute->type_constraint->type_parameter
  99             ->_compiled_type_constraint );
 100
 101     return $env;
 102 }
 103
 104 1;