view release on metacpan or  search on metacpan

lib/SQL/Translator/Schema/Constraint.pm  view on Meta::CPAN

package SQL::Translator::Schema::Constraint;

=pod

=head1 NAME

SQL::Translator::Schema::Constraint - SQL::Translator constraint object

=head1 SYNOPSIS

  use SQL::Translator::Schema::Constraint;
  my $constraint = SQL::Translator::Schema::Constraint->new(
      name   => 'foo',
      fields => [ id ],
      type   => PRIMARY_KEY,
  );

=head1 DESCRIPTION

C<SQL::Translator::Schema::Constraint> is the constraint object.

=head1 METHODS

=cut

use Moo;
use SQL::Translator::Schema::Constants;
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);

extends 'SQL::Translator::Schema::Object';

our $VERSION = '1.66';

my %VALID_CONSTRAINT_TYPE = (PRIMARY_KEY, 1, UNIQUE, 1, CHECK_C, 1, FOREIGN_KEY, 1, NOT_NULL, 1, EXCLUDE, 1,);

=head2 new

Object constructor.

  my $schema           =  SQL::Translator::Schema::Constraint->new(
      table            => $table,        # table to which it belongs
      type             => 'foreign_key', # type of table constraint
      name             => 'fk_phone_id', # name of the constraint
      fields           => 'phone_id',    # field in the referring table
      reference_fields => 'phone_id',    # referenced field
      reference_table  => 'phone',       # referenced table
      match_type       => 'full',        # how to match
      on_delete        => 'cascade',     # what to do on deletes
      on_update        => '',            # what to do on updates
  );

=cut

# Override to remove empty arrays from args.
# t/14postgres-parser breaks without this.
around BUILDARGS => sub {
  my $orig = shift;
  my $self = shift;
  my $args = $self->$orig(@_);

  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 equivalent:

  $deferrable = $field->deferrable(0);
  $deferrable = $field->deferrable('');
  $deferrable = $field->deferrable('0');

=cut

has deferrable => (
  is      => 'rw',
  coerce  => quote_sub(q{ $_[0] ? 1 : 0 }),
  default => quote_sub(q{ 1 }),
);

=head2 expression

Gets and set the expression used in a CHECK constraint.

  my $expression = $constraint->expression('...');

=cut

has expression => (is => 'rw', default => quote_sub(q{ '' }));

around expression => sub {
  my ($orig, $self, $arg) = @_;
  $self->$orig($arg || ());
};

sub is_valid {

=pod

=head2 is_valid

lib/SQL/Translator/Schema/Constraint.pm  view on Meta::CPAN

=cut

with ListAttr field_names => (uniq => 1, undef_if_empty => 1);

=head2 match_type

Get or set the constraint's match_type.  Only valid values are "full"
"partial" and "simple"

  my $match_type = $constraint->match_type('FULL');

=cut

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,
    }
  ),
);

around match_type => \&ex2err;

=head2 name

Get or set the constraint's name.

  my $name = $constraint->name('foo');

=cut

has name => (is => 'rw', default => quote_sub(q{ '' }));

around name => sub {
  my ($orig, $self, $arg) = @_;
  $self->$orig($arg || ());
};

=head2 options

Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
Returns an array or array reference.

  $constraint->options('NORELY');
  my @options = $constraint->options;

=cut

with ListAttr options => ();

=head2 on_delete

Get or set the constraint's "on delete" action.

  my $action = $constraint->on_delete('cascade');

=cut

has on_delete => (is => 'rw', default => quote_sub(q{ '' }));

around on_delete => sub {
  my ($orig, $self, $arg) = @_;
  $self->$orig($arg || ());
};

=head2 on_update

Get or set the constraint's "on update" action.

  my $action = $constraint->on_update('no action');

=cut

has on_update => (is => 'rw', default => quote_sub(q{ '' }));

around on_update => sub {
  my ($orig, $self, $arg) = @_;
  $self->$orig($arg || ());
};

=head2 reference_fields

Gets and set the fields in the referred table.  Accepts a string, list or
arrayref; returns an array or array reference.

  $constraint->reference_fields('id');
  $constraint->reference_fields('id', 'name');
  $constraint->reference_fields( 'id, name' );
  $constraint->reference_fields( [ 'id', 'name' ] );
  $constraint->reference_fields( qw[ id name ] );

  my @reference_fields = $constraint->reference_fields;

=cut

with ListAttr reference_fields => (
  may_throw => 1,
  builder   => 1,
  lazy      => 1,
);

sub _build_reference_fields {
  my ($self) = @_;

  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'");

    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'");
    }