lib/SQL/Translator/Schema.pm

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