lib/SQL/Translator/Role/ListAttr.pm

   1 package SQL::Translator::Role::ListAttr;
   2 use strictures 1;
   3 use SQL::Translator::Utils qw(parse_list_arg ex2err);
   4 use List::MoreUtils qw(uniq);
   5 use Sub::Quote qw(quote_sub);
   6
   7 use Package::Variant (
   8     importing => {
   9         'Moo::Role' => [],
  10     },
  11     subs => [qw(has around)],
  12 );
  13
  14
  15 sub make_variant {
  16     my ($class, $target_package, $name, %arguments) = @_;
  17
  18     my $may_throw = delete $arguments{may_throw};
  19     my $undef_if_empty = delete $arguments{undef_if_empty};
  20     my $append = delete $arguments{append};
  21     my $coerce = delete $arguments{uniq}
  22         ? sub { [ uniq @{parse_list_arg($_[0])} ] }
  23         : \&parse_list_arg;
  24
  25     has($name => (
  26         is => 'rw',
  27         (!$arguments{builder} ? (
  28             default => quote_sub(q{ [] }),
  29         ) : ()),
  30         coerce => $coerce,
  31         %arguments,
  32     ));
  33
  34     around($name => sub {
  35         my ($orig, $self) = (shift, shift);
  36         my $list = parse_list_arg(@_);
  37         $self->$orig([ @{$append ? $self->$orig : []}, @$list ])
  38             if @$list;
  39
  40         my $return;
  41         if ($may_throw) {
  42             $return = ex2err($orig, $self) or return;
  43         }
  44         else {
  45             $return = $self->$orig;
  46         }
  47         my $scalar_return = !@{$return} && $undef_if_empty ? undef : $return;
  48         return wantarray ? @{$return} : $scalar_return;
  49     });
  50 }
  51
  52 1;