A Parser for SQL Server, mostly copied from Sybase parser and geared toward working...
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema.pm
1 package SQL::Translator::Schema;
2
3 # vim: sw=4: ts=4:
4
5 # ----------------------------------------------------------------------
6 # $Id: Schema.pm,v 1.23 2005-06-08 15:31:06 mwz444 Exp $
7 # ----------------------------------------------------------------------
8 # Copyright (C) 2002-4 SQLFairy Authors
9 #
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License as
12 # published by the Free Software Foundation; version 2.
13 #
14 # This program is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17 # General Public License for more details.
18 #
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
22 # 02111-1307  USA
23 # -------------------------------------------------------------------
24
25 =pod
26
27 =head1 NAME
28
29 SQL::Translator::Schema - SQL::Translator schema object
30
31 =head1 SYNOPSIS
32
33   use SQL::Translator::Schema;
34   my $schema   =  SQL::Translator::Schema->new(
35       name     => 'Foo',
36       database => 'MySQL',
37   );
38   my $table    = $schema->add_table( name => 'foo' );
39   my $view     = $schema->add_view( name => 'bar', sql => '...' );
40
41
42 =head1 DESCSIPTION
43
44 C<SQL::Translator::Schema> is the object that accepts, validates, and
45 returns the database structure.
46
47 =head1 METHODS
48
49 =cut
50
51 use strict;
52 use SQL::Translator::Schema::Constants;
53 use SQL::Translator::Schema::Procedure;
54 use SQL::Translator::Schema::Table;
55 use SQL::Translator::Schema::Trigger;
56 use SQL::Translator::Schema::View;
57 use SQL::Translator::Schema::Graph;
58 use SQL::Translator::Utils 'parse_list_arg';
59
60 use base 'SQL::Translator::Schema::Object';
61 use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
62
63 $VERSION = sprintf "%d.%02d", q$Revision: 1.23 $ =~ /(\d+)\.(\d+)/;
64
65 __PACKAGE__->_attributes(qw/name database translator/);
66
67 # ----------------------------------------------------------------------
68 sub as_graph {
69
70 =pod
71
72 =head2 as_graph
73
74 Returns the schema as an L<SQL::Translator::Schema::Graph> object.
75
76 =cut
77
78     my $self = shift;
79     return SQL::Translator::Schema::Graph->new(
80         translator => $self->translator );
81 }
82
83 # ----------------------------------------------------------------------
84 sub add_table {
85
86 =pod
87
88 =head2 add_table
89
90 Add a table object.  Returns the new SQL::Translator::Schema::Table object.
91 The "name" parameter is required.  If you try to create a table with the
92 same name as an existing table, you will get an error and the table will 
93 not be created.
94
95   my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
96   my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
97   $t2    = $schema->add_table( $table_bar ) or die $schema->error;
98
99 =cut
100
101     my $self        = shift;
102     my $table_class = 'SQL::Translator::Schema::Table';
103     my $table;
104
105     if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
106         $table = shift;
107         $table->schema($self);
108     }
109     else {
110         my %args = @_;
111         $args{'schema'} = $self;
112         $table = $table_class->new( \%args )
113           or return $self->error( $table_class->error );
114     }
115
116     $table->order( ++$TABLE_ORDER );
117
118     # We know we have a name as the Table->new above errors if none given.
119     my $table_name = $table->name;
120
121     if ( defined $self->{'tables'}{$table_name} ) {
122         return $self->error(qq[Can't create table: "$table_name" exists]);
123     }
124     else {
125         $self->{'tables'}{$table_name} = $table;
126     }
127
128     return $table;
129 }
130
131 # ----------------------------------------------------------------------
132 sub drop_table {
133
134 =pod
135
136 =head2 drop_table
137
138 Remove a table from the schema. Returns the table object if the table was found
139 and removed, an error otherwise. The single parameter can be either a table
140 name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
141 can be set to 1 to also drop all triggers on the table, default is 0.
142
143   $schema->drop_table('mytable');
144   $schema->drop_table('mytable', cascade => 1);
145
146 =cut
147
148     my $self        = shift;
149     my $table_class = 'SQL::Translator::Schema::Table';
150     my $table_name;
151
152     if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
153         $table_name = shift->name;
154     }
155     else {
156         $table_name = shift;
157     }
158     my %args    = @_;
159     my $cascade = $args{'cascade'};
160
161     if ( !exists $self->{'tables'}{$table_name} ) {
162         return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
163     }
164
165     my $table = delete $self->{'tables'}{$table_name};
166
167     if ($cascade) {
168
169         # Drop all triggers on this table
170         $self->drop_trigger()
171           for ( grep { $_->on_table eq $table_name } @{ $self->{'triggers'} } );
172     }
173     return $table;
174 }
175
176 # ----------------------------------------------------------------------
177 sub add_procedure {
178
179 =pod
180
181 =head2 add_procedure
182
183 Add a procedure object.  Returns the new SQL::Translator::Schema::Procedure
184 object.  The "name" parameter is required.  If you try to create a procedure
185 with the same name as an existing procedure, you will get an error and the
186 procedure will not be created.
187
188   my $p1 = $schema->add_procedure( name => 'foo' );
189   my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
190   $p2    = $schema->add_procedure( $procedure_bar ) or die $schema->error;
191
192 =cut
193
194     my $self            = shift;
195     my $procedure_class = 'SQL::Translator::Schema::Procedure';
196     my $procedure;
197
198     if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
199         $procedure = shift;
200         $procedure->schema($self);
201     }
202     else {
203         my %args = @_;
204         $args{'schema'} = $self;
205         return $self->error('No procedure name') unless $args{'name'};
206         $procedure = $procedure_class->new( \%args )
207           or return $self->error( $procedure_class->error );
208     }
209
210     $procedure->order( ++$PROC_ORDER );
211     my $procedure_name = $procedure->name
212       or return $self->error('No procedure name');
213
214     if ( defined $self->{'procedures'}{$procedure_name} ) {
215         return $self->error(
216             qq[Can't create procedure: "$procedure_name" exists] );
217     }
218     else {
219         $self->{'procedures'}{$procedure_name} = $procedure;
220     }
221
222     return $procedure;
223 }
224
225 # ----------------------------------------------------------------------
226 sub drop_procedure {
227
228 =pod
229
230 =head2 drop_procedure
231
232 Remove a procedure from the schema. Returns the procedure object if the
233 procedure was found and removed, an error otherwise. The single parameter
234 can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
235 object.
236
237   $schema->drop_procedure('myprocedure');
238
239 =cut
240
241     my $self       = shift;
242     my $proc_class = 'SQL::Translator::Schema::Procedure';
243     my $proc_name;
244
245     if ( UNIVERSAL::isa( $_[0], $proc_class ) ) {
246         $proc_name = shift->name;
247     }
248     else {
249         $proc_name = shift;
250     }
251
252     if ( !exists $self->{'procedures'}{$proc_name} ) {
253         return $self->error(
254             qq[Can't drop procedure: $proc_name" doesn't exist]);
255     }
256
257     my $proc = delete $self->{'procedures'}{$proc_name};
258
259     return $proc;
260 }
261
262 # ----------------------------------------------------------------------
263 sub add_trigger {
264
265 =pod
266
267 =head2 add_trigger
268
269 Add a trigger object.  Returns the new SQL::Translator::Schema::Trigger object.
270 The "name" parameter is required.  If you try to create a trigger with the
271 same name as an existing trigger, you will get an error and the trigger will 
272 not be created.
273
274   my $t1 = $schema->add_trigger( name => 'foo' );
275   my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
276   $t2    = $schema->add_trigger( $trigger_bar ) or die $schema->error;
277
278 =cut
279
280     my $self          = shift;
281     my $trigger_class = 'SQL::Translator::Schema::Trigger';
282     my $trigger;
283
284     if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
285         $trigger = shift;
286         $trigger->schema($self);
287     }
288     else {
289         my %args = @_;
290         $args{'schema'} = $self;
291         return $self->error('No trigger name') unless $args{'name'};
292         $trigger = $trigger_class->new( \%args )
293           or return $self->error( $trigger_class->error );
294     }
295
296     $trigger->order( ++$TRIGGER_ORDER );
297     my $trigger_name = $trigger->name or return $self->error('No trigger name');
298
299     if ( defined $self->{'triggers'}{$trigger_name} ) {
300         return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
301     }
302     else {
303         $self->{'triggers'}{$trigger_name} = $trigger;
304     }
305
306     return $trigger;
307 }
308
309 # ----------------------------------------------------------------------
310 sub drop_trigger {
311
312 =pod
313
314 =head2 drop_trigger
315
316 Remove a trigger from the schema. Returns the trigger object if the trigger was
317 found and removed, an error otherwise. The single parameter can be either a
318 trigger name or an C<SQL::Translator::Schema::Trigger> object.
319
320   $schema->drop_trigger('mytrigger');
321
322 =cut
323
324     my $self          = shift;
325     my $trigger_class = 'SQL::Translator::Schema::Trigger';
326     my $trigger_name;
327
328     if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
329         $trigger_name = shift->name;
330     }
331     else {
332         $trigger_name = shift;
333     }
334
335     if ( !exists $self->{'triggers'}{$trigger_name} ) {
336         return $self->error(
337             qq[Can't drop trigger: $trigger_name" doesn't exist]);
338     }
339
340     my $trigger = delete $self->{'triggers'}{$trigger_name};
341
342     return $trigger;
343 }
344
345 # ----------------------------------------------------------------------
346 sub add_view {
347
348 =pod
349
350 =head2 add_view
351
352 Add a view object.  Returns the new SQL::Translator::Schema::View object.
353 The "name" parameter is required.  If you try to create a view with the
354 same name as an existing view, you will get an error and the view will 
355 not be created.
356
357   my $v1 = $schema->add_view( name => 'foo' );
358   my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
359   $v2    = $schema->add_view( $view_bar ) or die $schema->error;
360
361 =cut
362
363     my $self       = shift;
364     my $view_class = 'SQL::Translator::Schema::View';
365     my $view;
366
367     if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
368         $view = shift;
369         $view->schema($self);
370     }
371     else {
372         my %args = @_;
373         $args{'schema'} = $self;
374         return $self->error('No view name') unless $args{'name'};
375         $view = $view_class->new( \%args ) or return $view_class->error;
376     }
377
378     $view->order( ++$VIEW_ORDER );
379     my $view_name = $view->name or return $self->error('No view name');
380
381     if ( defined $self->{'views'}{$view_name} ) {
382         return $self->error(qq[Can't create view: "$view_name" exists]);
383     }
384     else {
385         $self->{'views'}{$view_name} = $view;
386     }
387
388     return $view;
389 }
390
391 # ----------------------------------------------------------------------
392 sub drop_view {
393
394 =pod
395
396 =head2 drop_view
397
398 Remove a view from the schema. Returns the view object if the view was found
399 and removed, an error otherwise. The single parameter can be either a view
400 name or an C<SQL::Translator::Schema::View> object.
401
402   $schema->drop_view('myview');
403
404 =cut
405
406     my $self       = shift;
407     my $view_class = 'SQL::Translator::Schema::View';
408     my $view_name;
409
410     if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
411         $view_name = shift->name;
412     }
413     else {
414         $view_name = shift;
415     }
416
417     if ( !exists $self->{'views'}{$view_name} ) {
418         return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
419     }
420
421     my $view = delete $self->{'views'}{$view_name};
422
423     return $view;
424 }
425
426 # ----------------------------------------------------------------------
427 sub database {
428
429 =pod
430
431 =head2 database
432
433 Get or set the schema's database.  (optional)
434
435   my $database = $schema->database('PostgreSQL');
436
437 =cut
438
439     my $self = shift;
440     $self->{'database'} = shift if @_;
441     return $self->{'database'} || '';
442 }
443
444 # ----------------------------------------------------------------------
445 sub is_valid {
446
447 =pod
448
449 =head2 is_valid
450
451 Returns true if all the tables and views are valid.
452
453   my $ok = $schema->is_valid or die $schema->error;
454
455 =cut
456
457     my $self = shift;
458
459     return $self->error('No tables') unless $self->get_tables;
460
461     for my $object ( $self->get_tables, $self->get_views ) {
462         return $object->error unless $object->is_valid;
463     }
464
465     return 1;
466 }
467
468 # ----------------------------------------------------------------------
469 sub get_procedure {
470
471 =pod
472
473 =head2 get_procedure
474
475 Returns a procedure by the name provided.
476
477   my $procedure = $schema->get_procedure('foo');
478
479 =cut
480
481     my $self = shift;
482     my $procedure_name = shift or return $self->error('No procedure name');
483     return $self->error(qq[Table "$procedure_name" does not exist])
484       unless exists $self->{'procedures'}{$procedure_name};
485     return $self->{'procedures'}{$procedure_name};
486 }
487
488 # ----------------------------------------------------------------------
489 sub get_procedures {
490
491 =pod
492
493 =head2 get_procedures
494
495 Returns all the procedures as an array or array reference.
496
497   my @procedures = $schema->get_procedures;
498
499 =cut
500
501     my $self       = shift;
502     my @procedures =
503       map  { $_->[1] }
504       sort { $a->[0] <=> $b->[0] }
505       map  { [ $_->order, $_ ] } values %{ $self->{'procedures'} };
506
507     if (@procedures) {
508         return wantarray ? @procedures : \@procedures;
509     }
510     else {
511         $self->error('No procedures');
512         return wantarray ? () : undef;
513     }
514 }
515
516 # ----------------------------------------------------------------------
517 sub get_table {
518
519 =pod
520
521 =head2 get_table
522
523 Returns a table by the name provided.
524
525   my $table = $schema->get_table('foo');
526
527 =cut
528
529     my $self = shift;
530     my $table_name = shift or return $self->error('No table name');
531     return $self->error(qq[Table "$table_name" does not exist])
532       unless exists $self->{'tables'}{$table_name};
533     return $self->{'tables'}{$table_name};
534 }
535
536 # ----------------------------------------------------------------------
537 sub get_tables {
538
539 =pod
540
541 =head2 get_tables
542
543 Returns all the tables as an array or array reference.
544
545   my @tables = $schema->get_tables;
546
547 =cut
548
549     my $self   = shift;
550     my @tables =
551       map  { $_->[1] }
552       sort { $a->[0] <=> $b->[0] }
553       map  { [ $_->order, $_ ] } values %{ $self->{'tables'} };
554
555     if (@tables) {
556         return wantarray ? @tables : \@tables;
557     }
558     else {
559         $self->error('No tables');
560         return wantarray ? () : undef;
561     }
562 }
563
564 # ----------------------------------------------------------------------
565 sub get_trigger {
566
567 =pod
568
569 =head2 get_trigger
570
571 Returns a trigger by the name provided.
572
573   my $trigger = $schema->get_trigger('foo');
574
575 =cut
576
577     my $self = shift;
578     my $trigger_name = shift or return $self->error('No trigger name');
579     return $self->error(qq[Table "$trigger_name" does not exist])
580       unless exists $self->{'triggers'}{$trigger_name};
581     return $self->{'triggers'}{$trigger_name};
582 }
583
584 # ----------------------------------------------------------------------
585 sub get_triggers {
586
587 =pod
588
589 =head2 get_triggers
590
591 Returns all the triggers as an array or array reference.
592
593   my @triggers = $schema->get_triggers;
594
595 =cut
596
597     my $self     = shift;
598     my @triggers =
599       map  { $_->[1] }
600       sort { $a->[0] <=> $b->[0] }
601       map  { [ $_->order, $_ ] } values %{ $self->{'triggers'} };
602
603     if (@triggers) {
604         return wantarray ? @triggers : \@triggers;
605     }
606     else {
607         $self->error('No triggers');
608         return wantarray ? () : undef;
609     }
610 }
611
612 # ----------------------------------------------------------------------
613 sub get_view {
614
615 =pod
616
617 =head2 get_view
618
619 Returns a view by the name provided.
620
621   my $view = $schema->get_view('foo');
622
623 =cut
624
625     my $self = shift;
626     my $view_name = shift or return $self->error('No view name');
627     return $self->error('View "$view_name" does not exist')
628       unless exists $self->{'views'}{$view_name};
629     return $self->{'views'}{$view_name};
630 }
631
632 # ----------------------------------------------------------------------
633 sub get_views {
634
635 =pod
636
637 =head2 get_views
638
639 Returns all the views as an array or array reference.
640
641   my @views = $schema->get_views;
642
643 =cut
644
645     my $self  = shift;
646     my @views =
647       map  { $_->[1] }
648       sort { $a->[0] <=> $b->[0] }
649       map  { [ $_->order, $_ ] } values %{ $self->{'views'} };
650
651     if (@views) {
652         return wantarray ? @views : \@views;
653     }
654     else {
655         $self->error('No views');
656         return wantarray ? () : undef;
657     }
658 }
659
660 # ----------------------------------------------------------------------
661 sub make_natural_joins {
662
663 =pod
664
665 =head2 make_natural_joins
666
667 Creates foriegn key relationships among like-named fields in different
668 tables.  Accepts the following arguments:
669
670 =over 4
671
672 =item * join_pk_only
673
674 A True or False argument which determins whether or not to perform 
675 the joins from primary keys to fields of the same name in other tables
676
677 =item * skip_fields
678
679 A list of fields to skip in the joins
680
681 =back 4
682
683   $schema->make_natural_joins(
684       join_pk_only => 1,
685       skip_fields  => 'name,department_id',
686   );
687
688 =cut
689
690     my $self         = shift;
691     my %args         = @_;
692     my $join_pk_only = $args{'join_pk_only'} || 0;
693     my %skip_fields  =
694       map { s/^\s+|\s+$//g; $_, 1 } @{ parse_list_arg( $args{'skip_fields'} ) };
695
696     my ( %common_keys, %pk );
697     for my $table ( $self->get_tables ) {
698         for my $field ( $table->get_fields ) {
699             my $field_name = $field->name or next;
700             next if $skip_fields{$field_name};
701             $pk{$field_name} = 1 if $field->is_primary_key;
702             push @{ $common_keys{$field_name} }, $table->name;
703         }
704     }
705
706     for my $field ( keys %common_keys ) {
707         next if $join_pk_only and !defined $pk{$field};
708
709         my @table_names = @{ $common_keys{$field} };
710         next unless scalar @table_names > 1;
711
712         for my $i ( 0 .. $#table_names ) {
713             my $table1 = $self->get_table( $table_names[$i] ) or next;
714
715             for my $j ( 1 .. $#table_names ) {
716                 my $table2 = $self->get_table( $table_names[$j] ) or next;
717                 next if $table1->name eq $table2->name;
718
719                 $table1->add_constraint(
720                     type             => FOREIGN_KEY,
721                     fields           => $field,
722                     reference_table  => $table2->name,
723                     reference_fields => $field,
724                 );
725             }
726         }
727     }
728
729     return 1;
730 }
731
732 # ----------------------------------------------------------------------
733 sub name {
734
735 =pod
736
737 =head2 name
738
739 Get or set the schema's name.  (optional)
740
741   my $schema_name = $schema->name('Foo Database');
742
743 =cut
744
745     my $self = shift;
746     $self->{'name'} = shift if @_;
747     return $self->{'name'} || '';
748 }
749
750 # ----------------------------------------------------------------------
751 sub translator {
752
753 =pod
754
755 =head2 translator
756
757 Get the SQL::Translator instance that instantiated the parser.
758
759 =cut
760
761     my $self = shift;
762     $self->{'translator'} = shift if @_;
763     return $self->{'translator'};
764 }
765
766 # ----------------------------------------------------------------------
767 sub DESTROY {
768     my $self = shift;
769     undef $_ for values %{ $self->{'tables'} };
770     undef $_ for values %{ $self->{'views'} };
771 }
772
773 1;
774
775 # ----------------------------------------------------------------------
776
777 =pod
778
779 =head1 AUTHOR
780
781 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
782
783 =cut
784