Commit | Line | Data |
44babf1f |
1 | package Moose::Meta::Method::Accessor::Native::Hash::set; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
d3a83c08 |
6 | use List::MoreUtils (); |
44babf1f |
7 | use Scalar::Util qw( looks_like_number ); |
8 | |
8b9641b8 |
9 | use Moose::Role; |
10 | |
11 | with 'Moose::Meta::Method::Accessor::Native::Hash::Writer' => { |
12 | -excludes => [ |
13 | qw( |
14 | _minimum_arguments |
15 | _maximum_arguments |
16 | _inline_process_arguments |
17 | _inline_check_arguments |
53a4677c |
18 | _inline_coerce_new_values |
a486d5ad |
19 | _inline_optimized_set_new_value |
7f5ec80d |
20 | _return_value |
8b9641b8 |
21 | ) |
22 | ], |
23 | }; |
44babf1f |
24 | |
25 | sub _minimum_arguments { 2 } |
26 | |
27 | sub _maximum_arguments { undef } |
28 | |
8b9641b8 |
29 | around _inline_check_argument_count => sub { |
30 | my $orig = shift; |
44babf1f |
31 | my $self = shift; |
32 | |
53a4677c |
33 | return ( |
34 | $self->$orig(@_), |
35 | 'if (@_ % 2) {', |
36 | $self->_inline_throw_error( |
53f4ad9f |
37 | sprintf( |
38 | '"You must pass an even number of arguments to %s"', |
39 | $self->delegate_to_method, |
40 | ), |
53a4677c |
41 | ) . ';', |
42 | '}', |
43 | ); |
8b9641b8 |
44 | }; |
44babf1f |
45 | |
46 | sub _inline_process_arguments { |
47 | my $self = shift; |
48 | |
53a4677c |
49 | return ( |
50 | 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;', |
51 | 'my @values_idx = grep { $_ % 2 } 0..$#_;', |
52 | ); |
44babf1f |
53 | } |
54 | |
55 | sub _inline_check_arguments { |
56 | my $self = shift; |
57 | |
53a4677c |
58 | return ( |
59 | 'for (@keys_idx) {', |
60 | 'if (!defined($_[$_])) {', |
61 | $self->_inline_throw_error( |
53f4ad9f |
62 | sprintf( |
63 | '"Hash keys passed to %s must be defined"', |
64 | $self->delegate_to_method, |
65 | ), |
53a4677c |
66 | ) . ';', |
67 | '}', |
68 | '}', |
69 | ); |
44babf1f |
70 | } |
71 | |
72 | sub _adds_members { 1 } |
73 | |
d3a83c08 |
74 | # We need to override this because while @_ can be written to, we cannot write |
75 | # directly to $_[1]. |
53a4677c |
76 | sub _inline_coerce_new_values { |
d3a83c08 |
77 | my $self = shift; |
78 | |
53a4677c |
79 | return unless $self->associated_attribute->should_coerce; |
d3a83c08 |
80 | |
53a4677c |
81 | return unless $self->_tc_member_type_can_coerce; |
d3a83c08 |
82 | |
83 | # Is there a simpler way to do this? |
53a4677c |
84 | return ( |
85 | 'my $iter = List::MoreUtils::natatime(2, @_);', |
86 | '@_ = ();', |
87 | 'while (my ($key, $val) = $iter->()) {', |
ec02b571 |
88 | 'push @_, $key, $member_coercion->($val);', |
53a4677c |
89 | '}', |
90 | ); |
d3a83c08 |
91 | }; |
92 | |
44babf1f |
93 | sub _potential_value { |
53a4677c |
94 | my $self = shift; |
95 | my ($slot_access) = @_; |
44babf1f |
96 | |
53a4677c |
97 | return '{ %{ (' . $slot_access . ') }, @_ }'; |
44babf1f |
98 | } |
99 | |
100 | sub _new_members { '@_[ @values_idx ]' } |
101 | |
a486d5ad |
102 | sub _inline_optimized_set_new_value { |
53a4677c |
103 | my $self = shift; |
104 | my ($inv, $new, $slot_access) = @_; |
44babf1f |
105 | |
a486d5ad |
106 | return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];'; |
44babf1f |
107 | } |
108 | |
7f5ec80d |
109 | sub _return_value { |
53a4677c |
110 | my $self = shift; |
111 | my ($slot_access) = @_; |
7f5ec80d |
112 | |
53a4677c |
113 | return 'wantarray ' |
114 | . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } ' |
115 | . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }'; |
7f5ec80d |
116 | } |
117 | |
8b9641b8 |
118 | no Moose::Role; |
119 | |
44babf1f |
120 | 1; |