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