lib/SQL/Translator/Schema.pm

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