1 package SQL::Translator::Schema;
5 # ----------------------------------------------------------------------
6 # $Id: Schema.pm,v 1.27 2007-10-24 10:58:35 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;
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.27 $ =~ /(\d+)\.(\d+)/;
65 __PACKAGE__->_attributes(qw/name database translator/);
67 # ----------------------------------------------------------------------
74 Returns the schema as an L<SQL::Translator::Schema::Graph> object.
77 require SQL::Translator::Schema::Graph;
81 return SQL::Translator::Schema::Graph->new(
82 translator => $self->translator );
85 # ----------------------------------------------------------------------
92 Returns a Graph::Directed object with the table names for nodes.
96 require Graph::Directed;
99 my $g = Graph::Directed->new;
101 for my $table ( $self->get_tables ) {
102 my $tname = $table->name;
103 $g->add_vertex( $tname );
105 for my $field ( $table->get_fields ) {
106 if ( $field->is_foreign_key ) {
107 my $fktable = $field->foreign_key_reference->reference_table;
109 $g->add_edge( $fktable, $tname );
117 # ----------------------------------------------------------------------
124 Add a table object. Returns the new SQL::Translator::Schema::Table object.
125 The "name" parameter is required. If you try to create a table with the
126 same name as an existing table, you will get an error and the table will
129 my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
130 my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
131 $t2 = $schema->add_table( $table_bar ) or die $schema->error;
136 my $table_class = 'SQL::Translator::Schema::Table';
139 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
141 $table->schema($self);
145 $args{'schema'} = $self;
146 $table = $table_class->new( \%args )
147 or return $self->error( $table_class->error );
150 $table->order( ++$TABLE_ORDER );
152 # We know we have a name as the Table->new above errors if none given.
153 my $table_name = $table->name;
155 if ( defined $self->{'tables'}{$table_name} ) {
156 return $self->error(qq[Can't create table: "$table_name" exists]);
159 $self->{'tables'}{$table_name} = $table;
165 # ----------------------------------------------------------------------
172 Remove a table from the schema. Returns the table object if the table was found
173 and removed, an error otherwise. The single parameter can be either a table
174 name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
175 can be set to 1 to also drop all triggers on the table, default is 0.
177 $schema->drop_table('mytable');
178 $schema->drop_table('mytable', cascade => 1);
183 my $table_class = 'SQL::Translator::Schema::Table';
186 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
187 $table_name = shift->name;
193 my $cascade = $args{'cascade'};
195 if ( !exists $self->{'tables'}{$table_name} ) {
196 return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
199 my $table = delete $self->{'tables'}{$table_name};
203 # Drop all triggers on this table
204 $self->drop_trigger()
205 for ( grep { $_->on_table eq $table_name } @{ $self->{'triggers'} } );
210 # ----------------------------------------------------------------------
217 Add a procedure object. Returns the new SQL::Translator::Schema::Procedure
218 object. The "name" parameter is required. If you try to create a procedure
219 with the same name as an existing procedure, you will get an error and the
220 procedure will not be created.
222 my $p1 = $schema->add_procedure( name => 'foo' );
223 my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
224 $p2 = $schema->add_procedure( $procedure_bar ) or die $schema->error;
229 my $procedure_class = 'SQL::Translator::Schema::Procedure';
232 if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
234 $procedure->schema($self);
238 $args{'schema'} = $self;
239 return $self->error('No procedure name') unless $args{'name'};
240 $procedure = $procedure_class->new( \%args )
241 or return $self->error( $procedure_class->error );
244 $procedure->order( ++$PROC_ORDER );
245 my $procedure_name = $procedure->name
246 or return $self->error('No procedure name');
248 if ( defined $self->{'procedures'}{$procedure_name} ) {
250 qq[Can't create procedure: "$procedure_name" exists] );
253 $self->{'procedures'}{$procedure_name} = $procedure;
259 # ----------------------------------------------------------------------
264 =head2 drop_procedure
266 Remove a procedure from the schema. Returns the procedure object if the
267 procedure was found and removed, an error otherwise. The single parameter
268 can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
271 $schema->drop_procedure('myprocedure');
276 my $proc_class = 'SQL::Translator::Schema::Procedure';
279 if ( UNIVERSAL::isa( $_[0], $proc_class ) ) {
280 $proc_name = shift->name;
286 if ( !exists $self->{'procedures'}{$proc_name} ) {
288 qq[Can't drop procedure: $proc_name" doesn't exist]);
291 my $proc = delete $self->{'procedures'}{$proc_name};
296 # ----------------------------------------------------------------------
303 Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
304 The "name" parameter is required. If you try to create a trigger with the
305 same name as an existing trigger, you will get an error and the trigger will
308 my $t1 = $schema->add_trigger( name => 'foo' );
309 my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
310 $t2 = $schema->add_trigger( $trigger_bar ) or die $schema->error;
315 my $trigger_class = 'SQL::Translator::Schema::Trigger';
318 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
320 $trigger->schema($self);
324 $args{'schema'} = $self;
325 return $self->error('No trigger name') unless $args{'name'};
326 $trigger = $trigger_class->new( \%args )
327 or return $self->error( $trigger_class->error );
330 $trigger->order( ++$TRIGGER_ORDER );
332 my $trigger_name = $trigger->name or return $self->error('No trigger name');
333 if ( defined $self->{'triggers'}{$trigger_name} ) {
334 return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
337 $self->{'triggers'}{$trigger_name} = $trigger;
343 # ----------------------------------------------------------------------
350 Remove a trigger from the schema. Returns the trigger object if the trigger was
351 found and removed, an error otherwise. The single parameter can be either a
352 trigger name or an C<SQL::Translator::Schema::Trigger> object.
354 $schema->drop_trigger('mytrigger');
359 my $trigger_class = 'SQL::Translator::Schema::Trigger';
362 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
363 $trigger_name = shift->name;
366 $trigger_name = shift;
369 if ( !exists $self->{'triggers'}{$trigger_name} ) {
371 qq[Can't drop trigger: $trigger_name" doesn't exist]);
374 my $trigger = delete $self->{'triggers'}{$trigger_name};
379 # ----------------------------------------------------------------------
386 Add a view object. Returns the new SQL::Translator::Schema::View object.
387 The "name" parameter is required. If you try to create a view with the
388 same name as an existing view, you will get an error and the view will
391 my $v1 = $schema->add_view( name => 'foo' );
392 my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
393 $v2 = $schema->add_view( $view_bar ) or die $schema->error;
398 my $view_class = 'SQL::Translator::Schema::View';
401 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
403 $view->schema($self);
407 $args{'schema'} = $self;
408 return $self->error('No view name') unless $args{'name'};
409 $view = $view_class->new( \%args ) or return $view_class->error;
412 $view->order( ++$VIEW_ORDER );
413 my $view_name = $view->name or return $self->error('No view name');
415 if ( defined $self->{'views'}{$view_name} ) {
416 return $self->error(qq[Can't create view: "$view_name" exists]);
419 $self->{'views'}{$view_name} = $view;
425 # ----------------------------------------------------------------------
432 Remove a view from the schema. Returns the view object if the view was found
433 and removed, an error otherwise. The single parameter can be either a view
434 name or an C<SQL::Translator::Schema::View> object.
436 $schema->drop_view('myview');
441 my $view_class = 'SQL::Translator::Schema::View';
444 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
445 $view_name = shift->name;
451 if ( !exists $self->{'views'}{$view_name} ) {
452 return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
455 my $view = delete $self->{'views'}{$view_name};
460 # ----------------------------------------------------------------------
467 Get or set the schema's database. (optional)
469 my $database = $schema->database('PostgreSQL');
474 $self->{'database'} = shift if @_;
475 return $self->{'database'} || '';
478 # ----------------------------------------------------------------------
485 Returns true if all the tables and views are valid.
487 my $ok = $schema->is_valid or die $schema->error;
493 return $self->error('No tables') unless $self->get_tables;
495 for my $object ( $self->get_tables, $self->get_views ) {
496 return $object->error unless $object->is_valid;
502 # ----------------------------------------------------------------------
509 Returns a procedure by the name provided.
511 my $procedure = $schema->get_procedure('foo');
516 my $procedure_name = shift or return $self->error('No procedure name');
517 return $self->error(qq[Table "$procedure_name" does not exist])
518 unless exists $self->{'procedures'}{$procedure_name};
519 return $self->{'procedures'}{$procedure_name};
522 # ----------------------------------------------------------------------
527 =head2 get_procedures
529 Returns all the procedures as an array or array reference.
531 my @procedures = $schema->get_procedures;
538 sort { $a->[0] <=> $b->[0] }
539 map { [ $_->order, $_ ] } values %{ $self->{'procedures'} };
542 return wantarray ? @procedures : \@procedures;
545 $self->error('No procedures');
546 return wantarray ? () : undef;
550 # ----------------------------------------------------------------------
557 Returns a table by the name provided.
559 my $table = $schema->get_table('foo');
564 my $table_name = shift or return $self->error('No table name');
565 my $case_insensitive = shift;
566 if ( $case_insensitive ) {
567 $table_name = uc($table_name);
568 foreach my $table ( keys %{$self->{tables}} ) {
569 return $self->{tables}{$table} if $table_name eq uc($table);
571 return $self->error(qq[Table "$table_name" does not exist]);
573 return $self->error(qq[Table "$table_name" does not exist])
574 unless exists $self->{'tables'}{$table_name};
575 return $self->{'tables'}{$table_name};
578 # ----------------------------------------------------------------------
585 Returns all the tables as an array or array reference.
587 my @tables = $schema->get_tables;
594 sort { $a->[0] <=> $b->[0] }
595 map { [ $_->order, $_ ] } values %{ $self->{'tables'} };
598 return wantarray ? @tables : \@tables;
601 $self->error('No tables');
602 return wantarray ? () : undef;
606 # ----------------------------------------------------------------------
613 Returns a trigger by the name provided.
615 my $trigger = $schema->get_trigger('foo');
620 my $trigger_name = shift or return $self->error('No trigger name');
621 return $self->error(qq[Table "$trigger_name" does not exist])
622 unless exists $self->{'triggers'}{$trigger_name};
623 return $self->{'triggers'}{$trigger_name};
626 # ----------------------------------------------------------------------
633 Returns all the triggers as an array or array reference.
635 my @triggers = $schema->get_triggers;
642 sort { $a->[0] <=> $b->[0] }
643 map { [ $_->order, $_ ] } values %{ $self->{'triggers'} };
646 return wantarray ? @triggers : \@triggers;
649 $self->error('No triggers');
650 return wantarray ? () : undef;
654 # ----------------------------------------------------------------------
661 Returns a view by the name provided.
663 my $view = $schema->get_view('foo');
668 my $view_name = shift or return $self->error('No view name');
669 return $self->error('View "$view_name" does not exist')
670 unless exists $self->{'views'}{$view_name};
671 return $self->{'views'}{$view_name};
674 # ----------------------------------------------------------------------
681 Returns all the views as an array or array reference.
683 my @views = $schema->get_views;
690 sort { $a->[0] <=> $b->[0] }
691 map { [ $_->order, $_ ] } values %{ $self->{'views'} };
694 return wantarray ? @views : \@views;
697 $self->error('No views');
698 return wantarray ? () : undef;
702 # ----------------------------------------------------------------------
703 sub make_natural_joins {
707 =head2 make_natural_joins
709 Creates foriegn key relationships among like-named fields in different
710 tables. Accepts the following arguments:
716 A True or False argument which determins whether or not to perform
717 the joins from primary keys to fields of the same name in other tables
721 A list of fields to skip in the joins
725 $schema->make_natural_joins(
727 skip_fields => 'name,department_id',
734 my $join_pk_only = $args{'join_pk_only'} || 0;
736 map { s/^\s+|\s+$//g; $_, 1 } @{ parse_list_arg( $args{'skip_fields'} ) };
738 my ( %common_keys, %pk );
739 for my $table ( $self->get_tables ) {
740 for my $field ( $table->get_fields ) {
741 my $field_name = $field->name or next;
742 next if $skip_fields{$field_name};
743 $pk{$field_name} = 1 if $field->is_primary_key;
744 push @{ $common_keys{$field_name} }, $table->name;
748 for my $field ( keys %common_keys ) {
749 next if $join_pk_only and !defined $pk{$field};
751 my @table_names = @{ $common_keys{$field} };
752 next unless scalar @table_names > 1;
754 for my $i ( 0 .. $#table_names ) {
755 my $table1 = $self->get_table( $table_names[$i] ) or next;
757 for my $j ( 1 .. $#table_names ) {
758 my $table2 = $self->get_table( $table_names[$j] ) or next;
759 next if $table1->name eq $table2->name;
761 $table1->add_constraint(
764 reference_table => $table2->name,
765 reference_fields => $field,
774 # ----------------------------------------------------------------------
781 Get or set the schema's name. (optional)
783 my $schema_name = $schema->name('Foo Database');
788 $self->{'name'} = shift if @_;
789 return $self->{'name'} || '';
792 # ----------------------------------------------------------------------
799 Get the SQL::Translator instance that instantiated the parser.
804 $self->{'translator'} = shift if @_;
805 return $self->{'translator'};
808 # ----------------------------------------------------------------------
811 undef $_ for values %{ $self->{'tables'} };
812 undef $_ for values %{ $self->{'views'} };
817 # ----------------------------------------------------------------------
823 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.