Commit | Line | Data |
0fb58589 |
1 | package SQL::Translator::Role::ListAttr; |
4e43db0d |
2 | |
3 | =head1 NAME |
4 | |
5 | SQL::Translator::Role::ListAttr - context-sensitive list attributes |
6 | |
7 | =head1 SYNOPSIS |
8 | |
9 | package Foo; |
10 | use Moo; |
11 | use SQL::Translator::Role::ListAttr; |
12 | |
13 | with ListAttr foo => ( uniq => 1, append => 1 ); |
14 | |
15 | =head1 DESCRIPTION |
16 | |
17 | This package provides a variable L<Moo::Role> for context-sensitive list |
18 | attributes. |
19 | |
20 | =cut |
21 | |
0fb58589 |
22 | use strictures 1; |
23 | use SQL::Translator::Utils qw(parse_list_arg ex2err); |
24 | use List::MoreUtils qw(uniq); |
68d75205 |
25 | use Sub::Quote qw(quote_sub); |
0fb58589 |
26 | |
27 | use Package::Variant ( |
28 | importing => { |
29 | 'Moo::Role' => [], |
30 | }, |
31 | subs => [qw(has around)], |
32 | ); |
33 | |
4e43db0d |
34 | =head1 FUNCTIONS |
35 | |
36 | =head2 ListAttr $name => %parameters; |
37 | |
38 | Returns a L<Moo::Role> providing an arrayref attribute named C<$name>, |
39 | and wrapping the accessor to provide context-sensitivity both for |
40 | setting and getting. If no C<builder> or C<default> is provided, the |
41 | default value is the empty list. |
42 | |
43 | On setting, the arguments are parsed using |
44 | L<SQL::Translator::Utils/parse_list_arg>, and the accessor will return |
45 | an array reference or a list, depending on context. |
46 | |
47 | =head3 Parameters |
48 | |
49 | =over |
50 | |
51 | =item append |
52 | |
53 | If true, the setter will append arguments to the existing ones, rather |
54 | than replacing them. |
55 | |
56 | =item uniq |
57 | |
58 | If true, duplicate items will be removed, keeping the first one seen. |
59 | |
60 | =item may_throw |
61 | |
62 | If accessing the attribute might L<throw|SQL::Translator::Utils/throw> |
63 | an exception (e.g. from a C<builder> or C<isa> check), this should be |
64 | set to make the accessor store the exception using |
65 | L<SQL::Translator::Role::Error> and return undef. |
66 | |
67 | =item undef_if_empty |
68 | |
69 | If true, and the list is empty, the accessor will return C<undef> |
70 | instead of a reference to an empty in scalar context. |
71 | |
72 | =back |
73 | |
9fc1e74a |
74 | Unknown parameters are passed through to the L<has|Moo/has> call for |
4e43db0d |
75 | the attribute. |
76 | |
77 | =cut |
0fb58589 |
78 | |
79 | sub make_variant { |
80 | my ($class, $target_package, $name, %arguments) = @_; |
81 | |
82 | my $may_throw = delete $arguments{may_throw}; |
83 | my $undef_if_empty = delete $arguments{undef_if_empty}; |
84 | my $append = delete $arguments{append}; |
85 | my $coerce = delete $arguments{uniq} |
86 | ? sub { [ uniq @{parse_list_arg($_[0])} ] } |
87 | : \&parse_list_arg; |
88 | |
89 | has($name => ( |
90 | is => 'rw', |
91 | (!$arguments{builder} ? ( |
68d75205 |
92 | default => quote_sub(q{ [] }), |
0fb58589 |
93 | ) : ()), |
94 | coerce => $coerce, |
95 | %arguments, |
96 | )); |
97 | |
98 | around($name => sub { |
99 | my ($orig, $self) = (shift, shift); |
100 | my $list = parse_list_arg(@_); |
101 | $self->$orig([ @{$append ? $self->$orig : []}, @$list ]) |
102 | if @$list; |
103 | |
104 | my $return; |
105 | if ($may_throw) { |
106 | $return = ex2err($orig, $self) or return; |
107 | } |
108 | else { |
109 | $return = $self->$orig; |
110 | } |
111 | my $scalar_return = !@{$return} && $undef_if_empty ? undef : $return; |
112 | return wantarray ? @{$return} : $scalar_return; |
113 | }); |
114 | } |
115 | |
4e43db0d |
116 | =head1 SEE ALSO |
117 | |
118 | =over |
119 | |
120 | =item L<SQL::Translator::Utils> |
121 | |
122 | =item L<SQL::Translator::Role::Error> |
123 | |
124 | =back |
125 | |
126 | =cut |
127 | |
0fb58589 |
128 | 1; |