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