lib/SQL/Translator/Schema.pm

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