lib/SQL/Translator/Schema.pm

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