Commit | Line | Data |
a7821be5 |
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; |
05c05448 |
42 | |
a7821be5 |
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 | ); |
56 | |
57 | $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv); |
58 | $code .= "\n" . $self->_capture_old_value($slot_access); |
59 | |
60 | $code |
61 | .= "\n" . $self->_inline_store( $inv, '[' . $potential_value . ']' ); |
62 | |
63 | $code .= "\n" . $self->_inline_post_body(@_); |
64 | $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' ); |
65 | |
66 | $code .= "\n}"; |
67 | $code .= "\n}"; |
68 | |
69 | return $code; |
70 | } |
71 | |
72 | # If we get one argument we won't check the argument count |
73 | sub _minimum_arguments {2} |
74 | sub _maximum_arguments {2} |
75 | |
76 | sub _adds_members {1} |
77 | |
78 | sub _potential_value { |
79 | my ( $self, $slot_access ) = @_; |
80 | |
81 | return |
82 | "( do { my \@potential = \@{ $slot_access }; \$potential[ \$_[0] ] = \$_[1]; \@potential } )"; |
83 | } |
84 | |
85 | sub _new_values {'$_[1]'} |
86 | |
87 | sub _eval_environment { |
88 | my $self = shift; |
89 | |
90 | my $env = $self->SUPER::_eval_environment; |
91 | |
92 | return $env |
93 | unless $self->_constraint_must_be_checked |
94 | and $self->_check_new_members_only; |
95 | |
96 | $env->{'$member_tc'} |
97 | = \( $self->associated_attribute->type_constraint->type_parameter |
98 | ->_compiled_type_constraint ); |
99 | |
100 | return $env; |
101 | } |
102 | |
103 | 1; |