Made debugging work and it now exports its parse method.
[dbsrgits/SQL-Translator.git] / 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