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

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

# ----------------------------------------------------------------------
# $Id: Constraint.pm,v 1.13 2004-03-29 11:18:12 grommit Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2002-4 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 Class::Base;
use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils 'parse_list_arg';

use base 'Class::Base';
use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);

$VERSION = sprintf "%d.%02d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;

my %VALID_CONSTRAINT_TYPE = (
    PRIMARY_KEY, 1,
    UNIQUE,      1,
    CHECK_C,     1,
    FOREIGN_KEY, 1,
    NOT_NULL,    1,
);

# ----------------------------------------------------------------------
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, $config ) = @_;
    my @fields = qw[ 
        table name type fields reference_fields reference_table 
        match_type on_delete on_update expression
    ];

    for my $arg ( @fields ) {
        next unless $config->{ $arg };
        next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
        defined $self->$arg( $config->{ $arg } ) or return;
    }

    return $self;
}

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