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