lib/SQL/Translator/Schema/Constraint.pm

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