X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FConstraint.pm;h=edf8752bdbca2ca3db5778613d370f82172059df;hb=2bdef63659f546187a4d1266e88aa66671b228b7;hp=84f1d8cd8167521c58de28fbde25daf20094968c;hpb=11ad2df91bcc0674faa8fb5b6bab52c9e4a73762;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Constraint.pm b/lib/SQL/Translator/Schema/Constraint.pm index 84f1d8c..edf8752 100644 --- a/lib/SQL/Translator/Schema/Constraint.pm +++ b/lib/SQL/Translator/Schema/Constraint.pm @@ -1,23 +1,5 @@ package SQL::Translator::Schema::Constraint; -# ---------------------------------------------------------------------- -# Copyright (C) 2002-2009 SQLFairy Authors -# -# This program is free software; you can redistribute it and/or -# modify it under the terms of the GNU General Public License as -# published by the Free Software Foundation; version 2. -# -# This program is distributed in the hope that it will be useful, but -# WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA -# 02111-1307 USA -# ------------------------------------------------------------------- - =pod =head1 NAME @@ -41,15 +23,16 @@ C is the constraint object. =cut -use strict; +use Moo 1.000003; use SQL::Translator::Schema::Constants; -use SQL::Translator::Utils 'parse_list_arg'; - -use base 'SQL::Translator::Schema::Object'; +use SQL::Translator::Utils qw(ex2err throw); +use SQL::Translator::Role::ListAttr; +use SQL::Translator::Types qw(schema_obj); +use Sub::Quote qw(quote_sub); -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); +extends 'SQL::Translator::Schema::Object'; -$VERSION = '1.59'; +our $VERSION = '1.59'; my %VALID_CONSTRAINT_TYPE = ( PRIMARY_KEY, 1, @@ -59,19 +42,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. @@ -90,15 +60,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 @@ -112,19 +88,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 => quote_sub(q{ 1 }) ); =head2 expression @@ -134,17 +98,13 @@ 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 => quote_sub(q{ '' }) ); - return $self->{'expression'} || ''; -} +around expression => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; -# ---------------------------------------------------------------------- sub is_valid { =pod @@ -179,7 +139,7 @@ Determine whether the constraint is valid or not. return $self->error('Only one field allowed for foreign key') if scalar @fields > 1; - my $ref_table_name = $self->reference_table or + my $ref_table_name = $self->reference_table or return $self->error('No reference table'); my $ref_table = $schema->get_table( $ref_table_name ) or @@ -193,25 +153,20 @@ 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'" ); } } elsif ( $type eq CHECK_C ) { - return $self->error('No expression for CHECK') unless + return $self->error('No expression for CHECK') unless $self->expression; } return 1; } -# ---------------------------------------------------------------------- -sub fields { - -=pod - =head2 fields Gets and set the fields the constraint is on. Accepts a string, list or @@ -234,79 +189,48 @@ 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 -or an empty list if the constraint has no fields set. Usefull if you want to +or an empty list if the constraint has no fields set. Useful if you want to avoid the overload magic of the Field objects returned by the fields method. my @names = $constraint->field_names; =cut - my $self = shift; - return wantarray ? @{ $self->{'fields'} || [] } : ($self->{'fields'} || ''); -} - -# ---------------------------------------------------------------------- -sub match_type { - -=pod +with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 ); =head2 match_type Get or set the constraint's match_type. Only valid values are "full" -or "partial." +"partial" and "simple" my $match_type = $constraint->match_type('FULL'); =cut - my ( $self, $arg ) = @_; - - if ( $arg ) { - $arg = lc $arg; - return $self->error("Invalid match type: $arg") - unless $arg eq 'full' || $arg eq 'partial'; - $self->{'match_type'} = $arg; - } - - return $self->{'match_type'} || ''; -} +has match_type => ( + is => 'rw', + default => quote_sub(q{ '' }), + 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'); + }, +); -# ---------------------------------------------------------------------- -sub name { - -=pod +around match_type => \&ex2err; =head2 name @@ -316,20 +240,16 @@ Get or set the constraint's name. =cut - my $self = shift; - my $arg = shift || ''; - $self->{'name'} = $arg if $arg; - return $self->{'name'} || ''; -} - -# ---------------------------------------------------------------------- -sub options { +has name => ( is => 'rw', default => quote_sub(q{ '' }) ); -=pod +around name => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 options -Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE"). +Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE"). Returns an array or array reference. $constraint->options('NORELY'); @@ -337,24 +257,7 @@ Returns an array or array reference. =cut - 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 { - -=pod +with ListAttr options => (); =head2 on_delete @@ -364,20 +267,12 @@ Get or set the constraint's "on delete" action. =cut - my $self = shift; - - if ( my $arg = shift ) { - # validate $arg? - $self->{'on_delete'} = $arg; - } +has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) ); - return $self->{'on_delete'} || ''; -} - -# ---------------------------------------------------------------------- -sub on_update { - -=pod +around on_delete => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 on_update @@ -387,20 +282,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'} || ''; -} +has on_update => ( is => 'rw', default => quote_sub(q{ '' }) ); -# ---------------------------------------------------------------------- -sub reference_fields { - -=pod +around on_update => sub { + my ($orig, $self, $arg) = @_; + $self->$orig($arg || ()); +}; =head2 reference_fields @@ -417,50 +304,33 @@ arrayref; returns an array or array reference. =cut - my $self = shift; - my $fields = parse_list_arg( @_ ); +with ListAttr reference_fields => ( + may_throw => 1, + builder => 1, + lazy => 1, +); + +sub _build_reference_fields { + my ($self) = @_; - if ( @$fields ) { - $self->{'reference_fields'} = $fields; - } + 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'"); - # 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'" - ); - } + 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'" + ); } - # 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. - } - - if ( ref $self->{'reference_fields'} ) { - return wantarray - ? @{ $self->{'reference_fields'} } - : $self->{'reference_fields'}; - } - else { - return wantarray ? () : []; } } -# ---------------------------------------------------------------------- -sub reference_table { - -=pod - =head2 reference_table Get or set the table referred to by the constraint. @@ -469,15 +339,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 => quote_sub(q{ '' }) ); =head2 table @@ -487,20 +349,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; - } +has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 ); - return $self->{'table'}; -} - -# ---------------------------------------------------------------------- -sub type { - -=pod +around table => \&ex2err; =head2 type @@ -510,23 +361,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 => quote_sub(q{ '' }), + 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 @@ -536,12 +381,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; @@ -549,33 +396,33 @@ Determines if this constraint is the same as another return 0 unless $self->deferrable eq $other->deferrable; #return 0 unless $self->is_valid eq $other->is_valid; return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name) - : $self->table->name eq $other->table->name; + : $self->table->name eq $other->table->name; return 0 unless $self->expression eq $other->expression; - + # Check fields, regardless of order - my %otherFields = (); # create a hash of the other fields + my %otherFields = (); # create a hash of the other fields foreach my $otherField ($other->fields) { - $otherField = uc($otherField) if $case_insensitive; - $otherFields{$otherField} = 1; + $otherField = uc($otherField) if $case_insensitive; + $otherFields{$otherField} = 1; } foreach my $selfField ($self->fields) { # check for self fields in hash - $selfField = uc($selfField) if $case_insensitive; - return 0 unless $otherFields{$selfField}; - delete $otherFields{$selfField}; + $selfField = uc($selfField) if $case_insensitive; + return 0 unless $otherFields{$selfField}; + delete $otherFields{$selfField}; } # Check all other fields were accounted for return 0 unless keys %otherFields == 0; # Check reference fields, regardless of order - my %otherRefFields = (); # create a hash of the other reference fields + my %otherRefFields = (); # create a hash of the other reference fields foreach my $otherRefField ($other->reference_fields) { - $otherRefField = uc($otherRefField) if $case_insensitive; - $otherRefFields{$otherRefField} = 1; + $otherRefField = uc($otherRefField) if $case_insensitive; + $otherRefFields{$otherRefField} = 1; } foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash - $selfRefField = uc($selfRefField) if $case_insensitive; - return 0 unless $otherRefFields{$selfRefField}; - delete $otherRefFields{$selfRefField}; + $selfRefField = uc($selfRefField) if $case_insensitive; + return 0 unless $otherRefFields{$selfRefField}; + delete $otherRefFields{$selfRefField}; } # Check all other reference fields were accounted for return 0 unless keys %otherRefFields == 0; @@ -587,18 +434,13 @@ 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; -# ---------------------------------------------------------------------- - =pod =head1 AUTHOR