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=aa6ff1dba6d26aa1cfb5eeae2e67d10fd3a827c3;hpb=c1e3c768182d75d6b1f24aeba26964602994a01c;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm index aa6ff1d..a882632 100644 --- a/lib/SQL/Translator/Schema/Field.pm +++ b/lib/SQL/Translator/Schema/Field.pm @@ -1,25 +1,5 @@ package SQL::Translator::Schema::Field; -# ---------------------------------------------------------------------- -# $Id: Field.pm,v 1.18 2004-03-29 09:57:50 grommit Exp $ -# ---------------------------------------------------------------------- -# Copyright (C) 2002-4 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 @@ -42,15 +22,16 @@ C is the field object. =cut -use strict; -use Class::Base; +use Moo; use SQL::Translator::Schema::Constants; -use SQL::Translator::Utils 'parse_list_arg'; +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 base 'Class::Base'; -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); +extends 'SQL::Translator::Schema::Object'; -$VERSION = sprintf "%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/; +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,45 +42,66 @@ use overload fallback => 1, ; -# ---------------------------------------------------------------------- -sub init { +use DBI qw(:sql_types); -=pod +# Mapping from string to sql constant +our %type_mapping = ( + integer => SQL_INTEGER, + int => SQL_INTEGER, -=head2 new + tinyint => SQL_TINYINT, + smallint => SQL_SMALLINT, + bigint => SQL_BIGINT, -Object constructor. + double => SQL_DOUBLE, + 'double precision' => SQL_DOUBLE, - my $field = SQL::Translator::Schema::Field->new( - name => 'foo', - table => $table, - ); + decimal => SQL_DECIMAL, + dec => SQL_DECIMAL, + numeric => SQL_NUMERIC, -=cut + real => SQL_REAL, + float => SQL_FLOAT, - my ( $self, $config ) = @_; + bit => SQL_BIT, - for my $arg ( - qw[ - table name data_type size is_primary_key is_nullable - is_auto_increment default_value comments - ] - ) { - next unless defined $config->{ $arg }; - defined $self->$arg( $config->{ $arg } ) or return; - } + date => SQL_DATE, + datetime => SQL_DATETIME, + timestamp => SQL_TIMESTAMP, + time => SQL_TIME, + + char => SQL_CHAR, + varchar => SQL_VARCHAR, + binary => SQL_BINARY, + varbinary => SQL_VARBINARY, + tinyblob => SQL_BLOB, + blob => SQL_BLOB, + text => SQL_LONGVARCHAR + +); - return $self; +has _numeric_sql_data_types => ( is => 'lazy' ); + +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) + }; } -# ---------------------------------------------------------------------- -sub comments { +=head2 new -=pod +Object constructor. + + my $field = SQL::Translator::Schema::Field->new( + name => 'foo', + table => $table, + ); =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. @@ -110,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 ? () : ''; - } -} - - -# ---------------------------------------------------------------------- -sub data_type { + return wantarray + ? @{ $self->$orig } + : join( "\n", @{ $self->$orig } ); +}; -=pod =head2 data_type @@ -141,60 +141,32 @@ Get or set the field's data type. =cut - my $self = shift; - $self->{'data_type'} = shift if @_; - return $self->{'data_type'} || ''; -} +has data_type => ( is => 'rw', default => quote_sub(q{ '' }) ); -# ---------------------------------------------------------------------- -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 -assume an error like other methods. +=head2 sql_data_type - my $default = $field->default_value('foo'); +Constant from DBI package representing this data type. See L +for more details. =cut - my ( $self, $arg ) = @_; - $self->{'default_value'} = $arg if defined $arg; - return $self->{'default_value'}; -} +has sql_data_type => ( is => 'rw', lazy => 1, builder => 1 ); -# ---------------------------------------------------------------------- -sub extra { - -=pod +sub _build_sql_data_type { + $type_mapping{lc $_[0]->data_type} || SQL_UNKNOWN_TYPE; +} -=head2 extra +=head2 default_value -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. +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 +assume an error like other methods. - $field->extra( qualifier => 'ZEROFILL' ); - my %extra = $field->extra; + my $default = $field->default_value('foo'); =cut - my $self = shift; - my $args = ref $_[0] eq 'HASH' ? shift : { @_ }; - - while ( my ( $key, $value ) = each %$args ) { - $self->{'extra'}{ $key } = $value; - } - - return %{ $self->{'extra'} || {} }; -} - -# ---------------------------------------------------------------------- -sub foreign_key_reference { - -=pod +has default_value => ( is => 'rw' ); =head2 foreign_key_reference @@ -204,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 @@ -238,33 +205,29 @@ Get or set the field's C attribute. =cut - my ( $self, $arg ) = @_; - - if ( defined $arg ) { - $self->{'is_auto_increment'} = $arg ? 1 : 0; - } - - 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; - } +has is_auto_increment => ( + is => 'rw', + coerce => quote_sub(q{ $_[0] ? 1 : 0 }), + builder => 1, + lazy => 1, +); + +sub _build_is_auto_increment { + my ( $self ) = @_; + + 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. @@ -273,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(''); @@ -315,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 @@ -346,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. @@ -380,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 @@ -419,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. @@ -438,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 { @@ -466,11 +407,6 @@ e.g. "person.foo". return $self->table.".".$self->name; } -# ---------------------------------------------------------------------- -sub order { - -=pod - =head2 order Get or set the field's order. @@ -479,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. @@ -505,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 @@ -525,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( @_ ); @@ -535,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 @@ -559,34 +498,100 @@ also be used to get the table name. =cut +has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 ); + +around table => \&ex2err; + +=head2 parsed_field + +Returns the field exactly as the parser found it + +=cut + +has parsed_field => ( is => 'rw' ); + +around parsed_field => sub { + my $orig = shift; 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->$orig(@_) || $self; +}; + +=head2 equals + +Determines if this field is the same as another + + my $isIdentical = $field1->equals( $field2 ); + +=cut + +around equals => sub { + my $orig = shift; + my $self = shift; + my $other = shift; + my $case_insensitive = shift; + + 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 + if ($self->sql_data_type && $other->sql_data_type) { + return 0 unless $self->sql_data_type == $other->sql_data_type + } else { + return 0 unless lc($self->data_type) eq lc($other->data_type) } - return $self->{'table'}; -} + return 0 unless $self->size eq $other->size; + + { + my $lhs = $self->default_value; + $lhs = \'NULL' unless defined $lhs; + my $lhs_is_ref = ! ! ref $lhs; + + my $rhs = $other->default_value; + $rhs = \'NULL' unless defined $rhs; + my $rhs_is_ref = ! ! ref $rhs; + + # If only one is a ref, fail. -- rjbs, 2008-12-02 + return 0 if $lhs_is_ref xor $rhs_is_ref; + + my $effective_lhs = $lhs_is_ref ? $$lhs : $lhs; + my $effective_rhs = $rhs_is_ref ? $$rhs : $rhs; -# ---------------------------------------------------------------------- -sub DESTROY { -# -# Destroy cyclical references. -# + 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; +# return 0 unless $self->is_unique eq $other->is_unique; + return 0 unless $self->is_primary_key eq $other->is_primary_key; +# return 0 unless $self->is_foreign_key eq $other->is_foreign_key; + return 0 unless $self->is_auto_increment eq $other->is_auto_increment; +# 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 _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