t/lib/dbixcsl_common_tests.pm

   1 package dbixcsl_common_tests;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7 use Test::Deep;
   8 use Test::Exception;
   9 use Test::Differences;
  10 use DBIx::Class::Schema::Loader;
  11 use Class::Unload;
  12 use File::Path 'rmtree';
  13 use curry;
  14 use DBI;
  15 use File::Find 'find';
  16 use Class::Unload ();
  17 use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file sigwarn_silencer apply/;
  18 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
  19 use Try::Tiny;
  20 use File::Spec::Functions 'catfile';
  21 use File::Basename 'basename';
  22 use namespace::clean;
  23
  24 use dbixcsl_test_dir '$tdir';
  25
  26 use constant DUMP_DIR => "$tdir/common_dump";
  27
  28 rmtree DUMP_DIR;
  29
  30 use 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
  33 use constant SOURCE_DDL => qr/CREATE (?:TABLE|VIEW) (?!"dbicsl[.-]test")/i;
  34
  35 use constant SCHEMA_CLASS => 'DBIXCSL_Test::Schema';
  36
  37 use constant RESULT_NAMESPACE => [ 'MyResult', 'MyResultTwo' ];
  38
  39 use constant RESULTSET_NAMESPACE => [ 'MyResultSet', 'MyResultSetTwo' ];
  40
  41 sub 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
  84 sub skip_tests {
  85     my ($self, $why) = @_;
  86
  87     plan skip_all => $why;
  88 }
  89
  90 sub _monikerize {
  91     my $name = shift;
  92     my $orig = pop;
  93     return $orig->({
  94         loader_test2 => 'LoaderTest2X',
  95         LOADER_TEST2 => 'LoaderTest2X',
  96     });
  97 }
  98
  99 sub 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
 140 sub 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
 194 sub 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
 212 my (@statements, @statements_reltests, @statements_advanced,
 213     @statements_advanced_sqlite, @statements_inline_rels,
 214     @statements_implicit_rels);
 215
 216 sub CONSTRAINT {
 217     my $self = shift;
 218 return qr/^(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i;
 219 }
 220
 221 sub 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
 338 sub 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,
 406 qr/\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,
 413 qr/\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}
1211 EOF
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)
1214 EOF
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
1362 TODO: {
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
1398 sub 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
1430 sub 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 (
1440 qq|
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 |,
1446 qq|
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 |,
1453 qq| INSERT INTO ${oqt}${table40_name}${cqt} VALUES (1, 'foo') |,
1454 qq| 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
1487 sub 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
1507 sub 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
1520 sub 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
1547 sub 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
1567 sub 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
2165 sub 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
2310 sub 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
2325 sub _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
2348 my %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
2354 sub 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
2445 sub rescan_without_warnings {
2446     my ($self, $conn) = @_;
2447
2448     local $SIG{__WARN__} = sigwarn_silencer(RESCAN_WARNINGS);
2449     return $conn->rescan;
2450 }
2451
2452 sub 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
2474 sub 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
2482 1;
2483 # vim:et sts=4 sw=4 tw=0: