lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.14 2004-11-04 16:29:56 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 SQL::Translator::Schema::Constants;
  48 use SQL::Translator::Utils 'parse_list_arg';
  49
  50 use base 'SQL::Translator::Schema::Object';
  51
  52 use vars qw($VERSION $TABLE_COUNT $VIEW_COUNT);
  53
  54 $VERSION = sprintf "%d.%02d", q$Revision: 1.14 $ =~ /(\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 The fields are returned as Field objects if they exist or as plain
 226 names if not. (If you just want the names and want to avoid the Field's overload
 227 magic use L<field_names>).
 228
 229 Returns undef or an empty list if the constraint has no fields set.
 230
 231   $constraint->fields('id');
 232   $constraint->fields('id', 'name');
 233   $constraint->fields( 'id, name' );
 234   $constraint->fields( [ 'id', 'name' ] );
 235   $constraint->fields( qw[ id name ] );
 236
 237   my @fields = $constraint->fields;
 238
 239 =cut
 240
 241     my $self   = shift;
 242     my $fields = parse_list_arg( @_ );
 243
 244     if ( @$fields ) {
 245         my ( %unique, @unique );
 246         for my $f ( @$fields ) {
 247             next if $unique{ $f };
 248             $unique{ $f } = 1;
 249             push @unique, $f;
 250         }
 251
 252         $self->{'fields'} = \@unique;
 253     }
 254
 255     if ( @{ $self->{'fields'} || [] } ) {
 256         # We have to return fields that don't exist on the table as names in
 257         # case those fields havn't been created yet.
 258         my @ret = map {
 259             $self->table->get_field($_) || $_ } @{ $self->{'fields'} };
 260         return wantarray ? @ret : \@ret;
 261     }
 262     else {
 263         return wantarray ? () : undef;
 264     }
 265 }
 266
 267 # ----------------------------------------------------------------------
 268 sub field_names {
 269
 270 =head2 field_names
 271
 272 Read-only method to return a list or array ref of the field names. Returns undef
 273 or an empty list if the constraint has no fields set. Usefull if you want to
 274 avoid the overload magic of the Field objects returned by the fields method.
 275
 276   my @names = $constraint->field_names;
 277
 278 =cut
 279
 280     my $self = shift;
 281     return wantarray ? @{ $self->{'fields'} } : $self->{'fields'};
 282 }
 283
 284 # ----------------------------------------------------------------------
 285 sub match_type {
 286
 287 =pod
 288
 289 =head2 match_type
 290
 291 Get or set the constraint's match_type.  Only valid values are "full"
 292 or "partial."
 293
 294   my $match_type = $constraint->match_type('FULL');
 295
 296 =cut
 297
 298     my $self = shift;
 299
 300     if ( my $arg = lc shift ) {
 301         return $self->error("Invalid match type: $arg")
 302             unless $arg eq 'full' || $arg eq 'partial';
 303         $self->{'match_type'} = $arg;
 304     }
 305
 306     return $self->{'match_type'} || '';
 307 }
 308
 309 # ----------------------------------------------------------------------
 310 sub name {
 311
 312 =pod
 313
 314 =head2 name
 315
 316 Get or set the constraint's name.
 317
 318   my $name = $constraint->name('foo');
 319
 320 =cut
 321
 322     my $self = shift;
 323     my $arg  = shift || '';
 324     $self->{'name'} = $arg if $arg;
 325     return $self->{'name'} || '';
 326 }
 327
 328 # ----------------------------------------------------------------------
 329 sub options {
 330
 331 =pod
 332
 333 =head2 options
 334
 335 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 336 Returns an array or array reference.
 337
 338   $constraint->options('NORELY');
 339   my @options = $constraint->options;
 340
 341 =cut
 342
 343     my $self    = shift;
 344     my $options = parse_list_arg( @_ );
 345
 346     push @{ $self->{'options'} }, @$options;
 347
 348     if ( ref $self->{'options'} ) {
 349         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 350     }
 351     else {
 352         return wantarray ? () : [];
 353     }
 354 }
 355
 356
 357 # ----------------------------------------------------------------------
 358 sub on_delete {
 359
 360 =pod
 361
 362 =head2 on_delete
 363
 364 Get or set the constraint's "on delete" action.
 365
 366   my $action = $constraint->on_delete('cascade');
 367
 368 =cut
 369
 370     my $self = shift;
 371
 372     if ( my $arg = shift ) {
 373         # validate $arg?
 374         $self->{'on_delete'} = $arg;
 375     }
 376
 377     return $self->{'on_delete'} || '';
 378 }
 379
 380 # ----------------------------------------------------------------------
 381 sub on_update {
 382
 383 =pod
 384
 385 =head2 on_update
 386
 387 Get or set the constraint's "on update" action.
 388
 389   my $action = $constraint->on_update('no action');
 390
 391 =cut
 392
 393     my $self = shift;
 394
 395     if ( my $arg = shift ) {
 396         # validate $arg?
 397         $self->{'on_update'} = $arg;
 398     }
 399
 400     return $self->{'on_update'} || '';
 401 }
 402
 403 # ----------------------------------------------------------------------
 404 sub reference_fields {
 405
 406 =pod
 407
 408 =head2 reference_fields
 409
 410 Gets and set the fields in the referred table.  Accepts a string, list or
 411 arrayref; returns an array or array reference.
 412
 413   $constraint->reference_fields('id');
 414   $constraint->reference_fields('id', 'name');
 415   $constraint->reference_fields( 'id, name' );
 416   $constraint->reference_fields( [ 'id', 'name' ] );
 417   $constraint->reference_fields( qw[ id name ] );
 418
 419   my @reference_fields = $constraint->reference_fields;
 420
 421 =cut
 422
 423     my $self   = shift;
 424     my $fields = parse_list_arg( @_ );
 425
 426     if ( @$fields ) {
 427         $self->{'reference_fields'} = $fields;
 428     }
 429
 430     # Nothing set so try and derive it from the other constraint data
 431     unless ( ref $self->{'reference_fields'} ) {
 432         my $table   = $self->table   or return $self->error('No table');
 433         my $schema  = $table->schema or return $self->error('No schema');
 434         if ( my $ref_table_name = $self->reference_table ) {
 435             my $ref_table  = $schema->get_table( $ref_table_name ) or
 436                 return $self->error("Can't find table '$ref_table_name'");
 437
 438             if ( my $constraint = $ref_table->primary_key ) {
 439                 $self->{'reference_fields'} = [ $constraint->fields ];
 440             }
 441             else {
 442                 $self->error(
 443                  'No reference fields defined and cannot find primary key in ',
 444                  "reference table '$ref_table_name'"
 445                 );
 446             }
 447         }
 448         # No ref table so we are not that sort of constraint, hence no ref
 449         # fields. So we let the return below return an empty list.
 450     }
 451
 452     if ( ref $self->{'reference_fields'} ) {
 453         return wantarray
 454             ?  @{ $self->{'reference_fields'} }
 455             :     $self->{'reference_fields'};
 456     }
 457     else {
 458         return wantarray ? () : [];
 459     }
 460 }
 461
 462 # ----------------------------------------------------------------------
 463 sub reference_table {
 464
 465 =pod
 466
 467 =head2 reference_table
 468
 469 Get or set the table referred to by the constraint.
 470
 471   my $reference_table = $constraint->reference_table('foo');
 472
 473 =cut
 474
 475     my $self = shift;
 476     $self->{'reference_table'} = shift if @_;
 477     return $self->{'reference_table'} || '';
 478 }
 479
 480 # ----------------------------------------------------------------------
 481 sub table {
 482
 483 =pod
 484
 485 =head2 table
 486
 487 Get or set the constraint's table object.
 488
 489   my $table = $field->table;
 490
 491 =cut
 492
 493     my $self = shift;
 494     if ( my $arg = shift ) {
 495         return $self->error('Not a table object') unless
 496             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 497         $self->{'table'} = $arg;
 498     }
 499
 500     return $self->{'table'};
 501 }
 502
 503 # ----------------------------------------------------------------------
 504 sub type {
 505
 506 =pod
 507
 508 =head2 type
 509
 510 Get or set the constraint's type.
 511
 512   my $type = $constraint->type( PRIMARY_KEY );
 513
 514 =cut
 515
 516     my $self = shift;
 517
 518     if ( my $type = uc shift ) {
 519         $type =~ s/_/ /g;
 520         return $self->error("Invalid constraint type: $type")
 521             unless $VALID_CONSTRAINT_TYPE{ $type };
 522         $self->{'type'} = $type;
 523     }
 524
 525     return $self->{'type'} || '';
 526 }
 527 # ----------------------------------------------------------------------
 528 sub DESTROY {
 529     my $self = shift;
 530     undef $self->{'table'}; # destroy cyclical reference
 531 }
 532
 533 1;
 534
 535 # ----------------------------------------------------------------------
 536
 537 =pod
 538
 539 =head1 AUTHOR
 540
 541 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 542
 543 =cut