X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FConstraint.pm;h=d81dd1aa47850dda4c0b8f0fa714e6bc347c6eac;hb=954ed12e43bd40637cd4e5a08b6d24d1560ac2fa;hp=485f59d341e3387a079a3f88324c46b99af50f71;hpb=df399712c8e458cbd2bf0389cb17666ce499dedd;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Constraint.pm b/lib/SQL/Translator/Schema/Constraint.pm index 485f59d..d81dd1a 100644 --- a/lib/SQL/Translator/Schema/Constraint.pm +++ b/lib/SQL/Translator/Schema/Constraint.pm @@ -23,15 +23,15 @@ C is the constraint object. =cut -use strict; +use Moo; use SQL::Translator::Schema::Constants; -use SQL::Translator::Utils 'parse_list_arg'; +use SQL::Translator::Utils qw(parse_list_arg ex2err throw); +use SQL::Translator::Types qw(schema_obj); +use List::MoreUtils qw(uniq); -use base 'SQL::Translator::Schema::Object'; +extends 'SQL::Translator::Schema::Object'; -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); - -$VERSION = '1.59'; +our $VERSION = '1.59'; my %VALID_CONSTRAINT_TYPE = ( PRIMARY_KEY, 1, @@ -41,17 +41,6 @@ my %VALID_CONSTRAINT_TYPE = ( NOT_NULL, 1, ); -__PACKAGE__->_attributes( qw/ - table name type fields reference_fields reference_table - match_type on_delete on_update expression deferrable -/); - -# Override to remove empty arrays from args. -# t/14postgres-parser breaks without this. -sub init { - -=pod - =head2 new Object constructor. @@ -70,14 +59,21 @@ Object constructor. =cut +# Override to remove empty arrays from args. +# t/14postgres-parser breaks without this. +around BUILDARGS => sub { + my $orig = shift; my $self = shift; - foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; } - $self->SUPER::init(@_); -} + my $args = $self->$orig(@_); -sub deferrable { - -=pod + foreach my $arg (keys %{$args}) { + delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}}; + } + if (exists $args->{fields}) { + $args->{field_names} = delete $args->{fields}; + } + return $args; +}; =head2 deferrable @@ -91,18 +87,7 @@ False, so the following are eqivalent: =cut - my ( $self, $arg ) = @_; - - if ( defined $arg ) { - $self->{'deferrable'} = $arg ? 1 : 0; - } - - return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1; -} - -sub expression { - -=pod +has deferrable => ( is => 'rw', coerce => sub { $_[0] ? 1 : 0 }, default => sub { 1 } ); =head2 expression @@ -112,15 +97,12 @@ Gets and set the expression used in a CHECK constraint. =cut - my $self = shift; - - if ( my $arg = shift ) { - # check arg here? - $self->{'expression'} = $arg; - } +has expression => ( is => 'rw', default => sub { '' } ); - return $self->{'expression'} || ''; -} +around expression => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; sub is_valid { @@ -170,8 +152,8 @@ Determine whether the constraint is valid or not. for my $ref_field ( @ref_fields ) { next if $ref_table->get_field( $ref_field ); return $self->error( - "Constraint from field(s) ", - join(', ', map {qq['$table_name.$_']} @fields), + "Constraint from field(s) ". + join(', ', map {qq['$table_name.$_']} @fields). " to non-existent field '$ref_table_name.$ref_field'" ); } @@ -184,10 +166,6 @@ Determine whether the constraint is valid or not. return 1; } -sub fields { - -=pod - =head2 fields Gets and set the fields the constraint is on. Accepts a string, list or @@ -210,34 +188,15 @@ Returns undef or an empty list if the constraint has no fields set. =cut - my $self = shift; - my $fields = parse_list_arg( @_ ); - - if ( @$fields ) { - my ( %unique, @unique ); - for my $f ( @$fields ) { - next if $unique{ $f }; - $unique{ $f } = 1; - push @unique, $f; - } - - $self->{'fields'} = \@unique; - } - - if ( @{ $self->{'fields'} || [] } ) { - # We have to return fields that don't exist on the table as names in - # case those fields havn't been created yet. - my @ret = map { - $self->table->get_field($_) || $_ } @{ $self->{'fields'} }; - return wantarray ? @ret : \@ret; - } - else { - return wantarray ? () : undef; - } +sub fields { + my $self = shift; + my $table = $self->table; + my @tables = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []}; + return wantarray ? @tables + : @tables ? \@tables + : undef; } -sub field_names { - =head2 field_names Read-only method to return a list or array ref of the field names. Returns undef @@ -248,13 +207,23 @@ avoid the overload magic of the Field objects returned by the fields method. =cut - my $self = shift; - return wantarray ? @{ $self->{'fields'} || [] } : ($self->{'fields'} || ''); -} +has field_names => ( + is => 'rw', + default => sub { [] }, + coerce => sub { [uniq @{parse_list_arg($_[0])}] }, +); -sub match_type { +around field_names => sub { + my $orig = shift; + my $self = shift; + my $fields = parse_list_arg( @_ ); + $self->$orig($fields) if @$fields; -=pod + $fields = $self->$orig; + return wantarray ? @{$fields} + : @{$fields} ? $fields + : undef; +}; =head2 match_type @@ -265,21 +234,18 @@ Get or set the constraint's match_type. Only valid values are "full" =cut - my ( $self, $arg ) = @_; - - if ( $arg ) { - $arg = lc $arg; - return $self->error("Invalid match type: $arg") - unless $arg eq 'full' || $arg eq 'partial' || $arg eq 'simple'; - $self->{'match_type'} = $arg; - } - - return $self->{'match_type'} || ''; -} - -sub name { +has match_type => ( + is => 'rw', + default => sub { '' }, + coerce => sub { lc $_[0] }, + isa => sub { + my $arg = $_[0]; + throw("Invalid match type: $arg") + if $arg && !($arg eq 'full' || $arg eq 'partial' || $arg eq 'simple'); + }, +); -=pod +around match_type => \&ex2err; =head2 name @@ -289,15 +255,12 @@ Get or set the constraint's name. =cut - my $self = shift; - my $arg = shift || ''; - $self->{'name'} = $arg if $arg; - return $self->{'name'} || ''; -} +has name => ( is => 'rw', default => sub { '' } ); -sub options { - -=pod +around name => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 options @@ -309,22 +272,17 @@ 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->{'options'} }, @$options; - - if ( ref $self->{'options'} ) { - return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'}; - } - else { - return wantarray ? () : []; - } -} - -sub on_delete { + push @{ $self->$orig }, @$options; -=pod + return wantarray ? @{ $self->$orig } : $self->$orig; +}; =head2 on_delete @@ -334,19 +292,12 @@ Get or set the constraint's "on delete" action. =cut - my $self = shift; - - if ( my $arg = shift ) { - # validate $arg? - $self->{'on_delete'} = $arg; - } - - return $self->{'on_delete'} || ''; -} - -sub on_update { +has on_delete => ( is => 'rw', default => sub { '' } ); -=pod +around on_delete => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 on_update @@ -356,19 +307,12 @@ Get or set the constraint's "on update" action. =cut - my $self = shift; - - if ( my $arg = shift ) { - # validate $arg? - $self->{'on_update'} = $arg; - } - - return $self->{'on_update'} || ''; -} - -sub reference_fields { +has on_update => ( is => 'rw', default => sub { '' } ); -=pod +around on_update => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 reference_fields @@ -385,49 +329,44 @@ arrayref; returns an array or array reference. =cut +has reference_fields => ( + is => 'rw', + coerce => sub { [uniq @{parse_list_arg($_[0])}] }, + builder => 1, + lazy => 1, +); + +around reference_fields => sub { + my $orig = shift; my $self = shift; my $fields = parse_list_arg( @_ ); + $self->$orig($fields) if @$fields; - if ( @$fields ) { - $self->{'reference_fields'} = $fields; - } + $fields = ex2err($orig, $self) or return; + return wantarray ? @{$fields} : $fields +}; - # Nothing set so try and derive it from the other constraint data - unless ( ref $self->{'reference_fields'} ) { - my $table = $self->table or return $self->error('No table'); - my $schema = $table->schema or return $self->error('No schema'); - if ( my $ref_table_name = $self->reference_table ) { - my $ref_table = $schema->get_table( $ref_table_name ) or - return $self->error("Can't find table '$ref_table_name'"); - - if ( my $constraint = $ref_table->primary_key ) { - $self->{'reference_fields'} = [ $constraint->fields ]; - } - else { - $self->error( - 'No reference fields defined and cannot find primary key in ', - "reference table '$ref_table_name'" - ); - } - } - # No ref table so we are not that sort of constraint, hence no ref - # fields. So we let the return below return an empty list. - } +sub _build_reference_fields { + my ($self) = @_; - if ( ref $self->{'reference_fields'} ) { - return wantarray - ? @{ $self->{'reference_fields'} } - : $self->{'reference_fields'}; - } - else { - return wantarray ? () : []; + my $table = $self->table or throw('No table'); + my $schema = $table->schema or throw('No schema'); + if ( my $ref_table_name = $self->reference_table ) { + my $ref_table = $schema->get_table( $ref_table_name ) or + throw("Can't find table '$ref_table_name'"); + + if ( my $constraint = $ref_table->primary_key ) { + return [ $constraint->fields ]; + } + else { + throw( + 'No reference fields defined and cannot find primary key in ', + "reference table '$ref_table_name'" + ); + } } } -sub reference_table { - -=pod - =head2 reference_table Get or set the table referred to by the constraint. @@ -436,14 +375,7 @@ Get or set the table referred to by the constraint. =cut - my $self = shift; - $self->{'reference_table'} = shift if @_; - return $self->{'reference_table'} || ''; -} - -sub table { - -=pod +has reference_table => ( is => 'rw', default => sub { '' } ); =head2 table @@ -453,19 +385,9 @@ Get or set the constraint's table object. =cut - my $self = shift; - if ( my $arg = shift ) { - return $self->error('Not a table object') unless - UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' ); - $self->{'table'} = $arg; - } - - return $self->{'table'}; -} - -sub type { +has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 ); -=pod +around table => \&ex2err; =head2 type @@ -475,22 +397,17 @@ Get or set the constraint's type. =cut - my ( $self, $type ) = @_; - - if ( $type ) { - $type = uc $type; - $type =~ s/_/ /g; - return $self->error("Invalid constraint type: $type") - unless $VALID_CONSTRAINT_TYPE{ $type }; - $self->{'type'} = $type; - } - - return $self->{'type'} || ''; -} - -sub equals { +has type => ( + is => 'rw', + default => sub { '' }, + isa => sub { + throw("Invalid constraint type: $_[0]") + if $_[0] && !$VALID_CONSTRAINT_TYPE{ $_[0] }; + }, + coerce => sub { (my $t = $_[0]) =~ s/_/ /g; uc $t }, +); -=pod +around type => \&ex2err; =head2 equals @@ -500,12 +417,14 @@ Determines if this constraint is the same as another =cut +around equals => sub { + my $orig = shift; my $self = shift; my $other = shift; my $case_insensitive = shift; my $ignore_constraint_names = shift; - return 0 unless $self->SUPER::equals($other); + return 0 unless $self->$orig($other); return 0 unless $self->type eq $other->type; unless ($ignore_constraint_names) { return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name; @@ -551,12 +470,10 @@ Determines if this constraint is the same as another return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options); return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra); return 1; -} +}; -sub DESTROY { - my $self = shift; - undef $self->{'table'}; # destroy cyclical reference -} +# Must come after all 'has' declarations +around new => \&ex2err; 1;