lib/SQL/Translator/Schema.pm

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