lib/SQL/Translator/Schema.pm

   1 package SQL::Translator::Schema;
   2
   3 # ----------------------------------------------------------------------
   4 # $Id: Schema.pm,v 1.17 2004-10-15 02:23:30 allenday 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 Class::Base;
  47 use SQL::Translator::Schema::Constants;
  48 use SQL::Translator::Schema::Procedure;
  49 use SQL::Translator::Schema::Table;
  50 use SQL::Translator::Schema::Trigger;
  51 use SQL::Translator::Schema::View;
  52 use SQL::Translator::Schema::Graph;
  53 use SQL::Translator::Utils 'parse_list_arg';
  54
  55 use base 'Class::Base';
  56 use vars qw[ $VERSION $TABLE_ORDER $VIEW_ORDER $TRIGGER_ORDER $PROC_ORDER ];
  57
  58 $VERSION = sprintf "%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/;
  59
  60 # ----------------------------------------------------------------------
  61 sub init {
  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     my ( $self, $config ) = @_;
  77     $self->params( $config, qw[ name database parser_args producer_args ] )
  78       || return undef;
  79     return $self;
  80 }
  81
  82 # ----------------------------------------------------------------------
  83 sub add_table {
  84
  85 =pod
  86
  87 =head2 add_table
  88
  89 Add a table object.  Returns the new SQL::Translator::Schema::Table object.
  90 The "name" parameter is required.  If you try to create a table with the
  91 same name as an existing table, you will get an error and the table will
  92 not be created.
  93
  94   my $t1 = $schema->add_table( name => 'foo' ) or die $schema->error;
  95   my $t2 = SQL::Translator::Schema::Table->new( name => 'bar' );
  96   $t2    = $schema->add_table( $table_bar ) or die $schema->error;
  97
  98 =cut
  99
 100     my $self        = shift;
 101     my $table_class = 'SQL::Translator::Schema::Table';
 102     my $table;
 103
 104     if ( UNIVERSAL::isa( $_[0], $table_class ) ) {
 105         $table = shift;
 106         $table->schema( $self );
 107     }
 108     else {
 109         my %args = @_;
 110         $args{'schema'} = $self;
 111         $table = $table_class->new( \%args ) or return
 112             $self->error( $table_class->error );
 113     }
 114
 115     $table->order( ++$TABLE_ORDER );
 116     # We know we have a name as the Table->new above errors if none given.
 117     my $table_name = $table->name;
 118
 119     if ( defined $self->{'tables'}{ $table_name } ) {
 120         return $self->error(qq[Can't create table: "$table_name" exists]);
 121     }
 122     else {
 123         $self->{'tables'}{ $table_name } = $table;
 124     }
 125
 126     return $table;
 127 }
 128
 129 # ----------------------------------------------------------------------
 130 sub add_procedure {
 131
 132 =pod
 133
 134 =head2 add_procedure
 135
 136 Add a procedure object.  Returns the new
 137 SQL::Translator::Schema::Procedure object.  The "name" parameter is
 138 required.  If you try to create a procedure with the same name as an
 139 existing procedure, you will get an error and the procedure will not
 140 be created.
 141
 142   my $p1 = $schema->add_procedure( name => 'foo' );
 143   my $p2 = SQL::Translator::Schema::Procedure->new( name => 'bar' );
 144   $p2    = $schema->add_procedure( $procedure_bar ) or die $schema->error;
 145
 146 =cut
 147
 148     my $self            = shift;
 149     my $procedure_class = 'SQL::Translator::Schema::Procedure';
 150     my $procedure;
 151
 152     if ( UNIVERSAL::isa( $_[0], $procedure_class ) ) {
 153         $procedure = shift;
 154         $procedure->schema( $self );
 155     }
 156     else {
 157         my %args = @_;
 158         $args{'schema'} = $self;
 159         return $self->error('No procedure name') unless $args{'name'};
 160         $procedure = $procedure_class->new( \%args ) or
 161             return $self->error( $procedure_class->error );
 162     }
 163
 164     $procedure->order( ++$PROC_ORDER );
 165     my $procedure_name = $procedure->name or return
 166         $self->error('No procedure name');
 167
 168     if ( defined $self->{'procedures'}{ $procedure_name } ) {
 169         return $self->error(
 170             qq[Can't create procedure: "$procedure_name" exists]
 171         );
 172     }
 173     else {
 174         $self->{'procedures'}{ $procedure_name } = $procedure;
 175     }
 176
 177     return $procedure;
 178 }
 179
 180 # ----------------------------------------------------------------------
 181 sub add_trigger {
 182
 183 =pod
 184
 185 =head2 add_trigger
 186
 187 Add a trigger object.  Returns the new SQL::Translator::Schema::Trigger object.
 188 The "name" parameter is required.  If you try to create a trigger with the
 189 same name as an existing trigger, you will get an error and the trigger will
 190 not be created.
 191
 192   my $t1 = $schema->add_trigger( name => 'foo' );
 193   my $t2 = SQL::Translator::Schema::Trigger->new( name => 'bar' );
 194   $t2    = $schema->add_trigger( $trigger_bar ) or die $schema->error;
 195
 196 =cut
 197
 198     my $self          = shift;
 199     my $trigger_class = 'SQL::Translator::Schema::Trigger';
 200     my $trigger;
 201
 202     if ( UNIVERSAL::isa( $_[0], $trigger_class ) ) {
 203         $trigger = shift;
 204         $trigger->schema( $self );
 205     }
 206     else {
 207         my %args = @_;
 208         $args{'schema'} = $self;
 209         return $self->error('No trigger name') unless $args{'name'};
 210         $trigger = $trigger_class->new( \%args ) or
 211             return $self->error( $trigger_class->error );
 212     }
 213
 214     $trigger->order( ++$TRIGGER_ORDER );
 215     my $trigger_name = $trigger->name or return $self->error('No trigger name');
 216
 217     if ( defined $self->{'triggers'}{ $trigger_name } ) {
 218         return $self->error(qq[Can't create trigger: "$trigger_name" exists]);
 219     }
 220     else {
 221         $self->{'triggers'}{ $trigger_name } = $trigger;
 222     }
 223
 224     return $trigger;
 225 }
 226
 227 # ----------------------------------------------------------------------
 228 sub add_view {
 229
 230 =pod
 231
 232 =head2 add_view
 233
 234 Add a view object.  Returns the new SQL::Translator::Schema::View object.
 235 The "name" parameter is required.  If you try to create a view with the
 236 same name as an existing view, you will get an error and the view will
 237 not be created.
 238
 239   my $v1 = $schema->add_view( name => 'foo' );
 240   my $v2 = SQL::Translator::Schema::View->new( name => 'bar' );
 241   $v2    = $schema->add_view( $view_bar ) or die $schema->error;
 242
 243 =cut
 244
 245     my $self        = shift;
 246     my $view_class = 'SQL::Translator::Schema::View';
 247     my $view;
 248
 249     if ( UNIVERSAL::isa( $_[0], $view_class ) ) {
 250         $view = shift;
 251         $view->schema( $self );
 252     }
 253     else {
 254         my %args = @_;
 255         $args{'schema'} = $self;
 256         return $self->error('No view name') unless $args{'name'};
 257         $view = $view_class->new( \%args ) or return $view_class->error;
 258     }
 259
 260     $view->order( ++$VIEW_ORDER );
 261     my $view_name = $view->name or return $self->error('No view name');
 262
 263     if ( defined $self->{'views'}{ $view_name } ) {
 264         return $self->error(qq[Can't create view: "$view_name" exists]);
 265     }
 266     else {
 267         $self->{'views'}{ $view_name } = $view;
 268     }
 269
 270     return $view;
 271 }
 272
 273 # ----------------------------------------------------------------------
 274 sub database {
 275
 276 =pod
 277
 278 =head2 database
 279
 280 Get or set the schema's database.  (optional)
 281
 282   my $database = $schema->database('PostgreSQL');
 283
 284 =cut
 285
 286     my $self = shift;
 287     $self->{'database'} = shift if @_;
 288     return $self->{'database'} || '';
 289 }
 290
 291 # ----------------------------------------------------------------------
 292 sub is_valid {
 293
 294 =pod
 295
 296 =head2 is_valid
 297
 298 Returns true if all the tables and views are valid.
 299
 300   my $ok = $schema->is_valid or die $schema->error;
 301
 302 =cut
 303
 304     my $self = shift;
 305
 306     return $self->error('No tables') unless $self->get_tables;
 307
 308     for my $object ( $self->get_tables, $self->get_views ) {
 309         return $object->error unless $object->is_valid;
 310     }
 311
 312     return 1;
 313 }
 314
 315 # ----------------------------------------------------------------------
 316 sub get_procedure {
 317
 318 =pod
 319
 320 =head2 get_procedure
 321
 322 Returns a procedure by the name provided.
 323
 324   my $procedure = $schema->get_procedure('foo');
 325
 326 =cut
 327
 328     my $self       = shift;
 329     my $procedure_name = shift or return $self->error('No procedure name');
 330     return $self->error( qq[Table "$procedure_name" does not exist] ) unless
 331         exists $self->{'procedures'}{ $procedure_name };
 332     return $self->{'procedures'}{ $procedure_name };
 333 }
 334
 335 # ----------------------------------------------------------------------
 336 sub get_procedures {
 337
 338 =pod
 339
 340 =head2 get_procedures
 341
 342 Returns all the procedures as an array or array reference.
 343
 344   my @procedures = $schema->get_procedures;
 345
 346 =cut
 347
 348     my $self   = shift;
 349     my @procedures =
 350         map  { $_->[1] }
 351         sort { $a->[0] <=> $b->[0] }
 352         map  { [ $_->order, $_ ] }
 353         values %{ $self->{'procedures'} };
 354
 355     if ( @procedures ) {
 356         return wantarray ? @procedures : \@procedures;
 357     }
 358     else {
 359         $self->error('No procedures');
 360         return wantarray ? () : undef;
 361     }
 362 }
 363
 364 # ----------------------------------------------------------------------
 365 sub get_table {
 366
 367 =pod
 368
 369 =head2 get_table
 370
 371 Returns a table by the name provided.
 372
 373   my $table = $schema->get_table('foo');
 374
 375 =cut
 376
 377     my $self       = shift;
 378     my $table_name = shift or return $self->error('No table name');
 379     return $self->error( qq[Table "$table_name" does not exist] ) unless
 380         exists $self->{'tables'}{ $table_name };
 381     return $self->{'tables'}{ $table_name };
 382 }
 383
 384 # ----------------------------------------------------------------------
 385 sub get_tables {
 386
 387 =pod
 388
 389 =head2 get_tables
 390
 391 Returns all the tables as an array or array reference.
 392
 393   my @tables = $schema->get_tables;
 394
 395 =cut
 396
 397     my $self   = shift;
 398     my @tables =
 399         map  { $_->[1] }
 400         sort { $a->[0] <=> $b->[0] }
 401         map  { [ $_->order, $_ ] }
 402         values %{ $self->{'tables'} };
 403
 404     if ( @tables ) {
 405         return wantarray ? @tables : \@tables;
 406     }
 407     else {
 408         $self->error('No tables');
 409         return wantarray ? () : undef;
 410     }
 411 }
 412
 413 # ----------------------------------------------------------------------
 414 sub get_trigger {
 415
 416 =pod
 417
 418 =head2 get_trigger
 419
 420 Returns a trigger by the name provided.
 421
 422   my $trigger = $schema->get_trigger('foo');
 423
 424 =cut
 425
 426     my $self       = shift;
 427     my $trigger_name = shift or return $self->error('No trigger name');
 428     return $self->error( qq[Table "$trigger_name" does not exist] ) unless
 429         exists $self->{'triggers'}{ $trigger_name };
 430     return $self->{'triggers'}{ $trigger_name };
 431 }
 432
 433 # ----------------------------------------------------------------------
 434 sub get_triggers {
 435
 436 =pod
 437
 438 =head2 get_triggers
 439
 440 Returns all the triggers as an array or array reference.
 441
 442   my @triggers = $schema->get_triggers;
 443
 444 =cut
 445
 446     my $self   = shift;
 447     my @triggers =
 448         map  { $_->[1] }
 449         sort { $a->[0] <=> $b->[0] }
 450         map  { [ $_->order, $_ ] }
 451         values %{ $self->{'triggers'} };
 452
 453     if ( @triggers ) {
 454         return wantarray ? @triggers : \@triggers;
 455     }
 456     else {
 457         $self->error('No triggers');
 458         return wantarray ? () : undef;
 459     }
 460 }
 461
 462 # ----------------------------------------------------------------------
 463 sub get_view {
 464
 465 =pod
 466
 467 =head2 get_view
 468
 469 Returns a view by the name provided.
 470
 471   my $view = $schema->get_view('foo');
 472
 473 =cut
 474
 475     my $self      = shift;
 476     my $view_name = shift or return $self->error('No view name');
 477     return $self->error('View "$view_name" does not exist') unless
 478         exists $self->{'views'}{ $view_name };
 479     return $self->{'views'}{ $view_name };
 480 }
 481
 482 # ----------------------------------------------------------------------
 483 sub get_views {
 484
 485 =pod
 486
 487 =head2 get_views
 488
 489 Returns all the views as an array or array reference.
 490
 491   my @views = $schema->get_views;
 492
 493 =cut
 494
 495     my $self  = shift;
 496     my @views =
 497         map  { $_->[1] }
 498         sort { $a->[0] <=> $b->[0] }
 499         map  { [ $_->order, $_ ] }
 500         values %{ $self->{'views'} };
 501
 502     if ( @views ) {
 503         return wantarray ? @views : \@views;
 504     }
 505     else {
 506         $self->error('No views');
 507         return wantarray ? () : undef;
 508     }
 509 }
 510
 511 # ----------------------------------------------------------------------
 512 sub make_natural_joins {
 513
 514 =pod
 515
 516 =head2 make_natural_joins
 517
 518 Creates foriegn key relationships among like-named fields in different
 519 tables.  Accepts the following arguments:
 520
 521 =over 4
 522
 523 =item * join_pk_only
 524
 525 A True or False argument which determins whether or not to perform
 526 the joins from primary keys to fields of the same name in other tables
 527
 528 =item * skip_fields
 529
 530 A list of fields to skip in the joins
 531
 532 =back 4
 533
 534   $schema->make_natural_joins(
 535       join_pk_only => 1,
 536       skip_fields  => 'name,department_id',
 537   );
 538
 539 =cut
 540
 541     my $self         = shift;
 542     my %args         = @_;
 543     my $join_pk_only = $args{'join_pk_only'} || 0;
 544     my %skip_fields  = map { s/^\s+|\s+$//g; $_, 1 } @{
 545         parse_list_arg( $args{'skip_fields'} )
 546     };
 547
 548     my ( %common_keys, %pk );
 549     for my $table ( $self->get_tables ) {
 550         for my $field ( $table->get_fields ) {
 551             my $field_name = $field->name or next;
 552             next if $skip_fields{ $field_name };
 553             $pk{ $field_name } = 1 if $field->is_primary_key;
 554             push @{ $common_keys{ $field_name } }, $table->name;
 555         }
 556     }
 557
 558     for my $field ( keys %common_keys ) {
 559         next if $join_pk_only and !defined $pk{ $field };
 560
 561         my @table_names = @{ $common_keys{ $field } };
 562         next unless scalar @table_names > 1;
 563
 564         for my $i ( 0 .. $#table_names ) {
 565             my $table1 = $self->get_table( $table_names[ $i ] ) or next;
 566
 567             for my $j ( 1 .. $#table_names ) {
 568                 my $table2 = $self->get_table( $table_names[ $j ] ) or next;
 569                 next if $table1->name eq $table2->name;
 570
 571                 $table1->add_constraint(
 572                     type             => FOREIGN_KEY,
 573                     fields           => $field,
 574                     reference_table  => $table2->name,
 575                     reference_fields => $field,
 576                 );
 577             }
 578         }
 579     }
 580
 581     return 1;
 582 }
 583
 584 # ----------------------------------------------------------------------
 585 sub name {
 586
 587 =pod
 588
 589 =head2 name
 590
 591 Get or set the schema's name.  (optional)
 592
 593   my $schema_name = $schema->name('Foo Database');
 594
 595 =cut
 596
 597     my $self = shift;
 598     $self->{'name'} = shift if @_;
 599     return $self->{'name'} || '';
 600 }
 601
 602 =head2 parser_args
 603
 604 =cut
 605
 606 sub parser_args {
 607     my $self = shift;
 608     return $self->{'parser_args'};
 609 }
 610
 611 =head2 producer_args
 612
 613 =cut
 614
 615 sub producer_args {
 616     my $self = shift;
 617     return $self->{'producer_args'};
 618 }
 619
 620 # ----------------------------------------------------------------------
 621 sub DESTROY {
 622     my $self = shift;
 623     undef $_ for values %{ $self->{'tables'} };
 624     undef $_ for values %{ $self->{'views'}  };
 625 }
 626
 627 1;
 628
 629 # ----------------------------------------------------------------------
 630
 631 =pod
 632
 633 =head1 AUTHOR
 634
 635 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 636
 637 =cut