From: Dagfinn Ilmari Mannsåker Date: Tue, 31 Jul 2012 23:08:15 +0000 (+0100) Subject: Mooify SQLT::Schema::Table X-Git-Tag: v0.11013_01~27 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=558482f72a892e14b674647c814cf9861a3b4aea;p=dbsrgits%2FSQL-Translator.git Mooify SQLT::Schema::Table --- diff --git a/lib/SQL/Translator/Schema.pm b/lib/SQL/Translator/Schema.pm index 6cf710c..d4caf91 100644 --- a/lib/SQL/Translator/Schema.pm +++ b/lib/SQL/Translator/Schema.pm @@ -140,7 +140,7 @@ not be created. my $table_name = $table->name; if ( defined $self->_tables->{$table_name} ) { - return $self->error(qq[Can't create table: "$table_name" exists]); + return $self->error(qq[Can't use table name "$table_name": table exists]); } else { $self->_tables->{$table_name} = $table; diff --git a/lib/SQL/Translator/Schema/Table.pm b/lib/SQL/Translator/Schema/Table.pm index 36c2c09..a7ee464 100644 --- a/lib/SQL/Translator/Schema/Table.pm +++ b/lib/SQL/Translator/Schema/Table.pm @@ -19,9 +19,9 @@ C is the table object. =cut -use strict; -use warnings; -use SQL::Translator::Utils 'parse_list_arg'; +use Moo; +use SQL::Translator::Utils qw(parse_list_arg ex2err throw); +use SQL::Translator::Types qw(schema_obj); use SQL::Translator::Schema::Constants; use SQL::Translator::Schema::Constraint; use SQL::Translator::Schema::Field; @@ -30,7 +30,11 @@ use SQL::Translator::Schema::Index; use Carp::Clan '^SQL::Translator'; use List::Util 'max'; -use base 'SQL::Translator::Schema::Object'; +with qw( + SQL::Translator::Schema::Role::Extra + SQL::Translator::Schema::Role::Error + SQL::Translator::Schema::Role::Compare +); our $VERSION = '1.59'; @@ -43,8 +47,6 @@ use overload fallback => 1, ; -__PACKAGE__->_attributes( qw/schema name comments options order/ ); - =pod =head2 new @@ -56,12 +58,6 @@ Object constructor. name => 'foo', ); -=cut - -sub add_constraint { - -=pod - =head2 add_constraint Add a constraint to the table. Returns the newly created @@ -78,6 +74,15 @@ C object. =cut +has _constraints => ( + is => 'ro', + init_arg => undef, + default => sub { +[] }, + predicate => 1, + lazy => 1, +); + +sub add_constraint { my $self = shift; my $constraint_class = 'SQL::Translator::Schema::Constraint'; my $constraint; @@ -137,16 +142,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 @@ -157,6 +158,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; @@ -168,21 +170,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 @@ -199,6 +197,15 @@ C object. =cut +has _indices => ( + is => 'ro', + init_arg => undef, + default => sub { [] }, + predicate => 1, + lazy => 1, +); + +sub add_index { my $self = shift; my $index_class = 'SQL::Translator::Schema::Index'; my $index; @@ -216,14 +223,10 @@ C object. 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 @@ -234,6 +237,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; @@ -245,21 +249,17 @@ 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 @@ -281,6 +281,15 @@ existing field, you will get an error and the field will not be created. =cut +has _fields => ( + is => 'ro', + init_arg => undef, + default => sub { +{} }, + predicate => 1, + lazy => 1 +); + +sub add_field { my $self = shift; my $field_class = 'SQL::Translator::Schema::Field'; my $field; @@ -328,16 +337,12 @@ existing field, you will get an error and the field will not be created. return $self->error(qq[Can't create field: "$field_name" 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 @@ -348,6 +353,7 @@ a field name or an C object. =cut +sub drop_field { my $self = shift; my $field_class = 'SQL::Translator::Schema::Field'; my $field_name; @@ -361,11 +367,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 @@ -386,10 +392,6 @@ 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 @@ -403,28 +405,27 @@ all the comments joined on newlines. =cut +has comments => ( + is => 'rw', + coerce => sub { ref($_[0]) eq 'ARRAY' ? $_[0] : [$_[0]] }, + default => sub { [] }, +); + +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 @@ -434,11 +435,12 @@ Returns all the constraint objects as an array or array reference. =cut +sub get_constraints { my $self = shift; - if ( ref $self->{'constraints'} ) { + if ( $self->_has_constraints ) { return wantarray - ? @{ $self->{'constraints'} } : $self->{'constraints'}; + ? @{ $self->_constraints } : $self->_constraints; } else { $self->error('No constraints'); @@ -446,10 +448,6 @@ Returns all the constraint objects as an array or array reference. } } -sub get_indices { - -=pod - =head2 get_indices Returns all the index objects as an array or array reference. @@ -458,12 +456,13 @@ Returns all the index objects as an array or array reference. =cut +sub get_indices { my $self = shift; - if ( ref $self->{'indices'} ) { + if ( $self->_has_indices ) { return wantarray - ? @{ $self->{'indices'} } - : $self->{'indices'}; + ? @{ $self->_indices } + : $self->_indices; } else { $self->error('No indices'); @@ -471,10 +470,6 @@ Returns all the index objects as an array or array reference. } } -sub get_field { - -=pod - =head2 get_field Returns a field by the name provided. @@ -483,25 +478,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); + 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. @@ -510,12 +504,13 @@ Returns all the field objects as an array or array reference. =cut +sub get_fields { my $self = shift; 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; @@ -526,10 +521,6 @@ Returns all the field objects as an array or array reference. } } -sub is_valid { - -=pod - =head2 is_valid Determine whether the view is valid or not. @@ -538,6 +529,7 @@ 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; @@ -551,21 +543,17 @@ 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 ); + +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 = (); @@ -576,44 +564,33 @@ True if table has no data (non-key) fields and only uses single key joins. foreach my $referenced (keys %fk){ if($fk{$referenced} > 1){ - $self->{'is_trivial_link'} = 0; - last; + 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; +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. @@ -622,15 +599,18 @@ Determine whether the table can link two arg tables via many-to-many. =cut +has _can_link => ( is => 'ro', init_arg => undef, default => sub { +{} } ); + +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 = (); @@ -644,18 +624,18 @@ 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, @@ -664,9 +644,9 @@ 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 } = [ '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, @@ -675,9 +655,9 @@ 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 } = [ '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 @@ -685,26 +665,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 # 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. @@ -719,23 +695,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 @@ -745,15 +722,9 @@ 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') ); - return $self->{'schema'}; -} +around schema => \&ex2err; sub primary_key { @@ -820,10 +791,6 @@ These are eqivalent: return; } -sub options { - -=pod - =head2 options Get or set the table's options (e.g., table types for MySQL). Returns @@ -833,22 +800,21 @@ an array or array reference. =cut +has options => ( + is => 'rw', + default => sub { [] }, + coerce => \&parse_list_arg, +); + +around options => sub { + my $orig = shift; 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 { + push @{ $self->$orig }, @$options; -=pod + return wantarray ? @{ $self->$orig } : $self->$orig; +}; =head2 order @@ -858,16 +824,17 @@ Get or set the table's order. =cut - my ( $self, $arg ) = @_; +has order => ( is => 'rw', default => sub { 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 @@ -879,11 +846,11 @@ avoid the overload magic of the Field objects returned by the get_fields method. =cut +sub field_names { my $self = shift; my @fields = map { $_->name } - sort { $a->order <=> $b->order } - values %{ $self->{'fields'} || {} }; + $self->get_fields; if ( @fields ) { return wantarray ? @fields : \@fields; @@ -1076,6 +1043,9 @@ sub DESTROY { undef $_ for values %{ $self->{'fields'} }; } +# Must come after all 'has' declarations +around new => \&ex2err; + 1; =pod