X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FField.pm;h=b9aed47295a8d1937bd39c90aa3bb5bee9e42576;hb=cf915bd8314fb9cd781f1d65cb398cbb98b6ad3b;hp=b558381b7d14dc8449ee849b7656fcdb430a571e;hpb=aa3a9517cf9e63ebbed4e1e8c9f072fd92470dce;p=dbsrgits%2FSQL-Translator.git diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm index b558381..b9aed47 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.11 2003-06-27 16:47:40 kycl4rk Exp $ -# ---------------------------------------------------------------------- -# Copyright (C) 2003 Ken Y. Clark -# -# 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 @@ -30,8 +10,8 @@ SQL::Translator::Schema::Field - SQL::Translator field object use SQL::Translator::Schema::Field; my $field = SQL::Translator::Schema::Field->new( - name => 'foo', - sql => 'select * from foo', + name => 'foo', + table => $table, ); =head1 DESCRIPTION @@ -42,52 +22,71 @@ 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 base 'Class::Base'; -use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT); +extends 'SQL::Translator::Schema::Object'; -$VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/; +our $VERSION = '1.59'; -# ---------------------------------------------------------------------- -sub init { +# 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 +# still true when it doesn't have a name (which shouldn't happen!). +use overload + '""' => sub { shift->name }, + 'bool' => sub { $_[0]->name || $_[0] }, + fallback => 1, +; -=pod +use DBI qw(:sql_types); -=head2 new +# Mapping from string to sql constant +our %type_mapping = ( + integer => SQL_INTEGER, + int => SQL_INTEGER, -Object constructor. + tinyint => SQL_TINYINT, + smallint => SQL_SMALLINT, + bigint => SQL_BIGINT, - my $schema = SQL::Translator::Schema::Field->new; + double => SQL_DOUBLE, -=cut + decimal => SQL_DECIMAL, + numeric => SQL_NUMERIC, + dec => SQL_DECIMAL, - 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, - return $self; -} + char => SQL_CHAR, + varchar => SQL_VARCHAR, + binary => SQL_BINARY, + varbinary => SQL_VARBINARY, + tinyblob => SQL_BLOB, + blob => SQL_BLOB, + text => SQL_LONGVARCHAR -# ---------------------------------------------------------------------- -sub comments { +); -=pod +=head2 new + +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. @@ -98,28 +97,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 @@ -129,60 +126,32 @@ Get or set the field's data type. =cut - my $self = shift; - $self->{'data_type'} = shift if @_; - return $self->{'data_type'} || ''; -} - -# ---------------------------------------------------------------------- -sub default_value { - -=pod - -=head2 default_value +has data_type => ( is => 'rw', default => quote_sub(q{ '' }) ); -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'}; -} - -# ---------------------------------------------------------------------- -sub extra { +has sql_data_type => ( is => 'rw', lazy => 1, builder => 1 ); -=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 @@ -192,67 +161,58 @@ 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 Get or set the field's C attribute. - my $is_pk = $field->is_auto_increment(1); + my $is_auto = $field->is_auto_increment(1); =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. @@ -261,36 +221,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 the 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(''); @@ -303,19 +262,17 @@ foreign keys; checks) are represented as table constraints. =cut - my ( $self, $arg ) = @_; +has is_nullable => ( + is => 'rw', + coerce => quote_sub(q{ $_[0] ? 1 : 0 }), + default => quote_sub(q{ 1 }), + ); - if ( defined $arg ) { - $self->{'is_nullable'} = $arg ? 1 : 0; - } +around is_nullable => sub { + my ($orig, $self, $arg) = @_; - return defined $self->{'is_nullable'} ? $self->{'is_nullable'} : 1; -} - -# ---------------------------------------------------------------------- -sub is_primary_key { - -=pod + $self->$orig($self->is_primary_key ? 0 : defined $arg ? $arg : ()); +}; =head2 is_primary_key @@ -326,32 +283,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. @@ -360,26 +310,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 @@ -399,37 +349,48 @@ Determine whether the field is valid or not. return 1; } -# ---------------------------------------------------------------------- -sub name { - -=pod - =head2 name Get or set the field's name. - my $name = $field->name('foo'); + my $name = $field->name('foo'); + +The field object will also stringify to its name. + + my $setter_name = "set_$field"; + +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 ) { - if ( my $table = $self->table ) { - return $self->error( qq[Can't use field name "$arg": table exists] ) - if $table->get_field( $arg ); + if ( my ($arg) = @_ ) { + if ( my $schema = $self->table ) { + return $self->error( qq[Can't use field name "$arg": field exists] ) + if $schema->get_field( $arg ); } - - $self->{'name'} = $arg; } - return $self->{'name'} || ''; -} + return ex2err($orig, $self, @_); +}; -# ---------------------------------------------------------------------- -sub order { +sub full_name { -=pod +=head2 full_name + +Read only method to return the fields name with its table name pre-pended. +e.g. "person.foo". + +=cut + + my $self = shift; + return $self->table.".".$self->name; +} =head2 order @@ -439,19 +400,33 @@ 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 size { +sub schema { -=pod +=head2 schema + +Shortcut to get the fields schema ($field->table->schema) or undef if it +doesn't have one. + + my $schema = $field->schema; + +=cut + + my $self = shift; + if ( my $table = $self->table ) { return $table->schema || undef; } + return undef; +} =head2 size @@ -468,6 +443,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( @_ ); @@ -478,56 +464,107 @@ 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 -Get or set the field's table object. +Get or set the field's table object. As the table object stringifies this can +also be used to get the table name. my $table = $field->table; + print "Table name: $table"; + +=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->{'table'}; -} + return $self->$orig(@_) || $self; +}; + +=head2 equals + +Determines if this field is the same as another -# ---------------------------------------------------------------------- -sub DESTROY { -# -# Destroy cyclical references. -# + my $isIdentical = $field1->equals( $field2 ); + +=cut + +around equals => sub { + my $orig = shift; my $self = shift; - undef $self->{'table'}; - undef $self->{'foreign_key_reference'}; -} + my $other = shift; + my $case_insensitive = shift; -1; + 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 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; + + 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; + +1; =pod =head1 AUTHOR -Ken Y. Clark Ekclark@cpan.orgE +Ken Youens-Clark Ekclark@cpan.orgE. =cut