[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema / Constraint.pm

package SQL::Translator::Schema::Constraint;

# ----------------------------------------------------------------------
# $Id$
# ----------------------------------------------------------------------
# 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

SQL::Translator::Schema::Constraint - SQL::Translator constraint object

=head1 SYNOPSIS

  use SQL::Translator::Schema::Constraint;
  my $constraint = SQL::Translator::Schema::Constraint->new(
      name   => 'foo',
      fields => [ id ],
      type   => PRIMARY_KEY,
  );

=head1 DESCRIPTION

C<SQL::Translator::Schema::Constraint> is the constraint object.

=head1 METHODS

=cut

use strict;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils 'parse_list_arg';

use base 'SQL::Translator::Schema::Object';

use vars qw($TABLE_COUNT $VIEW_COUNT);

my %VALID_CONSTRAINT_TYPE = (
    PRIMARY_KEY, 1,
    UNIQUE,      1,
    CHECK_C,     1,
    FOREIGN_KEY, 1,
    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.

  my $schema           =  SQL::Translator::Schema::Constraint->new(
      table            => $table,        # table to which it belongs
      type             => 'foreign_key', # type of table constraint
      name             => 'fk_phone_id', # name of the constraint
      fields           => 'phone_id',    # field in the referring table
      reference_fields => 'phone_id',    # referenced field
      reference_table  => 'phone',       # referenced table
      match_type       => 'full',        # how to match
      on_delete        => 'cascade',     # what to do on deletes
      on_update        => '',            # what to do on updates
  );

=cut

    my $self = shift;
    foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
    $self->SUPER::init(@_);
}

# ----------------------------------------------------------------------
sub deferrable {

=pod

=head2 deferrable

Get or set whether the constraint is deferrable.  If not defined,
then returns "1."  The argument is evaluated by Perl for True or
False, so the following are eqivalent:

  $deferrable = $field->deferrable(0);
  $deferrable = $field->deferrable('');
  $deferrable = $field->deferrable('0');

=cut

    my ( $self, $arg ) = @_;

    if ( defined $arg ) {
        $self->{'deferrable'} = $arg ? 1 : 0;
    }

    return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
}

# ----------------------------------------------------------------------
sub expression {

=pod

=head2 expression

Gets and set the expression used in a CHECK constraint.

  my $expression = $constraint->expression('...');

=cut

    my $self = shift;
    
    if ( my $arg = shift ) {
        # check arg here?
        $self->{'expression'} = $arg;
    }

    return $self->{'expression'} || '';
}

# ----------------------------------------------------------------------
sub is_valid {

=pod

=head2 is_valid

Determine whether the constraint is valid or not.

  my $ok = $constraint->is_valid;

=cut

    my $self       = shift;
    my $type       = $self->type   or return $self->error('No type');
    my $table      = $self->table  or return $self->error('No table');
    my @fields     = $self->fields or return $self->error('No fields');
    my $table_name = $table->name  or return $self->error('No table name');

    for my $f ( @fields ) {
        next if $table->get_field( $f );
        return $self->error(
            "Constraint references non-existent field '$f' ",
            "in table '$table_name'"
        );
    }

    my $schema = $table->schema or return $self->error(
        'Table ', $table->name, ' has no schema object'
    );

    if ( $type eq FOREIGN_KEY ) {
        return $self->error('Only one field allowed for foreign key')
            if scalar @fields > 1;

        my $ref_table_name  = $self->reference_table or 
            return $self->error('No reference table');

        my $ref_table = $schema->get_table( $ref_table_name ) or
            return $self->error("No table named '$ref_table_name' in schema");

        my @ref_fields = $self->reference_fields or return;

        return $self->error('Only one field allowed for foreign key reference')
            if scalar @ref_fields > 1;

        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),
                " to non-existent field '$ref_table_name.$ref_field'"
            );
        }
    }
    elsif ( $type eq CHECK_C ) {
        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
arrayref; returns an array or array reference.  Will unique the field
names and keep them in order by the first occurrence of a field name.

The fields are returned as Field objects if they exist or as plain
names if not. (If you just want the names and want to avoid the Field's overload
magic use L<field_names>).

Returns undef or an empty list if the constraint has no fields set.

  $constraint->fields('id');
  $constraint->fields('id', 'name');
  $constraint->fields( 'id, name' );
  $constraint->fields( [ 'id', 'name' ] );
  $constraint->fields( qw[ id name ] );

  my @fields = $constraint->fields;

=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 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
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

=head2 match_type

Get or set the constraint's match_type.  Only valid values are "full"
or "partial."

  my $match_type = $constraint->match_type('FULL');

=cut

    my $self = shift;
    
    if ( my $arg = lc shift ) {
        return $self->error("Invalid match type: $arg")
            unless $arg eq 'full' || $arg eq 'partial';
        $self->{'match_type'} = $arg;
    }

    return $self->{'match_type'} || '';
}

# ----------------------------------------------------------------------
sub name {

=pod

=head2 name

Get or set the constraint's name.

  my $name = $constraint->name('foo');

=cut

    my $self = shift;
    my $arg  = shift || '';
    $self->{'name'} = $arg if $arg;
    return $self->{'name'} || '';
}

# ----------------------------------------------------------------------
sub options {

=pod

=head2 options

Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").  
Returns an array or array reference.

  $constraint->options('NORELY');
  my @options = $constraint->options;

=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

=head2 on_delete

Get or set the constraint's "on delete" action.

  my $action = $constraint->on_delete('cascade');

=cut

    my $self = shift;
    
    if ( my $arg = shift ) {
        # validate $arg?
        $self->{'on_delete'} = $arg;
    }

    return $self->{'on_delete'} || '';
}

# ----------------------------------------------------------------------
sub on_update {

=pod

=head2 on_update

Get or set the constraint's "on update" action.

  my $action = $constraint->on_update('no action');

=cut

    my $self = shift;
    
    if ( my $arg = shift ) {
        # validate $arg?
        $self->{'on_update'} = $arg;
    }

    return $self->{'on_update'} || '';
}

# ----------------------------------------------------------------------
sub reference_fields {

=pod

=head2 reference_fields

Gets and set the fields in the referred table.  Accepts a string, list or
arrayref; returns an array or array reference.

  $constraint->reference_fields('id');
  $constraint->reference_fields('id', 'name');
  $constraint->reference_fields( 'id, name' );
  $constraint->reference_fields( [ 'id', 'name' ] );
  $constraint->reference_fields( qw[ id name ] );

  my @reference_fields = $constraint->reference_fields;

=cut

    my $self   = shift;
    my $fields = parse_list_arg( @_ );

    if ( @$fields ) {
        $self->{'reference_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.
    }

    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.

  my $reference_table = $constraint->reference_table('foo');

=cut

    my $self = shift;
    $self->{'reference_table'} = shift if @_;
    return $self->{'reference_table'} || '';
}

# ----------------------------------------------------------------------
sub table {

=pod

=head2 table

Get or set the constraint's table object.

  my $table = $field->table;

=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 {

=pod

=head2 type

Get or set the constraint's type.

  my $type = $constraint->type( PRIMARY_KEY );

=cut

    my $self = shift;

    if ( my $type = uc shift ) {
        $type =~ s/_/ /g;
        return $self->error("Invalid constraint type: $type") 
            unless $VALID_CONSTRAINT_TYPE{ $type };
        $self->{'type'} = $type;
    }

    return $self->{'type'} || '';
}

# ----------------------------------------------------------------------
sub equals {

=pod

=head2 equals

Determines if this constraint is the same as another

  my $isIdentical = $constraint1->equals( $constraint2 );

=cut

    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->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;
    }
    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;
    return 0 unless $self->expression eq $other->expression;
    
    # Check fields, regardless of order
    my %otherFields = ();	# create a hash of the other fields
    foreach my $otherField ($other->fields) {
    	$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};
    }
    # 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
    foreach my $otherRefField ($other->reference_fields) {
    	$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};
    }
    # Check all other reference fields were accounted for
    return 0 unless keys %otherRefFields == 0;

    return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
    return 0 unless $self->match_type eq $other->match_type;
    return 0 unless $self->on_delete eq $other->on_delete;
    return 0 unless $self->on_update eq $other->on_update;
    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
}

1;

# ----------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.

=cut
Commit	Line	Data
3c5de62a	1	package SQL::Translator::Schema::Constraint;
	2
	3	# ----------------------------------------------------------------------
821a0fde	4	# $Id$
3c5de62a	5	# ----------------------------------------------------------------------
478f608d	6	# Copyright (C) 2002-2009 SQLFairy Authors
3c5de62a	7	#
	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
	23	=pod
	24
	25	=head1 NAME
	26
	27	SQL::Translator::Schema::Constraint - SQL::Translator constraint object
	28
	29	=head1 SYNOPSIS
	30
	31	use SQL::Translator::Schema::Constraint;
	32	my $constraint = SQL::Translator::Schema::Constraint->new(
	33	name => 'foo',
	34	fields => [ id ],
43b9dc7a	35	type => PRIMARY_KEY,
3c5de62a	36	);
	37
	38	=head1 DESCRIPTION
	39
	40	C<SQL::Translator::Schema::Constraint> is the constraint object.
	41
	42	=head1 METHODS
	43
	44	=cut
	45
	46	use strict;
43b9dc7a	47	use SQL::Translator::Schema::Constants;
752608d5	48	use SQL::Translator::Utils 'parse_list_arg';
3c5de62a	49
b6a880d1	50	use base 'SQL::Translator::Schema::Object';
b6a880d1	51
478f608d	52	use vars qw($TABLE_COUNT $VIEW_COUNT);
3c5de62a	53
695c2da2	54	my %VALID_CONSTRAINT_TYPE = (
43b9dc7a	55	PRIMARY_KEY, 1,
	56	UNIQUE, 1,
	57	CHECK_C, 1,
	58	FOREIGN_KEY, 1,
695c2da2	59	NOT_NULL, 1,
695c2da2	60	);
3c5de62a	61
3c5de62a	62	# ----------------------------------------------------------------------
3c5de62a	63
9371be50	64	__PACKAGE__->_attributes( qw/
	65	table name type fields reference_fields reference_table
	66	match_type on_delete on_update expression deferrable
	67	/);
	68
	69	# Override to remove empty arrays from args.
	70	# t/14postgres-parser breaks without this.
	71	sub init {
	72
3c5de62a	73	=pod
	74
	75	=head2 new
	76
	77	Object constructor.
	78
	79	my $schema = SQL::Translator::Schema::Constraint->new(
dedb8f3b	80	table => $table, # table to which it belongs
3c5de62a	81	type => 'foreign_key', # type of table constraint
dedb8f3b	82	name => 'fk_phone_id', # name of the constraint
dedb8f3b	83	fields => 'phone_id', # field in the referring table
65157eda	84	reference_fields => 'phone_id', # referenced field
65157eda	85	reference_table => 'phone', # referenced table
3c5de62a	86	match_type => 'full', # how to match
2d034ab4	87	on_delete => 'cascade', # what to do on deletes
2d034ab4	88	on_update => '', # what to do on updates
3c5de62a	89	);
	90
	91	=cut
	92
9371be50	93	my $self = shift;
	94	foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
	95	$self->SUPER::init(@_);
3c5de62a	96	}
	97
	98	# ----------------------------------------------------------------------
43b9dc7a	99	sub deferrable {
	100
	101	=pod
	102
	103	=head2 deferrable
	104
2d034ab4	105	Get or set whether the constraint is deferrable. If not defined,
43b9dc7a	106	then returns "1." The argument is evaluated by Perl for True or
	107	False, so the following are eqivalent:
	108
	109	$deferrable = $field->deferrable(0);
	110	$deferrable = $field->deferrable('');
	111	$deferrable = $field->deferrable('0');
	112
	113	=cut
	114
	115	my ( $self, $arg ) = @_;
	116
	117	if ( defined $arg ) {
	118	$self->{'deferrable'} = $arg ? 1 : 0;
	119	}
	120
	121	return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
	122	}
	123
	124	# ----------------------------------------------------------------------
	125	sub expression {
	126
	127	=pod
	128
	129	=head2 expression
	130
	131	Gets and set the expression used in a CHECK constraint.
	132
	133	my $expression = $constraint->expression('...');
	134
	135	=cut
	136
	137	my $self = shift;
	138
	139	if ( my $arg = shift ) {
	140	# check arg here?
	141	$self->{'expression'} = $arg;
	142	}
	143
	144	return $self->{'expression'} \|\| '';
	145	}
	146
	147	# ----------------------------------------------------------------------
	148	sub is_valid {
	149
	150	=pod
	151
	152	=head2 is_valid
	153
	154	Determine whether the constraint is valid or not.
	155
	156	my $ok = $constraint->is_valid;
	157
	158	=cut
	159
	160	my $self = shift;
	161	my $type = $self->type or return $self->error('No type');
	162	my $table = $self->table or return $self->error('No table');
	163	my @fields = $self->fields or return $self->error('No fields');
	164	my $table_name = $table->name or return $self->error('No table name');
	165
	166	for my $f ( @fields ) {
	167	next if $table->get_field( $f );
	168	return $self->error(
	169	"Constraint references non-existent field '$f' ",
170	"in table '$table_name'"
171	);
172	}
173
174	my $schema = $table->schema or return $self->error(
175	'Table ', $table->name, ' has no schema object'
176	);
177
178	if ( $type eq FOREIGN_KEY ) {
179	return $self->error('Only one field allowed for foreign key')
180	if scalar @fields > 1;
181
182	my $ref_table_name = $self->reference_table or
183	return $self->error('No reference table');
184
185	my $ref_table = $schema->get_table( $ref_table_name ) or
186	return $self->error("No table named '$ref_table_name' in schema");
187
188	my @ref_fields = $self->reference_fields or return;
189
190	return $self->error('Only one field allowed for foreign key reference')
191	if scalar @ref_fields > 1;
192
193	for my $ref_field ( @ref_fields ) {
194	next if $ref_table->get_field( $ref_field );
195	return $self->error(
196	"Constraint from field(s) ",
197	join(', ', map {qq['$table_name.$_']} @fields),
198	" to non-existent field '$ref_table_name.$ref_field'"
199	);
200	}
201	}
202	elsif ( $type eq CHECK_C ) {
203	return $self->error('No expression for CHECK') unless
204	$self->expression;
205	}
206
207	return 1;
208	}
209
210	# ----------------------------------------------------------------------
3c5de62a	211	sub fields {
	212
	213	=pod
	214
	215	=head2 fields
	216
43b9dc7a	217	Gets and set the fields the constraint is on. Accepts a string, list or
	218	arrayref; returns an array or array reference. Will unique the field
	219	names and keep them in order by the first occurrence of a field name.
	220
ac095e5e	221	The fields are returned as Field objects if they exist or as plain
	222	names if not. (If you just want the names and want to avoid the Field's overload
	223	magic use L<field_names>).
	224
	225	Returns undef or an empty list if the constraint has no fields set.
	226
43b9dc7a	227	$constraint->fields('id');
	228	$constraint->fields('id', 'name');
	229	$constraint->fields( 'id, name' );
	230	$constraint->fields( [ 'id', 'name' ] );
	231	$constraint->fields( qw[ id name ] );
3c5de62a	232
43b9dc7a	233	my @fields = $constraint->fields;
3c5de62a	234
	235	=cut
	236
	237	my $self = shift;
752608d5	238	my $fields = parse_list_arg( @_ );
3c5de62a	239
3c5de62a	240	if ( @$fields ) {
43b9dc7a	241	my ( %unique, @unique );
	242	for my $f ( @$fields ) {
	243	next if $unique{ $f };
	244	$unique{ $f } = 1;
	245	push @unique, $f;
	246	}
	247
	248	$self->{'fields'} = \@unique;
3c5de62a	249	}
3c5de62a	250
53ded04a	251	if ( @{ $self->{'fields'} \|\| [] } ) {
ac095e5e	252	# We have to return fields that don't exist on the table as names in
	253	# case those fields havn't been created yet.
	254	my @ret = map {
	255	$self->table->get_field($_) \|\| $_ } @{ $self->{'fields'} };
	256	return wantarray ? @ret : \@ret;
53ded04a	257	}
	258	else {
	259	return wantarray ? () : undef;
	260	}
3c5de62a	261	}
3c5de62a	262
ebe49790	263	# ----------------------------------------------------------------------
ac095e5e	264	sub field_names {
	265
	266	=head2 field_names
	267
	268	Read-only method to return a list or array ref of the field names. Returns undef
	269	or an empty list if the constraint has no fields set. Usefull if you want to
	270	avoid the overload magic of the Field objects returned by the fields method.
	271
	272	my @names = $constraint->field_names;
	273
	274	=cut
	275
	276	my $self = shift;
4598b71c	277	return wantarray ? @{ $self->{'fields'} \|\| [] } : ($self->{'fields'} \|\| '');
ac095e5e	278	}
ac095e5e	279
3c5de62a	280	# ----------------------------------------------------------------------
752608d5	281	sub match_type {
	282
	283	=pod
	284
	285	=head2 match_type
	286
	287	Get or set the constraint's match_type. Only valid values are "full"
	288	or "partial."
	289
	290	my $match_type = $constraint->match_type('FULL');
	291
	292	=cut
	293
	294	my $self = shift;
	295
	296	if ( my $arg = lc shift ) {
	297	return $self->error("Invalid match type: $arg")
	298	unless $arg eq 'full' \|\| $arg eq 'partial';
	299	$self->{'match_type'} = $arg;
	300	}
	301
	302	return $self->{'match_type'} \|\| '';
	303	}
	304
	305	# ----------------------------------------------------------------------
3c5de62a	306	sub name {
	307
	308	=pod
	309
	310	=head2 name
	311
	312	Get or set the constraint's name.
	313
	314	my $name = $constraint->name('foo');
	315
	316	=cut
	317
	318	my $self = shift;
695c2da2	319	my $arg = shift \|\| '';
695c2da2	320	$self->{'name'} = $arg if $arg;
3c5de62a	321	return $self->{'name'} \|\| '';
	322	}
	323
	324	# ----------------------------------------------------------------------
dedb8f3b	325	sub options {
	326
	327	=pod
	328
	329	=head2 options
	330
	331	Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
	332	Returns an array or array reference.
	333
	334	$constraint->options('NORELY');
	335	my @options = $constraint->options;
	336
	337	=cut
	338
	339	my $self = shift;
	340	my $options = parse_list_arg( @_ );
	341
	342	push @{ $self->{'options'} }, @$options;
	343
	344	if ( ref $self->{'options'} ) {
	345	return wantarray ? @{ $self->{'options'} \|\| [] } : $self->{'options'};
	346	}
	347	else {
	348	return wantarray ? () : [];
	349	}
	350	}
	351
	352
	353	# ----------------------------------------------------------------------
43b9dc7a	354	sub on_delete {
	355
	356	=pod
	357
	358	=head2 on_delete
	359
	360	Get or set the constraint's "on delete" action.
	361
	362	my $action = $constraint->on_delete('cascade');
	363
	364	=cut
	365
	366	my $self = shift;
	367
	368	if ( my $arg = shift ) {
	369	# validate $arg?
	370	$self->{'on_delete'} = $arg;
	371	}
	372
	373	return $self->{'on_delete'} \|\| '';
	374	}
	375
	376	# ----------------------------------------------------------------------
	377	sub on_update {
	378
	379	=pod
	380
	381	=head2 on_update
	382
	383	Get or set the constraint's "on update" action.
	384
	385	my $action = $constraint->on_update('no action');
	386
	387	=cut
	388
	389	my $self = shift;
	390
	391	if ( my $arg = shift ) {
	392	# validate $arg?
	393	$self->{'on_update'} = $arg;
	394	}
	395
	396	return $self->{'on_update'} \|\| '';
	397	}
	398
	399	# ----------------------------------------------------------------------
	400	sub reference_fields {
	401
	402	=pod
	403
	404	=head2 reference_fields
	405
	406	Gets and set the fields in the referred table. Accepts a string, list or
	407	arrayref; returns an array or array reference.
	408
	409	$constraint->reference_fields('id');
	410	$constraint->reference_fields('id', 'name');
	411	$constraint->reference_fields( 'id, name' );
	412	$constraint->reference_fields( [ 'id', 'name' ] );
	413	$constraint->reference_fields( qw[ id name ] );
	414
	415	my @reference_fields = $constraint->reference_fields;
	416
	417	=cut
418
419	my $self = shift;
752608d5	420	my $fields = parse_list_arg( @_ );
43b9dc7a	421
	422	if ( @$fields ) {
	423	$self->{'reference_fields'} = $fields;
	424	}
	425
2d034ab4	426	# Nothing set so try and derive it from the other constraint data
43b9dc7a	427	unless ( ref $self->{'reference_fields'} ) {
2d034ab4	428	my $table = $self->table or return $self->error('No table');
	429	my $schema = $table->schema or return $self->error('No schema');
	430	if ( my $ref_table_name = $self->reference_table ) {
	431	my $ref_table = $schema->get_table( $ref_table_name ) or
	432	return $self->error("Can't find table '$ref_table_name'");
	433
	434	if ( my $constraint = $ref_table->primary_key ) {
	435	$self->{'reference_fields'} = [ $constraint->fields ];
	436	}
	437	else {
	438	$self->error(
	439	'No reference fields defined and cannot find primary key in ',
	440	"reference table '$ref_table_name'"
	441	);
	442	}
43b9dc7a	443	}
2d034ab4	444	# No ref table so we are not that sort of constraint, hence no ref
2d034ab4	445	# fields. So we let the return below return an empty list.
43b9dc7a	446	}
	447
	448	if ( ref $self->{'reference_fields'} ) {
	449	return wantarray
2d034ab4	450	? @{ $self->{'reference_fields'} }
43b9dc7a	451	: $self->{'reference_fields'};
	452	}
	453	else {
	454	return wantarray ? () : [];
	455	}
	456	}
	457
	458	# ----------------------------------------------------------------------
	459	sub reference_table {
	460
	461	=pod
	462
	463	=head2 reference_table
	464
	465	Get or set the table referred to by the constraint.
	466
	467	my $reference_table = $constraint->reference_table('foo');
	468
	469	=cut
	470
	471	my $self = shift;
	472	$self->{'reference_table'} = shift if @_;
	473	return $self->{'reference_table'} \|\| '';
	474	}
	475
3c5de62a	476	# ----------------------------------------------------------------------
43b9dc7a	477	sub table {
3c5de62a	478
	479	=pod
	480
43b9dc7a	481	=head2 table
3c5de62a	482
2d034ab4	483	Get or set the constraint's table object.
3c5de62a	484
43b9dc7a	485	my $table = $field->table;
3c5de62a	486
	487	=cut
	488
	489	my $self = shift;
43b9dc7a	490	if ( my $arg = shift ) {
	491	return $self->error('Not a table object') unless
	492	UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
	493	$self->{'table'} = $arg;
	494	}
	495
	496	return $self->{'table'};
	497	}
	498
	499	# ----------------------------------------------------------------------
dedb8f3b	500	sub type {
43b9dc7a	501
	502	=pod
	503
dedb8f3b	504	=head2 type
43b9dc7a	505
dedb8f3b	506	Get or set the constraint's type.
43b9dc7a	507
dedb8f3b	508	my $type = $constraint->type( PRIMARY_KEY );
43b9dc7a	509
	510	=cut
	511
dedb8f3b	512	my $self = shift;
43b9dc7a	513
dedb8f3b	514	if ( my $type = uc shift ) {
	515	$type =~ s/_/ /g;
	516	return $self->error("Invalid constraint type: $type")
695c2da2	517	unless $VALID_CONSTRAINT_TYPE{ $type };
dedb8f3b	518	$self->{'type'} = $type;
43b9dc7a	519	}
3c5de62a	520
dedb8f3b	521	return $self->{'type'} \|\| '';
dedb8f3b	522	}
abf315bb	523
	524	# ----------------------------------------------------------------------
	525	sub equals {
	526
	527	=pod
	528
	529	=head2 equals
	530
	531	Determines if this constraint is the same as another
	532
	533	my $isIdentical = $constraint1->equals( $constraint2 );
	534
	535	=cut
	536
	537	my $self = shift;
	538	my $other = shift;
	539	my $case_insensitive = shift;
d990d84b	540	my $ignore_constraint_names = shift;
abf315bb	541
abf315bb	542	return 0 unless $self->SUPER::equals($other);
b8d24485	543	return 0 unless $self->type eq $other->type;
d990d84b	544	unless ($ignore_constraint_names) {
	545	return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
	546	}
abf315bb	547	return 0 unless $self->deferrable eq $other->deferrable;
4598b71c	548	#return 0 unless $self->is_valid eq $other->is_valid;
abf315bb	549	return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
	550	: $self->table->name eq $other->table->name;
	551	return 0 unless $self->expression eq $other->expression;
6a0f3000	552
	553	# Check fields, regardless of order
	554	my %otherFields = (); # create a hash of the other fields
	555	foreach my $otherField ($other->fields) {
	556	$otherField = uc($otherField) if $case_insensitive;
	557	$otherFields{$otherField} = 1;
	558	}
	559	foreach my $selfField ($self->fields) { # check for self fields in hash
	560	$selfField = uc($selfField) if $case_insensitive;
	561	return 0 unless $otherFields{$selfField};
	562	delete $otherFields{$selfField};
	563	}
	564	# Check all other fields were accounted for
	565	return 0 unless keys %otherFields == 0;
	566
	567	# Check reference fields, regardless of order
	568	my %otherRefFields = (); # create a hash of the other reference fields
	569	foreach my $otherRefField ($other->reference_fields) {
	570	$otherRefField = uc($otherRefField) if $case_insensitive;
	571	$otherRefFields{$otherRefField} = 1;
	572	}
	573	foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
	574	$selfRefField = uc($selfRefField) if $case_insensitive;
	575	return 0 unless $otherRefFields{$selfRefField};
	576	delete $otherRefFields{$selfRefField};
	577	}
	578	# Check all other reference fields were accounted for
	579	return 0 unless keys %otherRefFields == 0;
	580
b8d24485	581	return 0 unless $case_insensitive ? uc($self->reference_table) eq uc($other->reference_table) : $self->reference_table eq $other->reference_table;
abf315bb	582	return 0 unless $self->match_type eq $other->match_type;
	583	return 0 unless $self->on_delete eq $other->on_delete;
	584	return 0 unless $self->on_update eq $other->on_update;
4598b71c	585	return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
4598b71c	586	return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
abf315bb	587	return 1;
	588	}
	589
752608d5	590	# ----------------------------------------------------------------------
	591	sub DESTROY {
	592	my $self = shift;
	593	undef $self->{'table'}; # destroy cyclical reference
	594	}
	595
3c5de62a	596	1;
	597
	598	# ----------------------------------------------------------------------
	599
	600	=pod
	601
	602	=head1 AUTHOR
	603
6606c4c6	604	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
3c5de62a	605
3c5de62a	606	=cut