X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FField.pm;h=8e4a0cb237c7301ce873b2436cf906f872d9101c;hb=45595850cc8937473606c3430c5fcbbd4b07a294;hp=ae2b127b8b8706af225ebf248210970624989c81;hpb=282bf498899061be19ec7fd7ce16bf25a562fdcf;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm index ae2b127..8e4a0cb 100644 --- a/lib/SQL/Translator/Schema/Field.pm +++ b/lib/SQL/Translator/Schema/Field.pm @@ -1,23 +1,5 @@ package SQL::Translator::Schema::Field; -# ---------------------------------------------------------------------- -# 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 @@ -40,15 +22,19 @@ C is the field object. =cut -use strict; +use Moo; use SQL::Translator::Schema::Constants; -use SQL::Translator::Utils 'parse_list_arg'; - -use base 'SQL::Translator::Schema::Object'; - -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); +use SQL::Translator::Types qw(schema_obj); +use SQL::Translator::Utils qw(parse_list_arg ex2err throw); + +with qw( + SQL::Translator::Role::Error + SQL::Translator::Role::BuildArgs + SQL::Translator::Schema::Role::Extra + SQL::Translator::Schema::Role::Compare +); -$VERSION = '1.59'; +our $VERSION = '1.59'; # 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 @@ -92,14 +78,6 @@ our %type_mapping = ( ); -__PACKAGE__->_attributes( qw/ - table name data_type size is_primary_key is_nullable - is_auto_increment default_value comments is_foreign_key - is_unique order sql_data_type -/); - -=pod - =head2 new Object constructor. @@ -109,12 +87,6 @@ Object constructor. table => $table, ); -=cut - -sub comments { - -=pod - =head2 comments Get or set the comments on a field. May be called several times to @@ -128,27 +100,26 @@ 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; for my $arg ( @_ ) { $arg = $arg->[0] if ref $arg; - push @{ $self->{'comments'} }, $arg if $arg; + push @{ $self->$orig }, $arg if $arg; } - if ( @{ $self->{'comments'} || [] } ) { - return wantarray - ? @{ $self->{'comments'} || [] } - : join( "\n", @{ $self->{'comments'} || [] } ); - } - else { - return wantarray ? () : ''; - } -} - - -sub data_type { + return wantarray + ? @{ $self->$orig } + : join( "\n", @{ $self->$orig } ); +}; -=pod =head2 data_type @@ -158,15 +129,7 @@ Get or set the field's data type. =cut - my $self = shift; - if (@_) { - $self->{'data_type'} = $_[0]; - $self->{'sql_data_type'} = $type_mapping{lc $_[0]} || SQL_UNKNOWN_TYPE unless exists $self->{sql_data_type}; - } - return $self->{'data_type'} || ''; -} - -sub sql_data_type { +has data_type => ( is => 'rw', default => sub { '' } ); =head2 sql_data_type @@ -175,16 +138,12 @@ for more details. =cut - my $self = shift; - $self->{sql_data_type} = shift if @_; - return $self->{sql_data_type} || 0; +has sql_data_type => ( is => 'rw', lazy => 1, builder => 1 ); +sub _build_sql_data_type { + $type_mapping{lc $_[0]->data_type} || SQL_UNKNOWN_TYPE; } -sub default_value { - -=pod - =head2 default_value Get or set the field's default value. Will return undef if not defined @@ -195,12 +154,7 @@ assume an error like other methods. =cut - my $self = shift; - $self->{'default_value'} = shift if @_; - return $self->{'default_value'}; -} - -=pod +has default_value => ( is => 'rw' ); =head2 extra @@ -212,10 +166,6 @@ Accepts a hash(ref) of name/value pairs to store; returns a hash. =cut -sub foreign_key_reference { - -=pod - =head2 foreign_key_reference Get or set the field's foreign key reference; @@ -224,30 +174,26 @@ Get or set the field's foreign key reference; =cut +has foreign_key_reference => ( + is => 'rw', + predicate => '_has_foreign_key_reference', + isa => schema_obj('Constraint'), + weak_ref => 1, +); + +around foreign_key_reference => sub { + my $orig = shift; my $self = shift; if ( my $arg = shift ) { - my $class = 'SQL::Translator::Schema::Constraint'; - if ( UNIVERSAL::isa( $arg, $class ) ) { - return $self->error( - 'Foreign key reference for ', $self->name, 'already defined' - ) if $self->{'foreign_key_reference'}; + return $self->error( + 'Foreign key reference for ', $self->name, 'already defined' + ) if $self->_has_foreign_key_reference; - $self->{'foreign_key_reference'} = $arg; - } - else { - return $self->error( - "Argument to foreign_key_reference is not an $class object" - ); - } + return ex2err($orig, $self, $arg); } - - return $self->{'foreign_key_reference'}; -} - -sub is_auto_increment { - -=pod + $self->$orig; +}; =head2 is_auto_increment @@ -257,32 +203,29 @@ Get or set the field's C attribute. =cut - my ( $self, $arg ) = @_; +has is_auto_increment => ( + is => 'rw', + coerce => sub { $_[0] ? 1 : 0 }, + builder => 1, + lazy => 1, +); - if ( defined $arg ) { - $self->{'is_auto_increment'} = $arg ? 1 : 0; - } +sub _build_is_auto_increment { + my ( $self ) = @_; - unless ( defined $self->{'is_auto_increment'} ) { - if ( my $table = $self->table ) { - if ( my $schema = $table->schema ) { - if ( - $schema->database eq 'PostgreSQL' && - $self->data_type eq 'serial' - ) { - $self->{'is_auto_increment'} = 1; - } + if ( my $table = $self->table ) { + if ( my $schema = $table->schema ) { + if ( + $schema->database eq 'PostgreSQL' && + $self->data_type eq 'serial' + ) { + return 1; } } } - - return $self->{'is_auto_increment'} || 0; + return 0; } -sub is_foreign_key { - -=pod - =head2 is_foreign_key Returns whether or not the field is a foreign key. @@ -291,30 +234,30 @@ Returns whether or not the field is a foreign key. =cut - my ( $self, $arg ) = @_; - - unless ( defined $self->{'is_foreign_key'} ) { - if ( my $table = $self->table ) { - for my $c ( $table->get_constraints ) { - if ( $c->type eq FOREIGN_KEY ) { - my %fields = map { $_, 1 } $c->fields; - if ( $fields{ $self->name } ) { - $self->{'is_foreign_key'} = 1; - $self->foreign_key_reference( $c ); - last; - } +has is_foreign_key => ( + is => 'rw', + coerce => sub { $_[0] ? 1 : 0 }, + builder => 1, + lazy => 1, +); + +sub _build_is_foreign_key { + my ( $self ) = @_; + + if ( my $table = $self->table ) { + for my $c ( $table->get_constraints ) { + if ( $c->type eq FOREIGN_KEY ) { + my %fields = map { $_, 1 } $c->fields; + if ( $fields{ $self->name } ) { + $self->foreign_key_reference( $c ); + return 1; } } } } - - return $self->{'is_foreign_key'} || 0; + return 0; } -sub is_nullable { - -=pod - =head2 is_nullable Get or set whether the field can be null. If not defined, then @@ -332,26 +275,17 @@ foreign keys; checks) are represented as table constraints. =cut - my ( $self, $arg ) = @_; - - if ( defined $arg ) { - $self->{'is_nullable'} = $arg ? 1 : 0; - } - - if ( - defined $self->{'is_nullable'} && - $self->{'is_nullable'} == 1 && - $self->is_primary_key - ) { - $self->{'is_nullable'} = 0; - } - - return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1; -} +has is_nullable => ( + is => 'rw', + coerce => sub { $_[0] ? 1 : 0 }, + default => sub { 1 }, + ); -sub is_primary_key { +around is_nullable => sub { + my ($orig, $self, $arg) = @_; -=pod + $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ()); +}; =head2 is_primary_key @@ -362,31 +296,25 @@ a table constraint (should it?). =cut - my ( $self, $arg ) = @_; +has is_primary_key => ( + is => 'rw', + coerce => sub { $_[0] ? 1 : 0 }, + lazy => 1, + builder => 1, +); - if ( defined $arg ) { - $self->{'is_primary_key'} = $arg ? 1 : 0; - } +sub _build_is_primary_key { + my ( $self ) = @_; - unless ( defined $self->{'is_primary_key'} ) { - if ( my $table = $self->table ) { - if ( my $pk = $table->primary_key ) { - my %fields = map { $_, 1 } $pk->fields; - $self->{'is_primary_key'} = $fields{ $self->name } || 0; - } - else { - $self->{'is_primary_key'} = 0; - } + if ( my $table = $self->table ) { + if ( my $pk = $table->primary_key ) { + my %fields = map { $_, 1 } $pk->fields; + return $fields{ $self->name } || 0; } } - - return $self->{'is_primary_key'} || 0; + return 0; } -sub is_unique { - -=pod - =head2 is_unique Determine whether the field has a UNIQUE constraint or not. @@ -395,23 +323,22 @@ Determine whether the field has a UNIQUE constraint or not. =cut - my $self = shift; +has is_unique => ( is => 'lazy', init_arg => undef ); + +sub _build_is_unique { + my ( $self ) = @_; - unless ( defined $self->{'is_unique'} ) { - if ( my $table = $self->table ) { - for my $c ( $table->get_constraints ) { - if ( $c->type eq UNIQUE ) { - my %fields = map { $_, 1 } $c->fields; - if ( $fields{ $self->name } ) { - $self->{'is_unique'} = 1; - last; - } + if ( my $table = $self->table ) { + for my $c ( $table->get_constraints ) { + if ( $c->type eq UNIQUE ) { + my %fields = map { $_, 1 } $c->fields; + if ( $fields{ $self->name } ) { + return 1; } } } } - - return $self->{'is_unique'} || 0; + return 0; } sub is_valid { @@ -433,10 +360,6 @@ Determine whether the field is valid or not. return 1; } -sub name { - -=pod - =head2 name Get or set the field's name. @@ -451,20 +374,21 @@ Errors ("No field name") if you try to set a blank name. =cut +has name => ( is => 'rw', isa => sub { throw( "No field name" ) unless $_[0] } ); + +around name => sub { + my $orig = shift; my $self = shift; - if ( @_ ) { - my $arg = shift || return $self->error( "No field name" ); - if ( my $table = $self->table ) { + if ( my ($arg) = @_ ) { + if ( my $schema = $self->table ) { return $self->error( qq[Can't use field name "$arg": field exists] ) - if $table->get_field( $arg ); + if $schema->get_field( $arg ); } - - $self->{'name'} = $arg; } - return $self->{'name'} || ''; -} + return ex2err($orig, $self, @_); +}; sub full_name { @@ -479,10 +403,6 @@ e.g. "person.foo". return $self->table.".".$self->name; } -sub order { - -=pod - =head2 order Get or set the field's order. @@ -491,14 +411,17 @@ Get or set the field'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; -} + return $self->$orig; +}; sub schema { @@ -516,10 +439,6 @@ doesn't have one. return undef; } -sub size { - -=pod - =head2 size Get or set the field's size. Accepts a string, array or arrayref of @@ -535,6 +454,17 @@ numbers and returns a string. =cut +has size => ( + is => 'rw', + default => sub { [0] }, + coerce => sub { + my @sizes = grep { defined && m/^\d+(?:\.\d+)?$/ } @{parse_list_arg($_[0])}; + @sizes ? \@sizes : [0]; + }, +); + +around size => sub { + my $orig = shift; my $self = shift; my $numbers = parse_list_arg( @_ ); @@ -545,18 +475,14 @@ numbers and returns a string. push @new, $num; } } - $self->{'size'} = \@new if @new; # only set if all OK + $self->$orig(\@new) if @new; # only set if all OK } return wantarray - ? @{ $self->{'size'} || [0] } - : join( ',', @{ $self->{'size'} || [0] } ) + ? @{ $self->$orig || [0] } + : join( ',', @{ $self->$orig || [0] } ) ; -} - -sub table { - -=pod +}; =head2 table @@ -568,17 +494,9 @@ also be used to get the table name. =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'}; -} +has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 ); -sub parsed_field { +around table => \&ex2err; =head2 @@ -586,19 +504,14 @@ Returns the field exactly as the parser found it =cut - my $self = shift; +has parsed_field => ( is => 'rw' ); - if (@_) { - my $value = shift; - $self->{parsed_field} = $value; - return $value || $self; - } - return $self->{parsed_field} || $self; -} - -sub equals { +around parsed_field => sub { + my $orig = shift; + my $self = shift; -=pod + return $self->$orig(@_) || $self; +}; =head2 equals @@ -608,11 +521,13 @@ Determines if this field is the same as another =cut +around equals => sub { + my $orig = shift; my $self = shift; my $other = shift; my $case_insensitive = shift; - return 0 unless $self->SUPER::equals($other); + return 0 unless $self->$orig($other); return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name; # Comparing types: use sql_data_type if both are not 0. Else use string data_type @@ -650,16 +565,10 @@ Determines if this field is the same as another # return 0 unless $self->comments eq $other->comments; return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra); return 1; -} +}; -sub DESTROY { -# -# Destroy cyclical references. -# - my $self = shift; - undef $self->{'table'}; - undef $self->{'foreign_key_reference'}; -} +# Must come after all 'has' declarations +around new => \&ex2err; 1;