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( |
37 | '"You must pass an even number of arguments to set"', |
38 | ) . ';', |
39 | '}', |
40 | ); |
8b9641b8 |
41 | }; |
44babf1f |
42 | |
43 | sub _inline_process_arguments { |
44 | my $self = shift; |
45 | |
53a4677c |
46 | return ( |
47 | 'my @keys_idx = grep { ! ($_ % 2) } 0..$#_;', |
48 | 'my @values_idx = grep { $_ % 2 } 0..$#_;', |
49 | ); |
44babf1f |
50 | } |
51 | |
52 | sub _inline_check_arguments { |
53 | my $self = shift; |
54 | |
53a4677c |
55 | return ( |
56 | 'for (@keys_idx) {', |
57 | 'if (!defined($_[$_])) {', |
58 | $self->_inline_throw_error( |
59 | '"Hash keys passed to set must be defined"', |
60 | ) . ';', |
61 | '}', |
62 | '}', |
63 | ); |
44babf1f |
64 | } |
65 | |
66 | sub _adds_members { 1 } |
67 | |
d3a83c08 |
68 | # We need to override this because while @_ can be written to, we cannot write |
69 | # directly to $_[1]. |
53a4677c |
70 | sub _inline_coerce_new_values { |
d3a83c08 |
71 | my $self = shift; |
72 | |
53a4677c |
73 | return unless $self->associated_attribute->should_coerce; |
d3a83c08 |
74 | |
53a4677c |
75 | return unless $self->_tc_member_type_can_coerce; |
d3a83c08 |
76 | |
77 | # Is there a simpler way to do this? |
53a4677c |
78 | return ( |
79 | 'my $iter = List::MoreUtils::natatime(2, @_);', |
80 | '@_ = ();', |
81 | 'while (my ($key, $val) = $iter->()) {', |
82 | 'push @_, $key, $member_tc_obj->coerce($val);', |
83 | '}', |
84 | ); |
d3a83c08 |
85 | }; |
86 | |
44babf1f |
87 | sub _potential_value { |
53a4677c |
88 | my $self = shift; |
89 | my ($slot_access) = @_; |
44babf1f |
90 | |
53a4677c |
91 | return '{ %{ (' . $slot_access . ') }, @_ }'; |
44babf1f |
92 | } |
93 | |
94 | sub _new_members { '@_[ @values_idx ]' } |
95 | |
a486d5ad |
96 | sub _inline_optimized_set_new_value { |
53a4677c |
97 | my $self = shift; |
98 | my ($inv, $new, $slot_access) = @_; |
44babf1f |
99 | |
a486d5ad |
100 | return '@{ (' . $slot_access . ') }{ @_[@keys_idx] } = @_[@values_idx];'; |
44babf1f |
101 | } |
102 | |
7f5ec80d |
103 | sub _return_value { |
53a4677c |
104 | my $self = shift; |
105 | my ($slot_access) = @_; |
7f5ec80d |
106 | |
53a4677c |
107 | return 'wantarray ' |
108 | . '? @{ (' . $slot_access . ') }{ @_[@keys_idx] } ' |
109 | . ': ' . $slot_access . '->{ $_[$keys_idx[0]] }'; |
7f5ec80d |
110 | } |
111 | |
8b9641b8 |
112 | no Moose::Role; |
113 | |
44babf1f |
114 | 1; |