Commit | Line | Data |
0fb58589 |
1 | package SQL::Translator::Role::ListAttr; |
2 | use strictures 1; |
3 | use SQL::Translator::Utils qw(parse_list_arg ex2err); |
4 | use List::MoreUtils qw(uniq); |
5 | |
6 | use Package::Variant ( |
7 | importing => { |
8 | 'Moo::Role' => [], |
9 | }, |
10 | subs => [qw(has around)], |
11 | ); |
12 | |
13 | |
14 | sub make_variant { |
15 | my ($class, $target_package, $name, %arguments) = @_; |
16 | |
17 | my $may_throw = delete $arguments{may_throw}; |
18 | my $undef_if_empty = delete $arguments{undef_if_empty}; |
19 | my $append = delete $arguments{append}; |
20 | my $coerce = delete $arguments{uniq} |
21 | ? sub { [ uniq @{parse_list_arg($_[0])} ] } |
22 | : \&parse_list_arg; |
23 | |
24 | has($name => ( |
25 | is => 'rw', |
26 | (!$arguments{builder} ? ( |
27 | default => sub { [] }, |
28 | ) : ()), |
29 | coerce => $coerce, |
30 | %arguments, |
31 | )); |
32 | |
33 | around($name => sub { |
34 | my ($orig, $self) = (shift, shift); |
35 | my $list = parse_list_arg(@_); |
36 | $self->$orig([ @{$append ? $self->$orig : []}, @$list ]) |
37 | if @$list; |
38 | |
39 | my $return; |
40 | if ($may_throw) { |
41 | $return = ex2err($orig, $self) or return; |
42 | } |
43 | else { |
44 | $return = $self->$orig; |
45 | } |
46 | my $scalar_return = !@{$return} && $undef_if_empty ? undef : $return; |
47 | return wantarray ? @{$return} : $scalar_return; |
48 | }); |
49 | } |
50 | |
51 | 1; |