File Coverage

blib/lib/SQL/Translator/Role/ListAttr.pm
Criterion Covered Total %
statement 35 35 100.0
branch 16 16 100.0
condition 3 3 100.0
subroutine 8 8 100.0
pod 0 1 0.0
total 62 63 98.4


line stmt bran cond sub pod time code
1             package SQL::Translator::Role::ListAttr;
2              
3 72     72   515 use warnings;
  72         177  
  72         2454  
4 72     72   395 use strict;
  72         208  
  72         2139  
5              
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 for context-sensitive list
21             attributes.
22              
23             =cut
24              
25 72     72   430 use SQL::Translator::Utils qw(parse_list_arg ex2err uniq);
  72         191  
  72         3884  
26 72     72   3529 use Sub::Quote qw(quote_sub);
  72         31560  
  72         4744  
27              
28             use Package::Variant (
29 72         615 importing => {
30             'Moo::Role' => [],
31             },
32             subs => [qw(has around)],
33 72     72   36021 );
  72         355671  
34              
35             =head1 FUNCTIONS
36              
37             =head2 ListAttr $name => %parameters;
38              
39             Returns a L 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 or C is provided, the
42             default value is the empty list.
43              
44             On setting, the arguments are parsed using
45             L, 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
64             an exception (e.g. from a C or C check), this should be
65             set to make the accessor store the exception using
66             L and return undef.
67              
68             =item undef_if_empty
69              
70             If true, and the list is empty, the accessor will return C
71             instead of a reference to an empty in scalar context.
72              
73             =back
74              
75             Unknown parameters are passed through to the L call for
76             the attribute.
77              
78             =cut
79              
80             sub make_variant {
81 704     704 0 537752 my ($class, $target_package, $name, %arguments) = @_;
82              
83 704         1947 my $may_throw = delete $arguments{may_throw};
84 704         1583 my $undef_if_empty = delete $arguments{undef_if_empty};
85 704         1336 my $append = delete $arguments{append};
86             my $coerce = delete $arguments{uniq}
87 861     861   37398 ? sub { [ uniq @{parse_list_arg($_[0])} ] }
  861         2991  
88 704 100       3047 : \&parse_list_arg;
89              
90             has($name => (
91             is => 'rw',
92             (!$arguments{builder} ? (
93 704 100       3479 default => quote_sub(q{ [] }),
94             ) : ()),
95             coerce => $coerce,
96             %arguments,
97             ));
98              
99             around($name => sub {
100 4037     4037   136848 my ($orig, $self) = (shift, shift);
101 4037         10351 my $list = parse_list_arg(@_);
102 4037 100       10079 $self->$orig([ @{$append ? $self->$orig : []}, @$list ])
  143 100       2805  
103             if @$list;
104              
105 4037         9056 my $return;
106 4037 100       7744 if ($may_throw) {
107 484 100       1385 $return = ex2err($orig, $self) or return;
108             }
109             else {
110 3553         58815 $return = $self->$orig;
111             }
112 4026 100 100     32416 my $scalar_return = !@{$return} && $undef_if_empty ? undef : $return;
113 4026 100       17784 return wantarray ? @{$return} : $scalar_return;
  998         5468  
114 704         737690 });
115             }
116              
117             =head1 SEE ALSO
118              
119             =over
120              
121             =item L
122              
123             =item L
124              
125             =back
126              
127             =cut
128              
129             1;