lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.9 2003-09-25 01:31:28 allenday Exp $
   5 # ----------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
   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.9 $ =~ /(\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_do     => 'cascade',     # what to do on deletes
  82       on_update_do     => '',            # 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 the 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     unless ( ref $self->{'reference_fields'} ) {
 404         my $table          = $self->table or return $self->error('No table');
 405         my $schema         = $table->schema or return $self->error('No schema');
 406         my $ref_table_name = $self->reference_table or
 407             return $self->error('No 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
 422     if ( ref $self->{'reference_fields'} ) {
 423         return wantarray
 424             ?  @{ $self->{'reference_fields'} || [] }
 425             :     $self->{'reference_fields'};
 426     }
 427     else {
 428         return wantarray ? () : [];
 429     }
 430 }
 431
 432 # ----------------------------------------------------------------------
 433 sub reference_table {
 434
 435 =pod
 436
 437 =head2 reference_table
 438
 439 Get or set the table referred to by the constraint.
 440
 441   my $reference_table = $constraint->reference_table('foo');
 442
 443 =cut
 444
 445     my $self = shift;
 446     $self->{'reference_table'} = shift if @_;
 447     return $self->{'reference_table'} || '';
 448 }
 449
 450 # ----------------------------------------------------------------------
 451 sub table {
 452
 453 =pod
 454
 455 =head2 table
 456
 457 Get or set the field's table object.
 458
 459   my $table = $field->table;
 460
 461 =cut
 462
 463     my $self = shift;
 464     if ( my $arg = shift ) {
 465         return $self->error('Not a table object') unless
 466             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 467         $self->{'table'} = $arg;
 468     }
 469
 470     return $self->{'table'};
 471 }
 472
 473 # ----------------------------------------------------------------------
 474 sub type {
 475
 476 =pod
 477
 478 =head2 type
 479
 480 Get or set the constraint's type.
 481
 482   my $type = $constraint->type( PRIMARY_KEY );
 483
 484 =cut
 485
 486     my $self = shift;
 487
 488     if ( my $type = uc shift ) {
 489         $type =~ s/_/ /g;
 490         return $self->error("Invalid constraint type: $type")
 491             unless $VALID_CONSTRAINT_TYPE{ $type };
 492         $self->{'type'} = $type;
 493     }
 494
 495     return $self->{'type'} || '';
 496 }
 497 # ----------------------------------------------------------------------
 498 sub DESTROY {
 499     my $self = shift;
 500     undef $self->{'table'}; # destroy cyclical reference
 501 }
 502
 503 1;
 504
 505 # ----------------------------------------------------------------------
 506
 507 =pod
 508
 509 =head1 AUTHOR
 510
 511 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 512
 513 =cut