lib/SQL/Translator/Schema.pm

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