=cut
-use strict;
+use Moo;
use SQL::Translator::Schema::Constants;
-use SQL::Translator::Utils 'parse_list_arg';
+use SQL::Translator::Utils qw(ex2err throw);
+use SQL::Translator::Role::ListAttr;
+use SQL::Translator::Types qw(schema_obj enum);
+use Sub::Quote qw(quote_sub);
-use base 'SQL::Translator::Schema::Object';
+extends 'SQL::Translator::Schema::Object';
-use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
-
-$VERSION = '1.59';
+our $VERSION = '1.59';
my %VALID_CONSTRAINT_TYPE = (
PRIMARY_KEY, 1,
NOT_NULL, 1,
);
-# ----------------------------------------------------------------------
-
-__PACKAGE__->_attributes( qw/
- table name type fields reference_fields reference_table
- match_type on_delete on_update expression deferrable
-/);
-
-# Override to remove empty arrays from args.
-# t/14postgres-parser breaks without this.
-sub init {
-
-=pod
-
=head2 new
Object constructor.
=cut
+# Override to remove empty arrays from args.
+# t/14postgres-parser breaks without this.
+around BUILDARGS => sub {
+ my $orig = shift;
my $self = shift;
- foreach ( values %{$_[0]} ) { $_ = undef if ref($_) eq "ARRAY" && ! @$_; }
- $self->SUPER::init(@_);
-}
-
-# ----------------------------------------------------------------------
-sub deferrable {
+ my $args = $self->$orig(@_);
-=pod
+ foreach my $arg (keys %{$args}) {
+ delete $args->{$arg} if ref($args->{$arg}) eq "ARRAY" && !@{$args->{$arg}};
+ }
+ if (exists $args->{fields}) {
+ $args->{field_names} = delete $args->{fields};
+ }
+ return $args;
+};
=head2 deferrable
Get or set whether the constraint is deferrable. If not defined,
then returns "1." The argument is evaluated by Perl for True or
-False, so the following are eqivalent:
+False, so the following are equivalent:
$deferrable = $field->deferrable(0);
$deferrable = $field->deferrable('');
=cut
- my ( $self, $arg ) = @_;
-
- if ( defined $arg ) {
- $self->{'deferrable'} = $arg ? 1 : 0;
- }
-
- return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
-}
-
-# ----------------------------------------------------------------------
-sub expression {
-
-=pod
+has deferrable => (
+ is => 'rw',
+ coerce => quote_sub(q{ $_[0] ? 1 : 0 }),
+ default => quote_sub(q{ 1 }),
+);
=head2 expression
=cut
- my $self = shift;
-
- if ( my $arg = shift ) {
- # check arg here?
- $self->{'expression'} = $arg;
- }
+has expression => ( is => 'rw', default => quote_sub(q{ '' }) );
- return $self->{'expression'} || '';
-}
+around expression => sub {
+ my ($orig, $self, $arg) = @_;
+ $self->$orig($arg || ());
+};
-# ----------------------------------------------------------------------
sub is_valid {
=pod
return $self->error('Only one field allowed for foreign key')
if scalar @fields > 1;
- my $ref_table_name = $self->reference_table or
+ my $ref_table_name = $self->reference_table or
return $self->error('No reference table');
my $ref_table = $schema->get_table( $ref_table_name ) or
for my $ref_field ( @ref_fields ) {
next if $ref_table->get_field( $ref_field );
return $self->error(
- "Constraint from field(s) ",
- join(', ', map {qq['$table_name.$_']} @fields),
+ "Constraint from field(s) ".
+ join(', ', map {qq['$table_name.$_']} @fields).
" to non-existent field '$ref_table_name.$ref_field'"
);
}
}
elsif ( $type eq CHECK_C ) {
- return $self->error('No expression for CHECK') unless
+ return $self->error('No expression for CHECK') unless
$self->expression;
}
return 1;
}
-# ----------------------------------------------------------------------
-sub fields {
-
-=pod
-
=head2 fields
Gets and set the fields the constraint is on. Accepts a string, list or
The fields are returned as Field objects if they exist or as plain
names if not. (If you just want the names and want to avoid the Field's overload
-magic use L<field_names>).
+magic use L</field_names>).
Returns undef or an empty list if the constraint has no fields set.
=cut
- my $self = shift;
- my $fields = parse_list_arg( @_ );
-
- if ( @$fields ) {
- my ( %unique, @unique );
- for my $f ( @$fields ) {
- next if $unique{ $f };
- $unique{ $f } = 1;
- push @unique, $f;
- }
-
- $self->{'fields'} = \@unique;
- }
-
- if ( @{ $self->{'fields'} || [] } ) {
- # We have to return fields that don't exist on the table as names in
- # case those fields havn't been created yet.
- my @ret = map {
- $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
- return wantarray ? @ret : \@ret;
- }
- else {
- return wantarray ? () : undef;
- }
+sub fields {
+ my $self = shift;
+ my $table = $self->table;
+ my @fields = map { $table->get_field($_) || $_ } @{$self->field_names(@_) || []};
+ return wantarray ? @fields
+ : @fields ? \@fields
+ : undef;
}
-# ----------------------------------------------------------------------
-sub field_names {
-
=head2 field_names
Read-only method to return a list or array ref of the field names. Returns undef
=cut
- my $self = shift;
- return wantarray ? @{ $self->{'fields'} || [] } : ($self->{'fields'} || '');
-}
-
-# ----------------------------------------------------------------------
-sub match_type {
-
-=pod
+with ListAttr field_names => ( uniq => 1, undef_if_empty => 1 );
=head2 match_type
=cut
- my ( $self, $arg ) = @_;
-
- if ( $arg ) {
- $arg = lc $arg;
- return $self->error("Invalid match type: $arg")
- unless $arg eq 'full' || $arg eq 'partial' || $arg eq 'simple';
- $self->{'match_type'} = $arg;
- }
-
- return $self->{'match_type'} || '';
-}
+has match_type => (
+ is => 'rw',
+ default => quote_sub(q{ '' }),
+ coerce => quote_sub(q{ lc $_[0] }),
+ isa => enum([qw(full partial simple)], {
+ msg => "Invalid match type: %s", allow_false => 1,
+ }),
+);
-# ----------------------------------------------------------------------
-sub name {
-
-=pod
+around match_type => \&ex2err;
=head2 name
=cut
- my $self = shift;
- my $arg = shift || '';
- $self->{'name'} = $arg if $arg;
- return $self->{'name'} || '';
-}
-
-# ----------------------------------------------------------------------
-sub options {
+has name => ( is => 'rw', default => quote_sub(q{ '' }) );
-=pod
+around name => sub {
+ my ($orig, $self, $arg) = @_;
+ $self->$orig($arg || ());
+};
=head2 options
-Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
+Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
Returns an array or array reference.
$constraint->options('NORELY');
=cut
- my $self = shift;
- my $options = parse_list_arg( @_ );
-
- push @{ $self->{'options'} }, @$options;
-
- if ( ref $self->{'options'} ) {
- return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
- }
- else {
- return wantarray ? () : [];
- }
-}
-
-
-# ----------------------------------------------------------------------
-sub on_delete {
-
-=pod
+with ListAttr options => ();
=head2 on_delete
=cut
- my $self = shift;
-
- if ( my $arg = shift ) {
- # validate $arg?
- $self->{'on_delete'} = $arg;
- }
+has on_delete => ( is => 'rw', default => quote_sub(q{ '' }) );
- return $self->{'on_delete'} || '';
-}
-
-# ----------------------------------------------------------------------
-sub on_update {
-
-=pod
+around on_delete => sub {
+ my ($orig, $self, $arg) = @_;
+ $self->$orig($arg || ());
+};
=head2 on_update
=cut
- my $self = shift;
-
- if ( my $arg = shift ) {
- # validate $arg?
- $self->{'on_update'} = $arg;
- }
-
- return $self->{'on_update'} || '';
-}
+has on_update => ( is => 'rw', default => quote_sub(q{ '' }) );
-# ----------------------------------------------------------------------
-sub reference_fields {
-
-=pod
+around on_update => sub {
+ my ($orig, $self, $arg) = @_;
+ $self->$orig($arg || ());
+};
=head2 reference_fields
=cut
- my $self = shift;
- my $fields = parse_list_arg( @_ );
+with ListAttr reference_fields => (
+ may_throw => 1,
+ builder => 1,
+ lazy => 1,
+);
+
+sub _build_reference_fields {
+ my ($self) = @_;
- if ( @$fields ) {
- $self->{'reference_fields'} = $fields;
- }
+ my $table = $self->table or throw('No table');
+ my $schema = $table->schema or throw('No schema');
+ if ( my $ref_table_name = $self->reference_table ) {
+ my $ref_table = $schema->get_table( $ref_table_name ) or
+ throw("Can't find table '$ref_table_name'");
- # Nothing set so try and derive it from the other constraint data
- unless ( ref $self->{'reference_fields'} ) {
- my $table = $self->table or return $self->error('No table');
- my $schema = $table->schema or return $self->error('No schema');
- if ( my $ref_table_name = $self->reference_table ) {
- my $ref_table = $schema->get_table( $ref_table_name ) or
- return $self->error("Can't find table '$ref_table_name'");
-
- if ( my $constraint = $ref_table->primary_key ) {
- $self->{'reference_fields'} = [ $constraint->fields ];
- }
- else {
- $self->error(
- 'No reference fields defined and cannot find primary key in ',
- "reference table '$ref_table_name'"
- );
- }
+ if ( my $constraint = $ref_table->primary_key ) {
+ return [ $constraint->fields ];
+ }
+ else {
+ throw(
+ 'No reference fields defined and cannot find primary key in ',
+ "reference table '$ref_table_name'"
+ );
}
- # No ref table so we are not that sort of constraint, hence no ref
- # fields. So we let the return below return an empty list.
- }
-
- if ( ref $self->{'reference_fields'} ) {
- return wantarray
- ? @{ $self->{'reference_fields'} }
- : $self->{'reference_fields'};
- }
- else {
- return wantarray ? () : [];
}
}
-# ----------------------------------------------------------------------
-sub reference_table {
-
-=pod
-
=head2 reference_table
Get or set the table referred to by the constraint.
=cut
- my $self = shift;
- $self->{'reference_table'} = shift if @_;
- return $self->{'reference_table'} || '';
-}
-
-# ----------------------------------------------------------------------
-sub table {
-
-=pod
+has reference_table => ( is => 'rw', default => quote_sub(q{ '' }) );
=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;
- }
+has table => ( is => 'rw', isa => schema_obj('Table'), weak_ref => 1 );
- return $self->{'table'};
-}
-
-# ----------------------------------------------------------------------
-sub type {
-
-=pod
+around table => \&ex2err;
=head2 type
=cut
- my ( $self, $type ) = @_;
-
- if ( $type ) {
- $type = uc $type;
- $type =~ s/_/ /g;
- return $self->error("Invalid constraint type: $type")
- unless $VALID_CONSTRAINT_TYPE{ $type };
- $self->{'type'} = $type;
- }
-
- return $self->{'type'} || '';
-}
-
-# ----------------------------------------------------------------------
-sub equals {
+has type => (
+ is => 'rw',
+ default => quote_sub(q{ '' }),
+ coerce => quote_sub(q{ (my $t = $_[0]) =~ s/_/ /g; uc $t }),
+ isa => enum([keys %VALID_CONSTRAINT_TYPE], {
+ msg => "Invalid constraint type: %s", allow_false => 1,
+ }),
+);
-=pod
+around type => \&ex2err;
=head2 equals
=cut
+around equals => sub {
+ my $orig = shift;
my $self = shift;
my $other = shift;
my $case_insensitive = shift;
my $ignore_constraint_names = shift;
-
- return 0 unless $self->SUPER::equals($other);
+
+ return 0 unless $self->$orig($other);
return 0 unless $self->type eq $other->type;
unless ($ignore_constraint_names) {
return 0 unless $case_insensitive ? uc($self->name) eq uc($other->name) : $self->name eq $other->name;
return 0 unless $self->deferrable eq $other->deferrable;
#return 0 unless $self->is_valid eq $other->is_valid;
return 0 unless $case_insensitive ? uc($self->table->name) eq uc($other->table->name)
- : $self->table->name eq $other->table->name;
+ : $self->table->name eq $other->table->name;
return 0 unless $self->expression eq $other->expression;
-
+
# Check fields, regardless of order
- my %otherFields = (); # create a hash of the other fields
+ my %otherFields = (); # create a hash of the other fields
foreach my $otherField ($other->fields) {
- $otherField = uc($otherField) if $case_insensitive;
- $otherFields{$otherField} = 1;
+ $otherField = uc($otherField) if $case_insensitive;
+ $otherFields{$otherField} = 1;
}
foreach my $selfField ($self->fields) { # check for self fields in hash
- $selfField = uc($selfField) if $case_insensitive;
- return 0 unless $otherFields{$selfField};
- delete $otherFields{$selfField};
+ $selfField = uc($selfField) if $case_insensitive;
+ return 0 unless $otherFields{$selfField};
+ delete $otherFields{$selfField};
}
# Check all other fields were accounted for
return 0 unless keys %otherFields == 0;
# Check reference fields, regardless of order
- my %otherRefFields = (); # create a hash of the other reference fields
+ my %otherRefFields = (); # create a hash of the other reference fields
foreach my $otherRefField ($other->reference_fields) {
- $otherRefField = uc($otherRefField) if $case_insensitive;
- $otherRefFields{$otherRefField} = 1;
+ $otherRefField = uc($otherRefField) if $case_insensitive;
+ $otherRefFields{$otherRefField} = 1;
}
foreach my $selfRefField ($self->reference_fields) { # check for self reference fields in hash
- $selfRefField = uc($selfRefField) if $case_insensitive;
- return 0 unless $otherRefFields{$selfRefField};
- delete $otherRefFields{$selfRefField};
+ $selfRefField = uc($selfRefField) if $case_insensitive;
+ return 0 unless $otherRefFields{$selfRefField};
+ delete $otherRefFields{$selfRefField};
}
# Check all other reference fields were accounted for
return 0 unless keys %otherRefFields == 0;
return 0 unless $self->_compare_objects(scalar $self->options, scalar $other->options);
return 0 unless $self->_compare_objects(scalar $self->extra, scalar $other->extra);
return 1;
-}
+};
-# ----------------------------------------------------------------------
-sub DESTROY {
- my $self = shift;
- undef $self->{'table'}; # destroy cyclical reference
-}
+# Must come after all 'has' declarations
+around new => \&ex2err;
1;
-# ----------------------------------------------------------------------
-
=pod
=head1 AUTHOR
projects / dbsrgits/SQL-Translator.git / blobdiff