package SQL::Translator::Schema::Field;
# ----------------------------------------------------------------------
-# $Id: Field.pm,v 1.3 2003-05-05 04:32:39 kycl4rk Exp $
+# $Id: Field.pm,v 1.12 2003-08-12 22:03:59 kycl4rk Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
#
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);
-$VERSION = 1.00;
+$VERSION = sprintf "%d.%02d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
# ----------------------------------------------------------------------
sub init {
my ( $self, $config ) = @_;
- for my $arg ( qw[ name data_type size is_primary_key nullable table ] ) {
+ 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 };
- $self->$arg( $config->{ $arg } ) or return;
+ defined $self->$arg( $config->{ $arg } ) or return;
}
+
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 {
=pod
}
# ----------------------------------------------------------------------
+sub extra {
+
+=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
+
+ 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
+
+=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
}
# ----------------------------------------------------------------------
+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 the 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 {
=pod
=head2 is_primary_key
-Get or set the field's C<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);
}
# ----------------------------------------------------------------------
+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
}
# ----------------------------------------------------------------------
-sub nullable {
+sub order {
=pod
-=head2 nullable
+=head2 order
-Get or set the 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:
+Get or set the field's order.
- $nullable = $field->nullable(0);
- $nullable = $field->nullable('');
- $nullable = $field->nullable('0');
+ my $order = $field->order(3);
=cut
my ( $self, $arg ) = @_;
- if ( defined $arg ) {
- $self->{'nullable'} = $arg ? 1 : 0;
+ if ( defined $arg && $arg =~ /^\d+$/ ) {
+ $self->{'order'} = $arg;
}
- return defined $self->{'nullable'} ? $self->{'nullable'} : 1;
+ return $self->{'order'} || 0;
}
# ----------------------------------------------------------------------
=cut
my $self = shift;
- my $numbers = UNIVERSAL::isa( $_[0], 'ARRAY' )
- ? shift : [ map { split /,/ } @_ ];
+ my $numbers = parse_list_arg( @_ );
if ( @$numbers ) {
my @new;
$self->{'size'} = \@new if @new; # only set if all OK
}
- return join( ',', @{ $self->{'size'} || [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;
+ return wantarray
+ ? @{ $self->{'size'} || [0] }
+ : join( ',', @{ $self->{'size'} || [0] } )
+ ;
}
# ----------------------------------------------------------------------
return $self->{'table'};
}
+# ----------------------------------------------------------------------
+sub DESTROY {
+#
+# Destroy cyclical references.
+#
+ my $self = shift;
+ undef $self->{'table'};
+ undef $self->{'foreign_key_reference'};
+}
+
1;
# ----------------------------------------------------------------------
projects / dbsrgits/SQL-Translator.git / blobdiff