lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.7 2003-06-27 16:47:40 kycl4rk 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.7 $ =~ /(\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 table
  79       reference_table  => 'phone',       # referenced fields
  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
  91     ];
  92
  93     for my $arg ( @fields ) {
  94         next unless $config->{ $arg };
  95         defined $self->$arg( $config->{ $arg } ) or return;
  96     }
  97
  98     return $self;
  99 }
 100
 101 # ----------------------------------------------------------------------
 102 sub deferrable {
 103
 104 =pod
 105
 106 =head2 deferrable
 107
 108 Get or set the whether the constraint is deferrable.  If not defined,
 109 then returns "1."  The argument is evaluated by Perl for True or
 110 False, so the following are eqivalent:
 111
 112   $deferrable = $field->deferrable(0);
 113   $deferrable = $field->deferrable('');
 114   $deferrable = $field->deferrable('0');
 115
 116 =cut
 117
 118     my ( $self, $arg ) = @_;
 119
 120     if ( defined $arg ) {
 121         $self->{'deferrable'} = $arg ? 1 : 0;
 122     }
 123
 124     return defined $self->{'deferrable'} ? $self->{'deferrable'} : 1;
 125 }
 126
 127 # ----------------------------------------------------------------------
 128 sub expression {
 129
 130 =pod
 131
 132 =head2 expression
 133
 134 Gets and set the expression used in a CHECK constraint.
 135
 136   my $expression = $constraint->expression('...');
 137
 138 =cut
 139
 140     my $self = shift;
 141
 142     if ( my $arg = shift ) {
 143         # check arg here?
 144         $self->{'expression'} = $arg;
 145     }
 146
 147     return $self->{'expression'} || '';
 148 }
 149
 150 # ----------------------------------------------------------------------
 151 sub is_valid {
 152
 153 =pod
 154
 155 =head2 is_valid
 156
 157 Determine whether the constraint is valid or not.
 158
 159   my $ok = $constraint->is_valid;
 160
 161 =cut
 162
 163     my $self       = shift;
 164     my $type       = $self->type   or return $self->error('No type');
 165     my $table      = $self->table  or return $self->error('No table');
 166     my @fields     = $self->fields or return $self->error('No fields');
 167     my $table_name = $table->name  or return $self->error('No table name');
 168
 169     for my $f ( @fields ) {
 170         next if $table->get_field( $f );
 171         return $self->error(
 172             "Constraint references non-existent field '$f' ",
 173             "in table '$table_name'"
 174         );
 175     }
 176
 177     my $schema = $table->schema or return $self->error(
 178         'Table ', $table->name, ' has no schema object'
 179     );
 180
 181     if ( $type eq FOREIGN_KEY ) {
 182         return $self->error('Only one field allowed for foreign key')
 183             if scalar @fields > 1;
 184
 185         my $ref_table_name  = $self->reference_table or
 186             return $self->error('No reference table');
 187
 188         my $ref_table = $schema->get_table( $ref_table_name ) or
 189             return $self->error("No table named '$ref_table_name' in schema");
 190
 191         my @ref_fields = $self->reference_fields or return;
 192
 193         return $self->error('Only one field allowed for foreign key reference')
 194             if scalar @ref_fields > 1;
 195
 196         for my $ref_field ( @ref_fields ) {
 197             next if $ref_table->get_field( $ref_field );
 198             return $self->error(
 199                 "Constraint from field(s) ",
 200                 join(', ', map {qq['$table_name.$_']} @fields),
 201                 " to non-existent field '$ref_table_name.$ref_field'"
 202             );
 203         }
 204     }
 205     elsif ( $type eq CHECK_C ) {
 206         return $self->error('No expression for CHECK') unless
 207             $self->expression;
 208     }
 209
 210     return 1;
 211 }
 212
 213 # ----------------------------------------------------------------------
 214 sub fields {
 215
 216 =pod
 217
 218 =head2 fields
 219
 220 Gets and set the fields the constraint is on.  Accepts a string, list or
 221 arrayref; returns an array or array reference.  Will unique the field
 222 names and keep them in order by the first occurrence of a field name.
 223
 224   $constraint->fields('id');
 225   $constraint->fields('id', 'name');
 226   $constraint->fields( 'id, name' );
 227   $constraint->fields( [ 'id', 'name' ] );
 228   $constraint->fields( qw[ id name ] );
 229
 230   my @fields = $constraint->fields;
 231
 232 =cut
 233
 234     my $self   = shift;
 235     my $fields = parse_list_arg( @_ );
 236
 237     if ( @$fields ) {
 238         my ( %unique, @unique );
 239         for my $f ( @$fields ) {
 240             next if $unique{ $f };
 241             $unique{ $f } = 1;
 242             push @unique, $f;
 243         }
 244
 245         $self->{'fields'} = \@unique;
 246     }
 247
 248     return wantarray ? @{ $self->{'fields'} || [] } : $self->{'fields'};
 249 }
 250
 251 # ----------------------------------------------------------------------
 252 sub match_type {
 253
 254 =pod
 255
 256 =head2 match_type
 257
 258 Get or set the constraint's match_type.  Only valid values are "full"
 259 or "partial."
 260
 261   my $match_type = $constraint->match_type('FULL');
 262
 263 =cut
 264
 265     my $self = shift;
 266
 267     if ( my $arg = lc shift ) {
 268         return $self->error("Invalid match type: $arg")
 269             unless $arg eq 'full' || $arg eq 'partial';
 270         $self->{'match_type'} = $arg;
 271     }
 272
 273     return $self->{'match_type'} || '';
 274 }
 275
 276 # ----------------------------------------------------------------------
 277 sub name {
 278
 279 =pod
 280
 281 =head2 name
 282
 283 Get or set the constraint's name.
 284
 285   my $name = $constraint->name('foo');
 286
 287 =cut
 288
 289     my $self = shift;
 290     my $arg  = shift || '';
 291     $self->{'name'} = $arg if $arg;
 292     return $self->{'name'} || '';
 293 }
 294
 295 # ----------------------------------------------------------------------
 296 sub options {
 297
 298 =pod
 299
 300 =head2 options
 301
 302 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 303 Returns an array or array reference.
 304
 305   $constraint->options('NORELY');
 306   my @options = $constraint->options;
 307
 308 =cut
 309
 310     my $self    = shift;
 311     my $options = parse_list_arg( @_ );
 312
 313     push @{ $self->{'options'} }, @$options;
 314
 315     if ( ref $self->{'options'} ) {
 316         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 317     }
 318     else {
 319         return wantarray ? () : [];
 320     }
 321 }
 322
 323
 324 # ----------------------------------------------------------------------
 325 sub on_delete {
 326
 327 =pod
 328
 329 =head2 on_delete
 330
 331 Get or set the constraint's "on delete" action.
 332
 333   my $action = $constraint->on_delete('cascade');
 334
 335 =cut
 336
 337     my $self = shift;
 338
 339     if ( my $arg = shift ) {
 340         # validate $arg?
 341         $self->{'on_delete'} = $arg;
 342     }
 343
 344     return $self->{'on_delete'} || '';
 345 }
 346
 347 # ----------------------------------------------------------------------
 348 sub on_update {
 349
 350 =pod
 351
 352 =head2 on_update
 353
 354 Get or set the constraint's "on update" action.
 355
 356   my $action = $constraint->on_update('no action');
 357
 358 =cut
 359
 360     my $self = shift;
 361
 362     if ( my $arg = shift ) {
 363         # validate $arg?
 364         $self->{'on_update'} = $arg;
 365     }
 366
 367     return $self->{'on_update'} || '';
 368 }
 369
 370 # ----------------------------------------------------------------------
 371 sub reference_fields {
 372
 373 =pod
 374
 375 =head2 reference_fields
 376
 377 Gets and set the fields in the referred table.  Accepts a string, list or
 378 arrayref; returns an array or array reference.
 379
 380   $constraint->reference_fields('id');
 381   $constraint->reference_fields('id', 'name');
 382   $constraint->reference_fields( 'id, name' );
 383   $constraint->reference_fields( [ 'id', 'name' ] );
 384   $constraint->reference_fields( qw[ id name ] );
 385
 386   my @reference_fields = $constraint->reference_fields;
 387
 388 =cut
 389
 390     my $self   = shift;
 391     my $fields = parse_list_arg( @_ );
 392
 393     if ( @$fields ) {
 394         $self->{'reference_fields'} = $fields;
 395     }
 396
 397     unless ( ref $self->{'reference_fields'} ) {
 398         my $table          = $self->table or return $self->error('No table');
 399         my $schema         = $table->schema or return $self->error('No schema');
 400         my $ref_table_name = $self->reference_table or
 401             return $self->error('No table');
 402         my $ref_table      = $schema->get_table( $ref_table_name ) or
 403             return $self->error("Can't find table '$ref_table_name'");
 404
 405         if ( my $constraint = $ref_table->primary_key ) {
 406             $self->{'reference_fields'} = [ $constraint->fields ];
 407         }
 408         else {
 409             $self->error(
 410                 'No reference fields defined and cannot find primary key in ',
 411                 "reference table '$ref_table_name'"
 412             );
 413         }
 414     }
 415
 416     if ( ref $self->{'reference_fields'} ) {
 417         return wantarray
 418             ?  @{ $self->{'reference_fields'} || [] }
 419             :     $self->{'reference_fields'};
 420     }
 421     else {
 422         return wantarray ? () : [];
 423     }
 424 }
 425
 426 # ----------------------------------------------------------------------
 427 sub reference_table {
 428
 429 =pod
 430
 431 =head2 reference_table
 432
 433 Get or set the table referred to by the constraint.
 434
 435   my $reference_table = $constraint->reference_table('foo');
 436
 437 =cut
 438
 439     my $self = shift;
 440     $self->{'reference_table'} = shift if @_;
 441     return $self->{'reference_table'} || '';
 442 }
 443
 444 # ----------------------------------------------------------------------
 445 sub table {
 446
 447 =pod
 448
 449 =head2 table
 450
 451 Get or set the field's table object.
 452
 453   my $table = $field->table;
 454
 455 =cut
 456
 457     my $self = shift;
 458     if ( my $arg = shift ) {
 459         return $self->error('Not a table object') unless
 460             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 461         $self->{'table'} = $arg;
 462     }
 463
 464     return $self->{'table'};
 465 }
 466
 467 # ----------------------------------------------------------------------
 468 sub type {
 469
 470 =pod
 471
 472 =head2 type
 473
 474 Get or set the constraint's type.
 475
 476   my $type = $constraint->type( PRIMARY_KEY );
 477
 478 =cut
 479
 480     my $self = shift;
 481
 482     if ( my $type = uc shift ) {
 483         $type =~ s/_/ /g;
 484         return $self->error("Invalid constraint type: $type")
 485             unless $VALID_CONSTRAINT_TYPE{ $type };
 486         $self->{'type'} = $type;
 487     }
 488
 489     return $self->{'type'} || '';
 490 }
 491 # ----------------------------------------------------------------------
 492 sub DESTROY {
 493     my $self = shift;
 494     undef $self->{'table'}; # destroy cyclical reference
 495 }
 496
 497 1;
 498
 499 # ----------------------------------------------------------------------
 500
 501 =pod
 502
 503 =head1 AUTHOR
 504
 505 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 506
 507 =cut