lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.11 2004-02-29 16:05:31 grommit Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =pod
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Schema::Constraint - SQL::Translator constraint object
  28
  29 =head1 SYNOPSIS
  30
  31   use SQL::Translator::Schema::Constraint;
  32   my $constraint = SQL::Translator::Schema::Constraint->new(
  33       name   => 'foo',
  34       fields => [ id ],
  35       type   => PRIMARY_KEY,
  36   );
  37
  38 =head1 DESCRIPTION
  39
  40 C<SQL::Translator::Schema::Constraint> is the constraint object.
  41
  42 =head1 METHODS
  43
  44 =cut
  45
  46 use strict;
  47 use Class::Base;
  48 use SQL::Translator::Schema::Constants;
  49 use SQL::Translator::Utils 'parse_list_arg';
  50
  51 use base 'Class::Base';
  52 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
  53
  54 $VERSION = sprintf "%d.%02d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
  55
  56 my %VALID_CONSTRAINT_TYPE = (
  57     PRIMARY_KEY, 1,
  58     UNIQUE,      1,
  59     CHECK_C,     1,
  60     FOREIGN_KEY, 1,
  61     NOT_NULL,    1,
  62 );
  63
  64 # ----------------------------------------------------------------------
  65 sub init {
  66
  67 =pod
  68
  69 =head2 new
  70
  71 Object constructor.
  72
  73   my $schema           =  SQL::Translator::Schema::Constraint->new(
  74       table            => $table,        # table to which it belongs
  75       type             => 'foreign_key', # type of table constraint
  76       name             => 'fk_phone_id', # name of the constraint
  77       fields           => 'phone_id',    # field in the referring table
  78       reference_fields => 'phone_id',    # referenced field
  79       reference_table  => 'phone',       # referenced table
  80       match_type       => 'full',        # how to match
  81       on_delete        => 'cascade',     # what to do on deletes
  82       on_update        => '',            # what to do on updates
  83   );
  84
  85 =cut
  86
  87     my ( $self, $config ) = @_;
  88     my @fields = qw[
  89         table name type fields reference_fields reference_table
  90         match_type on_delete on_update expression
  91     ];
  92
  93     for my $arg ( @fields ) {
  94         next unless $config->{ $arg };
  95         next if ref $config->{ $arg } eq 'ARRAY' && ! @{ $config->{ $arg } };
  96         defined $self->$arg( $config->{ $arg } ) or return;
  97     }
  98
  99     return $self;
 100 }
 101
 102 # ----------------------------------------------------------------------
 103 sub deferrable {
 104
 105 =pod
 106
 107 =head2 deferrable
 108
 109 Get or set whether the constraint is deferrable.  If not defined,
 110 then returns "1."  The argument is evaluated by Perl for True or
 111 False, so the following are eqivalent:
 112
 113   $deferrable = $field->deferrable(0);
 114   $deferrable = $field->deferrable('');
 115   $deferrable = $field->deferrable('0');
 116
 117 =cut
 118
 119     my ( $self, $arg ) = @_;
 120
 121     if ( defined $arg ) {
 122         $self->{'deferrable'} = $arg ? 1 : 0;
 123     }
 124
 125     return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
 126 }
 127
 128 # ----------------------------------------------------------------------
 129 sub expression {
 130
 131 =pod
 132
 133 =head2 expression
 134
 135 Gets and set the expression used in a CHECK constraint.
 136
 137   my $expression = $constraint->expression('...');
 138
 139 =cut
 140
 141     my $self = shift;
 142
 143     if ( my $arg = shift ) {
 144         # check arg here?
 145         $self->{'expression'} = $arg;
 146     }
 147
 148     return $self->{'expression'} || '';
 149 }
 150
 151 # ----------------------------------------------------------------------
 152 sub is_valid {
 153
 154 =pod
 155
 156 =head2 is_valid
 157
 158 Determine whether the constraint is valid or not.
 159
 160   my $ok = $constraint->is_valid;
 161
 162 =cut
 163
 164     my $self       = shift;
 165     my $type       = $self->type   or return $self->error('No type');
 166     my $table      = $self->table  or return $self->error('No table');
 167     my @fields     = $self->fields or return $self->error('No fields');
 168     my $table_name = $table->name  or return $self->error('No table name');
 169
 170     for my $f ( @fields ) {
 171         next if $table->get_field( $f );
 172         return $self->error(
 173             "Constraint references non-existent field '$f' ",
 174             "in table '$table_name'"
 175         );
 176     }
 177
 178     my $schema = $table->schema or return $self->error(
 179         'Table ', $table->name, ' has no schema object'
 180     );
 181
 182     if ( $type eq FOREIGN_KEY ) {
 183         return $self->error('Only one field allowed for foreign key')
 184             if scalar @fields > 1;
 185
 186         my $ref_table_name  = $self->reference_table or
 187             return $self->error('No reference table');
 188
 189         my $ref_table = $schema->get_table( $ref_table_name ) or
 190             return $self->error("No table named '$ref_table_name' in schema");
 191
 192         my @ref_fields = $self->reference_fields or return;
 193
 194         return $self->error('Only one field allowed for foreign key reference')
 195             if scalar @ref_fields > 1;
 196
 197         for my $ref_field ( @ref_fields ) {
 198             next if $ref_table->get_field( $ref_field );
 199             return $self->error(
 200                 "Constraint from field(s) ",
 201                 join(', ', map {qq['$table_name.$_']} @fields),
 202                 " to non-existent field '$ref_table_name.$ref_field'"
 203             );
 204         }
 205     }
 206     elsif ( $type eq CHECK_C ) {
 207         return $self->error('No expression for CHECK') unless
 208             $self->expression;
 209     }
 210
 211     return 1;
 212 }
 213
 214 # ----------------------------------------------------------------------
 215 sub fields {
 216
 217 =pod
 218
 219 =head2 fields
 220
 221 Gets and set the fields the constraint is on.  Accepts a string, list or
 222 arrayref; returns an array or array reference.  Will unique the field
 223 names and keep them in order by the first occurrence of a field name.
 224
 225   $constraint->fields('id');
 226   $constraint->fields('id', 'name');
 227   $constraint->fields( 'id, name' );
 228   $constraint->fields( [ 'id', 'name' ] );
 229   $constraint->fields( qw[ id name ] );
 230
 231   my @fields = $constraint->fields;
 232
 233 =cut
 234
 235     my $self   = shift;
 236     my $fields = parse_list_arg( @_ );
 237
 238     if ( @$fields ) {
 239         my ( %unique, @unique );
 240         for my $f ( @$fields ) {
 241             next if $unique{ $f };
 242             $unique{ $f } = 1;
 243             push @unique, $f;
 244         }
 245
 246         $self->{'fields'} = \@unique;
 247     }
 248
 249     if ( @{ $self->{'fields'} || [] } ) {
 250         return wantarray ? @{ $self->{'fields'} } : $self->{'fields'};
 251     }
 252     else {
 253         return wantarray ? () : undef;
 254     }
 255 }
 256
 257 # ----------------------------------------------------------------------
 258 sub match_type {
 259
 260 =pod
 261
 262 =head2 match_type
 263
 264 Get or set the constraint's match_type.  Only valid values are "full"
 265 or "partial."
 266
 267   my $match_type = $constraint->match_type('FULL');
 268
 269 =cut
 270
 271     my $self = shift;
 272
 273     if ( my $arg = lc shift ) {
 274         return $self->error("Invalid match type: $arg")
 275             unless $arg eq 'full' || $arg eq 'partial';
 276         $self->{'match_type'} = $arg;
 277     }
 278
 279     return $self->{'match_type'} || '';
 280 }
 281
 282 # ----------------------------------------------------------------------
 283 sub name {
 284
 285 =pod
 286
 287 =head2 name
 288
 289 Get or set the constraint's name.
 290
 291   my $name = $constraint->name('foo');
 292
 293 =cut
 294
 295     my $self = shift;
 296     my $arg  = shift || '';
 297     $self->{'name'} = $arg if $arg;
 298     return $self->{'name'} || '';
 299 }
 300
 301 # ----------------------------------------------------------------------
 302 sub options {
 303
 304 =pod
 305
 306 =head2 options
 307
 308 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 309 Returns an array or array reference.
 310
 311   $constraint->options('NORELY');
 312   my @options = $constraint->options;
 313
 314 =cut
 315
 316     my $self    = shift;
 317     my $options = parse_list_arg( @_ );
 318
 319     push @{ $self->{'options'} }, @$options;
 320
 321     if ( ref $self->{'options'} ) {
 322         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 323     }
 324     else {
 325         return wantarray ? () : [];
 326     }
 327 }
 328
 329
 330 # ----------------------------------------------------------------------
 331 sub on_delete {
 332
 333 =pod
 334
 335 =head2 on_delete
 336
 337 Get or set the constraint's "on delete" action.
 338
 339   my $action = $constraint->on_delete('cascade');
 340
 341 =cut
 342
 343     my $self = shift;
 344
 345     if ( my $arg = shift ) {
 346         # validate $arg?
 347         $self->{'on_delete'} = $arg;
 348     }
 349
 350     return $self->{'on_delete'} || '';
 351 }
 352
 353 # ----------------------------------------------------------------------
 354 sub on_update {
 355
 356 =pod
 357
 358 =head2 on_update
 359
 360 Get or set the constraint's "on update" action.
 361
 362   my $action = $constraint->on_update('no action');
 363
 364 =cut
 365
 366     my $self = shift;
 367
 368     if ( my $arg = shift ) {
 369         # validate $arg?
 370         $self->{'on_update'} = $arg;
 371     }
 372
 373     return $self->{'on_update'} || '';
 374 }
 375
 376 # ----------------------------------------------------------------------
 377 sub reference_fields {
 378
 379 =pod
 380
 381 =head2 reference_fields
 382
 383 Gets and set the fields in the referred table.  Accepts a string, list or
 384 arrayref; returns an array or array reference.
 385
 386   $constraint->reference_fields('id');
 387   $constraint->reference_fields('id', 'name');
 388   $constraint->reference_fields( 'id, name' );
 389   $constraint->reference_fields( [ 'id', 'name' ] );
 390   $constraint->reference_fields( qw[ id name ] );
 391
 392   my @reference_fields = $constraint->reference_fields;
 393
 394 =cut
 395
 396     my $self   = shift;
 397     my $fields = parse_list_arg( @_ );
 398
 399     if ( @$fields ) {
 400         $self->{'reference_fields'} = $fields;
 401     }
 402
 403     # Nothing set so try and derive it from the other constraint data
 404     unless ( ref $self->{'reference_fields'} ) {
 405         my $table   = $self->table   or return $self->error('No table');
 406         my $schema  = $table->schema or return $self->error('No schema');
 407         if ( my $ref_table_name = $self->reference_table ) {
 408             my $ref_table  = $schema->get_table( $ref_table_name ) or
 409                 return $self->error("Can't find table '$ref_table_name'");
 410
 411             if ( my $constraint = $ref_table->primary_key ) {
 412                 $self->{'reference_fields'} = [ $constraint->fields ];
 413             }
 414             else {
 415                 $self->error(
 416                  'No reference fields defined and cannot find primary key in ',
 417                  "reference table '$ref_table_name'"
 418                 );
 419             }
 420         }
 421         # No ref table so we are not that sort of constraint, hence no ref
 422         # fields. So we let the return below return an empty list.
 423     }
 424
 425     if ( ref $self->{'reference_fields'} ) {
 426         return wantarray
 427             ?  @{ $self->{'reference_fields'} }
 428             :     $self->{'reference_fields'};
 429     }
 430     else {
 431         return wantarray ? () : [];
 432     }
 433 }
 434
 435 # ----------------------------------------------------------------------
 436 sub reference_table {
 437
 438 =pod
 439
 440 =head2 reference_table
 441
 442 Get or set the table referred to by the constraint.
 443
 444   my $reference_table = $constraint->reference_table('foo');
 445
 446 =cut
 447
 448     my $self = shift;
 449     $self->{'reference_table'} = shift if @_;
 450     return $self->{'reference_table'} || '';
 451 }
 452
 453 # ----------------------------------------------------------------------
 454 sub table {
 455
 456 =pod
 457
 458 =head2 table
 459
 460 Get or set the constraint's table object.
 461
 462   my $table = $field->table;
 463
 464 =cut
 465
 466     my $self = shift;
 467     if ( my $arg = shift ) {
 468         return $self->error('Not a table object') unless
 469             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 470         $self->{'table'} = $arg;
 471     }
 472
 473     return $self->{'table'};
 474 }
 475
 476 # ----------------------------------------------------------------------
 477 sub type {
 478
 479 =pod
 480
 481 =head2 type
 482
 483 Get or set the constraint's type.
 484
 485   my $type = $constraint->type( PRIMARY_KEY );
 486
 487 =cut
 488
 489     my $self = shift;
 490
 491     if ( my $type = uc shift ) {
 492         $type =~ s/_/ /g;
 493         return $self->error("Invalid constraint type: $type")
 494             unless $VALID_CONSTRAINT_TYPE{ $type };
 495         $self->{'type'} = $type;
 496     }
 497
 498     return $self->{'type'} || '';
 499 }
 500 # ----------------------------------------------------------------------
 501 sub DESTROY {
 502     my $self = shift;
 503     undef $self->{'table'}; # destroy cyclical reference
 504 }
 505
 506 1;
 507
 508 # ----------------------------------------------------------------------
 509
 510 =pod
 511
 512 =head1 AUTHOR
 513
 514 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 515
 516 =cut