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
=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 = '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
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
-/);
-
-=pod
=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 ? () : '';
- }
-}
+ return wantarray
+ ? @{ $self->$orig }
+ : join( "\n", @{ $self->$orig } );
+};
-# ----------------------------------------------------------------------
-sub data_type {
-
-=pod
-
=head2 data_type
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
=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 = shift;
- $self->{'default_value'} = shift if @_;
- return $self->{'default_value'};
-}
-
-# ----------------------------------------------------------------------
-=pod
+has default_value => ( is => 'rw' );
=head2 extra
=cut
-
-# ----------------------------------------------------------------------
-sub foreign_key_reference {
-
-=pod
-
=head2 foreign_key_reference
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
=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.
=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:
=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;
- }
-
- if (
- defined $self->{'is_nullable'} &&
- $self->{'is_nullable'} == 1 &&
- $self->is_primary_key
- ) {
- $self->{'is_nullable'} = 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
=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
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;
# Comparing types: use sql_data_type if both are not 0. Else use string data_type
# 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
projects / dbsrgits/SQL-Translator.git / blobdiff