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