package SQL::Translator::Schema::Field;
# ----------------------------------------------------------------------
-# $Id: Field.pm,v 1.2 2003-05-03 15:42:59 kycl4rk Exp $
+# $Id$
# ----------------------------------------------------------------------
-# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
+# 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
use SQL::Translator::Schema::Field;
my $field = SQL::Translator::Schema::Field->new(
- name => 'foo',
- sql => 'select * from foo',
+ name => 'foo',
+ table => $table,
);
=head1 DESCRIPTION
=cut
use strict;
-use Class::Base;
+use SQL::Translator::Schema::Constants;
+use SQL::Translator::Utils 'parse_list_arg';
-use base 'Class::Base';
-use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
+use base 'SQL::Translator::Schema::Object';
-$VERSION = 1.00;
+use vars qw($TABLE_COUNT $VIEW_COUNT);
+# 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,
+;
+
+use DBI qw(:sql_types);
+
+# Mapping from string to sql contstant
+our %type_mapping = (
+ integer => SQL_INTEGER,
+ int => SQL_INTEGER,
+
+ smallint => SQL_SMALLINT,
+ bigint => 9999, # DBI doesn't export a constatn for this. Le suck
+
+ 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
+
+);
# ----------------------------------------------------------------------
-sub init {
+
+__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
Object constructor.
- my $schema = SQL::Translator::Schema::Field->new;
+ my $field = SQL::Translator::Schema::Field->new(
+ name => 'foo',
+ table => $table,
+ );
=cut
- my ( $self, $config ) = @_;
- $self->params( $config, qw[ name data_type size is_primary_key ] );
- return $self;
+# ----------------------------------------------------------------------
+sub comments {
+
+=pod
+
+=head2 comments
+
+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.
+
+ $field->comments('foo');
+ $field->comments('bar');
+ print join( ', ', $field->comments ); # prints "foo, bar"
+
+=cut
+
+ my $self = shift;
+
+ for my $arg ( @_ ) {
+ $arg = $arg->[0] if ref $arg;
+ push @{ $self->{'comments'} }, $arg if $arg;
+ }
+
+ if ( @{ $self->{'comments'} || [] } ) {
+ return wantarray
+ ? @{ $self->{'comments'} || [] }
+ : join( "\n", @{ $self->{'comments'} || [] } );
+ }
+ else {
+ return wantarray ? () : '';
+ }
}
+
# ----------------------------------------------------------------------
sub data_type {
=head2 data_type
-Get or set the field's data_type.
+Get or set the field's data type.
my $data_type = $field->data_type('integer');
=cut
my $self = shift;
- $self->{'data_type'} = shift if @_;
+ 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 {
+
+=head2 sql_data_type
+
+Constant from DBI package representing this data type. See L<DBI/DBI Constants>
+for more details.
+
+=cut
+
+ my $self = shift;
+ $self->{sql_data_type} = shift if @_;
+ return $self->{sql_data_type} || 0;
+
+}
+
+# ----------------------------------------------------------------------
+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.
+
+ 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
+
+=head2 foreign_key_reference
+
+Get or set the field's foreign key reference;
+
+ my $constraint = $field->foreign_key_reference( $constraint );
+
+=cut
+
+ 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'};
+
+ $self->{'foreign_key_reference'} = $arg;
+ }
+ else {
+ return $self->error(
+ "Argument to foreign_key_reference is not an $class object"
+ );
+ }
+ }
+
+ return $self->{'foreign_key_reference'};
+}
+
+# ----------------------------------------------------------------------
+sub is_auto_increment {
+
+=pod
+
+=head2 is_auto_increment
+
+Get or set the field's C<is_auto_increment> attribute.
+
+ 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;
+ }
+ }
+ }
+ }
+
+ return $self->{'is_auto_increment'} || 0;
+}
+
+# ----------------------------------------------------------------------
+sub is_foreign_key {
+
+=pod
+
+=head2 is_foreign_key
+
+Returns whether or not the field is a foreign key.
+
+ my $is_fk = $field->is_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;
+ }
+ }
+ }
+ }
+ }
+
+ return $self->{'is_foreign_key'} || 0;
+}
+
+# ----------------------------------------------------------------------
+sub is_nullable {
+
+=pod
+
+=head2 is_nullable
+
+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:
+
+ $is_nullable = $field->is_nullable(0);
+ $is_nullable = $field->is_nullable('');
+ $is_nullable = $field->is_nullable('0');
+
+While this is technically a field constraint, it's probably easier to
+represent this as an attribute of the field. In order keep things
+consistent, any other constraint on the field (unique, primary, and
+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;
+}
+
# ----------------------------------------------------------------------
sub is_primary_key {
=head2 is_primary_key
-Get or set the field's is_primary_key attribute.
+Get or set the field's C<is_primary_key> attribute. Does not create
+a table constraint (should it?).
my $is_pk = $field->is_primary_key(1);
$self->{'is_primary_key'} = $arg ? 1 : 0;
}
+ 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;
+ }
+ }
+ }
+
return $self->{'is_primary_key'} || 0;
}
# ----------------------------------------------------------------------
+sub is_unique {
+
+=pod
+
+=head2 is_unique
+
+Determine whether the field has a UNIQUE constraint or not.
+
+ my $is_unique = $field->is_unique;
+
+=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;
+ }
+ }
+ }
+ }
+ }
+
+ return $self->{'is_unique'} || 0;
+}
+
+# ----------------------------------------------------------------------
+sub is_valid {
+
+=pod
+
+=head2 is_valid
+
+Determine whether the field is valid or not.
+
+ my $ok = $field->is_valid;
+
+=cut
+
+ my $self = shift;
+ return $self->error('No name') unless $self->name;
+ return $self->error('No data type') unless $self->data_type;
+ return $self->error('No table object') unless $self->table;
+ return 1;
+}
+
+# ----------------------------------------------------------------------
sub name {
=pod
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
my $self = shift;
- $self->{'name'} = shift if @_;
+
+ if ( @_ ) {
+ my $arg = shift || return $self->error( "No field name" );
+ if ( my $table = $self->table ) {
+ return $self->error( qq[Can't use field name "$arg": field exists] )
+ if $table->get_field( $arg );
+ }
+
+ $self->{'name'} = $arg;
+ }
+
return $self->{'name'} || '';
}
+sub full_name {
+
+=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;
+}
+
+# ----------------------------------------------------------------------
+sub order {
+
+=pod
+
+=head2 order
+
+Get or set the field's order.
+
+ my $order = $field->order(3);
+
+=cut
+
+ my ( $self, $arg ) = @_;
+
+ if ( defined $arg && $arg =~ /^\d+$/ ) {
+ $self->{'order'} = $arg;
+ }
+
+ return $self->{'order'} || 0;
+}
+
+# ----------------------------------------------------------------------
+sub schema {
+
+=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;
+}
+
# ----------------------------------------------------------------------
sub size {
=head2 size
-Get or set the field's size.
+Get or set the field's size. Accepts a string, array or arrayref of
+numbers and returns a string.
+
+ $field->size( 30 );
+ $field->size( [ 255 ] );
+ $size = $field->size( 10, 2 );
+ print $size; # prints "10,2"
- my $size = $field->size('25');
+ $size = $field->size( '10, 2' );
+ print $size; # prints "10,2"
=cut
- my ( $self, $arg ) = @_;
+ my $self = shift;
+ my $numbers = parse_list_arg( @_ );
+
+ if ( @$numbers ) {
+ my @new;
+ for my $num ( @$numbers ) {
+ if ( defined $num && $num =~ m/^\d+(?:\.\d+)?$/ ) {
+ push @new, $num;
+ }
+ }
+ $self->{'size'} = \@new if @new; # only set if all OK
+ }
+
+ return wantarray
+ ? @{ $self->{'size'} || [0] }
+ : join( ',', @{ $self->{'size'} || [0] } )
+ ;
+}
+
+# ----------------------------------------------------------------------
+sub table {
+
+=pod
+
+=head2 table
+
+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
- if ( $arg && $arg =~ m/^\d+(?:\.\d+)?$/ ) {
- $self->{'size'} = $arg;
+ 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->{'size'} || 0;
+ return $self->{'table'};
+}
+
+sub parsed_field {
+
+=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;
}
# ----------------------------------------------------------------------
-sub is_valid {
+sub equals {
=pod
-=head2 is_valid
+=head2 equals
-Determine whether the field is valid or not.
+Determines if this field is the same as another
- my $ok = $field->is_valid;
+ my $isIdentical = $field1->equals( $field2 );
=cut
my $self = shift;
- return 1 if $self->name && $self->data_type;
+ my $other = shift;
+ my $case_insensitive = shift;
+
+ return 0 unless $self->SUPER::equals($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;
+}
+
+# ----------------------------------------------------------------------
+sub DESTROY {
+#
+# Destroy cyclical references.
+#
+ my $self = shift;
+ undef $self->{'table'};
+ undef $self->{'foreign_key_reference'};
}
1;
=head1 AUTHOR
-Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
+Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
=cut
projects / dbsrgits/SQL-Translator.git / blobdiff