[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($VERSION $TABLE_COUNT $VIEW_COUNT);

$VERSION = '1.99';

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