lib/SQL/Translator/Role/ListAttr.pm

   1 package SQL::Translator::Role::ListAttr;
   2
   3 use warnings;
   4 use strict;
   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<Moo::Role> for context-sensitive list
  21 attributes.
  22
  23 =cut
  24
  25 use SQL::Translator::Utils qw(parse_list_arg ex2err uniq);
  26 use Sub::Quote qw(quote_sub);
  27
  28 use Package::Variant (
  29     importing => {
  30         'Moo::Role' => [],
  31     },
  32     subs => [qw(has around)],
  33 );
  34
  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
  75 Unknown parameters are passed through to the L<has|Moo/has> call for
  76 the attribute.
  77
  78 =cut
  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} ? (
  93             default => quote_sub(q{ [] }),
  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
 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
 129 1;