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