lib/SQL/Translator/Schema/Constraint.pm

   1 package SQL::Translator::Schema::Constraint;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Constraint.pm,v 1.4 2003-06-06 00:08:14 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,        # table to which it belongs
  74       type             => 'foreign_key', # type of table constraint
  75       name             => 'fk_phone_id', # name of the constraint
  76       fields           => 'phone_id',    # field in the referring table
  77       reference_fields => 'phone_id',    # referenced table
  78       reference_table  => 'phone',       # 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 options {
 295
 296 =pod
 297
 298 =head2 options
 299
 300 Gets or adds to the constraints's options (e.g., "INITIALLY IMMEDIATE").
 301 Returns an array or array reference.
 302
 303   $constraint->options('NORELY');
 304   my @options = $constraint->options;
 305
 306 =cut
 307
 308     my $self    = shift;
 309     my $options = parse_list_arg( @_ );
 310
 311     push @{ $self->{'options'} }, @$options;
 312
 313     if ( ref $self->{'options'} ) {
 314         return wantarray ? @{ $self->{'options'} || [] } : $self->{'options'};
 315     }
 316     else {
 317         return wantarray ? () : [];
 318     }
 319 }
 320
 321
 322 # ----------------------------------------------------------------------
 323 sub on_delete {
 324
 325 =pod
 326
 327 =head2 on_delete
 328
 329 Get or set the constraint's "on delete" action.
 330
 331   my $action = $constraint->on_delete('cascade');
 332
 333 =cut
 334
 335     my $self = shift;
 336
 337     if ( my $arg = shift ) {
 338         # validate $arg?
 339         $self->{'on_delete'} = $arg;
 340     }
 341
 342     return $self->{'on_delete'} || '';
 343 }
 344
 345 # ----------------------------------------------------------------------
 346 sub on_update {
 347
 348 =pod
 349
 350 =head2 on_update
 351
 352 Get or set the constraint's "on update" action.
 353
 354   my $action = $constraint->on_update('no action');
 355
 356 =cut
 357
 358     my $self = shift;
 359
 360     if ( my $arg = shift ) {
 361         # validate $arg?
 362         $self->{'on_update'} = $arg;
 363     }
 364
 365     return $self->{'on_update'} || '';
 366 }
 367
 368 # ----------------------------------------------------------------------
 369 sub reference_fields {
 370
 371 =pod
 372
 373 =head2 reference_fields
 374
 375 Gets and set the fields in the referred table.  Accepts a string, list or
 376 arrayref; returns an array or array reference.
 377
 378   $constraint->reference_fields('id');
 379   $constraint->reference_fields('id', 'name');
 380   $constraint->reference_fields( 'id, name' );
 381   $constraint->reference_fields( [ 'id', 'name' ] );
 382   $constraint->reference_fields( qw[ id name ] );
 383
 384   my @reference_fields = $constraint->reference_fields;
 385
 386 =cut
 387
 388     my $self   = shift;
 389     my $fields = parse_list_arg( @_ );
 390
 391     if ( @$fields ) {
 392         $self->{'reference_fields'} = $fields;
 393     }
 394
 395     unless ( ref $self->{'reference_fields'} ) {
 396         my $table          = $self->table or return $self->error('No table');
 397         my $schema         = $table->schema or return $self->error('No schema');
 398         my $ref_table_name = $self->reference_table or
 399             return $self->error('No table');
 400         my $ref_table      = $schema->get_table( $ref_table_name ) or
 401             return $self->error("Can't find table '$ref_table_name'");
 402
 403         if ( my $constraint = $ref_table->primary_key ) {
 404             $self->{'reference_fields'} = [ $constraint->fields ];
 405         }
 406         else {
 407             $self->error(
 408                 'No reference fields defined and cannot find primary key in ',
 409                 "reference table '$ref_table_name'"
 410             );
 411         }
 412     }
 413
 414     if ( ref $self->{'reference_fields'} ) {
 415         return wantarray
 416             ?  @{ $self->{'reference_fields'} || [] }
 417             :     $self->{'reference_fields'};
 418     }
 419     else {
 420         return wantarray ? () : [];
 421     }
 422 }
 423
 424 # ----------------------------------------------------------------------
 425 sub reference_table {
 426
 427 =pod
 428
 429 =head2 reference_table
 430
 431 Get or set the table referred to by the constraint.
 432
 433   my $reference_table = $constraint->reference_table('foo');
 434
 435 =cut
 436
 437     my $self = shift;
 438     $self->{'reference_table'} = shift if @_;
 439     return $self->{'reference_table'} || '';
 440 }
 441
 442 # ----------------------------------------------------------------------
 443 sub table {
 444
 445 =pod
 446
 447 =head2 table
 448
 449 Get or set the field's table object.
 450
 451   my $table = $field->table;
 452
 453 =cut
 454
 455     my $self = shift;
 456     if ( my $arg = shift ) {
 457         return $self->error('Not a table object') unless
 458             UNIVERSAL::isa( $arg, 'SQL::Translator::Schema::Table' );
 459         $self->{'table'} = $arg;
 460     }
 461
 462     return $self->{'table'};
 463 }
 464
 465 # ----------------------------------------------------------------------
 466 sub type {
 467
 468 =pod
 469
 470 =head2 type
 471
 472 Get or set the constraint's type.
 473
 474   my $type = $constraint->type( PRIMARY_KEY );
 475
 476 =cut
 477
 478     my $self = shift;
 479
 480     if ( my $type = uc shift ) {
 481         $type =~ s/_/ /g;
 482         return $self->error("Invalid constraint type: $type")
 483             unless VALID_TYPE->{ $type };
 484         $self->{'type'} = $type;
 485     }
 486
 487     return $self->{'type'} || '';
 488 }
 489 # ----------------------------------------------------------------------
 490 sub DESTROY {
 491     my $self = shift;
 492     undef $self->{'table'}; # destroy cyclical reference
 493 }
 494
 495 1;
 496
 497 # ----------------------------------------------------------------------
 498
 499 =pod
 500
 501 =head1 AUTHOR
 502
 503 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 504
 505 =cut