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