1 package SQL::Translator::Schema;
5 # ----------------------------------------------------------------------
6 # $Id: Schema.pm,v 1.26 2006-06-07 16:43:41 schiffbruechige Exp $
7 # ----------------------------------------------------------------------
8 # Copyright (C) 2002-4 SQLFairy Authors
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.
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.
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
23 # -------------------------------------------------------------------
29 SQL::Translator::Schema - SQL::Translator schema object
33 use SQL::Translator::Schema;
34 my $schema = SQL::Translator::Schema->new(
38 my $table = $schema->add_table( name => 'foo' );
39 my $view = $schema->add_view( name => 'bar', sql => '...' );
44 C<SQL::Translator::Schema> is the object that accepts, validates, and
45 returns the database structure.
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';
60 use base 'SQL::Translator::Schema::Object';
61 use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
63 $VERSION = sprintf "%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/;
65 __PACKAGE__->_attributes(qw/name database translator/);
67 # ----------------------------------------------------------------------
74 Returns the schema as an L<SQL::Translator::Schema::Graph> object.
79 return SQL::Translator::Schema::Graph->new(
80 translator => $self->translator );
83 # ----------------------------------------------------------------------
90 Returns a Graph::Directed object with the table names for nodes.
95 my $g = Graph::Directed->new;
97 for my $table ( $self->get_tables ) {
98 my $tname = $table->name;
99 $g->add_vertex( $tname );
101 for my $field ( $table->get_fields ) {
102 if ( $field->is_foreign_key ) {
103 my $fktable = $field->foreign_key_reference->reference_table;
105 $g->add_edge( $fktable, $tname );
113 # ----------------------------------------------------------------------
120 Add a table object. Returns the new SQL::Translator::Schema::Table object.
121 The "name" parameter is required. If you try to create a table with the
122 same name as an existing table, you will get an error and the table will
125 my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
126 my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
127 $t2 = $schema->add_table( $table_bar ) or die $schema->error;
132 my $table_class = 'SQL::Translator::Schema::Table';
135 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
137 $table->schema($self);
141 $args{'schema'} = $self;
142 $table = $table_class->new( \%args )
143 or return $self->error( $table_class->error );
146 $table->order( ++$TABLE_ORDER );
148 # We know we have a name as the Table->new above errors if none given.
149 my $table_name = $table->name;
151 if ( defined $self->{'tables'}{$table_name} ) {
152 return $self->error(qq[Can't create table: "$table_name" exists]);
155 $self->{'tables'}{$table_name} = $table;
161 # ----------------------------------------------------------------------
168 Remove a table from the schema. Returns the table object if the table was found
169 and removed, an error otherwise. The single parameter can be either a table
170 name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
171 can be set to 1 to also drop all triggers on the table, default is 0.
173 $schema->drop_table('mytable');
174 $schema->drop_table('mytable', cascade => 1);
179 my $table_class = 'SQL::Translator::Schema::Table';
182 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
183 $table_name = shift->name;
189 my $cascade = $args{'cascade'};
191 if ( !exists $self->{'tables'}{$table_name} ) {
192 return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
195 my $table = delete $self->{'tables'}{$table_name};
199 # Drop all triggers on this table
200 $self->drop_trigger()
201 for ( grep { $_->on_table eq $table_name } @{ $self->{'triggers'} } );
206 # ----------------------------------------------------------------------
213 Add a procedure object. Returns the new SQL::Translator::Schema::Procedure
214 object. The "name" parameter is required. If you try to create a procedure
215 with the same name as an existing procedure, you will get an error and the
216 procedure will not be created.
218 my $p1 = $schema->add_procedure( name => 'foo' );
219 my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
220 $p2 = $schema->add_procedure( $procedure_bar ) or die $schema->error;
225 my $procedure_class = 'SQL::Translator::Schema::Procedure';
228 if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
230 $procedure->schema($self);
234 $args{'schema'} = $self;
235 return $self->error('No procedure name') unless $args{'name'};
236 $procedure = $procedure_class->new( \%args )
237 or return $self->error( $procedure_class->error );
240 $procedure->order( ++$PROC_ORDER );
241 my $procedure_name = $procedure->name
242 or return $self->error('No procedure name');
244 if ( defined $self->{'procedures'}{$procedure_name} ) {
246 qq[Can't create procedure: "$procedure_name" exists] );
249 $self->{'procedures'}{$procedure_name} = $procedure;
255 # ----------------------------------------------------------------------
260 =head2 drop_procedure
262 Remove a procedure from the schema. Returns the procedure object if the
263 procedure was found and removed, an error otherwise. The single parameter
264 can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
267 $schema->drop_procedure('myprocedure');
272 my $proc_class = 'SQL::Translator::Schema::Procedure';
275 if ( UNIVERSAL::isa( $_[0], $proc_class ) ) {
276 $proc_name = shift->name;
282 if ( !exists $self->{'procedures'}{$proc_name} ) {
284 qq[Can't drop procedure: $proc_name" doesn't exist]);
287 my $proc = delete $self->{'procedures'}{$proc_name};
292 # ----------------------------------------------------------------------
299 Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
300 The "name" parameter is required. If you try to create a trigger with the
301 same name as an existing trigger, you will get an error and the trigger will
304 my $t1 = $schema->add_trigger( name => 'foo' );
305 my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
306 $t2 = $schema->add_trigger( $trigger_bar ) or die $schema->error;
311 my $trigger_class = 'SQL::Translator::Schema::Trigger';
314 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
316 $trigger->schema($self);
320 $args{'schema'} = $self;
321 return $self->error('No trigger name') unless $args{'name'};
322 $trigger = $trigger_class->new( \%args )
323 or return $self->error( $trigger_class->error );
326 $trigger->order( ++$TRIGGER_ORDER );
328 my $trigger_name = $trigger->name or return $self->error('No trigger name');
329 if ( defined $self->{'triggers'}{$trigger_name} ) {
330 return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
333 $self->{'triggers'}{$trigger_name} = $trigger;
339 # ----------------------------------------------------------------------
346 Remove a trigger from the schema. Returns the trigger object if the trigger was
347 found and removed, an error otherwise. The single parameter can be either a
348 trigger name or an C<SQL::Translator::Schema::Trigger> object.
350 $schema->drop_trigger('mytrigger');
355 my $trigger_class = 'SQL::Translator::Schema::Trigger';
358 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
359 $trigger_name = shift->name;
362 $trigger_name = shift;
365 if ( !exists $self->{'triggers'}{$trigger_name} ) {
367 qq[Can't drop trigger: $trigger_name" doesn't exist]);
370 my $trigger = delete $self->{'triggers'}{$trigger_name};
375 # ----------------------------------------------------------------------
382 Add a view object. Returns the new SQL::Translator::Schema::View object.
383 The "name" parameter is required. If you try to create a view with the
384 same name as an existing view, you will get an error and the view will
387 my $v1 = $schema->add_view( name => 'foo' );
388 my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
389 $v2 = $schema->add_view( $view_bar ) or die $schema->error;
394 my $view_class = 'SQL::Translator::Schema::View';
397 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
399 $view->schema($self);
403 $args{'schema'} = $self;
404 return $self->error('No view name') unless $args{'name'};
405 $view = $view_class->new( \%args ) or return $view_class->error;
408 $view->order( ++$VIEW_ORDER );
409 my $view_name = $view->name or return $self->error('No view name');
411 if ( defined $self->{'views'}{$view_name} ) {
412 return $self->error(qq[Can't create view: "$view_name" exists]);
415 $self->{'views'}{$view_name} = $view;
421 # ----------------------------------------------------------------------
428 Remove a view from the schema. Returns the view object if the view was found
429 and removed, an error otherwise. The single parameter can be either a view
430 name or an C<SQL::Translator::Schema::View> object.
432 $schema->drop_view('myview');
437 my $view_class = 'SQL::Translator::Schema::View';
440 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
441 $view_name = shift->name;
447 if ( !exists $self->{'views'}{$view_name} ) {
448 return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
451 my $view = delete $self->{'views'}{$view_name};
456 # ----------------------------------------------------------------------
463 Get or set the schema's database. (optional)
465 my $database = $schema->database('PostgreSQL');
470 $self->{'database'} = shift if @_;
471 return $self->{'database'} || '';
474 # ----------------------------------------------------------------------
481 Returns true if all the tables and views are valid.
483 my $ok = $schema->is_valid or die $schema->error;
489 return $self->error('No tables') unless $self->get_tables;
491 for my $object ( $self->get_tables, $self->get_views ) {
492 return $object->error unless $object->is_valid;
498 # ----------------------------------------------------------------------
505 Returns a procedure by the name provided.
507 my $procedure = $schema->get_procedure('foo');
512 my $procedure_name = shift or return $self->error('No procedure name');
513 return $self->error(qq[Table "$procedure_name" does not exist])
514 unless exists $self->{'procedures'}{$procedure_name};
515 return $self->{'procedures'}{$procedure_name};
518 # ----------------------------------------------------------------------
523 =head2 get_procedures
525 Returns all the procedures as an array or array reference.
527 my @procedures = $schema->get_procedures;
534 sort { $a->[0] <=> $b->[0] }
535 map { [ $_->order, $_ ] } values %{ $self->{'procedures'} };
538 return wantarray ? @procedures : \@procedures;
541 $self->error('No procedures');
542 return wantarray ? () : undef;
546 # ----------------------------------------------------------------------
553 Returns a table by the name provided.
555 my $table = $schema->get_table('foo');
560 my $table_name = shift or return $self->error('No table name');
561 my $case_insensitive = shift;
562 if ( $case_insensitive ) {
563 $table_name = uc($table_name);
564 foreach my $table ( keys %{$self->{tables}} ) {
565 return $self->{tables}{$table} if $table_name eq uc($table);
567 return $self->error(qq[Table "$table_name" does not exist]);
569 return $self->error(qq[Table "$table_name" does not exist])
570 unless exists $self->{'tables'}{$table_name};
571 return $self->{'tables'}{$table_name};
574 # ----------------------------------------------------------------------
581 Returns all the tables as an array or array reference.
583 my @tables = $schema->get_tables;
590 sort { $a->[0] <=> $b->[0] }
591 map { [ $_->order, $_ ] } values %{ $self->{'tables'} };
594 return wantarray ? @tables : \@tables;
597 $self->error('No tables');
598 return wantarray ? () : undef;
602 # ----------------------------------------------------------------------
609 Returns a trigger by the name provided.
611 my $trigger = $schema->get_trigger('foo');
616 my $trigger_name = shift or return $self->error('No trigger name');
617 return $self->error(qq[Table "$trigger_name" does not exist])
618 unless exists $self->{'triggers'}{$trigger_name};
619 return $self->{'triggers'}{$trigger_name};
622 # ----------------------------------------------------------------------
629 Returns all the triggers as an array or array reference.
631 my @triggers = $schema->get_triggers;
638 sort { $a->[0] <=> $b->[0] }
639 map { [ $_->order, $_ ] } values %{ $self->{'triggers'} };
642 return wantarray ? @triggers : \@triggers;
645 $self->error('No triggers');
646 return wantarray ? () : undef;
650 # ----------------------------------------------------------------------
657 Returns a view by the name provided.
659 my $view = $schema->get_view('foo');
664 my $view_name = shift or return $self->error('No view name');
665 return $self->error('View "$view_name" does not exist')
666 unless exists $self->{'views'}{$view_name};
667 return $self->{'views'}{$view_name};
670 # ----------------------------------------------------------------------
677 Returns all the views as an array or array reference.
679 my @views = $schema->get_views;
686 sort { $a->[0] <=> $b->[0] }
687 map { [ $_->order, $_ ] } values %{ $self->{'views'} };
690 return wantarray ? @views : \@views;
693 $self->error('No views');
694 return wantarray ? () : undef;
698 # ----------------------------------------------------------------------
699 sub make_natural_joins {
703 =head2 make_natural_joins
705 Creates foriegn key relationships among like-named fields in different
706 tables. Accepts the following arguments:
712 A True or False argument which determins whether or not to perform
713 the joins from primary keys to fields of the same name in other tables
717 A list of fields to skip in the joins
721 $schema->make_natural_joins(
723 skip_fields => 'name,department_id',
730 my $join_pk_only = $args{'join_pk_only'} || 0;
732 map { s/^\s+|\s+$//g; $_, 1 } @{ parse_list_arg( $args{'skip_fields'} ) };
734 my ( %common_keys, %pk );
735 for my $table ( $self->get_tables ) {
736 for my $field ( $table->get_fields ) {
737 my $field_name = $field->name or next;
738 next if $skip_fields{$field_name};
739 $pk{$field_name} = 1 if $field->is_primary_key;
740 push @{ $common_keys{$field_name} }, $table->name;
744 for my $field ( keys %common_keys ) {
745 next if $join_pk_only and !defined $pk{$field};
747 my @table_names = @{ $common_keys{$field} };
748 next unless scalar @table_names > 1;
750 for my $i ( 0 .. $#table_names ) {
751 my $table1 = $self->get_table( $table_names[$i] ) or next;
753 for my $j ( 1 .. $#table_names ) {
754 my $table2 = $self->get_table( $table_names[$j] ) or next;
755 next if $table1->name eq $table2->name;
757 $table1->add_constraint(
760 reference_table => $table2->name,
761 reference_fields => $field,
770 # ----------------------------------------------------------------------
777 Get or set the schema's name. (optional)
779 my $schema_name = $schema->name('Foo Database');
784 $self->{'name'} = shift if @_;
785 return $self->{'name'} || '';
788 # ----------------------------------------------------------------------
795 Get the SQL::Translator instance that instantiated the parser.
800 $self->{'translator'} = shift if @_;
801 return $self->{'translator'};
804 # ----------------------------------------------------------------------
807 undef $_ for values %{ $self->{'tables'} };
808 undef $_ for values %{ $self->{'views'} };
813 # ----------------------------------------------------------------------
819 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.