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