lib/SQL/Translator/Schema/Constraint.pm

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