package SQL::Translator::Schema::Field;
-# ----------------------------------------------------------------------
-# $Id: Field.pm,v 1.27 2007-10-24 10:55:44 schiffbruechige 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
=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 vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
+extends 'SQL::Translator::Schema::Object';
-$VERSION = sprintf "%d.%02d", q$Revision: 1.27 $ =~ /(\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
fallback => 1,
;
-# ----------------------------------------------------------------------
+use DBI qw(:sql_types);
-__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
-/);
+# Mapping from string to sql constant
+our %type_mapping = (
+ integer => SQL_INTEGER,
+ int => SQL_INTEGER,
-=pod
+ tinyint => SQL_TINYINT,
+ smallint => SQL_SMALLINT,
+ bigint => SQL_BIGINT,
+
+ double => SQL_DOUBLE,
+
+ decimal => SQL_DECIMAL,
+ numeric => SQL_NUMERIC,
+ dec => SQL_DECIMAL,
+
+ bit => SQL_BIT,
+
+ 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
+
+);
=head2 new
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.
=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
=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 {
+=head2 sql_data_type
-=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.
-
- my $default = $field->default_value('foo');
+Constant from DBI package representing this data type. See L<DBI/DBI Constants>
+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 );
-# ----------------------------------------------------------------------
-=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
-
-# ----------------------------------------------------------------------
-sub foreign_key_reference {
-
-=pod
+has default_value => ( is => 'rw' );
=head2 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
=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.
=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('');
=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
=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.
=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
return 1;
}
-# ----------------------------------------------------------------------
-sub name {
-
-=pod
-
=head2 name
Get or set the field's 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 {
return $self->table.".".$self->name;
}
-# ----------------------------------------------------------------------
-sub order {
-
-=pod
-
=head2 order
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.
return undef;
}
-# ----------------------------------------------------------------------
-sub size {
-
-=pod
-
=head2 size
Get or set the field's size. Accepts a string, array or arrayref of
=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( @_ );
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
=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
=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;
- return 0 unless lc($self->data_type) eq lc($other->data_type);
+
+ # 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;
- return 0 unless (!defined $self->default_value || $self->default_value eq 'NULL') eq (!defined $other->default_value || $other->default_value eq 'NULL');
- return 0 if defined $self->default_value && $self->default_value ne $other->default_value;
+
+ {
+ 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->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;
-# ----------------------------------------------------------------------
-
=pod
=head1 AUTHOR
-Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
+Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
=cut
projects / dbsrgits/SQL-Translator.git / blobdiff