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