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