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