X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FTranslator%2FSchema%2FField.pm;h=f6ce2a63f8bb5417fb5c53abde28a013c75e8f38;hb=325e5e7b5b1e8daf807b7caba035f21d2ab49bc7;hp=24b1383313aebedbf28ec2b8e459ae921686e979;hpb=0c04c5a2210135419771878dc7e341a1cba52cca;p=dbsrgits%2FSQL-Translator.git

diff --git a/lib/SQL/Translator/Schema/Field.pm b/lib/SQL/Translator/Schema/Field.pm
index 24b1383..f6ce2a6 100644
--- a/lib/SQL/Translator/Schema/Field.pm
+++ b/lib/SQL/Translator/Schema/Field.pm
@@ -22,14 +22,13 @@ C<SQL::Translator::Schema::Field> is the field object.
 
 =cut
 
-use strict;
-use warnings;
+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 'SQL::Translator::Schema::Object';
-
-our ( $TABLE_COUNT, $VIEW_COUNT );
+extends 'SQL::Translator::Schema::Object';
 
 our $VERSION = '1.59';
 
@@ -44,13 +43,13 @@ use overload
 
 use DBI qw(:sql_types);
 
-# Mapping from string to sql contstant
+# Mapping from string to sql constant
 our %type_mapping = (
   integer => SQL_INTEGER,
   int     => SQL_INTEGER,
 
   smallint => SQL_SMALLINT,
-  bigint => 9999, # DBI doesn't export a constatn for this. Le suck
+  bigint => 9999, # DBI doesn't export a constant for this. Le suck
 
   double => SQL_DOUBLE,
 
@@ -75,14 +74,6 @@ our %type_mapping = (
 
 );
 
-__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
 
 Object constructor.
@@ -92,12 +83,6 @@ Object constructor.
       table => $table,
   );
 
-=cut
-
-sub comments {
-
-=pod
-
 =head2 comments
 
 Get or set the comments on a field.  May be called several times to
@@ -111,27 +96,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 ? () : '';
-    }
-}
-
-
-sub data_type {
+    return wantarray
+        ? @{ $self->$orig }
+        : join( "\n", @{ $self->$orig } );
+};
 
-=pod
 
 =head2 data_type
 
@@ -141,15 +125,7 @@ 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
 
@@ -158,16 +134,12 @@ for more details.
 
 =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
@@ -178,26 +150,7 @@ assume an error like other methods.
 
 =cut
 
-    my $self = shift;
-    $self->{'default_value'} = shift if @_;
-    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
+has default_value => ( is => 'rw' );
 
 =head2 foreign_key_reference
 
@@ -207,30 +160,26 @@ 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
 
@@ -240,32 +189,29 @@ Get or set the field's C<is_auto_increment> attribute.
 
 =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.
@@ -274,35 +220,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 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('');
@@ -315,26 +261,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;
-    }
-
-    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
 
@@ -345,31 +282,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.
@@ -378,23 +309,24 @@ Determine whether the field has a UNIQUE constraint or not.
 
 =cut
 
-    my $self = shift;
+has is_unique => ( is => 'lazy', init_arg => undef );
+
+around is_unique => carp_ro('is_unique');
+
+sub _build_is_unique {
+    my ( $self ) = @_;
 
-    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;
-                    }
+    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 {
@@ -416,10 +348,6 @@ Determine whether the field is valid or not.
     return 1;
 }
 
-sub name {
-
-=pod
-
 =head2 name
 
 Get or set the field's name.
@@ -434,20 +362,21 @@ 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 || 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 {
 
@@ -462,10 +391,6 @@ e.g. "person.foo".
     return $self->table.".".$self->name;
 }
 
-sub order {
-
-=pod
-
 =head2 order
 
 Get or set the field's order.
@@ -474,14 +399,17 @@ 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 {
 
@@ -499,10 +427,6 @@ 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
@@ -518,6 +442,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( @_ );
 
@@ -528,18 +463,14 @@ 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] } )
+        ? @{ $self->$orig || [0] }
+        : join( ',', @{ $self->$orig || [0] } )
     ;
-}
-
-sub table {
-
-=pod
+};
 
 =head2 table
 
@@ -551,37 +482,24 @@ also be used to get the table name.
 
 =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;
-    }
+has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
 
-    return $self->{'table'};
-}
+around table => \&ex2err;
 
-sub parsed_field {
-
-=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
 
@@ -591,11 +509,13 @@ Determines if this field is the same as another
 
 =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
@@ -633,16 +553,10 @@ Determines if this field is the same as another
 #    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;