While trying to create CDBI classes myself, I found some of the decisions
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Schema.pm
CommitLineData
3c5de62a 1package SQL::Translator::Schema;
2
97382c6d 3# vim: sw=4: ts=4:
4
3c5de62a 5# ----------------------------------------------------------------------
da8ab524 6# $Id: Schema.pm,v 1.23 2005-06-08 15:31:06 mwz444 Exp $
3c5de62a 7# ----------------------------------------------------------------------
977651a5 8# Copyright (C) 2002-4 SQLFairy Authors
3c5de62a 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
29SQL::Translator::Schema - SQL::Translator schema object
30
31=head1 SYNOPSIS
32
33 use SQL::Translator::Schema;
97382c6d 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
3c5de62a 41
42=head1 DESCSIPTION
43
44C<SQL::Translator::Schema> is the object that accepts, validates, and
45returns the database structure.
46
47=head1 METHODS
48
49=cut
50
51use strict;
9480e70b 52use SQL::Translator::Schema::Constants;
daf24e05 53use SQL::Translator::Schema::Procedure;
3c5de62a 54use SQL::Translator::Schema::Table;
5974bee7 55use SQL::Translator::Schema::Trigger;
3c5de62a 56use SQL::Translator::Schema::View;
b046b0b9 57use SQL::Translator::Schema::Graph;
5974bee7 58use SQL::Translator::Utils 'parse_list_arg';
3c5de62a 59
b6a880d1 60use base 'SQL::Translator::Schema::Object';
daf24e05 61use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
3c5de62a 62
da8ab524 63$VERSION = sprintf "%d.%02d", q$Revision: 1.23 $ =~ /(\d+)\.(\d+)/;
9371be50 64
da8ab524 65__PACKAGE__->_attributes(qw/name database translator/);
3c5de62a 66
97382c6d 67# ----------------------------------------------------------------------
68sub as_graph {
69
3c5de62a 70=pod
71
97382c6d 72=head2 as_graph
3c5de62a 73
97382c6d 74Returns the schema as an L<SQL::Translator::Schema::Graph> object.
3c5de62a 75
76=cut
77
da8ab524 78 my $self = shift;
97382c6d 79 return SQL::Translator::Schema::Graph->new(
da8ab524 80 translator => $self->translator );
10f36920 81}
82
3c5de62a 83# ----------------------------------------------------------------------
76dce619 84sub add_table {
3c5de62a 85
86=pod
87
76dce619 88=head2 add_table
3c5de62a 89
76dce619 90Add a table object. Returns the new SQL::Translator::Schema::Table object.
99248301 91The "name" parameter is required. If you try to create a table with the
92same name as an existing table, you will get an error and the table will
93not be created.
3c5de62a 94
68e8e2e1 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;
3c5de62a 98
99=cut
100
99248301 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;
da8ab524 107 $table->schema($self);
99248301 108 }
109 else {
110 my %args = @_;
111 $args{'schema'} = $self;
da8ab524 112 $table = $table_class->new( \%args )
113 or return $self->error( $table_class->error );
99248301 114 }
3c5de62a 115
d0b43695 116 $table->order( ++$TABLE_ORDER );
da8ab524 117
23044758 118 # We know we have a name as the Table->new above errors if none given.
119 my $table_name = $table->name;
99248301 120
da8ab524 121 if ( defined $self->{'tables'}{$table_name} ) {
99248301 122 return $self->error(qq[Can't create table: "$table_name" exists]);
123 }
124 else {
da8ab524 125 $self->{'tables'}{$table_name} = $table;
99248301 126 }
3c5de62a 127
128 return $table;
129}
130
131# ----------------------------------------------------------------------
650f87eb 132sub drop_table {
133
134=pod
135
136=head2 drop_table
137
138Remove a table from the schema. Returns the table object if the table was found
139and removed, an error otherwise. The single parameter can be either a table
140name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
141can 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
da8ab524 148 my $self = shift;
149 my $table_class = 'SQL::Translator::Schema::Table';
650f87eb 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 }
da8ab524 158 my %args = @_;
650f87eb 159 my $cascade = $args{'cascade'};
160
da8ab524 161 if ( !exists $self->{'tables'}{$table_name} ) {
650f87eb 162 return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
163 }
164
da8ab524 165 my $table = delete $self->{'tables'}{$table_name};
166
167 if ($cascade) {
650f87eb 168
650f87eb 169 # Drop all triggers on this table
da8ab524 170 $self->drop_trigger()
171 for ( grep { $_->on_table eq $table_name } @{ $self->{'triggers'} } );
650f87eb 172 }
173 return $table;
174}
175
176# ----------------------------------------------------------------------
daf24e05 177sub add_procedure {
178
179=pod
180
181=head2 add_procedure
182
650f87eb 183Add a procedure object. Returns the new SQL::Translator::Schema::Procedure
184object. The "name" parameter is required. If you try to create a procedure
185with the same name as an existing procedure, you will get an error and the
186procedure will not be created.
daf24e05 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;
da8ab524 200 $procedure->schema($self);
daf24e05 201 }
202 else {
203 my %args = @_;
204 $args{'schema'} = $self;
205 return $self->error('No procedure name') unless $args{'name'};
da8ab524 206 $procedure = $procedure_class->new( \%args )
207 or return $self->error( $procedure_class->error );
daf24e05 208 }
209
210 $procedure->order( ++$PROC_ORDER );
da8ab524 211 my $procedure_name = $procedure->name
212 or return $self->error('No procedure name');
daf24e05 213
da8ab524 214 if ( defined $self->{'procedures'}{$procedure_name} ) {
daf24e05 215 return $self->error(
da8ab524 216 qq[Can't create procedure: "$procedure_name" exists] );
daf24e05 217 }
218 else {
da8ab524 219 $self->{'procedures'}{$procedure_name} = $procedure;
daf24e05 220 }
221
222 return $procedure;
223}
da8ab524 224
650f87eb 225# ----------------------------------------------------------------------
226sub drop_procedure {
227
228=pod
229
230=head2 drop_procedure
231
232Remove a procedure from the schema. Returns the procedure object if the
233procedure was found and removed, an error otherwise. The single parameter
234can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
235object.
236
237 $schema->drop_procedure('myprocedure');
238
239=cut
240
da8ab524 241 my $self = shift;
242 my $proc_class = 'SQL::Translator::Schema::Procedure';
650f87eb 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
da8ab524 252 if ( !exists $self->{'procedures'}{$proc_name} ) {
253 return $self->error(
254 qq[Can't drop procedure: $proc_name" doesn't exist]);
650f87eb 255 }
256
da8ab524 257 my $proc = delete $self->{'procedures'}{$proc_name};
650f87eb 258
259 return $proc;
260}
daf24e05 261
262# ----------------------------------------------------------------------
5974bee7 263sub add_trigger {
264
265=pod
266
267=head2 add_trigger
268
269Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
270The "name" parameter is required. If you try to create a trigger with the
271same name as an existing trigger, you will get an error and the trigger will
272not 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;
da8ab524 286 $trigger->schema($self);
5974bee7 287 }
288 else {
289 my %args = @_;
daf24e05 290 $args{'schema'} = $self;
5974bee7 291 return $self->error('No trigger name') unless $args{'name'};
da8ab524 292 $trigger = $trigger_class->new( \%args )
293 or return $self->error( $trigger_class->error );
5974bee7 294 }
295
296 $trigger->order( ++$TRIGGER_ORDER );
297 my $trigger_name = $trigger->name or return $self->error('No trigger name');
298
da8ab524 299 if ( defined $self->{'triggers'}{$trigger_name} ) {
5974bee7 300 return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
301 }
302 else {
da8ab524 303 $self->{'triggers'}{$trigger_name} = $trigger;
5974bee7 304 }
305
306 return $trigger;
307}
da8ab524 308
650f87eb 309# ----------------------------------------------------------------------
310sub drop_trigger {
311
312=pod
313
314=head2 drop_trigger
315
316Remove a trigger from the schema. Returns the trigger object if the trigger was
317found and removed, an error otherwise. The single parameter can be either a
318trigger name or an C<SQL::Translator::Schema::Trigger> object.
319
320 $schema->drop_trigger('mytrigger');
321
322=cut
323
da8ab524 324 my $self = shift;
325 my $trigger_class = 'SQL::Translator::Schema::Trigger';
650f87eb 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
da8ab524 335 if ( !exists $self->{'triggers'}{$trigger_name} ) {
336 return $self->error(
337 qq[Can't drop trigger: $trigger_name" doesn't exist]);
650f87eb 338 }
339
da8ab524 340 my $trigger = delete $self->{'triggers'}{$trigger_name};
650f87eb 341
342 return $trigger;
343}
5974bee7 344
345# ----------------------------------------------------------------------
76dce619 346sub add_view {
3c5de62a 347
348=pod
349
76dce619 350=head2 add_view
3c5de62a 351
76dce619 352Add a view object. Returns the new SQL::Translator::Schema::View object.
99248301 353The "name" parameter is required. If you try to create a view with the
354same name as an existing view, you will get an error and the view will
355not be created.
356
68e8e2e1 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;
3c5de62a 360
361=cut
362
da8ab524 363 my $self = shift;
99248301 364 my $view_class = 'SQL::Translator::Schema::View';
365 my $view;
366
367 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
368 $view = shift;
da8ab524 369 $view->schema($self);
99248301 370 }
371 else {
372 my %args = @_;
daf24e05 373 $args{'schema'} = $self;
99248301 374 return $self->error('No view name') unless $args{'name'};
375 $view = $view_class->new( \%args ) or return $view_class->error;
376 }
3c5de62a 377
d0b43695 378 $view->order( ++$VIEW_ORDER );
99248301 379 my $view_name = $view->name or return $self->error('No view name');
380
da8ab524 381 if ( defined $self->{'views'}{$view_name} ) {
99248301 382 return $self->error(qq[Can't create view: "$view_name" exists]);
383 }
384 else {
da8ab524 385 $self->{'views'}{$view_name} = $view;
99248301 386 }
3c5de62a 387
76dce619 388 return $view;
3c5de62a 389}
390
391# ----------------------------------------------------------------------
650f87eb 392sub drop_view {
393
394=pod
395
396=head2 drop_view
397
398Remove a view from the schema. Returns the view object if the view was found
399and removed, an error otherwise. The single parameter can be either a view
400name or an C<SQL::Translator::Schema::View> object.
401
402 $schema->drop_view('myview');
403
404=cut
405
da8ab524 406 my $self = shift;
407 my $view_class = 'SQL::Translator::Schema::View';
650f87eb 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
da8ab524 417 if ( !exists $self->{'views'}{$view_name} ) {
650f87eb 418 return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
419 }
420
da8ab524 421 my $view = delete $self->{'views'}{$view_name};
650f87eb 422
423 return $view;
424}
425
426# ----------------------------------------------------------------------
99248301 427sub database {
428
429=pod
430
431=head2 database
432
433Get 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# ----------------------------------------------------------------------
76dce619 445sub is_valid {
3c5de62a 446
447=pod
448
76dce619 449=head2 is_valid
3c5de62a 450
76dce619 451Returns true if all the tables and views are valid.
3c5de62a 452
76dce619 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# ----------------------------------------------------------------------
daf24e05 469sub get_procedure {
470
471=pod
472
473=head2 get_procedure
474
475Returns a procedure by the name provided.
476
477 my $procedure = $schema->get_procedure('foo');
478
479=cut
480
da8ab524 481 my $self = shift;
daf24e05 482 my $procedure_name = shift or return $self->error('No procedure name');
da8ab524 483 return $self->error(qq[Table "$procedure_name" does not exist])
484 unless exists $self->{'procedures'}{$procedure_name};
485 return $self->{'procedures'}{$procedure_name};
daf24e05 486}
487
488# ----------------------------------------------------------------------
489sub get_procedures {
490
491=pod
492
493=head2 get_procedures
494
495Returns all the procedures as an array or array reference.
496
497 my @procedures = $schema->get_procedures;
498
499=cut
500
da8ab524 501 my $self = shift;
502 my @procedures =
503 map { $_->[1] }
504 sort { $a->[0] <=> $b->[0] }
505 map { [ $_->order, $_ ] } values %{ $self->{'procedures'} };
daf24e05 506
da8ab524 507 if (@procedures) {
daf24e05 508 return wantarray ? @procedures : \@procedures;
509 }
510 else {
511 $self->error('No procedures');
512 return wantarray ? () : undef;
513 }
514}
515
516# ----------------------------------------------------------------------
76dce619 517sub get_table {
518
519=pod
520
521=head2 get_table
522
523Returns a table by the name provided.
524
525 my $table = $schema->get_table('foo');
526
527=cut
528
da8ab524 529 my $self = shift;
76dce619 530 my $table_name = shift or return $self->error('No table name');
da8ab524 531 return $self->error(qq[Table "$table_name" does not exist])
532 unless exists $self->{'tables'}{$table_name};
533 return $self->{'tables'}{$table_name};
76dce619 534}
535
536# ----------------------------------------------------------------------
537sub get_tables {
538
539=pod
540
541=head2 get_tables
542
543Returns all the tables as an array or array reference.
544
545 my @tables = $schema->get_tables;
546
547=cut
548
549 my $self = shift;
da8ab524 550 my @tables =
551 map { $_->[1] }
552 sort { $a->[0] <=> $b->[0] }
553 map { [ $_->order, $_ ] } values %{ $self->{'tables'} };
76dce619 554
da8ab524 555 if (@tables) {
76dce619 556 return wantarray ? @tables : \@tables;
557 }
558 else {
559 $self->error('No tables');
560 return wantarray ? () : undef;
561 }
562}
563
564# ----------------------------------------------------------------------
daf24e05 565sub get_trigger {
566
567=pod
568
569=head2 get_trigger
570
571Returns a trigger by the name provided.
572
573 my $trigger = $schema->get_trigger('foo');
574
575=cut
576
da8ab524 577 my $self = shift;
daf24e05 578 my $trigger_name = shift or return $self->error('No trigger name');
da8ab524 579 return $self->error(qq[Table "$trigger_name" does not exist])
580 unless exists $self->{'triggers'}{$trigger_name};
581 return $self->{'triggers'}{$trigger_name};
daf24e05 582}
583
584# ----------------------------------------------------------------------
585sub get_triggers {
586
587=pod
588
589=head2 get_triggers
590
591Returns all the triggers as an array or array reference.
592
593 my @triggers = $schema->get_triggers;
594
595=cut
596
da8ab524 597 my $self = shift;
598 my @triggers =
599 map { $_->[1] }
600 sort { $a->[0] <=> $b->[0] }
601 map { [ $_->order, $_ ] } values %{ $self->{'triggers'} };
daf24e05 602
da8ab524 603 if (@triggers) {
daf24e05 604 return wantarray ? @triggers : \@triggers;
605 }
606 else {
607 $self->error('No triggers');
608 return wantarray ? () : undef;
609 }
610}
611
612# ----------------------------------------------------------------------
76dce619 613sub get_view {
614
615=pod
616
617=head2 get_view
618
619Returns a view by the name provided.
620
621 my $view = $schema->get_view('foo');
3c5de62a 622
623=cut
624
da8ab524 625 my $self = shift;
76dce619 626 my $view_name = shift or return $self->error('No view name');
da8ab524 627 return $self->error('View "$view_name" does not exist')
628 unless exists $self->{'views'}{$view_name};
629 return $self->{'views'}{$view_name};
76dce619 630}
3c5de62a 631
76dce619 632# ----------------------------------------------------------------------
633sub get_views {
3c5de62a 634
76dce619 635=pod
636
637=head2 get_views
638
639Returns all the views as an array or array reference.
640
641 my @views = $schema->get_views;
642
643=cut
644
645 my $self = shift;
da8ab524 646 my @views =
647 map { $_->[1] }
648 sort { $a->[0] <=> $b->[0] }
649 map { [ $_->order, $_ ] } values %{ $self->{'views'} };
76dce619 650
da8ab524 651 if (@views) {
76dce619 652 return wantarray ? @views : \@views;
653 }
654 else {
655 $self->error('No views');
656 return wantarray ? () : undef;
657 }
3c5de62a 658}
659
99248301 660# ----------------------------------------------------------------------
9480e70b 661sub make_natural_joins {
662
663=pod
664
665=head2 make_natural_joins
666
667Creates foriegn key relationships among like-named fields in different
668tables. Accepts the following arguments:
669
670=over 4
671
650f87eb 672=item * join_pk_only
9480e70b 673
674A True or False argument which determins whether or not to perform
675the joins from primary keys to fields of the same name in other tables
676
677=item * skip_fields
678
679A 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;
da8ab524 693 my %skip_fields =
694 map { s/^\s+|\s+$//g; $_, 1 } @{ parse_list_arg( $args{'skip_fields'} ) };
9480e70b 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;
da8ab524 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;
9480e70b 703 }
da8ab524 704 }
705
9480e70b 706 for my $field ( keys %common_keys ) {
da8ab524 707 next if $join_pk_only and !defined $pk{$field};
9480e70b 708
da8ab524 709 my @table_names = @{ $common_keys{$field} };
9480e70b 710 next unless scalar @table_names > 1;
711
712 for my $i ( 0 .. $#table_names ) {
da8ab524 713 my $table1 = $self->get_table( $table_names[$i] ) or next;
9480e70b 714
715 for my $j ( 1 .. $#table_names ) {
da8ab524 716 my $table2 = $self->get_table( $table_names[$j] ) or next;
9480e70b 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 );
650f87eb 725 }
9480e70b 726 }
650f87eb 727 }
9480e70b 728
729 return 1;
730}
731
732# ----------------------------------------------------------------------
99248301 733sub name {
734
735=pod
736
737=head2 name
738
739Get 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
97382c6d 750# ----------------------------------------------------------------------
751sub translator {
752
753=pod
754
10f36920 755=head2 translator
47fed978 756
97382c6d 757Get the SQL::Translator instance that instantiated the parser.
47fed978 758
759=cut
760
47fed978 761 my $self = shift;
10f36920 762 $self->{'translator'} = shift if @_;
763 return $self->{'translator'};
47fed978 764}
765
d0b43695 766# ----------------------------------------------------------------------
767sub DESTROY {
768 my $self = shift;
769 undef $_ for values %{ $self->{'tables'} };
da8ab524 770 undef $_ for values %{ $self->{'views'} };
d0b43695 771}
772
3c5de62a 7731;
774
775# ----------------------------------------------------------------------
776
777=pod
778
779=head1 AUTHOR
780
97382c6d 781Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
3c5de62a 782
783=cut
da8ab524 784