Use Test::Differences to check lack of file rewrite
[dbsrgits/DBIx-Class-Schema-Loader.git] / t / lib / dbixcsl_common_tests.pm
index e00920b..d9f3485 100644 (file)
@@ -5,14 +5,14 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
+use Test::Differences;
 use DBIx::Class::Schema::Loader;
 use Class::Unload;
 use File::Path 'rmtree';
 use DBI;
-use Digest::MD5;
 use File::Find 'find';
 use Class::Unload ();
-use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file/;
+use DBIx::Class::Schema::Loader::Utils qw/dumper_squashed slurp_file sigwarn_silencer/;
 use List::MoreUtils 'apply';
 use DBIx::Class::Schema::Loader::Optional::Dependencies ();
 use Try::Tiny;
@@ -88,8 +88,11 @@ sub skip_tests {
 
 sub _monikerize {
     my $name = shift;
-    return 'LoaderTest2X' if $name =~ /^loader_test2$/i;
-    return undef;
+    my $orig = pop;
+    return $orig->({
+        loader_test2 => 'LoaderTest2X',
+        LOADER_TEST2 => 'LoaderTest2X',
+    });
 }
 
 sub run_tests {
@@ -113,13 +116,13 @@ sub run_tests {
 
     my $extra_count = $self->{extra}{count} || 0;
 
-    my $col_accessor_map_tests = 5;
+    my $col_accessor_map_tests = 6;
     my $num_rescans = 6;
     $num_rescans++ if $self->{vendor} eq 'mssql';
     $num_rescans++ if $self->{vendor} eq 'Firebird';
 
     plan tests => @connect_info *
-        (221 + $num_rescans * $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+        (228 + $num_rescans * $col_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
 
     foreach my $info_idx (0..$#connect_info) {
         my $info = $connect_info[$info_idx];
@@ -212,7 +215,7 @@ my (@statements, @statements_reltests, @statements_advanced,
 
 sub CONSTRAINT {
     my $self = shift;
-return qr/^(?:\S+\.)?(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i;
+return qr/^(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i;
 }
 
 sub setup_schema {
@@ -254,6 +257,7 @@ sub setup_schema {
         ) : (),
         col_collision_map       => { '^(can)\z' => 'caught_collision_%s' },
         rel_collision_map       => { '^(set_primary_key)\z' => 'caught_rel_collision_%s' },
+        relationship_attrs      => { many_to_many => { order_by => 'me.id' } },
         col_accessor_map        => \&test_col_accessor_map,
         result_components_map   => { LoaderTest2X => 'TestComponentForMap', LoaderTest1 => '+TestComponentForMapFQN' },
         uniq_to_primary         => 1,
@@ -283,7 +287,7 @@ sub setup_schema {
         my $standard_sources = not defined $expected_count;
 
         if ($standard_sources) {
-            $expected_count = 37;
+            $expected_count = 38;
 
             if (not ($self->{vendor} eq 'mssql' && $connect_info->[0] =~ /Sybase/)) {
                 $expected_count++ for @{ $self->{data_type_tests}{table_names} || [] };
@@ -624,7 +628,7 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
         'is_nullable=1 detection';
 
     SKIP: {
-        skip $self->{skip_rels}, 137 if $self->{skip_rels};
+        skip $self->{skip_rels}, 145 if $self->{skip_rels};
 
         my $moniker3 = $monikers->{loader_test3};
         my $class3   = $classes->{loader_test3};
@@ -722,6 +726,10 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
         my $class36   = $classes->{loader_test36};
         my $rsobj36   = $conn->resultset($moniker36);
 
+        my $moniker37 = $monikers->{loader_test37};
+        my $class37   = $classes->{loader_test37};
+        my $rsobj37   = $conn->resultset($moniker37);
+
         isa_ok( $rsobj3, "DBIx::Class::ResultSet" );
         isa_ok( $rsobj4, "DBIx::Class::ResultSet" );
         isa_ok( $rsobj5, "DBIx::Class::ResultSet" );
@@ -746,6 +754,7 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
         isa_ok( $rsobj33, "DBIx::Class::ResultSet" );
         isa_ok( $rsobj34, "DBIx::Class::ResultSet" );
         isa_ok( $rsobj36, "DBIx::Class::ResultSet" );
+        isa_ok( $rsobj37, "DBIx::Class::ResultSet" );
 
         # basic rel test
         my $obj4 = try { $rsobj4->find(123) } || $rsobj4->search({ id => 123 })->single;
@@ -791,13 +800,17 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
 
         my $default_on_clause = $self->{default_on_clause} || 'CASCADE';
 
+        my $default_on_delete_clause = $self->{default_on_delete_clause} || $default_on_clause;
+
         is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete} },
-            $default_on_clause,
-            "on_delete is $default_on_clause on belongs_to by default";
+            $default_on_delete_clause,
+            "on_delete is $default_on_delete_clause on belongs_to by default";
+
+        my $default_on_update_clause = $self->{default_on_update_clause} || $default_on_clause;
 
         is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update} },
-            $default_on_clause,
-            "on_update is $default_on_clause on belongs_to by default";
+            $default_on_update_clause,
+            "on_update is $default_on_update_clause on belongs_to by default";
 
         my $default_is_deferrable = $self->{default_is_deferrable};
 
@@ -925,11 +938,19 @@ qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\(
 
         is $m2m->{relation}, 'loader_test20s', 'm2m near rel';
         is $m2m->{foreign_relation}, 'child', 'm2m far rel';
+        is $m2m->{attrs}->{order_by}, 'me.id', 'm2m bridge attrs';
 
         ok($m2m = (try { $class19->_m2m_metadata->{parents} }), 'many_to_many created');
 
         is $m2m->{relation}, 'loader_test20s', 'm2m near rel';
         is $m2m->{foreign_relation}, 'parent', 'm2m far rel';
+        is $m2m->{attrs}->{order_by}, 'me.id', 'm2m bridge attrs';
+
+        ok( $class37->relationship_info('parent'), 'parents rel created' );
+        ok( $class37->relationship_info('child'), 'child rel created' );
+
+        is_deeply($class32->_m2m_metadata, {}, 'many_to_many not created for might_have');
+        is_deeply($class34->_m2m_metadata, {}, 'many_to_many not created for might_have');
 
         # test double multi-col fk 26 -> 25
         my $obj26 = try { $rsobj26->find(33) } || $rsobj26->search({ id => 33 })->single;
@@ -1076,7 +1097,7 @@ qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\(
 
         # relname is preserved when another fk is added
         {
-            local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /invalidates \d+ active statement/ };
+            local $SIG{__WARN__} = sigwarn_silencer(qr/invalidates \d+ active statement/);
             $conn->storage->disconnect; # for mssql and access
         }
 
@@ -1157,8 +1178,8 @@ EOF
             q{ INSERT INTO loader_test30 (id,loader_test2) VALUES(321, 2) },
         );
 
-        # get md5
-        my $digest  = Digest::MD5->new;
+        # get contents
+        my %contents;
 
         my $find_cb = sub {
             return if -d;
@@ -1166,18 +1187,18 @@ EOF
 
             open my $fh, '<', $_ or die "Could not open $_ for reading: $!";
             binmode $fh;
-            $digest->addfile($fh);
+            local $/;
+            $contents{$File::Find::name} = <$fh>;
         };
 
         find $find_cb, DUMP_DIR;
+        my %contents_before = %contents;
 
 #        system "rm -rf /tmp/before_rescan /tmp/after_rescan";
 #        system "mkdir /tmp/before_rescan";
 #        system "mkdir /tmp/after_rescan";
 #        system "cp -a @{[DUMP_DIR]} /tmp/before_rescan";
 
-        my $before_digest = $digest->b64digest;
-
         $conn->storage->disconnect; # needed for Firebird and Informix
         my $dbh = $self->dbconnect(1);
         $dbh->do($_) for @statements_rescan;
@@ -1191,12 +1212,21 @@ EOF
 
 #        system "cp -a @{[DUMP_DIR]} /tmp/after_rescan";
 
-        $digest = Digest::MD5->new;
+        undef %contents;
         find $find_cb, DUMP_DIR;
-        my $after_digest = $digest->b64digest;
-
-        is $before_digest, $after_digest,
-            'dumped files are not rewritten when there is no modification';
+        my %contents_after = %contents;
+
+        subtest 'dumped files are not rewritten when there is no modification' => sub {
+            plan tests => 1 + scalar keys %contents_before;
+            is_deeply
+                [sort keys %contents_before],
+                [sort keys %contents_after],
+                'same files dumped';
+            for my $file (sort keys %contents_before) {
+                eq_or_diff $contents_before{$file}, $contents_after{$file},
+                    "$file not rewritten";
+            }
+        };
 
         my $rsobj30   = $conn->resultset('LoaderTest30');
         isa_ok($rsobj30, 'DBIx::Class::ResultSet');
@@ -1246,12 +1276,10 @@ TODO: {
 
         my $guard = $conn->txn_scope_guard;
 
-        my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-        local $SIG{__WARN__} = sub {
-            $warn_handler->(@_)
-                unless $_[0] =~ RESCAN_WARNINGS
-                    || $_[0] =~ /commit ineffective with AutoCommit enabled/; # FIXME
-        };
+        my $rescan_warnings = RESCAN_WARNINGS;
+        local $SIG{__WARN__} = sigwarn_silencer(
+            qr/$rescan_warnings|commit ineffective with AutoCommit enabled/ # FIXME
+        );
 
         my $schema_from = DBIx::Class::Schema::Loader::make_schema_at(
             "TestSchemaFromAnother", \%opts, [ sub { $conn->storage->dbh } ]
@@ -1847,6 +1875,17 @@ sub create {
           ) $self->{innodb}
         },
         q{ INSERT INTO loader_test34 (id,rel1,rel2) VALUES (1,2,2) },
+
+        qq{
+          CREATE TABLE loader_test37 (
+            parent INTEGER NOT NULL,
+            child INTEGER NOT NULL UNIQUE,
+            PRIMARY KEY (parent, child),
+            FOREIGN KEY (parent) REFERENCES loader_test32 (id),
+            FOREIGN KEY (child) REFERENCES loader_test34 (id)
+          ) $self->{innodb}
+        },
+        q{ INSERT INTO loader_test37 (parent, child) VALUES (1,1) },
     );
 
     @statements_advanced = (
@@ -2039,6 +2078,7 @@ sub drop_tables {
         loader_test28
         loader_test29
         loader_test27
+        loader_test37
         loader_test32
         loader_test31
         loader_test34
@@ -2202,8 +2242,10 @@ sub setup_data_type_tests {
         @first_table_types = grep !/$split_off_re/, @types;
     }
 
-    @types = +{ map +($_, $types->{$_}), @first_table_types },
-        map +{ $_, $types->{$_} }, @split_off_types;
+    @types = (
+        +{ map +($_, $types->{$_}), @first_table_types },
+        map +{ $_, $types->{$_} }, @split_off_types,
+    );
 
     my $test_count = 0;
     my $table_num  = 10000;
@@ -2277,7 +2319,7 @@ sub setup_data_type_tests {
 sub rescan_without_warnings {
     my ($self, $conn) = @_;
 
-    local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ RESCAN_WARNINGS };
+    local $SIG{__WARN__} = sigwarn_silencer(RESCAN_WARNINGS);
     return $conn->rescan;
 }
 
@@ -2287,7 +2329,7 @@ sub test_col_accessor_map {
 
         is( $default_name, 'crumb_crisp_coating', 'col_accessor_map was passed the default name' );
         ok( $context->{$_}, "col_accessor_map func was passed the $_" )
-            for qw( table_name table_class table_moniker schema_class );
+            for qw( table table_name table_class table_moniker schema_class );
 
         return 'trivet';
     } else {