1package dbixcsl_common_tests; 2 3use strict; 4use warnings; 5 6use Test::More; 7use Test::Deep; 8use Test::Exception; 9use Test::Differences; 10use DBIx::Class::Schema::Loader; 11use Class::Unload; 12use File::Path 'rmtree'; 13use curry; 14use DBI; 15use File::Find 'find'; 16use Class::Unload (); 17use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file sigwarn_silencer apply/; 18use DBIx::Class::Schema::Loader::Optional::Dependencies (); 19use Try::Tiny; 20use File::Spec::Functions 'catfile'; 21use File::Basename 'basename'; 22use namespace::clean; 23 24use dbixcsl_test_dir '$tdir'; 25 26use constant DUMP_DIR => "$tdir/common_dump"; 27 28rmtree DUMP_DIR; 29 30use constant RESCAN_WARNINGS => qr/(?i:loader_test|LoaderTest)\d+s? has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method|invalidates \d+ active statement|^Bad table or view/; 31 32# skip schema-qualified tables in the Pg tests 33use constant SOURCE_DDL => qr/CREATE (?:TABLE|VIEW) (?!"dbicsl[.-]test")/i; 34 35use constant SCHEMA_CLASS => 'DBIXCSL_Test::Schema'; 36 37use constant RESULT_NAMESPACE => [ 'MyResult', 'MyResultTwo' ]; 38 39use constant RESULTSET_NAMESPACE => [ 'MyResultSet', 'MyResultSetTwo' ]; 40 41sub new { 42 my $class = shift; 43 44 my $self; 45 46 if( ref($_[0]) eq 'HASH') { 47 my $args = shift; 48 $self = { (%$args) }; 49 } 50 else { 51 $self = { @_ }; 52 } 53 54 # Only MySQL uses this 55 $self->{innodb} ||= ''; 56 57 # DB2 and Firebird don't support 'field type NULL' 58 $self->{null} = 'NULL' unless defined $self->{null}; 59 60 $self->{verbose} = $ENV{TEST_VERBOSE} || 0; 61 62 # Optional extra tables and tests 63 $self->{extra} ||= {}; 64 65 $self->{basic_date_datatype} ||= 'DATE'; 66 67 # Not all DBS do SQL-standard CURRENT_TIMESTAMP 68 $self->{default_function} ||= "current_timestamp"; 69 $self->{default_function_def} ||= "timestamp default $self->{default_function}"; 70 71 $self = bless $self, $class; 72 73 $self->{preserve_case_tests_table_names} = [qw/LoaderTest40 LoaderTest41/]; 74 75 if (lc($self->{vendor}) eq 'mysql' && $^O =~ /^(?:MSWin32|cygwin)\z/) { 76 $self->{preserve_case_tests_table_names} = [qw/Loader_Test40 Loader_Test41/]; 77 } 78 79 $self->setup_data_type_tests; 80 81 return $self; 82} 83 84sub skip_tests { 85 my ($self, $why) = @_; 86 87 plan skip_all => $why; 88} 89 90sub _monikerize { 91 my $name = shift; 92 my $orig = pop; 93 return $orig->({ 94 loader_test2 => 'LoaderTest2X', 95 LOADER_TEST2 => 'LoaderTest2X', 96 }); 97} 98 99sub run_tests { 100 my $self = shift; 101 102 my @connect_info; 103 104 if ($self->{dsn}) { 105 push @connect_info, [ @{$self}{qw/dsn user password connect_info_opts/ } ]; 106 } 107 else { 108 foreach my $info (@{ $self->{connect_info} || [] }) { 109 push @connect_info, [ @{$info}{qw/dsn user password connect_info_opts/ } ]; 110 } 111 } 112 113 if ($ENV{SCHEMA_LOADER_TESTS_EXTRA_ONLY}) { 114 $self->run_only_extra_tests(\@connect_info); 115 return; 116 } 117 118 my $extra_count = $self->{extra}{count} || 0; 119 120 my $col_accessor_map_tests = 6; 121 122 plan tests => @connect_info * 123 (233 + $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0)); 124 125 foreach my $info_idx (0..$#connect_info) { 126 my $info = $connect_info[$info_idx]; 127 128 @{$self}{qw/dsn user password connect_info_opts/} = @$info; 129 130 $self->create(); 131 132 my $schema_class = $self->setup_schema($info); 133 $self->test_schema($schema_class); 134 135 rmtree DUMP_DIR 136 unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} && $info_idx == $#connect_info; 137 } 138} 139 140sub run_only_extra_tests { 141 my ($self, $connect_info) = @_; 142 143 plan tests => @$connect_info * (3 + ($self->{extra}{count} || 0) + ($self->{data_type_tests}{test_count} || 0)); 144 145 rmtree DUMP_DIR; 146 147 foreach my $info_idx (0..$#$connect_info) { 148 my $info = $connect_info->[$info_idx]; 149 150 @{$self}{qw/dsn user password connect_info_opts/} = @$info; 151 152 $self->drop_extra_tables_only; 153 154 my $dbh = $self->dbconnect(1); 155 $dbh->do($_) for @{ $self->{pre_create} || [] }; 156 $dbh->do($_) for @{ $self->{extra}{create} || [] }; 157 158 if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) { 159 foreach my $ddl (@{ $self->{data_type_tests}{ddl} || []}) { 160 if (my $cb = $self->{data_types_ddl_cb}) { 161 $cb->($ddl); 162 } 163 else { 164 $dbh->do($ddl); 165 } 166 } 167 } 168 169 $dbh->disconnect; 170 $self->{_created} = 1; 171 172 my $file_count = grep $_ =~ SOURCE_DDL, @{ $self->{extra}{create} || [] }; 173 $file_count++; # schema 174 175 if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) { 176 $file_count++ for @{ $self->{data_type_tests}{table_names} || [] }; 177 } 178 179 my $schema_class = $self->setup_schema($info, $file_count); 180 my ($monikers, $classes) = $self->monikers_and_classes($schema_class); 181 my $conn = $schema_class->clone; 182 183 $self->test_data_types($conn); 184 $self->{extra}{run}->($conn, $monikers, $classes, $self) if $self->{extra}{run}; 185 $conn->storage->disconnect; 186 187 if (not ($ENV{SCHEMA_LOADER_TESTS_NOCLEANUP} && $info_idx == $#$connect_info)) { 188 $self->drop_extra_tables_only; 189 rmtree DUMP_DIR; 190 } 191 } 192} 193 194sub drop_extra_tables_only { 195 my $self = shift; 196 197 my $dbh = $self->dbconnect(0); 198 199 local $^W = 0; # for ADO 200 201 $dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] }; 202 $self->drop_table($dbh, $_) for @{ $self->{extra}{drop} || [] }; 203 204 if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) { 205 foreach my $data_type_table (@{ $self->{data_type_tests}{table_names} || [] }) { 206 $self->drop_table($dbh, $data_type_table); 207 } 208 } 209} 210 211# defined in sub create 212my (@statements, @statements_reltests, @statements_advanced, 213 @statements_advanced_sqlite, @statements_inline_rels, 214 @statements_implicit_rels); 215 216sub CONSTRAINT { 217 my $self = shift; 218return qr/^(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i; 219} 220 221sub setup_schema { 222 my ($self, $connect_info, $expected_count) = @_; 223 224 my $debug = ($self->{verbose} > 1) ? 1 : 0; 225 226 if ($ENV{SCHEMA_LOADER_TESTS_USE_MOOSE}) { 227 if (not DBIx::Class::Schema::Loader::Optional::Dependencies->req_ok_for('use_moose')) { 228 die sprintf ("Missing dependencies for SCHEMA_LOADER_TESTS_USE_MOOSE: %s\n", 229 DBIx::Class::Schema::Loader::Optional::Dependencies->req_missing_for('use_moose')); 230 } 231 232 $self->{use_moose} = 1; 233 } 234 235 $self->{col_accessor_map_tests_run} = 0; 236 237 my %loader_opts = ( 238 constraint => $self->CONSTRAINT, 239 result_namespace => RESULT_NAMESPACE, 240 resultset_namespace => RESULTSET_NAMESPACE, 241 schema_base_class => 'TestSchemaBaseClass', 242 schema_components => [ 'TestSchemaComponent', '+TestSchemaComponentFQN' ], 243 additional_classes => 'TestAdditional', 244 additional_base_classes => 'TestAdditionalBase', 245 left_base_classes => [ qw/TestLeftBase/ ], 246 components => [ qw/TestComponent +TestComponentFQN +IntrospectM2M/ ], 247 inflect_plural => { loader_test4_fkid => 'loader_test4zes' }, 248 inflect_singular => { fkid => 'fkid_singular' }, 249 moniker_map => \&_monikerize, 250 custom_column_info => \&_custom_column_info, 251 debug => $debug, 252 dump_directory => DUMP_DIR, 253 datetime_timezone => 'Europe/Berlin', 254 datetime_locale => 'de_DE', 255 $self->{use_moose} ? ( 256 use_moose => 1, 257 result_roles => 'TestRole', 258 result_roles_map => { LoaderTest2X => 'TestRoleForMap' }, 259 ) : (), 260 col_collision_map => { '^(can)\z' => 'caught_collision_%s' }, 261 rel_collision_map => { '^(set_primary_key)\z' => 'caught_rel_collision_%s' }, 262 relationship_attrs => { many_to_many => { order_by => 'me.id' } }, 263 col_accessor_map => $self->curry::weak::test_col_accessor_map, 264 result_components_map => { LoaderTest2X => 'TestComponentForMap', LoaderTest1 => '+TestComponentForMapFQN' }, 265 uniq_to_primary => 1, 266 %{ $self->{loader_options} || {} }, 267 ); 268 269 $loader_opts{db_schema} = $self->{db_schema} if $self->{db_schema}; 270 271 Class::Unload->unload(SCHEMA_CLASS); 272 273 my $file_count; 274 { 275 my @loader_warnings; 276 local $SIG{__WARN__} = sub { push(@loader_warnings, @_); }; 277 eval qq{ 278 package @{[SCHEMA_CLASS]}; 279 use base qw/DBIx::Class::Schema::Loader/; 280 281 __PACKAGE__->loader_options(\%loader_opts); 282 __PACKAGE__->connection(\@\$connect_info); 283 }; 284 285 ok(!$@, "Loader initialization") or diag $@; 286 287 find sub { return if -d; $file_count++ }, DUMP_DIR; 288 289 my $standard_sources = not defined $expected_count; 290 291 if ($standard_sources) { 292 $expected_count = 41; 293 294 if (not ($self->{vendor} eq 'mssql' && $connect_info->[0] =~ /Sybase/)) { 295 $expected_count++ for @{ $self->{data_type_tests}{table_names} || [] }; 296 } 297 298 $expected_count += grep $_ =~ SOURCE_DDL, 299 @{ $self->{extra}{create} || [] }; 300 301 $expected_count -= grep /CREATE TABLE/i, @statements_inline_rels 302 if $self->{skip_rels} || $self->{no_inline_rels}; 303 304 $expected_count -= grep /CREATE TABLE/i, @statements_implicit_rels 305 if $self->{skip_rels} || $self->{no_implicit_rels}; 306 307 $expected_count -= grep /CREATE TABLE/i, ($self->{vendor} =~ /sqlite/ ? @statements_advanced_sqlite : @statements_advanced), @statements_reltests 308 if $self->{skip_rels}; 309 } 310 311 is $file_count, $expected_count, 'correct number of files generated'; 312 313 my $warn_count = 2; 314 315 $warn_count++ for grep /^Bad table or view/, @loader_warnings; 316 317 $warn_count++ for grep /renaming \S+ relation/, @loader_warnings; 318 319 $warn_count++ for grep /\b(?!loader_test9)\w+ has no primary key/i, @loader_warnings; 320 321 $warn_count++ for grep /^Column '\w+' in table '\w+' collides with an inherited method\./, @loader_warnings; 322 323 $warn_count++ for grep /^Relationship '\w+' in source '\w+' for columns '[^']+' collides with an inherited method\./, @loader_warnings; 324 325 $warn_count++ for grep { my $w = $_; grep $w =~ $_, @{ $self->{warnings} || [] } } @loader_warnings; 326 327 $warn_count-- for grep { my $w = $_; grep $w =~ $_, @{ $self->{failtrigger_warnings} || [] } } @loader_warnings; 328 329 is scalar(@loader_warnings), $warn_count, 'Correct number of warnings' 330 or diag @loader_warnings; 331 } 332 333 exit if ($file_count||0) != $expected_count; 334 335 return SCHEMA_CLASS; 336} 337 338sub test_schema { 339 my $self = shift; 340 my $schema_class = shift; 341 342 my $conn = $schema_class->clone; 343 344 ($self->{before_tests_run} || sub {})->($conn); 345 346 my ($monikers, $classes) = $self->monikers_and_classes($schema_class); 347 348 my $moniker1 = $monikers->{loader_test1s}; 349 my $class1 = $classes->{loader_test1s}; 350 my $rsobj1 = $conn->resultset($moniker1); 351 check_no_duplicate_unique_constraints($class1); 352 353 my $moniker2 = $monikers->{loader_test2}; 354 my $class2 = $classes->{loader_test2}; 355 my $rsobj2 = $conn->resultset($moniker2); 356 check_no_duplicate_unique_constraints($class2); 357 358 my $moniker23 = $monikers->{LOADER_test23} || $monikers->{loader_test23}; 359 my $class23 = $classes->{LOADER_test23} || $classes->{loader_test23}; 360 my $rsobj23 = $conn->resultset($moniker1); 361 362 my $moniker24 = $monikers->{LoAdEr_test24} || $monikers->{loader_test24}; 363 my $class24 = $classes->{LoAdEr_test24} || $classes->{loader_test24}; 364 my $rsobj24 = $conn->resultset($moniker2); 365 366 my $moniker35 = $monikers->{loader_test35}; 367 my $class35 = $classes->{loader_test35}; 368 my $rsobj35 = $conn->resultset($moniker35); 369 370 my $moniker50 = $monikers->{loader_test50}; 371 my $class50 = $classes->{loader_test50}; 372 my $rsobj50 = $conn->resultset($moniker50); 373 374 isa_ok( $rsobj1, "DBIx::Class::ResultSet" ); 375 isa_ok( $rsobj2, "DBIx::Class::ResultSet" ); 376 isa_ok( $rsobj23, "DBIx::Class::ResultSet" ); 377 isa_ok( $rsobj24, "DBIx::Class::ResultSet" ); 378 isa_ok( $rsobj35, "DBIx::Class::ResultSet" ); 379 isa_ok( $rsobj50, "DBIx::Class::ResultSet" ); 380 381 # check result_namespace 382 my @schema_dir = split /::/, SCHEMA_CLASS; 383 my $result_dir = ref RESULT_NAMESPACE ? ${RESULT_NAMESPACE()}[0] : RESULT_NAMESPACE; 384 385 my $schema_files = [ sort map basename($_), glob catfile(DUMP_DIR, @schema_dir, '*') ]; 386 387 is_deeply $schema_files, [ $result_dir ], 388 'first entry in result_namespace exists as a directory'; 389 390 my $result_file_count =()= glob catfile(DUMP_DIR, @schema_dir, $result_dir, '*.pm'); 391 392 ok $result_file_count, 393 'Result files dumped to first entry in result_namespace'; 394 395 # parse out the resultset_namespace 396 my $schema_code = slurp_file $conn->_loader->get_dump_filename(SCHEMA_CLASS); 397 398 my ($schema_resultset_namespace) = $schema_code =~ /\bresultset_namespace => (.*)/; 399 $schema_resultset_namespace = eval $schema_resultset_namespace; 400 die $@ if $@; 401 402 is_deeply $schema_resultset_namespace, RESULTSET_NAMESPACE, 403 'resultset_namespace set correctly on Schema'; 404 405 like $schema_code, 406qr/\nuse base 'TestSchemaBaseClass';\n\n|\nextends 'TestSchemaBaseClass';\n\n/, 407 'schema_base_class works'; 408 409 is $conn->testschemabaseclass, 'TestSchemaBaseClass works', 410 'schema base class works'; 411 412 like $schema_code, 413qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponentFQN"\);\n\n__PACKAGE__->load_namespaces/, 414 'schema_components works'; 415 416 is $conn->dbix_class_testschemacomponent, 'dbix_class_testschemacomponent works', 417 'schema component works'; 418 419 is $conn->testschemacomponent_fqn, 'TestSchemaComponentFQN works', 420 'fully qualified schema component works'; 421 422 my @columns_lt2 = $class2->columns; 423 is_deeply( \@columns_lt2, [ qw/id dat dat2 set_primary_key can dbix_class_testcomponent dbix_class_testcomponentmap testcomponent_fqn meta test_role_method test_role_for_map_method crumb_crisp_coating sticky_filling/ ], "Column Ordering" ); 424 425 is $class2->column_info('can')->{accessor}, 'caught_collision_can', 426 'accessor for column name that conflicts with a UNIVERSAL method renamed based on col_collision_map'; 427 428 ok (exists $class2->column_info('set_primary_key')->{accessor} 429 && (not defined $class2->column_info('set_primary_key')->{accessor}), 430 'accessor for column name that conflicts with a result base class method removed'); 431 432 ok (exists $class2->column_info('dbix_class_testcomponent')->{accessor} 433 && (not defined $class2->column_info('dbix_class_testcomponent')->{accessor}), 434 'accessor for column name that conflicts with a component class method removed'); 435 436 ok (exists $class2->column_info('dbix_class_testcomponentmap')->{accessor} 437 && (not defined $class2->column_info('dbix_class_testcomponentmap')->{accessor}), 438 'accessor for column name that conflicts with a component class method removed'); 439 440 ok (exists $class2->column_info('testcomponent_fqn')->{accessor} 441 && (not defined $class2->column_info('testcomponent_fqn')->{accessor}), 442 'accessor for column name that conflicts with a fully qualified component class method removed'); 443 444 if ($self->{use_moose}) { 445 ok (exists $class2->column_info('meta')->{accessor} 446 && (not defined $class2->column_info('meta')->{accessor}), 447 'accessor for column name that conflicts with Moose removed'); 448 449 ok (exists $class2->column_info('test_role_for_map_method')->{accessor} 450 && (not defined $class2->column_info('test_role_for_map_method')->{accessor}), 451 'accessor for column name that conflicts with a Result role removed'); 452 453 ok (exists $class2->column_info('test_role_method')->{accessor} 454 && (not defined $class2->column_info('test_role_method')->{accessor}), 455 'accessor for column name that conflicts with a Result role removed'); 456 } 457 else { 458 ok ((not exists $class2->column_info('meta')->{accessor}), 459 "not removing 'meta' accessor with use_moose disabled"); 460 461 ok ((not exists $class2->column_info('test_role_for_map_method')->{accessor}), 462 'no role method conflicts with use_moose disabled'); 463 464 ok ((not exists $class2->column_info('test_role_method')->{accessor}), 465 'no role method conflicts with use_moose disabled'); 466 } 467 468 my %uniq1 = $class1->unique_constraints; 469 my $uniq1_test = 0; 470 foreach my $ucname (keys %uniq1) { 471 my $cols_arrayref = $uniq1{$ucname}; 472 if(@$cols_arrayref == 1 && $cols_arrayref->[0] eq 'dat') { 473 $uniq1_test = 1; 474 last; 475 } 476 } 477 ok($uniq1_test, "Unique constraint"); 478 479 is($moniker1, 'LoaderTest1', 'moniker singularisation'); 480 481 my %uniq2 = $class2->unique_constraints; 482 my $uniq2_test = 0; 483 foreach my $ucname (keys %uniq2) { 484 my $cols_arrayref = $uniq2{$ucname}; 485 if (@$cols_arrayref == 2 486 && $cols_arrayref->[0] eq 'dat2' 487 && $cols_arrayref->[1] eq 'dat' 488 ) { 489 $uniq2_test = 2; 490 last; 491 } 492 } 493 ok($uniq2_test, "Multi-col unique constraint"); 494 495 my %uniq3 = $class50->unique_constraints; 496 497 is_deeply $uniq3{primary}, ['id1', 'id2'], 498 'unique constraint promoted to primary key with uniq_to_primary'; 499 500 is($moniker2, 'LoaderTest2X', "moniker_map testing"); 501 502 SKIP: { 503 can_ok( $class1, 'test_additional_base' ) 504 or skip "Pre-requisite test failed", 1; 505 is( $class1->test_additional_base, "test_additional_base", 506 "Additional Base method" ); 507 } 508 509 SKIP: { 510 can_ok( $class1, 'test_additional_base_override' ) 511 or skip "Pre-requisite test failed", 1; 512 is( $class1->test_additional_base_override, 513 "test_left_base_override", 514 "Left Base overrides Additional Base method" ); 515 } 516 517 SKIP: { 518 can_ok( $class1, 'test_additional_base_additional' ) 519 or skip "Pre-requisite test failed", 1; 520 is( $class1->test_additional_base_additional, "test_additional", 521 "Additional Base can use Additional package method" ); 522 } 523 524 SKIP: { 525 can_ok( $class1, 'dbix_class_testcomponent' ) 526 or skip "Pre-requisite test failed", 1; 527 is( $class1->dbix_class_testcomponent, 528 'dbix_class_testcomponent works', 529 'Additional Component' ); 530 } 531 532 is try { $class2->dbix_class_testcomponentmap }, 'dbix_class_testcomponentmap works', 533 'component from result_component_map'; 534 535 isnt try { $class1->dbix_class_testcomponentmap }, 'dbix_class_testcomponentmap works', 536 'component from result_component_map not added to not mapped Result'; 537 538 is try { $class1->testcomponent_fqn }, 'TestComponentFQN works', 539 'fully qualified component class'; 540 541 is try { $class1->testcomponentformap_fqn }, 'TestComponentForMapFQN works', 542 'fully qualified component class from result_component_map'; 543 544 isnt try { $class2->testcomponentformap_fqn }, 'TestComponentForMapFQN works', 545 'fully qualified component class from result_component_map not added to not mapped Result'; 546 547 SKIP: { 548 skip 'not testing role methods with use_moose disabled', 2 549 unless $self->{use_moose}; 550 551 is try { $class1->test_role_method }, 'test_role_method works', 552 'role from result_roles applied'; 553 554 is try { $class2->test_role_for_map_method }, 555 'test_role_for_map_method works', 556 'role from result_roles_map applied'; 557 } 558 559 SKIP: { 560 can_ok( $class1, 'loader_test1_classmeth' ) 561 or skip "Pre-requisite test failed", 1; 562 is( $class1->loader_test1_classmeth, 'all is well', 'Class method' ); 563 } 564 565 ok( $class1->column_info('id')->{is_auto_increment}, 'is_auto_increment detection' ); 566 567 my $obj = try { $rsobj1->find(1) }; 568 569 is( try { $obj->id }, 1, "Find got the right row" ); 570 is( try { $obj->dat }, "foo", "Column value" ); 571 is( $rsobj2->count, 4, "Count" ); 572 my $saved_id; 573 eval { 574 my $new_obj1 = $rsobj1->create({ dat => 'newthing' }); 575 $saved_id = $new_obj1->id; 576 }; 577 ok(!$@, "Inserting new record using a PK::Auto key didn't die") or diag $@; 578 ok($saved_id, "Got PK::Auto-generated id"); 579 580 my $new_obj1 = $rsobj1->search({ dat => 'newthing' })->single; 581 ok($new_obj1, "Found newly inserted PK::Auto record"); 582 is($new_obj1->id, $saved_id, "Correct PK::Auto-generated id"); 583 584 my ($obj2) = $rsobj2->search({ dat => 'bbb' })->single; 585 is( $obj2->id, 2 ); 586 587 SKIP: { 588 skip 'no DEFAULT on Access', 7 if $self->{vendor} eq 'Access'; 589 590 is( 591 $class35->column_info('a_varchar')->{default_value}, 'foo', 592 'constant character default', 593 ); 594 595 is( 596 $class35->column_info('an_int')->{default_value}, 42, 597 'constant integer default', 598 ); 599 600 is( 601 $class35->column_info('a_negative_int')->{default_value}, -42, 602 'constant negative integer default', 603 ); 604 605 is( 606 sprintf("%.3f", $class35->column_info('a_double')->{default_value}||0), '10.555', 607 'constant numeric default', 608 ); 609 610 is( 611 sprintf("%.3f", $class35->column_info('a_negative_double')->{default_value}||0), -10.555, 612 'constant negative numeric default', 613 ); 614 615 my $function_default = $class35->column_info('a_function')->{default_value}; 616 617 isa_ok( $function_default, 'SCALAR', 'default_value for function default' ); 618 is_deeply( 619 $function_default, \$self->{default_function}, 620 'default_value for function default is correct' 621 ); 622 } 623 624 is( $class2->column_info('crumb_crisp_coating')->{accessor}, 'trivet', 625 'col_accessor_map is being run' ); 626 627 is( $class2->column_info('sticky_filling')->{accessor}, 'goo', 628 'multi-level hash col_accessor_map works' ); 629 630 is $class1->column_info('dat')->{is_nullable}, 0, 631 'is_nullable=0 detection'; 632 633 is $class2->column_info('set_primary_key')->{is_nullable}, 1, 634 'is_nullable=1 detection'; 635 636 SKIP: { 637 skip $self->{skip_rels}, 143 if $self->{skip_rels}; 638 639 my $moniker3 = $monikers->{loader_test3}; 640 my $class3 = $classes->{loader_test3}; 641 my $rsobj3 = $conn->resultset($moniker3); 642 643 my $moniker4 = $monikers->{loader_test4}; 644 my $class4 = $classes->{loader_test4}; 645 my $rsobj4 = $conn->resultset($moniker4); 646 647 my $moniker5 = $monikers->{loader_test5}; 648 my $class5 = $classes->{loader_test5}; 649 my $rsobj5 = $conn->resultset($moniker5); 650 651 my $moniker6 = $monikers->{loader_test6}; 652 my $class6 = $classes->{loader_test6}; 653 my $rsobj6 = $conn->resultset($moniker6); 654 655 my $moniker7 = $monikers->{loader_test7}; 656 my $class7 = $classes->{loader_test7}; 657 my $rsobj7 = $conn->resultset($moniker7); 658 659 my $moniker8 = $monikers->{loader_test8}; 660 my $class8 = $classes->{loader_test8}; 661 my $rsobj8 = $conn->resultset($moniker8); 662 663 my $moniker9 = $monikers->{loader_test9}; 664 my $class9 = $classes->{loader_test9}; 665 my $rsobj9 = $conn->resultset($moniker9); 666 667 my $moniker16 = $monikers->{loader_test16}; 668 my $class16 = $classes->{loader_test16}; 669 my $rsobj16 = $conn->resultset($moniker16); 670 671 my $moniker17 = $monikers->{loader_test17}; 672 my $class17 = $classes->{loader_test17}; 673 my $rsobj17 = $conn->resultset($moniker17); 674 675 my $moniker18 = $monikers->{loader_test18}; 676 my $class18 = $classes->{loader_test18}; 677 my $rsobj18 = $conn->resultset($moniker18); 678 679 my $moniker19 = $monikers->{loader_test19}; 680 my $class19 = $classes->{loader_test19}; 681 my $rsobj19 = $conn->resultset($moniker19); 682 683 my $moniker20 = $monikers->{loader_test20}; 684 my $class20 = $classes->{loader_test20}; 685 my $rsobj20 = $conn->resultset($moniker20); 686 687 my $moniker21 = $monikers->{loader_test21}; 688 my $class21 = $classes->{loader_test21}; 689 my $rsobj21 = $conn->resultset($moniker21); 690 691 my $moniker22 = $monikers->{loader_test22}; 692 my $class22 = $classes->{loader_test22}; 693 my $rsobj22 = $conn->resultset($moniker22); 694 695 my $moniker25 = $monikers->{loader_test25}; 696 my $class25 = $classes->{loader_test25}; 697 my $rsobj25 = $conn->resultset($moniker25); 698 699 my $moniker26 = $monikers->{loader_test26}; 700 my $class26 = $classes->{loader_test26}; 701 my $rsobj26 = $conn->resultset($moniker26); 702 703 my $moniker27 = $monikers->{loader_test27}; 704 my $class27 = $classes->{loader_test27}; 705 my $rsobj27 = $conn->resultset($moniker27); 706 707 my $moniker28 = $monikers->{loader_test28}; 708 my $class28 = $classes->{loader_test28}; 709 my $rsobj28 = $conn->resultset($moniker28); 710 711 my $moniker29 = $monikers->{loader_test29}; 712 my $class29 = $classes->{loader_test29}; 713 my $rsobj29 = $conn->resultset($moniker29); 714 715 my $moniker31 = $monikers->{loader_test31}; 716 my $class31 = $classes->{loader_test31}; 717 my $rsobj31 = $conn->resultset($moniker31); 718 719 my $moniker32 = $monikers->{loader_test32}; 720 my $class32 = $classes->{loader_test32}; 721 my $rsobj32 = $conn->resultset($moniker32); 722 723 my $moniker33 = $monikers->{loader_test33}; 724 my $class33 = $classes->{loader_test33}; 725 my $rsobj33 = $conn->resultset($moniker33); 726 727 my $moniker34 = $monikers->{loader_test34}; 728 my $class34 = $classes->{loader_test34}; 729 my $rsobj34 = $conn->resultset($moniker34); 730 731 my $moniker36 = $monikers->{loader_test36}; 732 my $class36 = $classes->{loader_test36}; 733 my $rsobj36 = $conn->resultset($moniker36); 734 735 my $moniker37 = $monikers->{loader_test37}; 736 my $class37 = $classes->{loader_test37}; 737 my $rsobj37 = $conn->resultset($moniker37); 738 739 my $moniker42 = $monikers->{loader_test42}; 740 my $class42 = $classes->{loader_test42}; 741 my $rsobj42 = $conn->resultset($moniker42); 742 743 my $moniker43 = $monikers->{loader_test43}; 744 my $class43 = $classes->{loader_test43}; 745 my $rsobj43 = $conn->resultset($moniker43); 746 747 my $moniker44 = $monikers->{loader_test44}; 748 my $class44 = $classes->{loader_test44}; 749 my $rsobj44 = $conn->resultset($moniker44); 750 751 isa_ok( $rsobj3, "DBIx::Class::ResultSet" ); 752 isa_ok( $rsobj4, "DBIx::Class::ResultSet" ); 753 isa_ok( $rsobj5, "DBIx::Class::ResultSet" ); 754 isa_ok( $rsobj6, "DBIx::Class::ResultSet" ); 755 isa_ok( $rsobj7, "DBIx::Class::ResultSet" ); 756 isa_ok( $rsobj8, "DBIx::Class::ResultSet" ); 757 isa_ok( $rsobj9, "DBIx::Class::ResultSet" ); 758 isa_ok( $rsobj16, "DBIx::Class::ResultSet" ); 759 isa_ok( $rsobj17, "DBIx::Class::ResultSet" ); 760 isa_ok( $rsobj18, "DBIx::Class::ResultSet" ); 761 isa_ok( $rsobj19, "DBIx::Class::ResultSet" ); 762 isa_ok( $rsobj20, "DBIx::Class::ResultSet" ); 763 isa_ok( $rsobj21, "DBIx::Class::ResultSet" ); 764 isa_ok( $rsobj22, "DBIx::Class::ResultSet" ); 765 isa_ok( $rsobj25, "DBIx::Class::ResultSet" ); 766 isa_ok( $rsobj26, "DBIx::Class::ResultSet" ); 767 isa_ok( $rsobj27, "DBIx::Class::ResultSet" ); 768 isa_ok( $rsobj28, "DBIx::Class::ResultSet" ); 769 isa_ok( $rsobj29, "DBIx::Class::ResultSet" ); 770 isa_ok( $rsobj31, "DBIx::Class::ResultSet" ); 771 isa_ok( $rsobj32, "DBIx::Class::ResultSet" ); 772 isa_ok( $rsobj33, "DBIx::Class::ResultSet" ); 773 isa_ok( $rsobj34, "DBIx::Class::ResultSet" ); 774 isa_ok( $rsobj36, "DBIx::Class::ResultSet" ); 775 isa_ok( $rsobj37, "DBIx::Class::ResultSet" ); 776 isa_ok( $rsobj42, "DBIx::Class::ResultSet" ); 777 isa_ok( $rsobj43, "DBIx::Class::ResultSet" ); 778 isa_ok( $rsobj44, "DBIx::Class::ResultSet" ); 779 780 # basic rel test 781 my $obj4 = try { $rsobj4->find(123) } || $rsobj4->search({ id => 123 })->single; 782 isa_ok( try { $obj4->fkid_singular }, $class3); 783 784 # test renaming rel that conflicts with a class method 785 ok ($obj4->has_relationship('belongs_to_rel'), 'relationship name that conflicts with a method renamed'); 786 787 isa_ok( try { $obj4->belongs_to_rel }, $class3); 788 789 ok ($obj4->has_relationship('caught_rel_collision_set_primary_key'), 790 'relationship name that conflicts with a method renamed based on rel_collision_map'); 791 isa_ok( try { $obj4->caught_rel_collision_set_primary_key }, $class3); 792 793 ok($class4->column_info('fkid')->{is_foreign_key}, 'Foreign key detected'); 794 795 my $obj3 = try { $rsobj3->find(1) } || $rsobj3->search({ id => 1 })->single; 796 my $rs_rel4 = try { $obj3->search_related('loader_test4zes') }; 797 isa_ok( try { $rs_rel4->single }, $class4); 798 799 # check rel naming with prepositions 800 ok ($rsobj4->result_source->has_relationship('loader_test5s_to'), 801 "rel with preposition 'to' pluralized correctly"); 802 803 ok ($rsobj4->result_source->has_relationship('loader_test5s_from'), 804 "rel with preposition 'from' pluralized correctly"); 805 806 # check default relationship attributes 807 is try { $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_delete} }, 0, 808 'cascade_delete => 0 on has_many by default'; 809 810 is try { $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_copy} }, 0, 811 'cascade_copy => 0 on has_many by default'; 812 813 ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_delete} }), 814 'has_many does not have on_delete'); 815 816 ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_update} }), 817 'has_many does not have on_update'); 818 819 ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{is_deferrable} }), 820 'has_many does not have is_deferrable'); 821 822 my $default_on_clause = $self->{default_on_clause} || 'CASCADE'; 823 824 my $default_on_delete_clause = $self->{default_on_delete_clause} || $default_on_clause; 825 826 is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete} }, 827 $default_on_delete_clause, 828 "on_delete is $default_on_delete_clause on belongs_to by default"; 829 830 my $default_on_update_clause = $self->{default_on_update_clause} || $default_on_clause; 831 832 is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update} }, 833 $default_on_update_clause, 834 "on_update is $default_on_update_clause on belongs_to by default"; 835 836 my $default_is_deferrable = $self->{default_is_deferrable}; 837 838 $default_is_deferrable = 1 839 if not defined $default_is_deferrable; 840 841 is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{is_deferrable} }, 842 $default_is_deferrable, 843 "is_deferrable => $default_is_deferrable on belongs_to by default"; 844 845 ok ((not try { exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_delete} }), 846 'belongs_to does not have cascade_delete'); 847 848 ok ((not try { exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_copy} }), 849 'belongs_to does not have cascade_copy'); 850 851 is try { $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_delete} }, 0, 852 'cascade_delete => 0 on might_have by default'; 853 854 is try { $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_copy} }, 0, 855 'cascade_copy => 0 on might_have by default'; 856 857 ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_delete} }), 858 'might_have does not have on_delete'); 859 860 ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_update} }), 861 'might_have does not have on_update'); 862 863 ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{is_deferrable} }), 864 'might_have does not have is_deferrable'); 865 866 # find on multi-col pk 867 if ($conn->loader->preserve_case) { 868 my $obj5 = $rsobj5->find({id1 => 1, iD2 => 1}); 869 is $obj5->i_d2, 1, 'Find on multi-col PK'; 870 } 871 else { 872 my $obj5 = $rsobj5->find({id1 => 1, id2 => 1}); 873 is $obj5->id2, 1, 'Find on multi-col PK'; 874 } 875 876 # mulit-col fk def 877 my $obj6 = try { $rsobj6->find(1) } || $rsobj6->search({ id => 1 })->single; 878 isa_ok( try { $obj6->loader_test2 }, $class2); 879 isa_ok( try { $obj6->loader_test5 }, $class5); 880 881 ok($class6->column_info('loader_test2_id')->{is_foreign_key}, 'Foreign key detected'); 882 ok($class6->column_info('id')->{is_foreign_key}, 'Foreign key detected'); 883 884 my $id2_info = try { $class6->column_info('id2') } || 885 $class6->column_info('Id2'); 886 ok($id2_info->{is_foreign_key}, 'Foreign key detected'); 887 888 unlike slurp_file $conn->_loader->get_dump_filename($class6), 889 qr{ 890 \n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\( 891 \s+ "(\w+?)" 892 .*? 893 \n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\( 894 \s+ "\1" 895 }xs, 896 'did not create two relationships with the same name'; 897 898 unlike slurp_file $conn->_loader->get_dump_filename($class8), 899 qr{ 900 \n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\( 901 \s+ "(\w+?)" 902 .*? 903 \n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\( 904 \s+ "\1" 905 }xs, 906 'did not create two relationships with the same name'; 907 908 # check naming of ambiguous relationships 909 my $rel_info = $class6->relationship_info('lovely_loader_test7') || {}; 910 911 ok (($class6->has_relationship('lovely_loader_test7') 912 && $rel_info->{cond}{'foreign.lovely_loader_test6'} eq 'self.id' 913 && $rel_info->{class} eq $class7 914 && $rel_info->{attrs}{accessor} eq 'single'), 915 'ambiguous relationship named correctly'); 916 917 $rel_info = $class8->relationship_info('active_loader_test16') || {}; 918 919 ok (($class8->has_relationship('active_loader_test16') 920 && $rel_info->{cond}{'foreign.loader_test8_id'} eq 'self.id' 921 && $rel_info->{class} eq $class16 922 && $rel_info->{attrs}{accessor} eq 'single'), 923 'ambiguous relationship named correctly'); 924 925 # fk that references a non-pk key (UNIQUE) 926 my $obj8 = try { $rsobj8->find(1) } || $rsobj8->search({ id => 1 })->single; 927 isa_ok( try { $obj8->loader_test7 }, $class7); 928 929 ok($class8->column_info('loader_test7')->{is_foreign_key}, 'Foreign key detected'); 930 931 # test double-fk 17 ->-> 16 932 my $obj17 = try { $rsobj17->find(33) } || $rsobj17->search({ id => 33 })->single; 933 934 my $rs_rel16_one = try { $obj17->loader16_one }; 935 isa_ok($rs_rel16_one, $class16); 936 is(try { $rs_rel16_one->dat }, 'y16', "Multiple FKs to same table"); 937 938 ok($class17->column_info('loader16_one')->{is_foreign_key}, 'Foreign key detected'); 939 940 my $rs_rel16_two = try { $obj17->loader16_two }; 941 isa_ok($rs_rel16_two, $class16); 942 is(try { $rs_rel16_two->dat }, 'z16', "Multiple FKs to same table"); 943 944 ok($class17->column_info('loader16_two')->{is_foreign_key}, 'Foreign key detected'); 945 946 my $obj16 = try { $rsobj16->find(2) } || $rsobj16->search({ id => 2 })->single; 947 my $rs_rel17 = try { $obj16->search_related('loader_test17_loader16_ones') }; 948 isa_ok(try { $rs_rel17->single }, $class17); 949 is(try { $rs_rel17->single->id }, 3, "search_related with multiple FKs from same table"); 950 951 # test many_to_many detection 18 -> 20 -> 19 and 19 -> 20 -> 18 952 ok($class20->column_info('parent')->{is_foreign_key}, 'Foreign key detected'); 953 ok($class20->column_info('child')->{is_foreign_key}, 'Foreign key detected'); 954 955 cmp_deeply( 956 $class18->_m2m_metadata->{children}, 957 superhashof({ 958 relation => 'loader_test20s', 959 foreign_relation => 'child', 960 attrs => superhashof({ order_by => 'me.id' }) 961 }), 962 'children m2m correct with ordering' 963 ); 964 965 cmp_deeply( 966 $class19->_m2m_metadata->{parents}, 967 superhashof({ 968 relation => 'loader_test20s', 969 foreign_relation => 'parent', 970 attrs => superhashof({ order_by => 'me.id' }) 971 }), 972 'parents m2m correct with ordering' 973 ); 974 975 976 # test double-fk m:m 21 <- 22 -> 21 977 ok($class22->column_info('parent')->{is_foreign_key}, 'Foreign key detected'); 978 ok($class22->column_info('child')->{is_foreign_key}, 'Foreign key detected'); 979 is_deeply( 980 $class21->relationship_info("loader_test22_parents")->{cond}, 981 { 'foreign.parent' => 'self.id' }, 982 'rel to foreign.parent correct' 983 ); 984 is_deeply( 985 $class21->relationship_info("loader_test22_children")->{cond}, 986 { 'foreign.child' => 'self.id' }, 987 'rel to foreign.child correct' 988 ); 989 990 cmp_deeply( 991 $class21->_m2m_metadata, 992 { 993 parents => superhashof({ 994 accessor => 'parents', 995 relation => 'loader_test22_children', 996 foreign_relation => 'parent', 997 }), 998 children => superhashof({ 999 accessor => 'children', 1000 relation => 'loader_test22_parents', 1001 foreign_relation => 'child', 1002 }), 1003 }, 1004 'self-m2m correct' 1005 ); 1006 1007 ok( $class37->relationship_info('parent'), 'parents rel created' ); 1008 ok( $class37->relationship_info('child'), 'child rel created' ); 1009 1010 is_deeply($class32->_m2m_metadata, {}, 'many_to_many not created for might_have'); 1011 is_deeply($class34->_m2m_metadata, {}, 'many_to_many not created for might_have'); 1012 1013 # test m2m with overlapping compound keys 1014 is_deeply( 1015 $class44->relationship_info('loader_test42')->{cond}, 1016 { 1017 'foreign.id1' => 'self.id42', 1018 'foreign.id2' => 'self.id2', 1019 }, 1020 'compound belongs_to key detected for overlapping m2m', 1021 ); 1022 is_deeply( 1023 $class44->relationship_info('loader_test43')->{cond}, 1024 { 1025 'foreign.id1' => 'self.id43', 1026 'foreign.id2' => 'self.id2', 1027 }, 1028 'compound belongs_to key detected for overlapping m2m', 1029 ); 1030 cmp_deeply( 1031 $class42->_m2m_metadata, 1032 { 1033 loader_test43s => superhashof({ 1034 accessor => "loader_test43s", 1035 foreign_relation => "loader_test43", 1036 }), 1037 }, 1038 'm2m created for overlapping multi-column foreign keys' 1039 ); 1040 1041 cmp_deeply( 1042 $class43->_m2m_metadata, 1043 { 1044 loader_test42s => superhashof({ 1045 accessor => "loader_test42s", 1046 foreign_relation => "loader_test42", 1047 }), 1048 }, 1049 'm2m created for overlapping multi-column foreign keys' 1050 ); 1051 1052 # test double multi-col fk 26 -> 25 1053 my $obj26 = try { $rsobj26->find(33) } || $rsobj26->search({ id => 33 })->single; 1054 1055 my $rs_rel25_one = try { $obj26->loader_test25_id_rel1 }; 1056 isa_ok($rs_rel25_one, $class25); 1057 is(try { $rs_rel25_one->dat }, 'x25', "Multiple multi-col FKs to same table"); 1058 1059 ok($class26->column_info('id')->{is_foreign_key}, 'Foreign key detected'); 1060 ok($class26->column_info('rel1')->{is_foreign_key}, 'Foreign key detected'); 1061 ok($class26->column_info('rel2')->{is_foreign_key}, 'Foreign key detected'); 1062 1063 my $rs_rel25_two = try { $obj26->loader_test25_id_rel2 }; 1064 isa_ok($rs_rel25_two, $class25); 1065 is(try { $rs_rel25_two->dat }, 'y25', "Multiple multi-col FKs to same table"); 1066 1067 my $obj25 = try { $rsobj25->find(3,42) } || $rsobj25->search({ id1 => 3, id2 => 42 })->single; 1068 my $rs_rel26 = try { $obj25->search_related('loader_test26_id_rel1s') }; 1069 isa_ok(try { $rs_rel26->single }, $class26); 1070 is(try { $rs_rel26->single->id }, 3, "search_related with multiple multi-col FKs from same table"); 1071 1072 # test one-to-one rels 1073 my $obj27 = try { $rsobj27->find(1) } || $rsobj27->search({ id => 1 })->single; 1074 my $obj28 = try { $obj27->loader_test28 }; 1075 isa_ok($obj28, $class28); 1076 is(try { $obj28->get_column('id') }, 1, "One-to-one relationship with PRIMARY FK"); 1077 1078 ok($class28->column_info('id')->{is_foreign_key}, 'Foreign key detected'); 1079 1080 my $obj29 = try { $obj27->loader_test29 }; 1081 isa_ok($obj29, $class29); 1082 is(try { $obj29->id }, 1, "One-to-one relationship with UNIQUE FK"); 1083 1084 ok($class29->column_info('fk')->{is_foreign_key}, 'Foreign key detected'); 1085 1086 $obj27 = try { $rsobj27->find(2) } || $rsobj27->search({ id => 2 })->single; 1087 is(try { $obj27->loader_test28 }, undef, "Undef for missing one-to-one row"); 1088 is(try { $obj27->loader_test29 }, undef, "Undef for missing one-to-one row"); 1089 1090 # test outer join for nullable referring columns: 1091 is $class32->column_info('rel2')->{is_nullable}, 1, 1092 'is_nullable detection'; 1093 1094 ok($class32->column_info('rel1')->{is_foreign_key}, 'Foreign key detected'); 1095 ok($class32->column_info('rel2')->{is_foreign_key}, 'Foreign key detected'); 1096 1097 my $obj32 = try { $rsobj32->find(1, { prefetch => [qw/rel1 rel2/] }) } 1098 || try { $rsobj32->search({ id => 1 }, { prefetch => [qw/rel1 rel2/] })->single } 1099 || $rsobj32->search({ id => 1 })->single; 1100 1101 my $obj34 = eval { $rsobj34->find(1, { prefetch => [qw/loader_test33_id_rel1 loader_test33_id_rel2/] }) } 1102 || eval { $rsobj34->search({ id => 1 }, { prefetch => [qw/loader_test33_id_rel1 loader_test33_id_rel2/] })->single } 1103 || $rsobj34->search({ id => 1 })->single; 1104 diag $@ if $@; 1105 1106 isa_ok($obj32,$class32); 1107 isa_ok($obj34,$class34); 1108 1109 ok($class34->column_info('id')->{is_foreign_key}, 'Foreign key detected'); 1110 ok($class34->column_info('rel1')->{is_foreign_key}, 'Foreign key detected'); 1111 ok($class34->column_info('rel2')->{is_foreign_key}, 'Foreign key detected'); 1112 1113 my $rs_rel31_one = try { $obj32->rel1 }; 1114 my $rs_rel31_two = try { $obj32->rel2 }; 1115 isa_ok($rs_rel31_one, $class31); 1116 is($rs_rel31_two, undef); 1117 1118 my $rs_rel33_one = try { $obj34->loader_test33_id_rel1 }; 1119 my $rs_rel33_two = try { $obj34->loader_test33_id_rel2 }; 1120 1121 isa_ok($rs_rel33_one, $class33); 1122 isa_ok($rs_rel33_two, $class33); 1123 1124 # from Chisel's tests... 1125 my $moniker10 = $monikers->{loader_test10}; 1126 my $class10 = $classes->{loader_test10}; 1127 my $rsobj10 = $conn->resultset($moniker10); 1128 1129 my $moniker11 = $monikers->{loader_test11}; 1130 my $class11 = $classes->{loader_test11}; 1131 my $rsobj11 = $conn->resultset($moniker11); 1132 1133 isa_ok( $rsobj10, "DBIx::Class::ResultSet" ); 1134 isa_ok( $rsobj11, "DBIx::Class::ResultSet" ); 1135 1136 ok($class10->column_info('loader_test11')->{is_foreign_key}, 'Foreign key detected'); 1137 ok($class11->column_info('loader_test10')->{is_foreign_key}, 'Foreign key detected'); 1138 1139 my $obj10 = $rsobj10->create({ subject => 'xyzzy' }); 1140 1141 $obj10->update(); 1142 ok( defined $obj10, 'Create row' ); 1143 1144 my $obj11 = $rsobj11->create({ loader_test10 => (try { $obj10->id() } || $obj10->id10) }); 1145 $obj11->update(); 1146 ok( defined $obj11, 'Create related row' ); 1147 1148 eval { 1149 my $obj10_2 = $obj11->loader_test10; 1150 $obj10_2->update({ loader_test11 => $obj11->id11 }); 1151 }; 1152 diag $@ if $@; 1153 ok(!$@, "Setting up circular relationship"); 1154 1155 SKIP: { 1156 skip 'Previous eval block failed', 3 if $@; 1157 1158 my $results = $rsobj10->search({ subject => 'xyzzy' }); 1159 is( $results->count(), 1, 'No duplicate row created' ); 1160 1161 my $obj10_3 = $results->single(); 1162 isa_ok( $obj10_3, $class10 ); 1163 is( $obj10_3->loader_test11()->id(), $obj11->id(), 1164 'Circular rel leads back to same row' ); 1165 } 1166 1167 SKIP: { 1168 skip 'This vendor cannot do inline relationship definitions', 9 1169 if $self->{no_inline_rels}; 1170 1171 my $moniker12 = $monikers->{loader_test12}; 1172 my $class12 = $classes->{loader_test12}; 1173 my $rsobj12 = $conn->resultset($moniker12); 1174 1175 my $moniker13 = $monikers->{loader_test13}; 1176 my $class13 = $classes->{loader_test13}; 1177 my $rsobj13 = $conn->resultset($moniker13); 1178 1179 isa_ok( $rsobj12, "DBIx::Class::ResultSet" ); 1180 isa_ok( $rsobj13, "DBIx::Class::ResultSet" ); 1181 1182 ok($class13->column_info('id')->{is_foreign_key}, 'Foreign key detected'); 1183 ok($class13->column_info('loader_test12')->{is_foreign_key}, 'Foreign key detected'); 1184 ok($class13->column_info('dat')->{is_foreign_key}, 'Foreign key detected'); 1185 1186 my $obj13 = try { $rsobj13->find(1) } || $rsobj13->search({ id => 1 })->single; 1187 isa_ok( $obj13->id, $class12 ); 1188 isa_ok( $obj13->loader_test12, $class12); 1189 isa_ok( $obj13->dat, $class12); 1190 1191 my $obj12 = try { $rsobj12->find(1) } || $rsobj12->search({ id => 1 })->single; 1192 isa_ok( try { $obj12->loader_test13 }, $class13 ); 1193 } 1194 1195 # relname is preserved when another fk is added 1196 { 1197 local $SIG{__WARN__} = sigwarn_silencer(qr/invalidates \d+ active statement/); 1198 $conn->storage->disconnect; # for mssql and access 1199 } 1200 1201 isa_ok try { $rsobj3->find(1)->loader_test4zes }, 'DBIx::Class::ResultSet'; 1202 1203 $conn->storage->disconnect; # for access 1204 1205 if (lc($self->{vendor}) !~ /^(?:sybase|mysql)\z/) { 1206 $conn->storage->dbh->do('ALTER TABLE loader_test4 ADD fkid2 INTEGER REFERENCES loader_test3 (id)'); 1207 } 1208 else { 1209 $conn->storage->dbh->do(<<"EOF"); 1210 ALTER TABLE loader_test4 ADD fkid2 INTEGER $self->{null} 1211EOF 1212 $conn->storage->dbh->do(<<"EOF"); 1213 ALTER TABLE loader_test4 ADD CONSTRAINT loader_test4_to_3_fk FOREIGN KEY (fkid2) REFERENCES loader_test3 (id) 1214EOF 1215 } 1216 1217 $conn->storage->disconnect; # for firebird 1218 1219 $self->rescan_without_warnings($conn); 1220 1221 isa_ok try { $rsobj3->find(1)->loader_test4zes }, 'DBIx::Class::ResultSet', 1222 'relationship name preserved when another foreign key is added in remote table'; 1223 1224 SKIP: { 1225 skip 'This vendor cannot do out-of-line implicit rel defs', 4 1226 if $self->{no_implicit_rels}; 1227 my $moniker14 = $monikers->{loader_test14}; 1228 my $class14 = $classes->{loader_test14}; 1229 my $rsobj14 = $conn->resultset($moniker14); 1230 1231 my $moniker15 = $monikers->{loader_test15}; 1232 my $class15 = $classes->{loader_test15}; 1233 my $rsobj15 = $conn->resultset($moniker15); 1234 1235 isa_ok( $rsobj14, "DBIx::Class::ResultSet" ); 1236 isa_ok( $rsobj15, "DBIx::Class::ResultSet" ); 1237 1238 ok($class15->column_info('loader_test14')->{is_foreign_key}, 'Foreign key detected'); 1239 1240 my $obj15 = try { $rsobj15->find(1) } || $rsobj15->search({ id => 1 })->single; 1241 isa_ok( $obj15->loader_test14, $class14 ); 1242 } 1243 } 1244 1245 # test custom_column_info and datetime_timezone/datetime_locale 1246 { 1247 my $class35 = $classes->{loader_test35}; 1248 my $class36 = $classes->{loader_test36}; 1249 1250 ok($class35->column_info('an_int')->{is_numeric}, 'custom_column_info'); 1251 1252 is($class36->column_info('a_date')->{locale},'de_DE','datetime_locale'); 1253 is($class36->column_info('a_date')->{timezone},'Europe/Berlin','datetime_timezone'); 1254 1255 ok($class36->column_info('b_char_as_data')->{inflate_datetime},'custom_column_info'); 1256 is($class36->column_info('b_char_as_data')->{locale},'de_DE','datetime_locale'); 1257 is($class36->column_info('b_char_as_data')->{timezone},'Europe/Berlin','datetime_timezone'); 1258 1259 ok($class36->column_info('c_char_as_data')->{inflate_date},'custom_column_info'); 1260 is($class36->column_info('c_char_as_data')->{locale},'de_DE','datetime_locale'); 1261 is($class36->column_info('c_char_as_data')->{timezone},'Europe/Berlin','datetime_timezone'); 1262 } 1263 1264 # rescan and norewrite test 1265 { 1266 my @statements_rescan = ( 1267 qq{ 1268 CREATE TABLE loader_test30 ( 1269 id INTEGER NOT NULL PRIMARY KEY, 1270 loader_test2 INTEGER NOT NULL, 1271 FOREIGN KEY (loader_test2) REFERENCES loader_test2 (id) 1272 ) $self->{innodb} 1273 }, 1274 q{ INSERT INTO loader_test30 (id,loader_test2) VALUES(123, 1) }, 1275 q{ INSERT INTO loader_test30 (id,loader_test2) VALUES(321, 2) }, 1276 ); 1277 1278 # get contents 1279 my %contents; 1280 1281 my $find_cb = sub { 1282 return if -d; 1283 return if /^(?:LoaderTest30|LoaderTest1|LoaderTest2X)\.pm\z/; 1284 1285 open my $fh, '<', $_ or die "Could not open $_ for reading: $!"; 1286 binmode $fh; 1287 local $/; 1288 $contents{$File::Find::name} = <$fh>; 1289 }; 1290 1291 find $find_cb, DUMP_DIR; 1292 my %contents_before = %contents; 1293 1294# system "rm -rf /tmp/before_rescan /tmp/after_rescan"; 1295# system "mkdir /tmp/before_rescan"; 1296# system "mkdir /tmp/after_rescan"; 1297# system "cp -a @{[DUMP_DIR]} /tmp/before_rescan"; 1298 1299 $conn->storage->disconnect; # needed for Firebird and Informix 1300 my $dbh = $self->dbconnect(1); 1301 $dbh->do($_) for @statements_rescan; 1302 $dbh->disconnect; 1303 1304 sleep 1; 1305 1306 my @new = $self->rescan_without_warnings($conn); 1307 1308 is_deeply(\@new, [ qw/LoaderTest30/ ], "Rescan"); 1309 1310# system "cp -a @{[DUMP_DIR]} /tmp/after_rescan"; 1311 1312 undef %contents; 1313 find $find_cb, DUMP_DIR; 1314 my %contents_after = %contents; 1315 1316 subtest 'dumped files are not rewritten when there is no modification' => sub { 1317 plan tests => 1 + scalar keys %contents_before; 1318 is_deeply 1319 [sort keys %contents_before], 1320 [sort keys %contents_after], 1321 'same files dumped'; 1322 for my $file (sort keys %contents_before) { 1323 eq_or_diff $contents_before{$file}, $contents_after{$file}, 1324 "$file not rewritten"; 1325 } 1326 }; 1327 1328 my $rsobj30 = $conn->resultset('LoaderTest30'); 1329 isa_ok($rsobj30, 'DBIx::Class::ResultSet'); 1330 1331 SKIP: { 1332 skip 'no rels', 2 if $self->{skip_rels}; 1333 1334 my $obj30 = try { $rsobj30->find(123) } || $rsobj30->search({ id => 123 })->single; 1335 isa_ok( $obj30->loader_test2, $class2); 1336 1337 ok $rsobj30->result_source->column_info('loader_test2')->{is_foreign_key}, 1338 'Foreign key detected'; 1339 } 1340 1341 $conn->storage->disconnect; # for Firebird 1342 $self->drop_table($conn->storage->dbh, 'loader_test30'); 1343 1344 @new = $self->rescan_without_warnings($conn); 1345 1346 is_deeply(\@new, [], 'no new tables on rescan'); 1347 1348 throws_ok { $conn->resultset('LoaderTest30') } 1349 qr/Can't find source/, 1350 'source unregistered for dropped table after rescan'; 1351 } 1352 1353 $self->test_data_types($conn); 1354 1355 $self->test_preserve_case($conn); 1356 1357 # run extra tests 1358 $self->{extra}{run}->($conn, $monikers, $classes, $self) if $self->{extra}{run}; 1359 1360 ## Create a dump from an existing $dbh in a transaction 1361 1362TODO: { 1363 local $TODO = 'dumping in a txn is experimental and Pg-only right now' 1364 unless $self->{vendor} eq 'Pg'; 1365 1366 ok eval { 1367 my %opts = ( 1368 naming => 'current', 1369 constraint => $self->CONSTRAINT, 1370 dump_directory => DUMP_DIR, 1371 debug => ($ENV{SCHEMA_LOADER_TESTS_DEBUG}||0) 1372 ); 1373 1374 my $guard = $conn->txn_scope_guard; 1375 1376 my $rescan_warnings = RESCAN_WARNINGS; 1377 local $SIG{__WARN__} = sigwarn_silencer( 1378 qr/$rescan_warnings|commit ineffective with AutoCommit enabled/ # FIXME 1379 ); 1380 1381 my $schema_from = DBIx::Class::Schema::Loader::make_schema_at( 1382 "TestSchemaFromAnother", \%opts, [ sub { $conn->storage->dbh } ] 1383 ); 1384 1385 $guard->commit; 1386 1387 1; 1388 }, 'Making a schema from another schema inside a transaction worked'; 1389 1390 diag $@ if $@ && (not $TODO); 1391} 1392 1393 $conn->storage->disconnect; 1394 1395 $self->drop_tables unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; 1396} 1397 1398sub test_data_types { 1399 my ($self, $conn) = @_; 1400 1401 SKIP: { 1402 if (my $test_count = $self->{data_type_tests}{test_count}) { 1403 if ($self->{vendor} eq 'mssql' && $conn->storage->dbh->{Driver}{Name} eq 'Sybase') { 1404 skip 'DBD::Sybase does not work with the data_type tests on latest SQL Server', $test_count; 1405 } 1406 1407 my $data_type_tests = $self->{data_type_tests}; 1408 1409 foreach my $moniker (@{ $data_type_tests->{table_monikers} }) { 1410 my $columns = $data_type_tests->{columns}{$moniker}; 1411 1412 my $rsrc = $conn->resultset($moniker)->result_source; 1413 1414 while (my ($col_name, $expected_info) = each %$columns) { 1415 my %info = %{ $rsrc->column_info($col_name) }; 1416 delete @info{qw/is_nullable timezone locale sequence/}; 1417 1418 my $text_col_def = dumper_squashed \%info; 1419 1420 my $text_expected_info = dumper_squashed $expected_info; 1421 1422 is_deeply \%info, $expected_info, 1423 "test column $col_name has definition: $text_col_def expecting: $text_expected_info"; 1424 } 1425 } 1426 } 1427 } 1428} 1429 1430sub test_preserve_case { 1431 my ($self, $conn) = @_; 1432 1433 my ($oqt, $cqt) = $self->get_oqt_cqt(always => 1); # open quote, close quote 1434 1435 my $dbh = $conn->storage->dbh; 1436 1437 my ($table40_name, $table41_name) = @{ $self->{preserve_case_tests_table_names} }; 1438 1439 $dbh->do($_) for ( 1440qq| 1441 CREATE TABLE ${oqt}${table40_name}${cqt} ( 1442 ${oqt}Id${cqt} INTEGER NOT NULL PRIMARY KEY, 1443 ${oqt}Foo3Bar${cqt} VARCHAR(100) NOT NULL 1444 ) $self->{innodb} 1445|, 1446qq| 1447 CREATE TABLE ${oqt}${table41_name}${cqt} ( 1448 ${oqt}Id${cqt} INTEGER NOT NULL PRIMARY KEY, 1449 ${oqt}LoaderTest40Id${cqt} INTEGER, 1450 FOREIGN KEY (${oqt}LoaderTest40Id${cqt}) REFERENCES ${oqt}${table40_name}${cqt} (${oqt}Id${cqt}) 1451 ) $self->{innodb} 1452|, 1453qq| INSERT INTO ${oqt}${table40_name}${cqt} VALUES (1, 'foo') |, 1454qq| INSERT INTO ${oqt}${table41_name}${cqt} VALUES (1, 1) |, 1455 ); 1456 $conn->storage->disconnect; 1457 1458 my $orig_preserve_case = $conn->loader->preserve_case; 1459 1460 $conn->loader->preserve_case(1); 1461 $conn->loader->_setup; 1462 $self->rescan_without_warnings($conn); 1463 1464 if (not $self->{skip_rels}) { 1465 ok my $row = try { $conn->resultset('LoaderTest41')->find(1) }, 1466 'row in mixed-case table'; 1467 ok my $related_row = try { $row->loader_test40 }, 1468 'rel in mixed-case table'; 1469 is try { $related_row->foo3_bar }, 'foo', 1470 'accessor for mixed-case column name in mixed case table'; 1471 } 1472 else { 1473 SKIP: { skip 'not testing mixed-case rels with skip_rels', 2 } 1474 1475 is try { $conn->resultset('LoaderTest40')->find(1)->foo3_bar }, 'foo', 1476 'accessor for mixed-case column name in mixed case table'; 1477 } 1478 1479 # Further tests may expect preserve_case to be unset, so reset it to the 1480 # original value and rescan again. 1481 1482 $conn->loader->preserve_case($orig_preserve_case); 1483 $conn->loader->_setup; 1484 $self->rescan_without_warnings($conn); 1485} 1486 1487sub monikers_and_classes { 1488 my ($self, $schema_class) = @_; 1489 my ($monikers, $classes); 1490 1491 foreach my $source_name ($schema_class->sources) { 1492 my $table_name = $schema_class->loader->moniker_to_table->{$source_name}; 1493 1494 my $result_class = $schema_class->source($source_name)->result_class; 1495 1496 $monikers->{$table_name} = $source_name; 1497 $classes->{$table_name} = $result_class; 1498 1499 # some DBs (Firebird, Oracle) uppercase everything 1500 $monikers->{lc $table_name} = $source_name; 1501 $classes->{lc $table_name} = $result_class; 1502 } 1503 1504 return ($monikers, $classes); 1505} 1506 1507sub check_no_duplicate_unique_constraints { 1508 my ($class) = @_; 1509 1510 # unique_constraints() automatically includes the PK, if any 1511 my %uc_cols; 1512 ++$uc_cols{ join ", ", @$_ } 1513 for values %{ { $class->unique_constraints } }; 1514 my $dup_uc = grep { $_ > 1 } values %uc_cols; 1515 1516 is($dup_uc, 0, "duplicate unique constraints ($class)") 1517 or diag "uc_cols: @{[ %uc_cols ]}"; 1518} 1519 1520sub dbconnect { 1521 my ($self, $complain) = @_; 1522 1523 require DBIx::Class::Storage::DBI; 1524 my $storage = DBIx::Class::Storage::DBI->new; 1525 1526 $complain = defined $complain ? $complain : 1; 1527 1528 $storage->connect_info([ 1529 @{ $self }{qw/dsn user password/}, 1530 { 1531 unsafe => 1, 1532 RaiseError => $complain, 1533 ShowErrorStatement => $complain, 1534 PrintError => 0, 1535 %{ $self->{connect_info_opts} || {} }, 1536 }, 1537 ]); 1538 1539 my $dbh = $storage->dbh; 1540 die "Failed to connect to database: $@" if !$dbh; 1541 1542 $self->{storage} = $storage; # storage DESTROY disconnects 1543 1544 return $dbh; 1545} 1546 1547sub get_oqt_cqt { 1548 my $self = shift; 1549 my %opts = @_; 1550 1551 if ((not $opts{always}) && $self->{preserve_case_mode_is_exclusive}) { 1552 return ('', ''); 1553 } 1554 1555 # XXX should get quote_char from the storage of an initialized loader. 1556 my ($oqt, $cqt); # open quote, close quote 1557 if (ref $self->{quote_char}) { 1558 ($oqt, $cqt) = @{ $self->{quote_char} }; 1559 } 1560 else { 1561 $oqt = $cqt = $self->{quote_char} || ''; 1562 } 1563 1564 return ($oqt, $cqt); 1565} 1566 1567sub create { 1568 my $self = shift; 1569 1570 $self->{_created} = 1; 1571 1572 $self->drop_tables; 1573 1574 my $make_auto_inc = $self->{auto_inc_cb} || sub { return () }; 1575 @statements = ( 1576 qq{ 1577 CREATE TABLE loader_test1s ( 1578 id $self->{auto_inc_pk}, 1579 dat VARCHAR(32) NOT NULL UNIQUE 1580 ) $self->{innodb} 1581 }, 1582 $make_auto_inc->(qw/loader_test1s id/), 1583 1584 q{ INSERT INTO loader_test1s (dat) VALUES('foo') }, 1585 q{ INSERT INTO loader_test1s (dat) VALUES('bar') }, 1586 q{ INSERT INTO loader_test1s (dat) VALUES('baz') }, 1587 1588 # also test method collision 1589 # crumb_crisp_coating and sticky_filling are for col_accessor_map tests 1590 qq{ 1591 CREATE TABLE loader_test2 ( 1592 id $self->{auto_inc_pk}, 1593 dat VARCHAR(32) NOT NULL, 1594 dat2 VARCHAR(32) NOT NULL, 1595 set_primary_key INTEGER $self->{null}, 1596 can INTEGER $self->{null}, 1597 dbix_class_testcomponent INTEGER $self->{null}, 1598 dbix_class_testcomponentmap INTEGER $self->{null}, 1599 testcomponent_fqn INTEGER $self->{null}, 1600 meta INTEGER $self->{null}, 1601 test_role_method INTEGER $self->{null}, 1602 test_role_for_map_method INTEGER $self->{null}, 1603 crumb_crisp_coating VARCHAR(32) $self->{null}, 1604 sticky_filling VARCHAR(32) $self->{null}, 1605 UNIQUE (dat2, dat) 1606 ) $self->{innodb} 1607 }, 1608 $make_auto_inc->(qw/loader_test2 id/), 1609 1610 q{ INSERT INTO loader_test2 (dat, dat2) VALUES('aaa', 'zzz') }, 1611 q{ INSERT INTO loader_test2 (dat, dat2) VALUES('bbb', 'yyy') }, 1612 q{ INSERT INTO loader_test2 (dat, dat2) VALUES('ccc', 'xxx') }, 1613 q{ INSERT INTO loader_test2 (dat, dat2) VALUES('ddd', 'www') }, 1614 1615 qq{ 1616 CREATE TABLE LOADER_test23 ( 1617 ID INTEGER NOT NULL PRIMARY KEY, 1618 DAT VARCHAR(32) NOT NULL UNIQUE 1619 ) $self->{innodb} 1620 }, 1621 1622 qq{ 1623 CREATE TABLE LoAdEr_test24 ( 1624 iD INTEGER NOT NULL PRIMARY KEY, 1625 DaT VARCHAR(32) NOT NULL UNIQUE 1626 ) $self->{innodb} 1627 }, 1628 1629# Access does not support DEFAULT 1630 $self->{vendor} ne 'Access' ? qq{ 1631 CREATE TABLE loader_test35 ( 1632 id INTEGER NOT NULL PRIMARY KEY, 1633 a_varchar VARCHAR(100) DEFAULT 'foo', 1634 an_int INTEGER DEFAULT 42, 1635 a_negative_int INTEGER DEFAULT -42, 1636 a_double DOUBLE PRECISION DEFAULT 10.555, 1637 a_negative_double DOUBLE PRECISION DEFAULT -10.555, 1638 a_function $self->{default_function_def} 1639 ) $self->{innodb} 1640 } : qq{ 1641 CREATE TABLE loader_test35 ( 1642 id INTEGER NOT NULL PRIMARY KEY, 1643 a_varchar VARCHAR(100), 1644 an_int INTEGER, 1645 a_negative_int INTEGER, 1646 a_double DOUBLE, 1647 a_negative_double DOUBLE, 1648 a_function DATETIME 1649 ) 1650 }, 1651 1652 qq{ 1653 CREATE TABLE loader_test36 ( 1654 id INTEGER NOT NULL PRIMARY KEY, 1655 a_date $self->{basic_date_datatype}, 1656 b_char_as_data VARCHAR(100), 1657 c_char_as_data VARCHAR(100) 1658 ) $self->{innodb} 1659 }, 1660 # DB2 does not allow nullable uniq components, SQLAnywhere automatically 1661 # converts nullable uniq components to NOT NULL 1662 qq{ 1663 CREATE TABLE loader_test50 ( 1664 id INTEGER NOT NULL UNIQUE, 1665 id1 INTEGER NOT NULL, 1666 id2 INTEGER NOT NULL, 1667 @{[ $self->{vendor} !~ /^(?:DB2|SQLAnywhere)\z/i ? " 1668 id3 INTEGER $self->{null}, 1669 id4 INTEGER NOT NULL, 1670 UNIQUE (id3, id4), 1671 " : '' ]} 1672 UNIQUE (id1, id2) 1673 ) $self->{innodb} 1674 }, 1675 ); 1676 1677 # some DBs require mixed case identifiers to be quoted 1678 my ($oqt, $cqt) = $self->get_oqt_cqt; 1679 1680 @statements_reltests = ( 1681 qq{ 1682 CREATE TABLE loader_test3 ( 1683 id INTEGER NOT NULL PRIMARY KEY, 1684 dat VARCHAR(32) 1685 ) $self->{innodb} 1686 }, 1687 1688 q{ INSERT INTO loader_test3 (id,dat) VALUES(1,'aaa') }, 1689 q{ INSERT INTO loader_test3 (id,dat) VALUES(2,'bbb') }, 1690 q{ INSERT INTO loader_test3 (id,dat) VALUES(3,'ccc') }, 1691 q{ INSERT INTO loader_test3 (id,dat) VALUES(4,'ddd') }, 1692 1693 qq{ 1694 CREATE TABLE loader_test4 ( 1695 id INTEGER NOT NULL PRIMARY KEY, 1696 fkid INTEGER NOT NULL, 1697 dat VARCHAR(32), 1698 belongs_to INTEGER $self->{null}, 1699 set_primary_key INTEGER $self->{null}, 1700 FOREIGN KEY( fkid ) REFERENCES loader_test3 (id), 1701 FOREIGN KEY( belongs_to ) REFERENCES loader_test3 (id), 1702 FOREIGN KEY( set_primary_key ) REFERENCES loader_test3 (id) 1703 ) $self->{innodb} 1704 }, 1705 1706 q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(123,1,'aaa',1,1) }, 1707 q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(124,2,'bbb',2,2) }, 1708 q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(125,3,'ccc',3,3) }, 1709 q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(126,4,'ddd',4,4) }, 1710 1711 qq| 1712 CREATE TABLE loader_test5 ( 1713 id1 INTEGER NOT NULL, 1714 ${oqt}iD2${cqt} INTEGER NOT NULL, 1715 dat VARCHAR(8), 1716 from_id INTEGER $self->{null}, 1717 to_id INTEGER $self->{null}, 1718 PRIMARY KEY (id1,${oqt}iD2${cqt}), 1719 FOREIGN KEY (from_id) REFERENCES loader_test4 (id), 1720 FOREIGN KEY (to_id) REFERENCES loader_test4 (id) 1721 ) $self->{innodb} 1722 |, 1723 1724 qq| INSERT INTO loader_test5 (id1,${oqt}iD2${cqt},dat) VALUES (1,1,'aaa') |, 1725 1726 qq| 1727 CREATE TABLE loader_test6 ( 1728 id INTEGER NOT NULL PRIMARY KEY, 1729 ${oqt}Id2${cqt} INTEGER, 1730 loader_test2_id INTEGER, 1731 dat VARCHAR(8), 1732 FOREIGN KEY (loader_test2_id) REFERENCES loader_test2 (id), 1733 FOREIGN KEY(id,${oqt}Id2${cqt}) REFERENCES loader_test5 (id1,${oqt}iD2${cqt}) 1734 ) $self->{innodb} 1735 |, 1736 1737 (qq| INSERT INTO loader_test6 (id, ${oqt}Id2${cqt},loader_test2_id,dat) | . 1738 q{ VALUES (1, 1,1,'aaa') }), 1739 1740 # here we are testing adjective detection 1741 1742 qq{ 1743 CREATE TABLE loader_test7 ( 1744 id INTEGER NOT NULL PRIMARY KEY, 1745 id2 VARCHAR(8) NOT NULL UNIQUE, 1746 dat VARCHAR(8), 1747 lovely_loader_test6 INTEGER NOT NULL UNIQUE, 1748 FOREIGN KEY (lovely_loader_test6) REFERENCES loader_test6 (id) 1749 ) $self->{innodb} 1750 }, 1751 1752 q{ INSERT INTO loader_test7 (id,id2,dat,lovely_loader_test6) VALUES (1,'aaa','bbb',1) }, 1753 1754 # for some DBs we need a named FK to drop later 1755 ($self->{vendor} =~ /^(mssql|sybase|access|mysql)\z/i ? ( 1756 (q{ ALTER TABLE loader_test6 ADD } . 1757 qq{ loader_test7_id INTEGER $self->{null} }), 1758 (q{ ALTER TABLE loader_test6 ADD CONSTRAINT loader_test6_to_7_fk } . 1759 q{ FOREIGN KEY (loader_test7_id) } . 1760 q{ REFERENCES loader_test7 (id) }) 1761 ) : ( 1762 (q{ ALTER TABLE loader_test6 ADD } . 1763 qq{ loader_test7_id INTEGER $self->{null} REFERENCES loader_test7 (id) }), 1764 )), 1765 1766 qq{ 1767 CREATE TABLE loader_test8 ( 1768 id INTEGER NOT NULL PRIMARY KEY, 1769 loader_test7 VARCHAR(8) NOT NULL, 1770 dat VARCHAR(8), 1771 FOREIGN KEY (loader_test7) REFERENCES loader_test7 (id2) 1772 ) $self->{innodb} 1773 }, 1774 1775 (q{ INSERT INTO loader_test8 (id,loader_test7,dat) VALUES (1,'aaa','bbb') }), 1776 (q{ INSERT INTO loader_test8 (id,loader_test7,dat) VALUES (2,'aaa','bbb') }), 1777 (q{ INSERT INTO loader_test8 (id,loader_test7,dat) VALUES (3,'aaa','bbb') }), 1778 1779 qq{ 1780 CREATE TABLE loader_test9 ( 1781 loader_test9 VARCHAR(8) NOT NULL 1782 ) $self->{innodb} 1783 }, 1784 1785 qq{ 1786 CREATE TABLE loader_test16 ( 1787 id INTEGER NOT NULL PRIMARY KEY, 1788 dat VARCHAR(8), 1789 loader_test8_id INTEGER NOT NULL UNIQUE, 1790 FOREIGN KEY (loader_test8_id) REFERENCES loader_test8 (id) 1791 ) $self->{innodb} 1792 }, 1793 1794 qq{ INSERT INTO loader_test16 (id,dat,loader_test8_id) VALUES (2,'x16',1) }, 1795 qq{ INSERT INTO loader_test16 (id,dat,loader_test8_id) VALUES (4,'y16',2) }, 1796 qq{ INSERT INTO loader_test16 (id,dat,loader_test8_id) VALUES (6,'z16',3) }, 1797 1798 # for some DBs we need a named FK to drop later 1799 ($self->{vendor} =~ /^(mssql|sybase|access|mysql)\z/i ? ( 1800 (q{ ALTER TABLE loader_test8 ADD } . 1801 qq{ loader_test16_id INTEGER $self->{null} }), 1802 (q{ ALTER TABLE loader_test8 ADD CONSTRAINT loader_test8_to_16_fk } . 1803 q{ FOREIGN KEY (loader_test16_id) } . 1804 q{ REFERENCES loader_test16 (id) }) 1805 ) : ( 1806 (q{ ALTER TABLE loader_test8 ADD } . 1807 qq{ loader_test16_id INTEGER $self->{null} REFERENCES loader_test16 (id) }), 1808 )), 1809 1810 qq{ 1811 CREATE TABLE loader_test17 ( 1812 id INTEGER NOT NULL PRIMARY KEY, 1813 loader16_one INTEGER, 1814 loader16_two INTEGER, 1815 FOREIGN KEY (loader16_one) REFERENCES loader_test16 (id), 1816 FOREIGN KEY (loader16_two) REFERENCES loader_test16 (id) 1817 ) $self->{innodb} 1818 }, 1819 1820 qq{ INSERT INTO loader_test17 (id, loader16_one, loader16_two) VALUES (3, 2, 4) }, 1821 qq{ INSERT INTO loader_test17 (id, loader16_one, loader16_two) VALUES (33, 4, 6) }, 1822 1823 qq{ 1824 CREATE TABLE loader_test18 ( 1825 id INTEGER NOT NULL PRIMARY KEY, 1826 dat VARCHAR(8) 1827 ) $self->{innodb} 1828 }, 1829 1830 qq{ INSERT INTO loader_test18 (id,dat) VALUES (1,'x18') }, 1831 qq{ INSERT INTO loader_test18 (id,dat) VALUES (2,'y18') }, 1832 qq{ INSERT INTO loader_test18 (id,dat) VALUES (3,'z18') }, 1833 1834 qq{ 1835 CREATE TABLE loader_test19 ( 1836 id INTEGER NOT NULL PRIMARY KEY, 1837 dat VARCHAR(8) 1838 ) $self->{innodb} 1839 }, 1840 1841 qq{ INSERT INTO loader_test19 (id,dat) VALUES (4,'x19') }, 1842 qq{ INSERT INTO loader_test19 (id,dat) VALUES (5,'y19') }, 1843 qq{ INSERT INTO loader_test19 (id,dat) VALUES (6,'z19') }, 1844 1845 qq{ 1846 CREATE TABLE loader_test20 ( 1847 parent INTEGER NOT NULL, 1848 child INTEGER NOT NULL, 1849 PRIMARY KEY (parent, child), 1850 FOREIGN KEY (parent) REFERENCES loader_test18 (id), 1851 FOREIGN KEY (child) REFERENCES loader_test19 (id) 1852 ) $self->{innodb} 1853 }, 1854 1855 q{ INSERT INTO loader_test20 (parent, child) VALUES (1,4) }, 1856 q{ INSERT INTO loader_test20 (parent, child) VALUES (2,5) }, 1857 q{ INSERT INTO loader_test20 (parent, child) VALUES (3,6) }, 1858 1859 qq{ 1860 CREATE TABLE loader_test21 ( 1861 id INTEGER NOT NULL PRIMARY KEY, 1862 dat VARCHAR(8) 1863 ) $self->{innodb} 1864 }, 1865 1866 q{ INSERT INTO loader_test21 (id,dat) VALUES (7,'a21')}, 1867 q{ INSERT INTO loader_test21 (id,dat) VALUES (11,'b21')}, 1868 q{ INSERT INTO loader_test21 (id,dat) VALUES (13,'c21')}, 1869 q{ INSERT INTO loader_test21 (id,dat) VALUES (17,'d21')}, 1870 1871 qq{ 1872 CREATE TABLE loader_test22 ( 1873 parent INTEGER NOT NULL, 1874 child INTEGER NOT NULL, 1875 PRIMARY KEY (parent, child), 1876 FOREIGN KEY (parent) REFERENCES loader_test21 (id), 1877 FOREIGN KEY (child) REFERENCES loader_test21 (id) 1878 ) $self->{innodb} 1879 }, 1880 1881 q{ INSERT INTO loader_test22 (parent, child) VALUES (7,11)}, 1882 q{ INSERT INTO loader_test22 (parent, child) VALUES (11,13)}, 1883 q{ INSERT INTO loader_test22 (parent, child) VALUES (13,17)}, 1884 1885 qq{ 1886 CREATE TABLE loader_test25 ( 1887 id1 INTEGER NOT NULL, 1888 id2 INTEGER NOT NULL, 1889 dat VARCHAR(8), 1890 PRIMARY KEY (id1,id2) 1891 ) $self->{innodb} 1892 }, 1893 1894 q{ INSERT INTO loader_test25 (id1,id2,dat) VALUES (33,5,'x25') }, 1895 q{ INSERT INTO loader_test25 (id1,id2,dat) VALUES (33,7,'y25') }, 1896 q{ INSERT INTO loader_test25 (id1,id2,dat) VALUES (3,42,'z25') }, 1897 1898 qq{ 1899 CREATE TABLE loader_test26 ( 1900 id INTEGER NOT NULL PRIMARY KEY, 1901 rel1 INTEGER NOT NULL, 1902 rel2 INTEGER NOT NULL, 1903 FOREIGN KEY (id, rel1) REFERENCES loader_test25 (id1, id2), 1904 FOREIGN KEY (id, rel2) REFERENCES loader_test25 (id1, id2) 1905 ) $self->{innodb} 1906 }, 1907 1908 q{ INSERT INTO loader_test26 (id,rel1,rel2) VALUES (33,5,7) }, 1909 q{ INSERT INTO loader_test26 (id,rel1,rel2) VALUES (3,42,42) }, 1910 1911 qq{ 1912 CREATE TABLE loader_test27 ( 1913 id INTEGER NOT NULL PRIMARY KEY 1914 ) $self->{innodb} 1915 }, 1916 1917 q{ INSERT INTO loader_test27 (id) VALUES (1) }, 1918 q{ INSERT INTO loader_test27 (id) VALUES (2) }, 1919 1920 qq{ 1921 CREATE TABLE loader_test28 ( 1922 id INTEGER NOT NULL PRIMARY KEY, 1923 FOREIGN KEY (id) REFERENCES loader_test27 (id) 1924 ) $self->{innodb} 1925 }, 1926 1927 q{ INSERT INTO loader_test28 (id) VALUES (1) }, 1928 1929 qq{ 1930 CREATE TABLE loader_test29 ( 1931 id INTEGER NOT NULL PRIMARY KEY, 1932 fk INTEGER NOT NULL UNIQUE, 1933 FOREIGN KEY (fk) REFERENCES loader_test27 (id) 1934 ) $self->{innodb} 1935 }, 1936 1937 q{ INSERT INTO loader_test29 (id,fk) VALUES (1,1) }, 1938 1939 qq{ 1940 CREATE TABLE loader_test31 ( 1941 id INTEGER NOT NULL PRIMARY KEY 1942 ) $self->{innodb} 1943 }, 1944 q{ INSERT INTO loader_test31 (id) VALUES (1) }, 1945 1946 qq{ 1947 CREATE TABLE loader_test32 ( 1948 id INTEGER NOT NULL PRIMARY KEY, 1949 rel1 INTEGER NOT NULL, 1950 rel2 INTEGER $self->{null}, 1951 FOREIGN KEY (rel1) REFERENCES loader_test31(id), 1952 FOREIGN KEY (rel2) REFERENCES loader_test31(id) 1953 ) $self->{innodb} 1954 }, 1955 q{ INSERT INTO loader_test32 (id,rel1) VALUES (1,1) }, 1956 1957 qq{ 1958 CREATE TABLE loader_test33 ( 1959 id1 INTEGER NOT NULL, 1960 id2 INTEGER NOT NULL, 1961 PRIMARY KEY (id1,id2) 1962 ) $self->{innodb} 1963 }, 1964 q{ INSERT INTO loader_test33 (id1,id2) VALUES (1,2) }, 1965 1966 qq{ 1967 CREATE TABLE loader_test34 ( 1968 id INTEGER NOT NULL PRIMARY KEY, 1969 rel1 INTEGER NOT NULL, 1970 rel2 INTEGER $self->{null}, 1971 FOREIGN KEY (id,rel1) REFERENCES loader_test33(id1,id2), 1972 FOREIGN KEY (id,rel2) REFERENCES loader_test33(id1,id2) 1973 ) $self->{innodb} 1974 }, 1975 q{ INSERT INTO loader_test34 (id,rel1,rel2) VALUES (1,2,2) }, 1976 1977 qq{ 1978 CREATE TABLE loader_test37 ( 1979 parent INTEGER NOT NULL, 1980 child INTEGER NOT NULL UNIQUE, 1981 PRIMARY KEY (parent, child), 1982 FOREIGN KEY (parent) REFERENCES loader_test32 (id), 1983 FOREIGN KEY (child) REFERENCES loader_test34 (id) 1984 ) $self->{innodb} 1985 }, 1986 q{ INSERT INTO loader_test37 (parent, child) VALUES (1,1) }, 1987 1988 qq{ 1989 CREATE TABLE loader_test42 ( 1990 id1 INTEGER NOT NULL, 1991 id2 INTEGER NOT NULL, 1992 PRIMARY KEY (id1, id2) 1993 ) $self->{innodb} 1994 }, 1995 qq{ 1996 CREATE TABLE loader_test43 ( 1997 id1 INTEGER NOT NULL, 1998 id2 INTEGER NOT NULL, 1999 PRIMARY KEY (id1, id2) 2000 ) $self->{innodb} 2001 }, 2002 qq{ 2003 CREATE TABLE loader_test44 ( 2004 id42 INTEGER NOT NULL, 2005 id43 INTEGER NOT NULL, 2006 id2 INTEGER NOT NULL, 2007 PRIMARY KEY (id42, id43, id2), 2008 FOREIGN KEY (id42, id2) REFERENCES loader_test42 (id1, id2), 2009 FOREIGN KEY (id43, id2) REFERENCES loader_test43 (id1, id2) 2010 ) $self->{innodb} 2011 }, 2012 ); 2013 2014 @statements_advanced = ( 2015 qq{ 2016 CREATE TABLE loader_test10 ( 2017 id10 $self->{auto_inc_pk}, 2018 subject VARCHAR(8), 2019 loader_test11 INTEGER $self->{null} 2020 ) $self->{innodb} 2021 }, 2022 $make_auto_inc->(qw/loader_test10 id10/), 2023 2024# Access does not support DEFAULT. 2025 qq{ 2026 CREATE TABLE loader_test11 ( 2027 id11 $self->{auto_inc_pk}, 2028 a_message VARCHAR(8) @{[ $self->{vendor} ne 'Access' ? "DEFAULT 'foo'" : '' ]}, 2029 loader_test10 INTEGER $self->{null}, 2030 FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10) 2031 ) $self->{innodb} 2032 }, 2033 $make_auto_inc->(qw/loader_test11 id11/), 2034 2035 (lc($self->{vendor}) ne 'informix' ? 2036 (q{ ALTER TABLE loader_test10 ADD CONSTRAINT loader_test11_fk } . 2037 q{ FOREIGN KEY (loader_test11) } . 2038 q{ REFERENCES loader_test11 (id11) }) 2039 : 2040 (q{ ALTER TABLE loader_test10 ADD CONSTRAINT } . 2041 q{ FOREIGN KEY (loader_test11) } . 2042 q{ REFERENCES loader_test11 (id11) } . 2043 q{ CONSTRAINT loader_test11_fk }) 2044 ), 2045 ); 2046 2047 @statements_advanced_sqlite = ( 2048 qq{ 2049 CREATE TABLE loader_test10 ( 2050 id10 $self->{auto_inc_pk}, 2051 subject VARCHAR(8) 2052 ) $self->{innodb} 2053 }, 2054 $make_auto_inc->(qw/loader_test10 id10/), 2055 2056 qq{ 2057 CREATE TABLE loader_test11 ( 2058 id11 $self->{auto_inc_pk}, 2059 a_message VARCHAR(8) DEFAULT 'foo', 2060 loader_test10 INTEGER $self->{null}, 2061 FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10) 2062 ) $self->{innodb} 2063 }, 2064 $make_auto_inc->(qw/loader_test11 id11/), 2065 2066 (q{ ALTER TABLE loader_test10 ADD COLUMN } . 2067 q{ loader_test11 INTEGER REFERENCES loader_test11 (id11) }), 2068 ); 2069 2070 @statements_inline_rels = ( 2071 qq{ 2072 CREATE TABLE loader_test12 ( 2073 id INTEGER NOT NULL PRIMARY KEY, 2074 id2 VARCHAR(8) NOT NULL UNIQUE, 2075 dat VARCHAR(8) NOT NULL UNIQUE 2076 ) $self->{innodb} 2077 }, 2078 2079 q{ INSERT INTO loader_test12 (id,id2,dat) VALUES (1,'aaa','bbb') }, 2080 2081 qq{ 2082 CREATE TABLE loader_test13 ( 2083 id INTEGER NOT NULL PRIMARY KEY REFERENCES loader_test12, 2084 loader_test12 VARCHAR(8) NOT NULL REFERENCES loader_test12 (id2), 2085 dat VARCHAR(8) REFERENCES loader_test12 (dat) 2086 ) $self->{innodb} 2087 }, 2088 2089 (q{ INSERT INTO loader_test13 (id,loader_test12,dat) } . 2090 q{ VALUES (1,'aaa','bbb') }), 2091 ); 2092 2093 2094 @statements_implicit_rels = ( 2095 qq{ 2096 CREATE TABLE loader_test14 ( 2097 id INTEGER NOT NULL PRIMARY KEY, 2098 dat VARCHAR(8) 2099 ) $self->{innodb} 2100 }, 2101 2102 q{ INSERT INTO loader_test14 (id,dat) VALUES (123,'aaa') }, 2103 2104 qq{ 2105 CREATE TABLE loader_test15 ( 2106 id INTEGER NOT NULL PRIMARY KEY, 2107 loader_test14 INTEGER NOT NULL, 2108 FOREIGN KEY (loader_test14) REFERENCES loader_test14 2109 ) $self->{innodb} 2110 }, 2111 2112 q{ INSERT INTO loader_test15 (id,loader_test14) VALUES (1,123) }, 2113 ); 2114 2115 $self->drop_tables; 2116 2117 my $dbh = $self->dbconnect(1); 2118 2119 $dbh->do($_) for @{ $self->{pre_create} || [] }; 2120 2121 $dbh->do($_) foreach (@statements); 2122 2123 if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) { 2124 foreach my $ddl (@{ $self->{data_type_tests}{ddl} || [] }) { 2125 if (my $cb = $self->{data_types_ddl_cb}) { 2126 $cb->($ddl); 2127 } 2128 else { 2129 $dbh->do($ddl); 2130 } 2131 } 2132 } 2133 2134 unless ($self->{skip_rels}) { 2135 # hack for now, since DB2 doesn't like inline comments, and we need 2136 # to test one for mysql, which works on everyone else... 2137 # this all needs to be refactored anyways. 2138 2139 for my $stmt (@statements_reltests) { 2140 try { 2141 $dbh->do($stmt); 2142 } 2143 catch { 2144 die "Error executing '$stmt': $_\n"; 2145 }; 2146 } 2147 if($self->{vendor} =~ /sqlite/i) { 2148 $dbh->do($_) for (@statements_advanced_sqlite); 2149 } 2150 else { 2151 $dbh->do($_) for (@statements_advanced); 2152 } 2153 unless($self->{no_inline_rels}) { 2154 $dbh->do($_) for (@statements_inline_rels); 2155 } 2156 unless($self->{no_implicit_rels}) { 2157 $dbh->do($_) for (@statements_implicit_rels); 2158 } 2159 } 2160 2161 $dbh->do($_) for @{ $self->{extra}->{create} || [] }; 2162 $dbh->disconnect(); 2163} 2164 2165sub drop_tables { 2166 my $self = shift; 2167 2168 my @tables = qw/ 2169 loader_test1 2170 loader_test1s 2171 loader_test2 2172 LOADER_test23 2173 LoAdEr_test24 2174 loader_test35 2175 loader_test36 2176 loader_test50 2177 /; 2178 2179 my @tables_auto_inc = ( 2180 [ qw/loader_test1s id/ ], 2181 [ qw/loader_test2 id/ ], 2182 ); 2183 2184 my @tables_reltests = qw/ 2185 loader_test4 2186 loader_test3 2187 loader_test6 2188 loader_test5 2189 loader_test8 2190 loader_test7 2191 loader_test9 2192 loader_test17 2193 loader_test16 2194 loader_test20 2195 loader_test19 2196 loader_test18 2197 loader_test22 2198 loader_test21 2199 loader_test26 2200 loader_test25 2201 loader_test28 2202 loader_test29 2203 loader_test27 2204 loader_test37 2205 loader_test32 2206 loader_test31 2207 loader_test34 2208 loader_test33 2209 loader_test44 2210 loader_test43 2211 loader_test42 2212 /; 2213 2214 my @tables_advanced = qw/ 2215 loader_test11 2216 loader_test10 2217 /; 2218 2219 my @tables_advanced_auto_inc = ( 2220 [ qw/loader_test10 id10/ ], 2221 [ qw/loader_test11 id11/ ], 2222 ); 2223 2224 my @tables_inline_rels = qw/ 2225 loader_test13 2226 loader_test12 2227 /; 2228 2229 my @tables_implicit_rels = qw/ 2230 loader_test15 2231 loader_test14 2232 /; 2233 2234 my @tables_rescan = qw/ loader_test30 /; 2235 2236 my @tables_preserve_case_tests = @{ $self->{preserve_case_tests_table_names} }; 2237 2238 my %drop_columns = ( 2239 loader_test6 => 'loader_test7_id', 2240 loader_test7 => 'lovely_loader_test6', 2241 loader_test8 => 'loader_test16_id', 2242 loader_test16 => 'loader_test8_id', 2243 ); 2244 2245 my %drop_constraints = ( 2246 loader_test10 => 'loader_test11_fk', 2247 loader_test6 => 'loader_test6_to_7_fk', 2248 loader_test8 => 'loader_test8_to_16_fk', 2249 ); 2250 2251 # For some reason some tests do this twice (I guess dependency issues?) 2252 # do it twice for all drops 2253 for (1,2) { 2254 local $^W = 0; # for ADO 2255 2256 my $dbh = $self->dbconnect(0); 2257 2258 $dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] }; 2259 2260 $self->drop_table($dbh, $_) for @{ $self->{extra}{drop} || [] }; 2261 2262 my $drop_auto_inc = $self->{auto_inc_drop_cb} || sub {}; 2263 2264 unless ($self->{skip_rels}) { 2265 # drop the circular rel columns if possible, this 2266 # doesn't work on all DBs 2267 foreach my $table (keys %drop_columns) { 2268 $dbh->do("ALTER TABLE $table DROP $drop_columns{$table}"); 2269 $dbh->do("ALTER TABLE $table DROP COLUMN $drop_columns{$table}"); 2270 } 2271 2272 foreach my $table (keys %drop_constraints) { 2273 # for MSSQL 2274 $dbh->do("ALTER TABLE $table DROP $drop_constraints{$table}"); 2275 # for Sybase and Access 2276 $dbh->do("ALTER TABLE $table DROP CONSTRAINT $drop_constraints{$table}"); 2277 # for MySQL 2278 $dbh->do("ALTER TABLE $table DROP FOREIGN KEY $drop_constraints{$table}"); 2279 } 2280 2281 $self->drop_table($dbh, $_) for (@tables_reltests); 2282 $self->drop_table($dbh, $_) for (@tables_reltests); 2283 2284 $dbh->do($_) for map { $drop_auto_inc->(@$_) } @tables_advanced_auto_inc; 2285 2286 $self->drop_table($dbh, $_) for (@tables_advanced); 2287 2288 unless($self->{no_inline_rels}) { 2289 $self->drop_table($dbh, $_) for (@tables_inline_rels); 2290 } 2291 unless($self->{no_implicit_rels}) { 2292 $self->drop_table($dbh, $_) for (@tables_implicit_rels); 2293 } 2294 } 2295 $dbh->do($_) for map { $drop_auto_inc->(@$_) } @tables_auto_inc; 2296 $self->drop_table($dbh, $_) for (@tables, @tables_rescan); 2297 2298 if (not ($self->{vendor} eq 'mssql' && $dbh->{Driver}{Name} eq 'Sybase')) { 2299 foreach my $data_type_table (@{ $self->{data_type_tests}{table_names} || [] }) { 2300 $self->drop_table($dbh, $data_type_table); 2301 } 2302 } 2303 2304 $self->drop_table($dbh, $_) for @tables_preserve_case_tests; 2305 2306 $dbh->disconnect; 2307 } 2308} 2309 2310sub drop_table { 2311 my ($self, $dbh, $table) = @_; 2312 2313 local $^W = 0; # for ADO 2314 2315 try { $dbh->do("DROP TABLE $table CASCADE CONSTRAINTS") }; # oracle 2316 try { $dbh->do("DROP TABLE $table CASCADE") }; # postgres and ? 2317 try { $dbh->do("DROP TABLE $table") }; 2318 2319 # if table name is case sensitive 2320 my ($oqt, $cqt) = $self->get_oqt_cqt(always => 1); 2321 2322 try { $dbh->do("DROP TABLE ${oqt}${table}${cqt}") }; 2323} 2324 2325sub _custom_column_info { 2326 my ( $table_name, $column_name, $column_info ) = @_; 2327 2328 $table_name = lc ( $table_name ); 2329 $column_name = lc ( $column_name ); 2330 2331 if ( $table_name eq 'loader_test35' 2332 and $column_name eq 'an_int' 2333 ){ 2334 return { is_numeric => 1 } 2335 } 2336 # Set inflate_datetime or inflate_date to check 2337 # datetime_timezone and datetime_locale 2338 if ( $table_name eq 'loader_test36' ){ 2339 return { inflate_datetime => 1 } if 2340 ( $column_name eq 'b_char_as_data' ); 2341 return { inflate_date => 1 } if 2342 ( $column_name eq 'c_char_as_data' ); 2343 } 2344 2345 return; 2346} 2347 2348my %DATA_TYPE_MULTI_TABLE_OVERRIDES = ( 2349 oracle => qr/\blong\b/i, 2350 mssql => qr/\b(?:timestamp|rowversion)\b/i, 2351 informix => qr/\b(?:bigserial|serial8)\b/i, 2352); 2353 2354sub setup_data_type_tests { 2355 my $self = shift; 2356 2357 return unless my $types = $self->{data_types}; 2358 2359 my $tests = $self->{data_type_tests} = {}; 2360 2361 # split types into tables based on overrides 2362 my (@types, @split_off_types, @first_table_types); 2363 { 2364 my $split_off_re = $DATA_TYPE_MULTI_TABLE_OVERRIDES{lc($self->{vendor})} || qr/(?!)/; 2365 2366 @types = keys %$types; 2367 @split_off_types = grep /$split_off_re/, @types; 2368 @first_table_types = grep !/$split_off_re/, @types; 2369 } 2370 2371 @types = ( 2372 +{ map +($_, $types->{$_}), @first_table_types }, 2373 map +{ $_, $types->{$_} }, @split_off_types, 2374 ); 2375 2376 my $test_count = 0; 2377 my $table_num = 10000; 2378 2379 foreach my $types (@types) { 2380 my $table_name = "loader_test$table_num"; 2381 push @{ $tests->{table_names} }, $table_name; 2382 2383 my $table_moniker = "LoaderTest$table_num"; 2384 push @{ $tests->{table_monikers} }, $table_moniker; 2385 2386 $table_num++; 2387 2388 my $cols = $tests->{columns}{$table_moniker} = {}; 2389 2390 my $ddl = "CREATE TABLE $table_name (\n id INTEGER NOT NULL PRIMARY KEY,\n"; 2391 2392 my %seen_col_names; 2393 2394 while (my ($col_def, $expected_info) = each %$types) { 2395 (my $type_alias = $col_def) =~ s/\( (.+) \)(?=(?:[^()]* '(?:[^']* (?:''|\\')* [^']*)* [^\\']' [^()]*)*\z)//xg; 2396 2397 my $size = $1; 2398 $size = '' unless defined $size; 2399 $size = '' unless $size =~ /^[\d, ]+\z/; 2400 $size =~ s/\s+//g; 2401 my @size = split /,/, $size; 2402 2403 # some DBs don't like very long column names 2404 if ($self->{vendor} =~ /^(?:Firebird|SQLAnywhere|Oracle|DB2)\z/i) { 2405 my ($col_def, $default) = $type_alias =~ /^(.*)(default.*)?\z/i; 2406 2407 $type_alias = substr $col_def, 0, 15; 2408 2409 $type_alias .= '_with_dflt' if $default; 2410 } 2411 2412 $type_alias =~ s/\s/_/g; 2413 $type_alias =~ s/\W//g; 2414 2415 my $col_name = 'col_' . $type_alias; 2416 2417 if (@size) { 2418 my $size_name = join '_', apply { s/\W//g } @size; 2419 2420 $col_name .= "_sz_$size_name"; 2421 } 2422 2423 # XXX would be better to check loader->preserve_case 2424 $col_name = lc $col_name; 2425 2426 $col_name .= '_' . $seen_col_names{$col_name} if $seen_col_names{$col_name}++; 2427 2428 $ddl .= " $col_name $col_def,\n"; 2429 2430 $cols->{$col_name} = $expected_info; 2431 2432 $test_count++; 2433 } 2434 2435 $ddl =~ s/,\n\z/\n)/; 2436 2437 push @{ $tests->{ddl} }, $ddl; 2438 } 2439 2440 $tests->{test_count} = $test_count; 2441 2442 return $test_count; 2443} 2444 2445sub rescan_without_warnings { 2446 my ($self, $conn) = @_; 2447 2448 local $SIG{__WARN__} = sigwarn_silencer(RESCAN_WARNINGS); 2449 return $conn->rescan; 2450} 2451 2452sub test_col_accessor_map { 2453 my ( $self, $column_name, $default_name, $context, $default_map ) = @_; 2454 if( lc($column_name) eq 'crumb_crisp_coating' ) { 2455 2456 unless ($self->{col_accessor_map_tests_run}++) { 2457 is( $default_name, 'crumb_crisp_coating', 'col_accessor_map was passed the default name' ); 2458 ok( $context->{$_}, "col_accessor_map func was passed the $_" ) 2459 for qw( table table_name table_class table_moniker schema_class ); 2460 } 2461 return 'trivet'; 2462 } else { 2463 return $default_map->({ 2464 LOADER_TEST2 => { 2465 sticky_filling => 'goo', 2466 }, 2467 loader_test2 => { 2468 sticky_filling => 'goo', 2469 }, 2470 }); 2471 } 2472} 2473 2474sub DESTROY { 2475 my $self = shift; 2476 unless ($ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) { 2477 $self->drop_tables if $self->{_created}; 2478 rmtree DUMP_DIR 2479 } 2480} 2481 24821; 2483# vim:et sts=4 sw=4 tw=0: 2484