Commit | Line | Data |
5df54980 |
1 | package Moose::Meta::Method::Accessor::Native::Writer; |
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 'Moose::Meta::Method::Accessor::Native'; |
11 | |
12 | sub _generate_method { |
13 | my $self = shift; |
14 | |
15 | my $inv = '$self'; |
16 | |
17 | my $slot_access = $self->_inline_get($inv); |
18 | |
19 | my $code = 'sub {'; |
e7724627 |
20 | |
5df54980 |
21 | $code .= "\n" . $self->_inline_pre_body(@_); |
22 | |
23 | $code .= "\n" . 'my $self = shift;'; |
24 | |
5df54980 |
25 | $code .= "\n" . $self->_inline_curried_arguments; |
26 | |
e7724627 |
27 | $code .= $self->_writer_core( $inv, $slot_access ); |
5df54980 |
28 | |
e7724627 |
29 | $code .= "\n" . $self->_inline_post_body(@_); |
30 | |
31 | $code .= "\n}"; |
5df54980 |
32 | |
e7724627 |
33 | return $code; |
34 | } |
35 | |
36 | sub _writer_core { |
37 | my ( $self, $inv, $slot_access ) = @_; |
38 | |
39 | my $code = q{}; |
40 | |
41 | $code .= "\n" . $self->_inline_check_argument_count; |
42 | $code .= "\n" . $self->_inline_process_arguments( $inv, $slot_access ); |
43 | $code .= "\n" . $self->_inline_check_arguments('for writer'); |
44 | |
45 | $code .= "\n" . $self->_inline_check_lazy($inv); |
5df54980 |
46 | |
47 | my $new_value = $self->_new_value($slot_access); |
48 | my $potential_value = $self->_potential_value($slot_access); |
49 | |
50 | $code .= "\n" . $self->_inline_copy_value( \$potential_value ); |
5df54980 |
51 | $code .= "\n" |
52 | . $self->_inline_tc_code( |
53 | $new_value, |
54 | $potential_value |
55 | ); |
56 | |
57 | $code .= "\n" . $self->_inline_get_old_value_for_trigger($inv); |
e32b7489 |
58 | $code .= "\n" . $self->_inline_capture_return_value($slot_access); |
5df54980 |
59 | $code .= "\n" |
60 | . $self->_inline_set_new_value( |
61 | $inv, |
e32b7489 |
62 | $potential_value, |
63 | $slot_access, |
5df54980 |
64 | ); |
5df54980 |
65 | $code .= "\n" . $self->_inline_trigger( $inv, $slot_access, '@old' ); |
e32b7489 |
66 | $code .= "\n" . $self->_return_value( $slot_access, 'for writer' ); |
5df54980 |
67 | |
68 | return $code; |
69 | } |
70 | |
71 | sub _inline_process_arguments {q{}} |
72 | |
73 | sub _inline_check_arguments {q{}} |
74 | |
75 | sub _value_needs_copy {0} |
76 | |
fa072458 |
77 | sub _inline_copy_value { |
78 | my ( $self, $potential_ref ) = @_; |
79 | |
80 | return q{} unless $self->_value_needs_copy; |
81 | |
82 | my $code = "my \$potential = ${$potential_ref};"; |
83 | |
84 | ${$potential_ref} = '$potential'; |
85 | |
86 | return $code; |
87 | } |
88 | |
e7724627 |
89 | sub _inline_tc_code { |
90 | die '_inline_tc_code must be overridden by ' . ref $_[0]; |
91 | } |
5df54980 |
92 | |
e7724627 |
93 | sub _inline_check_coercion { |
94 | die '_inline_check_coercion must be overridden by ' . ref $_[0]; |
95 | } |
5df54980 |
96 | |
97 | sub _inline_check_constraint { |
98 | my $self = shift; |
99 | |
100 | return q{} unless $self->_constraint_must_be_checked; |
101 | |
102 | return $self->SUPER::_inline_check_constraint( $_[0] ); |
103 | } |
104 | |
e7724627 |
105 | sub _constraint_must_be_checked { |
106 | die '_constraint_must_be_checked must be overridden by ' . ref $_[0]; |
107 | } |
5df54980 |
108 | |
e32b7489 |
109 | sub _inline_capture_return_value { return q{} } |
5df54980 |
110 | |
111 | sub _inline_set_new_value { |
112 | my $self = shift; |
113 | |
e32b7489 |
114 | return $self->SUPER::_inline_store(@_) |
115 | if $self->_value_needs_copy; |
116 | |
117 | return $self->_inline_optimized_set_new_value(@_); |
118 | } |
119 | |
120 | sub _inline_optimized_set_new_value { |
121 | my $self = shift; |
122 | |
123 | return $self->SUPER::_inline_store(@_) |
5df54980 |
124 | } |
125 | |
e7724627 |
126 | sub _return_value { return q{} } |
5df54980 |
127 | |
128 | 1; |