X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FField.pm;h=a88263233452ba1a7fd1b3f99942bbb3746942ab;hb=658991afb3d5cac4b807fe53f62eda5b0ef21a40;hp=42da7ae36e423bbe675b29104b3089c6e5546c43;hpb=b03926cdac036bdbcf69e478ca29e1121c814646;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm index 42da7ae..a882632 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,16 @@ 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 SQL::Translator::Types qw(schema_obj); +use SQL::Translator::Utils qw(parse_list_arg ex2err throw carp_ro); +use Sub::Quote qw(quote_sub); +use Scalar::Util (); -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); +extends 'SQL::Translator::Schema::Object'; -$VERSION = '1.99'; +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 @@ -61,19 +44,24 @@ use overload use DBI qw(:sql_types); -# Mapping from string to sql contstant +# Mapping from string to sql constant our %type_mapping = ( integer => SQL_INTEGER, int => SQL_INTEGER, + tinyint => SQL_TINYINT, smallint => SQL_SMALLINT, - bigint => 9999, # DBI doesn't export a constatn for this. Le suck + bigint => SQL_BIGINT, double => SQL_DOUBLE, + 'double precision' => SQL_DOUBLE, decimal => SQL_DECIMAL, - numeric => SQL_NUMERIC, dec => SQL_DECIMAL, + numeric => SQL_NUMERIC, + + real => SQL_REAL, + float => SQL_FLOAT, bit => SQL_BIT, @@ -91,15 +79,16 @@ our %type_mapping = ( text => SQL_LONGVARCHAR ); -# ---------------------------------------------------------------------- -__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 -/); +has _numeric_sql_data_types => ( is => 'lazy' ); -=pod +sub _build__numeric_sql_data_types { + return { + map { $_ => 1 } + (SQL_INTEGER, SQL_TINYINT, SQL_SMALLINT, SQL_BIGINT, SQL_DOUBLE, + SQL_NUMERIC, SQL_DECIMAL, SQL_FLOAT, SQL_REAL) + }; +} =head2 new @@ -110,16 +99,9 @@ Object constructor. table => $table, ); -=cut - -# ---------------------------------------------------------------------- -sub comments { - -=pod - =head2 comments -Get or set the comments on a field. May be called several times to +Get or set the comments on a field. 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. @@ -130,28 +112,26 @@ 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; 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 ? () : ''; - } -} - + return wantarray + ? @{ $self->$orig } + : join( "\n", @{ $self->$orig } ); +}; -# ---------------------------------------------------------------------- -sub data_type { - -=pod =head2 data_type @@ -161,15 +141,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 => quote_sub(q{ '' }) ); =head2 sql_data_type @@ -178,50 +150,23 @@ 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 -and could return the empty string (it's a valid default value), so don't +and could return the empty string (it's a valid default value), so don't assume an error like other methods. my $default = $field->default_value('foo'); =cut - my ( $self, $arg ) = @_; - $self->{'default_value'} = $arg if defined $arg; - return $self->{'default_value'}; -} - -# ---------------------------------------------------------------------- -=pod - -=head2 extra - -Get or set the field's "extra" attibutes (e.g., "ZEROFILL" for MySQL). -Accepts a hash(ref) of name/value pairs to store; returns a hash. - - $field->extra( qualifier => 'ZEROFILL' ); - my %extra = $field->extra; - -=cut - - -# ---------------------------------------------------------------------- -sub foreign_key_reference { - -=pod +has default_value => ( is => 'rw' ); =head2 foreign_key_reference @@ -231,31 +176,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 @@ -265,33 +205,29 @@ Get or set the field's C attribute. =cut - my ( $self, $arg ) = @_; +has is_auto_increment => ( + is => 'rw', + coerce => quote_sub(q{ $_[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. @@ -300,36 +236,35 @@ 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 => quote_sub(q{ $_[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 +Get or set whether the field can be null. If not defined, then returns "1" (assumes the field can be null). The argument is evaluated -by Perl for True or False, so the following are eqivalent: +by Perl for True or False, so the following are equivalent: $is_nullable = $field->is_nullable(0); $is_nullable = $field->is_nullable(''); @@ -342,27 +277,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 => quote_sub(q{ $_[0] ? 1 : 0 }), + default => quote_sub(q{ 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 @@ -373,32 +298,25 @@ a table constraint (should it?). =cut - my ( $self, $arg ) = @_; +has is_primary_key => ( + is => 'rw', + coerce => quote_sub(q{ $_[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. @@ -407,26 +325,26 @@ Determine whether the field has a UNIQUE constraint or not. =cut - my $self = shift; - - 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; - } +has is_unique => ( is => 'lazy', init_arg => undef ); + +around is_unique => carp_ro('is_unique'); + +sub _build_is_unique { + my ( $self ) = @_; + + 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 { =pod @@ -446,11 +364,6 @@ Determine whether the field is valid or not. return 1; } -# ---------------------------------------------------------------------- -sub name { - -=pod - =head2 name Get or set the field's name. @@ -465,20 +378,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 { @@ -493,11 +407,6 @@ e.g. "person.foo". return $self->table.".".$self->name; } -# ---------------------------------------------------------------------- -sub order { - -=pod - =head2 order Get or set the field's order. @@ -506,19 +415,21 @@ Get or set the field'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; -} + return $self->$orig; +}; -# ---------------------------------------------------------------------- sub schema { -=head2 schema +=head2 schema Shortcut to get the fields schema ($field->table->schema) or undef if it doesn't have one. @@ -532,11 +443,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 @@ -552,6 +458,17 @@ numbers and returns a string. =cut +has size => ( + is => 'rw', + default => quote_sub(q{ [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( @_ ); @@ -562,19 +479,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] } ) + return wantarray + ? @{ $self->$orig || [0] } + : join( ',', @{ $self->$orig || [0] } ) ; -} - -# ---------------------------------------------------------------------- -sub table { - -=pod +}; =head2 table @@ -586,38 +498,24 @@ 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 +=head2 parsed_field Returns the field exactly as the parser found it =cut - my $self = shift; - - if (@_) { - my $value = shift; - $self->{parsed_field} = $value; - return $value || $self; - } - return $self->{parsed_field} || $self; -} +has parsed_field => ( is => 'rw' ); -# ---------------------------------------------------------------------- -sub equals { +around parsed_field => sub { + my $orig = shift; + my $self = shift; -=pod + return $self->$orig(@_) || $self; +}; =head2 equals @@ -627,11 +525,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 @@ -658,7 +558,14 @@ Determines if this field is the same as another my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs; my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs; - return 0 if $effective_lhs ne $effective_rhs; + if ( $self->_is_numeric_data_type + && Scalar::Util::looks_like_number($effective_lhs) + && Scalar::Util::looks_like_number($effective_rhs) ) { + return 0 if ($effective_lhs + 0) != ($effective_rhs + 0); + } + else { + return 0 if $effective_lhs ne $effective_rhs; + } } return 0 unless $self->is_nullable eq $other->is_nullable; @@ -669,26 +576,22 @@ 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; -} +}; + +# Must come after all 'has' declarations +around new => \&ex2err; -# ---------------------------------------------------------------------- -sub DESTROY { -# -# Destroy cyclical references. -# +sub _is_numeric_data_type { my $self = shift; - undef $self->{'table'}; - undef $self->{'foreign_key_reference'}; + return $self->_numeric_sql_data_types->{ $self->sql_data_type }; } 1; -# ---------------------------------------------------------------------- - =pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE. +Ken Youens-Clark Ekclark@cpan.orgE. =cut