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