X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FTable.pm;h=42e2effa807d44e0e0aff3bb1c1c9c3308deff14;hb=d4f84dd192edc7a64a0b1a9923f1bafc0bc5ef9d;hp=02e7599b4c635beb7fc91f50bd6c9d7be9c27eee;hpb=43b9dc7ab0953ab9f4cbadf7810509d63d2ed87a;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm index 02e7599..42e2eff 100644 --- a/lib/SQL/Translator/Schema/Table.pm +++ b/lib/SQL/Translator/Schema/Table.pm @@ -1,9 +1,9 @@ package SQL::Translator::Schema::Table; # ---------------------------------------------------------------------- -# $Id: Table.pm,v 1.3 2003-05-05 04:32:39 kycl4rk Exp $ +# $Id: Table.pm 1440 2009-01-17 16:31:57Z jawnsy $ # ---------------------------------------------------------------------- -# Copyright (C) 2003 Ken Y. Clark +# 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 @@ -40,19 +40,29 @@ C is the table object. =cut use strict; -use Class::Base; +use SQL::Translator::Utils 'parse_list_arg'; use SQL::Translator::Schema::Constants; use SQL::Translator::Schema::Constraint; use SQL::Translator::Schema::Field; use SQL::Translator::Schema::Index; +use Data::Dumper; -use base 'Class::Base'; -use vars qw( $VERSION $FIELD_ORDER ); +use base 'SQL::Translator::Schema::Object'; -$VERSION = 1.00; +use vars qw( $FIELD_ORDER ); + +# Stringify to our name, being careful not to pass any args through so we don't +# accidentally set it to undef. We also have to tweak bool so the object is +# still true when it doesn't have a name (which shouldn't happen!). +use overload + '""' => sub { shift->name }, + 'bool' => sub { $_[0]->name || $_[0] }, + fallback => 1, +; # ---------------------------------------------------------------------- -sub init { + +__PACKAGE__->_attributes( qw/schema name comments options order/ ); =pod @@ -67,82 +77,126 @@ Object constructor. =cut - my ( $self, $config ) = @_; - - for my $arg ( qw[ schema name ] ) { - next unless defined $config->{ $arg }; - $self->$arg( $config->{ $arg } ) or return; - } - - return $self; -} - # ---------------------------------------------------------------------- -sub name { +sub add_constraint { =pod -=head2 name +=head2 add_constraint -Get or set the table's name. +Add a constraint to the table. Returns the newly created +C object. -If provided an argument, checks the schema object for a table of -that name and disallows the change if one exists. + my $c1 = $table->add_constraint( + name => 'pk', + type => PRIMARY_KEY, + fields => [ 'foo_id' ], + ); - my $table_name = $table->name('foo'); + my $c2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' ); + $c2 = $table->add_constraint( $constraint ); =cut - my $self = shift; + my $self = shift; + my $constraint_class = 'SQL::Translator::Schema::Constraint'; + my $constraint; - if ( my $arg = shift ) { - if ( my $schema = $self->schema ) { - return $self->error( qq[Can't use table name "$arg": table exists] ) - if $schema->get_table( $arg ); + if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) { + $constraint = shift; + $constraint->table( $self ); + } + else { + my %args = @_; + $args{'table'} = $self; + $constraint = $constraint_class->new( \%args ) or + return $self->error( $constraint_class->error ); + } + + # + # If we're trying to add a PK when one is already defined, + # then just add the fields to the existing definition. + # + my $ok = 1; + my $pk = $self->primary_key; + if ( $pk && $constraint->type eq PRIMARY_KEY ) { + $self->primary_key( $constraint->fields ); + $pk->name($constraint->name) if $constraint->name; + my %extra = $constraint->extra; + $pk->extra(%extra) if keys %extra; + $constraint = $pk; + $ok = 0; + } + elsif ( $constraint->type eq PRIMARY_KEY ) { + for my $fname ( $constraint->fields ) { + if ( my $f = $self->get_field( $fname ) ) { + $f->is_primary_key( 1 ); + } } - $self->{'name'} = $arg; + } + # + # See if another constraint of the same type + # covers the same fields. -- This doesn't work! ky + # +# elsif ( $constraint->type ne CHECK_C ) { +# my @field_names = $constraint->fields; +# for my $c ( +# grep { $_->type eq $constraint->type } +# $self->get_constraints +# ) { +# my %fields = map { $_, 1 } $c->fields; +# for my $field_name ( @field_names ) { +# if ( $fields{ $field_name } ) { +# $constraint = $c; +# $ok = 0; +# last; +# } +# } +# last unless $ok; +# } +# } + + if ( $ok ) { + push @{ $self->{'constraints'} }, $constraint; } - return $self->{'name'} || ''; + return $constraint; } # ---------------------------------------------------------------------- -sub add_constraint { +sub drop_constraint { =pod -=head2 add_constraint +=head2 drop_constraint -Add a constraint to the table. Returns the newly created -C object. +Remove a constraint from the table. Returns the constraint object if the index +was found and removed, an error otherwise. The single parameter can be either +an index name or an C object. - my $constraint1 = $table->add_constraint( - name => 'pk', - type => PRIMARY_KEY, - fields => [ 'foo_id' ], - ); - - my $constraint2 = SQL::Translator::Schema::Constraint->new( name => 'uniq' ); - $constraint2 = $table->add_constraint( $constraint ); + $table->drop_constraint('myconstraint'); =cut my $self = shift; my $constraint_class = 'SQL::Translator::Schema::Constraint'; - my $constraint; + my $constraint_name; if ( UNIVERSAL::isa( $_[0], $constraint_class ) ) { - $constraint = shift; - $constraint->table( $self ); + $constraint_name = shift->name; } else { - my %args = @_; - $args{'table'} = $self; - $constraint = $constraint_class->new( \%args ) or - return $self->error( $constraint_class->error ); + $constraint_name = shift; } - push @{ $self->{'constraints'} }, $constraint; + if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) { + return $self->error(qq[Can't drop constraint: "$constraint_name" doesn't exist]); + } + + my @cs = @{ $self->{'constraints'} }; + my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs); + my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1); + return $constraint; } @@ -156,14 +210,14 @@ sub add_index { Add an index to the table. Returns the newly created C object. - my $index1 = $table->add_index( + my $i1 = $table->add_index( name => 'name', fields => [ 'name' ], type => 'normal', ); - my $index2 = SQL::Translator::Schema::Index->new( name => 'id' ); - $index2 = $table->add_index( $index ); + my $i2 = SQL::Translator::Schema::Index->new( name => 'id' ); + $i2 = $table->add_index( $index ); =cut @@ -181,12 +235,51 @@ C object. $index = $index_class->new( \%args ) or return $self->error( $index_class->error ); } - + foreach my $ex_index ($self->get_indices) { + return if ($ex_index->equals($index)); + } push @{ $self->{'indices'} }, $index; return $index; } # ---------------------------------------------------------------------- +sub drop_index { + +=pod + +=head2 drop_index + +Remove an index from the table. Returns the index object if the index was +found and removed, an error otherwise. The single parameter can be either +an index name of an C object. + + $table->drop_index('myindex'); + +=cut + + my $self = shift; + my $index_class = 'SQL::Translator::Schema::Index'; + my $index_name; + + if ( UNIVERSAL::isa( $_[0], $index_class ) ) { + $index_name = shift->name; + } + else { + $index_name = shift; + } + + if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) { + return $self->error(qq[Can't drop index: "$index_name" doesn't exist]); + } + + my @is = @{ $self->{'indices'} }; + my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is); + my $index = splice(@{$self->{'indices'}}, $index_id, 1); + + return $index; +} + +# ---------------------------------------------------------------------- sub add_field { =pod @@ -198,21 +291,21 @@ C object. The "name" parameter is required. If you try to create a field with the same name as an existing field, you will get an error and the field will not be created. - my $field1 = $table->add_field( + my $f1 = $table->add_field( name => 'foo_id', data_type => 'integer', size => 11, ); - my $field2 = SQL::Translator::Schema::Field->new( + my $f2 = SQL::Translator::Schema::Field->new( name => 'name', table => $table, ); - $field2 = $table->add_field( $field2 ) or die $table->error; + $f2 = $table->add_field( $field2 ) or die $table->error; =cut - my $self = shift; + my $self = shift; my $field_class = 'SQL::Translator::Schema::Field'; my $field; @@ -227,20 +320,110 @@ existing field, you will get an error and the field will not be created. $self->error( $field_class->error ); } - my $field_name = $field->name or return $self->error('No name'); + $field->order( ++$FIELD_ORDER ); + # We know we have a name as the Field->new above errors if none given. + my $field_name = $field->name; if ( exists $self->{'fields'}{ $field_name } ) { return $self->error(qq[Can't create field: "$field_name" exists]); } else { $self->{'fields'}{ $field_name } = $field; - $self->{'fields'}{ $field_name }{'order'} = ++$FIELD_ORDER; + } + + return $field; +} +# ---------------------------------------------------------------------- +sub drop_field { + +=pod + +=head2 drop_field + +Remove a field from the table. Returns the field object if the field was +found and removed, an error otherwise. The single parameter can be either +a field name or an C object. + + $table->drop_field('myfield'); + +=cut + + my $self = shift; + my $field_class = 'SQL::Translator::Schema::Field'; + my $field_name; + + if ( UNIVERSAL::isa( $_[0], $field_class ) ) { + $field_name = shift->name; + } + else { + $field_name = shift; + } + my %args = @_; + my $cascade = $args{'cascade'}; + + if ( ! exists $self->{'fields'}{ $field_name } ) { + return $self->error(qq[Can't drop field: "$field_name" doesn't exists]); + } + + my $field = delete $self->{'fields'}{ $field_name }; + + if ( $cascade ) { + # Remove this field from all indices using it + foreach my $i ($self->get_indices()) { + my @fs = $i->fields(); + @fs = grep { $_ ne $field->name } @fs; + $i->fields(@fs); + } + + # Remove this field from all constraints using it + foreach my $c ($self->get_constraints()) { + my @cs = $c->fields(); + @cs = grep { $_ ne $field->name } @cs; + $c->fields(@cs); + } } return $field; } # ---------------------------------------------------------------------- +sub comments { + +=pod + +=head2 comments + +Get or set the comments on a table. May be called several times to +set and it will accumulate the comments. Called in an array context, +returns each comment individually; called in a scalar context, returns +all the comments joined on newlines. + + $table->comments('foo'); + $table->comments('bar'); + print join( ', ', $table->comments ); # prints "foo, bar" + +=cut + + my $self = shift; + my @comments = ref $_[0] ? @{ $_[0] } : @_; + + for my $arg ( @comments ) { + $arg = $arg->[0] if ref $arg; + push @{ $self->{'comments'} }, $arg if defined $arg && $arg; + } + + if ( @{ $self->{'comments'} || [] } ) { + return wantarray + ? @{ $self->{'comments'} } + : join( "\n", @{ $self->{'comments'} } ) + ; + } + else { + return wantarray ? () : undef; + } +} + +# ---------------------------------------------------------------------- sub get_constraints { =pod @@ -306,6 +489,14 @@ Returns a field by the name provided. my $self = shift; my $field_name = shift or return $self->error('No field name'); + my $case_insensitive = shift; + if ( $case_insensitive ) { + $field_name = uc($field_name); + foreach my $field ( keys %{$self->{fields}} ) { + return $self->{fields}{$field} if $field_name eq uc($field); + } + return $self->error(qq[Field "$field_name" does not exist]); + } return $self->error( qq[Field "$field_name" does not exist] ) unless exists $self->{'fields'}{ $field_name }; return $self->{'fields'}{ $field_name }; @@ -326,7 +517,9 @@ Returns all the field objects as an array or array reference. my $self = shift; my @fields = - sort { $a->{'order'} <=> $b->{'order'} } + map { $_->[1] } + sort { $a->[0] <=> $b->[0] } + map { [ $_->order, $_ ] } values %{ $self->{'fields'} || {} }; if ( @fields ) { @@ -365,6 +558,191 @@ Determine whether the view is valid or not. } # ---------------------------------------------------------------------- +sub is_trivial_link { + +=pod + +=head2 is_trivial_link + +True if table has no data (non-key) fields and only uses single key joins. + +=cut + + my $self = shift; + return 0 if $self->is_data; + return $self->{'is_trivial_link'} if defined $self->{'is_trivial_link'}; + + $self->{'is_trivial_link'} = 1; + + my %fk = (); + + foreach my $field ( $self->get_fields ) { + next unless $field->is_foreign_key; + $fk{$field->foreign_key_reference->reference_table}++; + } + + foreach my $referenced (keys %fk){ + if($fk{$referenced} > 1){ + $self->{'is_trivial_link'} = 0; + last; + } + } + + return $self->{'is_trivial_link'}; + +} + +sub is_data { + +=pod + +=head2 is_data + +Returns true if the table has some non-key fields. + +=cut + + my $self = shift; + return $self->{'is_data'} if defined $self->{'is_data'}; + + $self->{'is_data'} = 0; + + foreach my $field ( $self->get_fields ) { + if ( !$field->is_primary_key and !$field->is_foreign_key ) { + $self->{'is_data'} = 1; + return $self->{'is_data'}; + } + } + + return $self->{'is_data'}; +} + +# ---------------------------------------------------------------------- +sub can_link { + +=pod + +=head2 can_link + +Determine whether the table can link two arg tables via many-to-many. + + my $ok = $table->can_link($table1,$table2); + +=cut + + my ( $self, $table1, $table2 ) = @_; + + return $self->{'can_link'}{ $table1->name }{ $table2->name } + if defined $self->{'can_link'}{ $table1->name }{ $table2->name }; + + if ( $self->is_data == 1 ) { + $self->{'can_link'}{ $table1->name }{ $table2->name } = [0]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = [0]; + return $self->{'can_link'}{ $table1->name }{ $table2->name }; + } + + my %fk = (); + + foreach my $field ( $self->get_fields ) { + if ( $field->is_foreign_key ) { + push @{ $fk{ $field->foreign_key_reference->reference_table } }, + $field->foreign_key_reference; + } + } + + if ( !defined( $fk{ $table1->name } ) or !defined( $fk{ $table2->name } ) ) + { + $self->{'can_link'}{ $table1->name }{ $table2->name } = [0]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = [0]; + return $self->{'can_link'}{ $table1->name }{ $table2->name }; + } + + # trivial traversal, only one way to link the two tables + if ( scalar( @{ $fk{ $table1->name } } == 1 ) + and scalar( @{ $fk{ $table2->name } } == 1 ) ) + { + $self->{'can_link'}{ $table1->name }{ $table2->name } = + [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ]; + $self->{'can_link'}{ $table1->name }{ $table2->name } = + [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ]; + + # non-trivial traversal. one way to link table2, + # many ways to link table1 + } + elsif ( scalar( @{ $fk{ $table1->name } } > 1 ) + and scalar( @{ $fk{ $table2->name } } == 1 ) ) + { + $self->{'can_link'}{ $table1->name }{ $table2->name } = + [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = + [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ]; + + # non-trivial traversal. one way to link table1, + # many ways to link table2 + } + elsif ( scalar( @{ $fk{ $table1->name } } == 1 ) + and scalar( @{ $fk{ $table2->name } } > 1 ) ) + { + $self->{'can_link'}{ $table1->name }{ $table2->name } = + [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = + [ 'many2one', $fk{ $table2->name }, $fk{ $table1->name } ]; + + # non-trivial traversal. many ways to link table1 and table2 + } + elsif ( scalar( @{ $fk{ $table1->name } } > 1 ) + and scalar( @{ $fk{ $table2->name } } > 1 ) ) + { + $self->{'can_link'}{ $table1->name }{ $table2->name } = + [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = + [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ]; + + # one of the tables didn't export a key + # to this table, no linking possible + } + else { + $self->{'can_link'}{ $table1->name }{ $table2->name } = [0]; + $self->{'can_link'}{ $table2->name }{ $table1->name } = [0]; + } + + return $self->{'can_link'}{ $table1->name }{ $table2->name }; +} + +# ---------------------------------------------------------------------- +sub name { + +=pod + +=head2 name + +Get or set the table's name. + +Errors ("No table name") if you try to set a blank name. + +If provided an argument, checks the schema object for a table of +that name and disallows the change if one exists (setting the error to +"Can't use table name "%s": table exists"). + + my $table_name = $table->name('foo'); + +=cut + + my $self = shift; + + if ( @_ ) { + my $arg = shift || return $self->error( "No table name" ); + if ( my $schema = $self->schema ) { + return $self->error( qq[Can't use table name "$arg": table exists] ) + if $schema->get_table( $arg ); + } + $self->{'name'} = $arg; + } + + return $self->{'name'} || ''; +} + +# ---------------------------------------------------------------------- sub schema { =pod @@ -392,13 +770,20 @@ sub primary_key { =pod -=head2 options +=head2 primary_key + +Gets or sets the table's primary key(s). Takes one or more field +names (as a string, list or array[ref]) as an argument. If the field +names are present, it will create a new PK if none exists, or it will +add to the fields of an existing PK (and will unique the field names). +Returns the C object representing +the primary key. -Gets or sets the table's primary key(s). Takes one or more field names -(as a string, list or arrayref) and returns an array or arrayref. +These are eqivalent: $table->primary_key('id'); - $table->primary_key(['id']); + $table->primary_key(['name']); + $table->primary_key('id','name']); $table->primary_key(['id','name']); $table->primary_key('id,name'); $table->primary_key(qw[ id name ]); @@ -407,10 +792,10 @@ Gets or sets the table's primary key(s). Takes one or more field names =cut - my $self = shift; - my $fields = UNIVERSAL::isa( $_[0], 'ARRAY' ) - ? shift : [ map { s/^\s+|\s+$//g; $_ } map { split /,/ } @_ ]; + my $self = shift; + my $fields = parse_list_arg( @_ ); + my $constraint; if ( @$fields ) { for my $f ( @$fields ) { return $self->error(qq[Invalid field "$f"]) unless @@ -422,22 +807,28 @@ Gets or sets the table's primary key(s). Takes one or more field names if ( $c->type eq PRIMARY_KEY ) { $has_pk = 1; $c->fields( @{ $c->fields }, @$fields ); + $constraint = $c; } } unless ( $has_pk ) { - $self->add_constraint( + $constraint = $self->add_constraint( type => PRIMARY_KEY, fields => $fields, - ); + ) or return; } } - for my $c ( $self->get_constraints ) { - return $c if $c->type eq PRIMARY_KEY; + if ( $constraint ) { + return $constraint; + } + else { + for my $c ( $self->get_constraints ) { + return $c if $c->type eq PRIMARY_KEY; + } } - return $self->error('No primary key'); + return; } # ---------------------------------------------------------------------- @@ -455,27 +846,269 @@ an array or array reference. =cut my $self = shift; - my $options = UNIVERSAL::isa( $_[0], 'ARRAY' ) - ? shift : [ map { s/^\s+|\s+$//g; $_ } map { split /,/ } @_ ]; + my $options = parse_list_arg( @_ ); push @{ $self->{'options'} }, @$options; if ( ref $self->{'options'} ) { - return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'}; + return wantarray ? @{ $self->{'options'} || [] } : ($self->{'options'} || ''); } else { return wantarray ? () : []; } } +# ---------------------------------------------------------------------- +sub order { + +=pod + +=head2 order + +Get or set the table's order. + + my $order = $table->order(3); + +=cut + + my ( $self, $arg ) = @_; + + if ( defined $arg && $arg =~ /^\d+$/ ) { + $self->{'order'} = $arg; + } + + return $self->{'order'} || 0; +} + +# ---------------------------------------------------------------------- +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 table has no fields set. Usefull if you want to +avoid the overload magic of the Field objects returned by the get_fields method. + + my @names = $constraint->field_names; + +=cut + + my $self = shift; + my @fields = + map { $_->name } + sort { $a->order <=> $b->order } + values %{ $self->{'fields'} || {} }; + + if ( @fields ) { + return wantarray ? @fields : \@fields; + } + else { + $self->error('No fields'); + return wantarray ? () : undef; + } +} + +# ---------------------------------------------------------------------- +sub equals { + +=pod + +=head2 equals + +Determines if this table is the same as another + + my $isIdentical = $table1->equals( $table2 ); + +=cut + + my $self = shift; + my $other = shift; + my $case_insensitive = shift; + + return 0 unless $self->SUPER::equals($other); + return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name; + return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options); + return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra); + + # Fields + # Go through our fields + my %checkedFields; + foreach my $field ( $self->get_fields ) { + my $otherField = $other->get_field($field->name, $case_insensitive); + return 0 unless $field->equals($otherField, $case_insensitive); + $checkedFields{$field->name} = 1; + } + # Go through the other table's fields + foreach my $otherField ( $other->get_fields ) { + next if $checkedFields{$otherField->name}; + return 0; + } + + # Constraints + # Go through our constraints + my %checkedConstraints; +CONSTRAINT: + foreach my $constraint ( $self->get_constraints ) { + foreach my $otherConstraint ( $other->get_constraints ) { + if ( $constraint->equals($otherConstraint, $case_insensitive) ) { + $checkedConstraints{$otherConstraint} = 1; + next CONSTRAINT; + } + } + return 0; + } + # Go through the other table's constraints +CONSTRAINT2: + foreach my $otherConstraint ( $other->get_constraints ) { + next if $checkedFields{$otherConstraint}; + foreach my $constraint ( $self->get_constraints ) { + if ( $otherConstraint->equals($constraint, $case_insensitive) ) { + next CONSTRAINT2; + } + } + return 0; + } + + # Indices + # Go through our indices + my %checkedIndices; +INDEX: + foreach my $index ( $self->get_indices ) { + foreach my $otherIndex ( $other->get_indices ) { + if ( $index->equals($otherIndex, $case_insensitive) ) { + $checkedIndices{$otherIndex} = 1; + next INDEX; + } + } + return 0; + } + # Go through the other table's indices +INDEX2: + foreach my $otherIndex ( $other->get_indices ) { + next if $checkedIndices{$otherIndex}; + foreach my $index ( $self->get_indices ) { + if ( $otherIndex->equals($index, $case_insensitive) ) { + next INDEX2; + } + } + return 0; + } + + return 1; +} + +# ---------------------------------------------------------------------- + +=head1 LOOKUP METHODS + +The following are a set of shortcut methods for getting commonly used lists of +fields and constraints. They all return lists or array refs of Field or +Constraint objects. + +=over 4 + +=item pkey_fields + +The primary key fields. + +=item fkey_fields + +All foreign key fields. + +=item nonpkey_fields + +All the fields except the primary key. + +=item data_fields + +All non key fields. + +=item unique_fields + +All fields with unique constraints. + +=item unique_constraints + +All this tables unique constraints. + +=item fkey_constraints + +All this tables foreign key constraints. (See primary_key method to get the +primary key constraint) + +=back + +=cut + +sub pkey_fields { + my $me = shift; + my @fields = grep { $_->is_primary_key } $me->get_fields; + return wantarray ? @fields : \@fields; +} + +# ---------------------------------------------------------------------- +sub fkey_fields { + my $me = shift; + my @fields; + push @fields, $_->fields foreach $me->fkey_constraints; + return wantarray ? @fields : \@fields; +} + +# ---------------------------------------------------------------------- +sub nonpkey_fields { + my $me = shift; + my @fields = grep { !$_->is_primary_key } $me->get_fields; + return wantarray ? @fields : \@fields; +} + +# ---------------------------------------------------------------------- +sub data_fields { + my $me = shift; + my @fields = + grep { !$_->is_foreign_key and !$_->is_primary_key } $me->get_fields; + return wantarray ? @fields : \@fields; +} + +# ---------------------------------------------------------------------- +sub unique_fields { + my $me = shift; + my @fields; + push @fields, $_->fields foreach $me->unique_constraints; + return wantarray ? @fields : \@fields; +} + +# ---------------------------------------------------------------------- +sub unique_constraints { + my $me = shift; + my @cons = grep { $_->type eq UNIQUE } $me->get_constraints; + return wantarray ? @cons : \@cons; +} + +# ---------------------------------------------------------------------- +sub fkey_constraints { + my $me = shift; + my @cons = grep { $_->type eq FOREIGN_KEY } $me->get_constraints; + return wantarray ? @cons : \@cons; +} + +# ---------------------------------------------------------------------- +sub DESTROY { + my $self = shift; + undef $self->{'schema'}; # destroy cyclical reference + undef $_ for @{ $self->{'constraints'} }; + undef $_ for @{ $self->{'indices'} }; + undef $_ for values %{ $self->{'fields'} }; +} + 1; # ---------------------------------------------------------------------- =pod -=head1 AUTHOR +=head1 AUTHORS -Ken Y. Clark Ekclark@cpan.orgE +Ken Y. Clark Ekclark@cpan.orgE, +Allen Day Eallenday@ucla.eduE. =cut