1 package SQL::Translator::Schema;
7 SQL::Translator::Schema - SQL::Translator schema object
11 use SQL::Translator::Schema;
12 my $schema = SQL::Translator::Schema->new(
16 my $table = $schema->add_table( name => 'foo' );
17 my $view = $schema->add_view( name => 'bar', sql => '...' );
22 C<SQL::Translator::Schema> is the object that accepts, validates, and
23 returns the database structure.
30 use SQL::Translator::Schema::Constants;
31 use SQL::Translator::Schema::Procedure;
32 use SQL::Translator::Schema::Table;
33 use SQL::Translator::Schema::Trigger;
34 use SQL::Translator::Schema::View;
36 use SQL::Translator::Utils 'parse_list_arg';
38 use base 'SQL::Translator::Schema::Object';
39 use vars qw[ $VERSION ];
43 __PACKAGE__->_attributes(qw/name database translator/);
47 my $self = $class->SUPER::new (@_)
50 $self->{_order} = { map { $_ => 0 } qw/
60 # ----------------------------------------------------------------------
67 Returns the schema as an L<SQL::Translator::Schema::Graph> object.
70 require SQL::Translator::Schema::Graph;
74 return SQL::Translator::Schema::Graph->new(
75 translator => $self->translator );
78 # ----------------------------------------------------------------------
85 Returns a Graph::Directed object with the table names for nodes.
89 require Graph::Directed;
92 my $g = Graph::Directed->new;
94 for my $table ( $self->get_tables ) {
95 my $tname = $table->name;
96 $g->add_vertex( $tname );
98 for my $field ( $table->get_fields ) {
99 if ( $field->is_foreign_key ) {
100 my $fktable = $field->foreign_key_reference->reference_table;
102 $g->add_edge( $fktable, $tname );
110 # ----------------------------------------------------------------------
117 Add a table object. Returns the new SQL::Translator::Schema::Table object.
118 The "name" parameter is required. If you try to create a table with the
119 same name as an existing table, you will get an error and the table will
122 my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
123 my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
124 $t2 = $schema->add_table( $table_bar ) or die $schema->error;
129 my $table_class = 'SQL::Translator::Schema::Table';
132 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
134 $table->schema($self);
137 my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
138 $args{'schema'} = $self;
139 $table = $table_class->new( \%args )
140 or return $self->error( $table_class->error );
143 $table->order( ++$self->{_order}{table} );
145 # We know we have a name as the Table->new above errors if none given.
146 my $table_name = $table->name;
148 if ( defined $self->{'tables'}{$table_name} ) {
149 return $self->error(qq[Can't create table: "$table_name" exists]);
152 $self->{'tables'}{$table_name} = $table;
158 # ----------------------------------------------------------------------
165 Remove a table from the schema. Returns the table object if the table was found
166 and removed, an error otherwise. The single parameter can be either a table
167 name or an C<SQL::Translator::Schema::Table> object. The "cascade" parameter
168 can be set to 1 to also drop all triggers on the table, default is 0.
170 $schema->drop_table('mytable');
171 $schema->drop_table('mytable', cascade => 1);
176 my $table_class = 'SQL::Translator::Schema::Table';
179 if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
180 $table_name = shift->name;
186 my $cascade = $args{'cascade'};
188 if ( !exists $self->{'tables'}{$table_name} ) {
189 return $self->error(qq[Can't drop table: $table_name" doesn't exist]);
192 my $table = delete $self->{'tables'}{$table_name};
196 # Drop all triggers on this table
197 $self->drop_trigger()
198 for ( grep { $_->on_table eq $table_name } @{ $self->{'triggers'} } );
203 # ----------------------------------------------------------------------
210 Add a procedure object. Returns the new SQL::Translator::Schema::Procedure
211 object. The "name" parameter is required. If you try to create a procedure
212 with the same name as an existing procedure, you will get an error and the
213 procedure will not be created.
215 my $p1 = $schema->add_procedure( name => 'foo' );
216 my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
217 $p2 = $schema->add_procedure( $procedure_bar ) or die $schema->error;
222 my $procedure_class = 'SQL::Translator::Schema::Procedure';
225 if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
227 $procedure->schema($self);
230 my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
231 $args{'schema'} = $self;
232 return $self->error('No procedure name') unless $args{'name'};
233 $procedure = $procedure_class->new( \%args )
234 or return $self->error( $procedure_class->error );
237 $procedure->order( ++$self->{_order}{proc} );
238 my $procedure_name = $procedure->name
239 or return $self->error('No procedure name');
241 if ( defined $self->{'procedures'}{$procedure_name} ) {
243 qq[Can't create procedure: "$procedure_name" exists] );
246 $self->{'procedures'}{$procedure_name} = $procedure;
252 # ----------------------------------------------------------------------
257 =head2 drop_procedure
259 Remove a procedure from the schema. Returns the procedure object if the
260 procedure was found and removed, an error otherwise. The single parameter
261 can be either a procedure name or an C<SQL::Translator::Schema::Procedure>
264 $schema->drop_procedure('myprocedure');
269 my $proc_class = 'SQL::Translator::Schema::Procedure';
272 if ( UNIVERSAL::isa( $_[0], $proc_class ) ) {
273 $proc_name = shift->name;
279 if ( !exists $self->{'procedures'}{$proc_name} ) {
281 qq[Can't drop procedure: $proc_name" doesn't exist]);
284 my $proc = delete $self->{'procedures'}{$proc_name};
289 # ----------------------------------------------------------------------
296 Add a trigger object. Returns the new SQL::Translator::Schema::Trigger object.
297 The "name" parameter is required. If you try to create a trigger with the
298 same name as an existing trigger, you will get an error and the trigger will
301 my $t1 = $schema->add_trigger( name => 'foo' );
302 my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
303 $t2 = $schema->add_trigger( $trigger_bar ) or die $schema->error;
308 my $trigger_class = 'SQL::Translator::Schema::Trigger';
311 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
313 $trigger->schema($self);
316 my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
317 $args{'schema'} = $self;
318 return $self->error('No trigger name') unless $args{'name'};
319 $trigger = $trigger_class->new( \%args )
320 or return $self->error( $trigger_class->error );
323 $trigger->order( ++$self->{_order}{trigger} );
325 my $trigger_name = $trigger->name or return $self->error('No trigger name');
326 if ( defined $self->{'triggers'}{$trigger_name} ) {
327 return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
330 $self->{'triggers'}{$trigger_name} = $trigger;
336 # ----------------------------------------------------------------------
343 Remove a trigger from the schema. Returns the trigger object if the trigger was
344 found and removed, an error otherwise. The single parameter can be either a
345 trigger name or an C<SQL::Translator::Schema::Trigger> object.
347 $schema->drop_trigger('mytrigger');
352 my $trigger_class = 'SQL::Translator::Schema::Trigger';
355 if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
356 $trigger_name = shift->name;
359 $trigger_name = shift;
362 if ( !exists $self->{'triggers'}{$trigger_name} ) {
364 qq[Can't drop trigger: $trigger_name" doesn't exist]);
367 my $trigger = delete $self->{'triggers'}{$trigger_name};
372 # ----------------------------------------------------------------------
379 Add a view object. Returns the new SQL::Translator::Schema::View object.
380 The "name" parameter is required. If you try to create a view with the
381 same name as an existing view, you will get an error and the view will
384 my $v1 = $schema->add_view( name => 'foo' );
385 my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
386 $v2 = $schema->add_view( $view_bar ) or die $schema->error;
391 my $view_class = 'SQL::Translator::Schema::View';
394 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
396 $view->schema($self);
399 my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
400 $args{'schema'} = $self;
401 return $self->error('No view name') unless $args{'name'};
402 $view = $view_class->new( \%args ) or return $view_class->error;
405 $view->order( ++$self->{_order}{view} );
406 my $view_name = $view->name or return $self->error('No view name');
408 if ( defined $self->{'views'}{$view_name} ) {
409 return $self->error(qq[Can't create view: "$view_name" exists]);
412 $self->{'views'}{$view_name} = $view;
418 # ----------------------------------------------------------------------
425 Remove a view from the schema. Returns the view object if the view was found
426 and removed, an error otherwise. The single parameter can be either a view
427 name or an C<SQL::Translator::Schema::View> object.
429 $schema->drop_view('myview');
434 my $view_class = 'SQL::Translator::Schema::View';
437 if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
438 $view_name = shift->name;
444 if ( !exists $self->{'views'}{$view_name} ) {
445 return $self->error(qq[Can't drop view: $view_name" doesn't exist]);
448 my $view = delete $self->{'views'}{$view_name};
453 # ----------------------------------------------------------------------
460 Get or set the schema's database. (optional)
462 my $database = $schema->database('PostgreSQL');
467 $self->{'database'} = shift if @_;
468 return $self->{'database'} || '';
471 # ----------------------------------------------------------------------
478 Returns true if all the tables and views are valid.
480 my $ok = $schema->is_valid or die $schema->error;
486 return $self->error('No tables') unless $self->get_tables;
488 for my $object ( $self->get_tables, $self->get_views ) {
489 return $object->error unless $object->is_valid;
495 # ----------------------------------------------------------------------
502 Returns a procedure by the name provided.
504 my $procedure = $schema->get_procedure('foo');
509 my $procedure_name = shift or return $self->error('No procedure name');
510 return $self->error(qq[Table "$procedure_name" does not exist])
511 unless exists $self->{'procedures'}{$procedure_name};
512 return $self->{'procedures'}{$procedure_name};
515 # ----------------------------------------------------------------------
520 =head2 get_procedures
522 Returns all the procedures as an array or array reference.
524 my @procedures = $schema->get_procedures;
531 sort { $a->[0] <=> $b->[0] }
532 map { [ $_->order, $_ ] } values %{ $self->{'procedures'} };
535 return wantarray ? @procedures : \@procedures;
538 $self->error('No procedures');
539 return wantarray ? () : undef;
543 # ----------------------------------------------------------------------
550 Returns a table by the name provided.
552 my $table = $schema->get_table('foo');
557 my $table_name = shift or return $self->error('No table name');
558 my $case_insensitive = shift;
559 if ( $case_insensitive ) {
560 $table_name = uc($table_name);
561 foreach my $table ( keys %{$self->{tables}} ) {
562 return $self->{tables}{$table} if $table_name eq uc($table);
564 return $self->error(qq[Table "$table_name" does not exist]);
566 return $self->error(qq[Table "$table_name" does not exist])
567 unless exists $self->{'tables'}{$table_name};
568 return $self->{'tables'}{$table_name};
571 # ----------------------------------------------------------------------
578 Returns all the tables as an array or array reference.
580 my @tables = $schema->get_tables;
587 sort { $a->[0] <=> $b->[0] }
588 map { [ $_->order, $_ ] } values %{ $self->{'tables'} };
591 return wantarray ? @tables : \@tables;
594 $self->error('No tables');
595 return wantarray ? () : undef;
599 # ----------------------------------------------------------------------
606 Returns a trigger by the name provided.
608 my $trigger = $schema->get_trigger('foo');
613 my $trigger_name = shift or return $self->error('No trigger name');
614 return $self->error(qq[Table "$trigger_name" does not exist])
615 unless exists $self->{'triggers'}{$trigger_name};
616 return $self->{'triggers'}{$trigger_name};
619 # ----------------------------------------------------------------------
626 Returns all the triggers as an array or array reference.
628 my @triggers = $schema->get_triggers;
635 sort { $a->[0] <=> $b->[0] }
636 map { [ $_->order, $_ ] } values %{ $self->{'triggers'} };
639 return wantarray ? @triggers : \@triggers;
642 $self->error('No triggers');
643 return wantarray ? () : undef;
647 # ----------------------------------------------------------------------
654 Returns a view by the name provided.
656 my $view = $schema->get_view('foo');
661 my $view_name = shift or return $self->error('No view name');
662 return $self->error('View "$view_name" does not exist')
663 unless exists $self->{'views'}{$view_name};
664 return $self->{'views'}{$view_name};
667 # ----------------------------------------------------------------------
674 Returns all the views as an array or array reference.
676 my @views = $schema->get_views;
683 sort { $a->[0] <=> $b->[0] }
684 map { [ $_->order, $_ ] } values %{ $self->{'views'} };
687 return wantarray ? @views : \@views;
690 $self->error('No views');
691 return wantarray ? () : undef;
695 # ----------------------------------------------------------------------
696 sub make_natural_joins {
700 =head2 make_natural_joins
702 Creates foriegn key relationships among like-named fields in different
703 tables. Accepts the following arguments:
709 A True or False argument which determins whether or not to perform
710 the joins from primary keys to fields of the same name in other tables
714 A list of fields to skip in the joins
718 $schema->make_natural_joins(
720 skip_fields => 'name,department_id',
727 my $join_pk_only = $args{'join_pk_only'} || 0;
729 map { s/^\s+|\s+$//g; $_, 1 } @{ parse_list_arg( $args{'skip_fields'} ) };
731 my ( %common_keys, %pk );
732 for my $table ( $self->get_tables ) {
733 for my $field ( $table->get_fields ) {
734 my $field_name = $field->name or next;
735 next if $skip_fields{$field_name};
736 $pk{$field_name} = 1 if $field->is_primary_key;
737 push @{ $common_keys{$field_name} }, $table->name;
741 for my $field ( keys %common_keys ) {
742 next if $join_pk_only and !defined $pk{$field};
744 my @table_names = @{ $common_keys{$field} };
745 next unless scalar @table_names > 1;
747 for my $i ( 0 .. $#table_names ) {
748 my $table1 = $self->get_table( $table_names[$i] ) or next;
750 for my $j ( 1 .. $#table_names ) {
751 my $table2 = $self->get_table( $table_names[$j] ) or next;
752 next if $table1->name eq $table2->name;
754 $table1->add_constraint(
757 reference_table => $table2->name,
758 reference_fields => $field,
767 # ----------------------------------------------------------------------
774 Get or set the schema's name. (optional)
776 my $schema_name = $schema->name('Foo Database');
781 $self->{'name'} = shift if @_;
782 return $self->{'name'} || '';
785 # ----------------------------------------------------------------------
792 Get the SQL::Translator instance that instantiated the parser.
797 $self->{'translator'} = shift if @_;
798 return $self->{'translator'};
801 # ----------------------------------------------------------------------
804 undef $_ for values %{ $self->{'tables'} };
805 undef $_ for values %{ $self->{'views'} };
810 # ----------------------------------------------------------------------
816 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.