Factor list attributes into variant role

rporres · Sep 22, 2012 · 0fb5858 · 0fb5858
1 parent 6419f0f
commit 0fb5858
Show file tree

Hide file tree

Showing 7 changed files with 72 additions and 152 deletions.
diff --git a/Makefile.PL b/Makefile.PL
@@ -20,6 +20,7 @@ my $deps = {
     'File::Spec'               => '0',
     'XML::Writer'              => '0.500',
     'Moo'                      => '1.000003',
+    'Package::Variant'         => '1.001001',
     'Try::Tiny'                => '0.04',
   },
   recommends => {

diff --git a/lib/SQL/Translator/Role/ListAttr.pm b/lib/SQL/Translator/Role/ListAttr.pm
@@ -0,0 +1,51 @@
+package SQL::Translator::Role::ListAttr;
+use strictures 1;
+use SQL::Translator::Utils qw(parse_list_arg ex2err);
+use List::MoreUtils qw(uniq);
+
+use Package::Variant (
+    importing => {
+        'Moo::Role' => [],
+    },
+    subs => [qw(has around)],
+);
+
+
+sub make_variant {
+    my ($class, $target_package, $name, %arguments) = @_;
+
+    my $may_throw = delete $arguments{may_throw};
+    my $undef_if_empty = delete $arguments{undef_if_empty};
+    my $append = delete $arguments{append};
+    my $coerce = delete $arguments{uniq}
+        ? sub { [ uniq @{parse_list_arg($_[0])} ] }
+        : \&parse_list_arg;
+
+    has($name => (
+        is => 'rw',
+        (!$arguments{builder} ? (
+            default => sub { [] },
+        ) : ()),
+        coerce => $coerce,
+        %arguments,
+    ));
+
+    around($name => sub {
+        my ($orig, $self) = (shift, shift);
+        my $list = parse_list_arg(@_);
+        $self->$orig([ @{$append ? $self->$orig : []}, @$list ])
+            if @$list;
+
+        my $return;
+        if ($may_throw) {
+            $return = ex2err($orig, $self) or return;
+        }
+        else {
+            $return = $self->$orig;
+        }
+        my $scalar_return = !@{$return} && $undef_if_empty ? undef : $return;
+        return wantarray ? @{$return} : $scalar_return;
+    });
+}
+
+1;
diff --git a/lib/SQL/Translator/Schema/Constraint.pm b/lib/SQL/Translator/Schema/Constraint.pm
@@ -25,9 +25,9 @@ C<SQL::Translator::Schema::Constraint> is the constraint object.
 
 use Moo;
 use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
+use SQL::Translator::Utils qw(ex2err throw);
+use SQL::Translator::Role::ListAttr;
 use SQL::Translator::Types qw(schema_obj);
-use List::MoreUtils qw(uniq);
 
 extends 'SQL::Translator::Schema::Object';
 
@@ -207,23 +207,7 @@ avoid the overload magic of the Field objects returned by the fields method.
 
 =cut
 
-has field_names => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around field_names => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    $fields = $self->$orig;
-    return wantarray ? @{$fields}
-        : @{$fields} ? $fields
-        : undef;
-};
+with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 );
 
 =head2 match_type
 
@@ -272,17 +256,7 @@ Returns an array or array reference.
 
 =cut
 
-has options => ( is => 'rw', coerce => \&parse_list_arg, default => sub { [] } );
-
-around options => sub {
-    my $orig    = shift;
-    my $self    = shift;
-    my $options = parse_list_arg( @_ );
-
-    push @{ $self->$orig }, @$options;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr options => ();
 
 =head2 on_delete
 
@@ -329,23 +303,12 @@ arrayref; returns an array or array reference.
 
 =cut
 
-has reference_fields => (
-    is => 'rw',
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
+with ListAttr reference_fields => (
+    may_throw => 1,
     builder => 1,
     lazy => 1,
 );
 
-around reference_fields => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    $fields = ex2err($orig, $self) or return;
-    return wantarray ? @{$fields} : $fields
-};
-
 sub _build_reference_fields {
     my ($self) = @_;
 

diff --git a/lib/SQL/Translator/Schema/Index.pm b/lib/SQL/Translator/Schema/Index.pm
@@ -27,9 +27,9 @@ Primary and unique keys are table constraints, not indices.
 
 use Moo;
 use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
+use SQL::Translator::Utils qw(ex2err throw);
+use SQL::Translator::Role::ListAttr;
 use SQL::Translator::Types qw(schema_obj);
-use List::MoreUtils qw(uniq);
 
 extends 'SQL::Translator::Schema::Object';
 
@@ -65,20 +65,7 @@ names and keep them in order by the first occurrence of a field name.
 
 =cut
 
-has fields => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around fields => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr fields => ( uniq => 1 );
 
 sub is_valid {
 
@@ -124,21 +111,7 @@ an array or array reference.
 
 =cut
 
-has options => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => \&parse_list_arg,
-);
-
-around options => sub {
-    my $orig    = shift;
-    my $self    = shift;
-    my $options = parse_list_arg( @_ );
-
-    push @{ $self->$orig }, @$options;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr options => ();
 
 =head2 table
 

diff --git a/lib/SQL/Translator/Schema/Procedure.pm b/lib/SQL/Translator/Schema/Procedure.pm
@@ -28,9 +28,9 @@ stored procedures (and possibly other pieces of nameable SQL code?).
 =cut
 
 use Moo;
-use SQL::Translator::Utils qw(parse_list_arg ex2err);
+use SQL::Translator::Utils qw(ex2err);
+use SQL::Translator::Role::ListAttr;
 use SQL::Translator::Types qw(schema_obj);
-use List::MoreUtils qw(uniq);
 
 extends 'SQL::Translator::Schema::Object';
 
@@ -58,20 +58,7 @@ Gets and set the parameters of the stored procedure.
 
 =cut
 
-has parameters => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around parameters => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr parameters => ( uniq => 1 );
 
 =head2 name
 

diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm
@@ -22,6 +22,7 @@ C<SQL::Translator::Schema::Table> is the table object.
 use Moo;
 use SQL::Translator::Utils qw(parse_list_arg ex2err throw);
 use SQL::Translator::Types qw(schema_obj);
+use SQL::Translator::Role::ListAttr;
 use SQL::Translator::Schema::Constants;
 use SQL::Translator::Schema::Constraint;
 use SQL::Translator::Schema::Field;
@@ -796,21 +797,7 @@ an array or array reference.
 
 =cut
 
-has options => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => \&parse_list_arg,
-);
-
-around options => sub {
-    my $orig    = shift;
-    my $self    = shift;
-    my $options = parse_list_arg( @_ );
-
-    push @{ $self->$orig }, @$options;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr options => ( append => 1 );
 
 =head2 order
 

diff --git a/lib/SQL/Translator/Schema/View.pm b/lib/SQL/Translator/Schema/View.pm
@@ -24,9 +24,9 @@ C<SQL::Translator::Schema::View> is the view object.
 =cut
 
 use Moo;
-use SQL::Translator::Utils qw(parse_list_arg ex2err);
+use SQL::Translator::Utils qw(ex2err);
 use SQL::Translator::Types qw(schema_obj);
-use List::MoreUtils qw(uniq);
+use SQL::Translator::Role::ListAttr;
 
 extends 'SQL::Translator::Schema::Object';
 
@@ -54,20 +54,7 @@ names and keep them in order by the first occurrence of a field name.
 
 =cut
 
-has fields => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around fields => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr fields => ( uniq => 1 );
 
 =head2 tables
 
@@ -85,20 +72,7 @@ names and keep them in order by the first occurrence of a field name.
 
 =cut
 
-has tables => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around tables => sub {
-    my $orig   = shift;
-    my $self   = shift;
-    my $fields = parse_list_arg( @_ );
-    $self->$orig($fields) if @$fields;
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr tables => ( uniq => 1 );
 
 =head2 options
 
@@ -110,23 +84,7 @@ Gets and sets a list of options on the view.
 
 =cut
 
-has options => (
-    is => 'rw',
-    default => sub { [] },
-    coerce => sub { [uniq @{parse_list_arg($_[0])}] },
-);
-
-around options => sub {
-    my $orig    = shift;
-    my $self    = shift;
-    my $options = parse_list_arg( @_ );
-
-    if ( @$options ) {
-        $self->$orig([ @{$self->$orig}, @$options ])
-    }
-
-    return wantarray ? @{ $self->$orig } : $self->$orig;
-};
+with ListAttr options => ( uniq => 1, append => 1 );
 
 sub is_valid {