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