lib/SQL/Translator/Role/ListAttr.pm

   1 package SQL::Translator::Role::ListAttr;
   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
  22 use strictures 1;
  23 use SQL::Translator::Utils qw(parse_list_arg ex2err);
  24 use List::MoreUtils qw(uniq);
  25 use Sub::Quote qw(quote_sub);
  26
  27 use Package::Variant (
  28     importing => {
  29         'Moo::Role' => [],
  30     },
  31     subs => [qw(has around)],
  32 );
  33
  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
  74 Unknown parameters are passed through to the L<has|Moo/has> call for
  75 the attribute.
  76
  77 =cut
  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} ? (
  92             default => quote_sub(q{ [] }),
  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
 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
 128 1;