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