X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FTable.pm;h=f2ff231324e82a4f6fd1a19805d39032d69ff1d7;hb=752a0ffc868171987b517d88376181c3997bbba9;hp=2fbe757328b339ff24136d171d559a6a2c83ff8e;hpb=da06ac74ada30aacf656943306679a28605ad5c8;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm index 2fbe757..f2ff231 100644 --- a/lib/SQL/Translator/Schema/Table.pm +++ b/lib/SQL/Translator/Schema/Table.pm @@ -1,25 +1,5 @@ package SQL::Translator::Schema::Table; -# ---------------------------------------------------------------------- -# $Id: Table.pm 1440 2009-01-17 16:31:57Z jawnsy $ -# ---------------------------------------------------------------------- -# 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 @@ -31,7 +11,7 @@ SQL::Translator::Schema::Table - SQL::Translator table object use SQL::Translator::Schema::Table; my $table = SQL::Translator::Schema::Table->new( name => 'foo' ); -=head1 DESCSIPTION +=head1 DESCRIPTION C is the table object. @@ -39,19 +19,22 @@ C is the table object. =cut -use strict; -use SQL::Translator::Utils 'parse_list_arg'; +use Moo; +use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro); +use SQL::Translator::Types qw(schema_obj); +use SQL::Translator::Role::ListAttr; 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 'SQL::Translator::Schema::Object'; +use Carp::Clan '^SQL::Translator'; +use List::Util 'max'; +use Sub::Quote qw(quote_sub); -use vars qw( $VERSION $FIELD_ORDER ); +extends 'SQL::Translator::Schema::Object'; -$VERSION = '1.99'; +our $VERSION = '1.61'; # 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 @@ -62,31 +45,20 @@ use overload fallback => 1, ; -# ---------------------------------------------------------------------- - -__PACKAGE__->_attributes( qw/schema name comments options order/ ); - =pod =head2 new Object constructor. - my $table = SQL::Translator::Schema::Table->new( + my $table = SQL::Translator::Schema::Table->new( schema => $schema, name => 'foo', ); -=cut - -# ---------------------------------------------------------------------- -sub add_constraint { - -=pod - =head2 add_constraint -Add a constraint to the table. Returns the newly created +Add a constraint to the table. Returns the newly created C object. my $c1 = $table->add_constraint( @@ -100,6 +72,15 @@ C object. =cut +has _constraints => ( + is => 'ro', + init_arg => undef, + default => quote_sub(q{ +[] }), + predicate => 1, + lazy => 1, +); + +sub add_constraint { my $self = shift; my $constraint_class = 'SQL::Translator::Schema::Constraint'; my $constraint; @@ -111,7 +92,7 @@ C object. else { my %args = @_; $args{'table'} = $self; - $constraint = $constraint_class->new( \%args ) or + $constraint = $constraint_class->new( \%args ) or return $self->error( $constraint_class->error ); } @@ -124,7 +105,7 @@ C object. if ( $pk && $constraint->type eq PRIMARY_KEY ) { $self->primary_key( $constraint->fields ); $pk->name($constraint->name) if $constraint->name; - my %extra = $constraint->extra; + my %extra = $constraint->extra; $pk->extra(%extra) if keys %extra; $constraint = $pk; $ok = 0; @@ -137,20 +118,20 @@ C object. } } # - # See if another constraint of the same type + # 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 +# 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; +# $ok = 0; # last; # } # } @@ -159,17 +140,12 @@ C object. # } if ( $ok ) { - push @{ $self->{'constraints'} }, $constraint; + push @{ $self->_constraints }, $constraint; } return $constraint; } -# ---------------------------------------------------------------------- -sub drop_constraint { - -=pod - =head2 drop_constraint Remove a constraint from the table. Returns the constraint object if the index @@ -180,6 +156,7 @@ an index name or an C object. =cut +sub drop_constraint { my $self = shift; my $constraint_class = 'SQL::Translator::Schema::Constraint'; my $constraint_name; @@ -191,22 +168,17 @@ an index name or an C object. $constraint_name = shift; } - if ( ! grep { $_->name eq $constraint_name } @ { $self->{'constraints'} } ) { + if ( ! ($self->_has_constraints && 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 @cs = @{ $self->_constraints }; my ($constraint_id) = grep { $cs[$_]->name eq $constraint_name } (0..$#cs); - my $constraint = splice(@{$self->{'constraints'}}, $constraint_id, 1); + my $constraint = splice(@{$self->_constraints}, $constraint_id, 1); return $constraint; } -# ---------------------------------------------------------------------- -sub add_index { - -=pod - =head2 add_index Add an index to the table. Returns the newly created @@ -223,6 +195,15 @@ C object. =cut +has _indices => ( + is => 'ro', + init_arg => undef, + default => quote_sub(q{ [] }), + predicate => 1, + lazy => 1, +); + +sub add_index { my $self = shift; my $index_class = 'SQL::Translator::Schema::Index'; my $index; @@ -234,21 +215,16 @@ C object. else { my %args = @_; $args{'table'} = $self; - $index = $index_class->new( \%args ) or return + $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; + 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 @@ -259,6 +235,7 @@ an index name of an C object. =cut +sub drop_index { my $self = shift; my $index_class = 'SQL::Translator::Schema::Index'; my $index_name; @@ -270,27 +247,22 @@ an index name of an C object. $index_name = shift; } - if ( ! grep { $_->name eq $index_name } @{ $self->{'indices'} }) { + if ( ! ($self->_has_indices && 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 @is = @{ $self->_indices }; my ($index_id) = grep { $is[$_]->name eq $index_name } (0..$#is); - my $index = splice(@{$self->{'indices'}}, $index_id, 1); + my $index = splice(@{$self->_indices}, $index_id, 1); return $index; } -# ---------------------------------------------------------------------- -sub add_field { - -=pod - =head2 add_field Add an field to the table. Returns the newly created -C object. The "name" parameter is -required. If you try to create a field with the same name as an +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 $f1 = $table->add_field( @@ -299,14 +271,23 @@ existing field, you will get an error and the field will not be created. size => 11, ); - my $f2 = SQL::Translator::Schema::Field->new( - name => 'name', + my $f2 = SQL::Translator::Schema::Field->new( + name => 'name', table => $table, ); $f2 = $table->add_field( $field2 ) or die $table->error; =cut +has _fields => ( + is => 'ro', + init_arg => undef, + default => quote_sub(q{ +{} }), + predicate => 1, + lazy => 1 +); + +sub add_field { my $self = shift; my $field_class = 'SQL::Translator::Schema::Field'; my $field; @@ -318,38 +299,59 @@ existing field, you will get an error and the field will not be created. else { my %args = @_; $args{'table'} = $self; - $field = $field_class->new( \%args ) or return + $field = $field_class->new( \%args ) or return $self->error( $field_class->error ); } - $field->order( ++$FIELD_ORDER ); + my $existing_order = { map { $_->order => $_->name } $self->get_fields }; + + # supplied order, possible unordered assembly + if ( $field->order ) { + if($existing_order->{$field->order}) { + croak sprintf + "Requested order '%d' for column '%s' conflicts with already existing column '%s'", + $field->order, + $field->name, + $existing_order->{$field->order}, + ; + } + } + else { + my $last_field_no = max(keys %$existing_order) || 0; + if ( $last_field_no != scalar keys %$existing_order ) { + croak sprintf + "Table '%s' field order incomplete - unable to auto-determine order for newly added field", + $self->name, + ; + } + + $field->order( $last_field_no + 1 ); + } + # 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]); + if ( $self->get_field($field_name) ) { + return $self->error(qq[Can't use field name "$field_name": field exists]); } else { - $self->{'fields'}{ $field_name } = $field; + $self->_fields->{ $field_name } = $field; } 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 +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 +sub drop_field { my $self = shift; my $field_class = 'SQL::Translator::Schema::Field'; my $field_name; @@ -363,11 +365,11 @@ a field name or an C object. my %args = @_; my $cascade = $args{'cascade'}; - if ( ! exists $self->{'fields'}{ $field_name } ) { + if ( ! ($self->_has_fields && 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 }; + my $field = delete $self->_fields->{ $field_name }; if ( $cascade ) { # Remove this field from all indices using it @@ -388,14 +390,9 @@ a field name or an C object. return $field; } -# ---------------------------------------------------------------------- -sub comments { - -=pod - =head2 comments -Get or set the comments on a table. May be called several times to +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. @@ -406,29 +403,27 @@ all the comments joined on newlines. =cut +has comments => ( + is => 'rw', + coerce => quote_sub(q{ ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }), + default => quote_sub(q{ [] }), +); + +around comments => sub { + my $orig = shift; 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; + push @{ $self->$orig }, $arg if defined $arg && $arg; } - if ( @{ $self->{'comments'} || [] } ) { - return wantarray - ? @{ $self->{'comments'} } - : join( "\n", @{ $self->{'comments'} } ) - ; - } - else { - return wantarray ? () : undef; - } -} - -# ---------------------------------------------------------------------- -sub get_constraints { - -=pod + @comments = @{$self->$orig}; + return wantarray ? @comments + : @comments ? join( "\n", @comments ) + : undef; +}; =head2 get_constraints @@ -438,23 +433,19 @@ Returns all the constraint objects as an array or array reference. =cut +sub get_constraints { my $self = shift; - if ( ref $self->{'constraints'} ) { - return wantarray - ? @{ $self->{'constraints'} } : $self->{'constraints'}; + if ( $self->_has_constraints ) { + return wantarray + ? @{ $self->_constraints } : $self->_constraints; } else { $self->error('No constraints'); - return wantarray ? () : undef; + return; } } -# ---------------------------------------------------------------------- -sub get_indices { - -=pod - =head2 get_indices Returns all the index objects as an array or array reference. @@ -463,24 +454,20 @@ Returns all the index objects as an array or array reference. =cut +sub get_indices { my $self = shift; - if ( ref $self->{'indices'} ) { - return wantarray - ? @{ $self->{'indices'} } - : $self->{'indices'}; + if ( $self->_has_indices ) { + return wantarray + ? @{ $self->_indices } + : $self->_indices; } else { $self->error('No indices'); - return wantarray ? () : undef; + return; } } -# ---------------------------------------------------------------------- -sub get_field { - -=pod - =head2 get_field Returns a field by the name provided. @@ -489,26 +476,24 @@ Returns a field by the name provided. =cut +sub get_field { my $self = shift; my $field_name = shift or return $self->error('No field name'); my $case_insensitive = shift; + return $self->error(qq[Field "$field_name" does not exist]) + unless $self->_has_fields; 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]); + $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 }; + exists $self->_fields->{ $field_name }; + return $self->_fields->{ $field_name }; } -# ---------------------------------------------------------------------- -sub get_fields { - -=pod - =head2 get_fields Returns all the field objects as an array or array reference. @@ -517,27 +502,23 @@ Returns all the field objects as an array or array reference. =cut +sub get_fields { my $self = shift; - my @fields = + my @fields = map { $_->[1] } sort { $a->[0] <=> $b->[0] } map { [ $_->order, $_ ] } - values %{ $self->{'fields'} || {} }; + values %{ $self->_has_fields ? $self->_fields : {} }; if ( @fields ) { return wantarray ? @fields : \@fields; } else { $self->error('No fields'); - return wantarray ? () : undef; + return; } } -# ---------------------------------------------------------------------- -sub is_valid { - -=pod - =head2 is_valid Determine whether the view is valid or not. @@ -546,12 +527,13 @@ Determine whether the view is valid or not. =cut +sub is_valid { my $self = shift; return $self->error('No name') unless $self->name; return $self->error('No fields') unless $self->get_fields; - for my $object ( - $self->get_fields, $self->get_indices, $self->get_constraints + for my $object ( + $self->get_fields, $self->get_indices, $self->get_constraints ) { return $object->error unless $object->is_valid; } @@ -559,71 +541,58 @@ Determine whether the view is valid or not. return 1; } -# ---------------------------------------------------------------------- -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 +has is_trivial_link => ( is => 'lazy', init_arg => undef ); + +around is_trivial_link => carp_ro('is_trivial_link'); + +sub _build_is_trivial_link { 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}++; - } + 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; - } + if($fk{$referenced} > 1){ + return 0; + } } - return $self->{'is_trivial_link'}; - + return 1; } -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'}; +has is_data => ( is => 'lazy', init_arg => undef ); - $self->{'is_data'} = 0; +around is_data => carp_ro('is_data'); + +sub _build_is_data { + my $self = shift; 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 1; } } - return $self->{'is_data'}; + return 0; } -# ---------------------------------------------------------------------- -sub can_link { - -=pod - =head2 can_link Determine whether the table can link two arg tables via many-to-many. @@ -632,15 +601,18 @@ Determine whether the table can link two arg tables via many-to-many. =cut +has _can_link => ( is => 'ro', init_arg => undef, default => quote_sub(q{ +{} }) ); + +sub can_link { my ( $self, $table1, $table2 ) = @_; - return $self->{'can_link'}{ $table1->name }{ $table2->name } - if defined $self->{'can_link'}{ $table1->name }{ $table2->name }; + 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 }; + $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 = (); @@ -654,40 +626,40 @@ Determine whether the table can link two arg tables via many-to-many. 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 }; + $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 } = + $self->_can_link->{ $table1->name }{ $table2->name } = [ 'one2one', $fk{ $table1->name }, $fk{ $table2->name } ]; - $self->{'can_link'}{ $table1->name }{ $table2->name } = + $self->_can_link->{ $table1->name }{ $table2->name } = [ 'one2one', $fk{ $table2->name }, $fk{ $table1->name } ]; - # non-trivial traversal. one way to link table2, + # 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 } = + $self->_can_link->{ $table1->name }{ $table2->name } = [ 'many2one', $fk{ $table1->name }, $fk{ $table2->name } ]; - $self->{'can_link'}{ $table2->name }{ $table1->name } = + $self->_can_link->{ $table2->name }{ $table1->name } = [ 'one2many', $fk{ $table2->name }, $fk{ $table1->name } ]; - # non-trivial traversal. one way to link table1, + # 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 } = + $self->_can_link->{ $table1->name }{ $table2->name } = [ 'one2many', $fk{ $table1->name }, $fk{ $table2->name } ]; - $self->{'can_link'}{ $table2->name }{ $table1->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 @@ -695,27 +667,22 @@ Determine whether the table can link two arg tables via many-to-many. elsif ( scalar( @{ $fk{ $table1->name } } > 1 ) and scalar( @{ $fk{ $table2->name } } > 1 ) ) { - $self->{'can_link'}{ $table1->name }{ $table2->name } = + $self->_can_link->{ $table1->name }{ $table2->name } = [ 'many2many', $fk{ $table1->name }, $fk{ $table2->name } ]; - $self->{'can_link'}{ $table2->name }{ $table1->name } = + $self->_can_link->{ $table2->name }{ $table1->name } = [ 'many2many', $fk{ $table2->name }, $fk{ $table1->name } ]; - # one of the tables didn't export a key + # 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]; + $self->_can_link->{ $table1->name }{ $table2->name } = [0]; + $self->_can_link->{ $table2->name }{ $table1->name } = [0]; } - return $self->{'can_link'}{ $table1->name }{ $table2->name }; + return $self->_can_link->{ $table1->name }{ $table2->name }; } -# ---------------------------------------------------------------------- -sub name { - -=pod - =head2 name Get or set the table's name. @@ -730,24 +697,24 @@ that name and disallows the change if one exists (setting the error to =cut +has name => ( + is => 'rw', + isa => sub { throw("No table name") unless $_[0] }, +); + +around name => sub { + my $orig = shift; my $self = shift; - if ( @_ ) { - my $arg = shift || return $self->error( "No table name" ); + if ( my ($arg) = @_ ) { 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 + return ex2err($orig, $self, @_); +}; =head2 schema @@ -757,17 +724,10 @@ Get or set the table's schema object. =cut - my $self = shift; - if ( my $arg = shift ) { - return $self->error('Not a schema object') unless - UNIVERSAL::isa( $arg, 'SQL::Translator::Schema' ); - $self->{'schema'} = $arg; - } +has schema => ( is => 'rw', isa => schema_obj('Schema'), weak_ref => 1 ); - return $self->{'schema'}; -} +around schema => \&ex2err; -# ---------------------------------------------------------------------- sub primary_key { =pod @@ -781,7 +741,7 @@ add to the fields of an existing PK (and will unique the field names). Returns the C object representing the primary key. -These are eqivalent: +These are equivalent: $table->primary_key('id'); $table->primary_key(['name']); @@ -800,7 +760,7 @@ These are eqivalent: my $constraint; if ( @$fields ) { for my $f ( @$fields ) { - return $self->error(qq[Invalid field "$f"]) unless + return $self->error(qq[Invalid field "$f"]) unless $self->get_field($f); } @@ -810,7 +770,7 @@ These are eqivalent: $has_pk = 1; $c->fields( @{ $c->fields }, @$fields ); $constraint = $c; - } + } } unless ( $has_pk ) { @@ -833,37 +793,16 @@ These are eqivalent: return; } -# ---------------------------------------------------------------------- -sub options { - -=pod - =head2 options -Get or set the table's options (e.g., table types for MySQL). Returns -an array or array reference. +Get or append to the table's options (e.g., table types for MySQL). +Returns an array or array reference. my @options = $table->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 order { - -=pod +with ListAttr options => ( append => 1 ); =head2 order @@ -873,44 +812,43 @@ Get or set the table's order. =cut - my ( $self, $arg ) = @_; +has order => ( is => 'rw', default => quote_sub(q{ 0 }) ); + +around order => sub { + my ( $orig, $self, $arg ) = @_; if ( defined $arg && $arg =~ /^\d+$/ ) { - $self->{'order'} = $arg; + return $self->$orig($arg); } - return $self->{'order'} || 0; -} - -# ---------------------------------------------------------------------- -sub field_names { + return $self->$orig; +}; =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 +or an empty list if the table has no fields set. Useful if you want to avoid the overload magic of the Field objects returned by the get_fields method. my @names = $constraint->field_names; =cut +sub field_names { my $self = shift; - my @fields = + my @fields = map { $_->name } - sort { $a->order <=> $b->order } - values %{ $self->{'fields'} || {} }; + $self->get_fields; if ( @fields ) { return wantarray ? @fields : \@fields; } else { $self->error('No fields'); - return wantarray ? () : undef; + return; } } -# ---------------------------------------------------------------------- sub equals { =pod @@ -926,7 +864,7 @@ Determines if this table is the same as another 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); @@ -936,14 +874,14 @@ Determines if this table is the same as another # 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; + 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; + next if $checkedFields{$otherField->name}; + return 0; } # Constraints @@ -951,24 +889,24 @@ Determines if this table is the same as another 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; + 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; + next if $checkedFields{$otherConstraint}; + foreach my $constraint ( $self->get_constraints ) { + if ( $otherConstraint->equals($constraint, $case_insensitive) ) { + next CONSTRAINT2; + } + } + return 0; } # Indices @@ -976,35 +914,33 @@ CONSTRAINT2: 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; + 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; + next if $checkedIndices{$otherIndex}; + foreach my $index ( $self->get_indices ) { + if ( $otherIndex->equals($index, $case_insensitive) ) { + next INDEX2; + } + } + return 0; } - return 1; + 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 +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 @@ -1048,7 +984,6 @@ sub pkey_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub fkey_fields { my $me = shift; my @fields; @@ -1056,14 +991,12 @@ sub fkey_fields { 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 = @@ -1071,7 +1004,6 @@ sub data_fields { return wantarray ? @fields : \@fields; } -# ---------------------------------------------------------------------- sub unique_fields { my $me = shift; my @fields; @@ -1079,38 +1011,28 @@ sub unique_fields { 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'} }; -} +# Must come after all 'has' declarations +around new => \&ex2err; 1; -# ---------------------------------------------------------------------- - =pod =head1 AUTHORS -Ken Y. Clark Ekclark@cpan.orgE, +Ken Youens-Clark Ekclark@cpan.orgE, Allen Day Eallenday@ucla.eduE. =cut