X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2Fdbixcsl_common_tests.pm;h=e69ca71aefe44c2c0254982cda5f4c17309621d3;hb=55b9a2a018c33b87136f1c51bfb7e1e383a2545d;hp=13c8002ee2131468ad6b2b5e9f2d20a66cad57cc;hpb=a40434df5a53f085fb693e7c83aa08eca39de567;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index 13c8002..e69ca71 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -4,15 +4,16 @@ use strict; use warnings; use Test::More; +use Test::Deep; 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 +89,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 +117,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)); + (225 + $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 +216,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 +258,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 +288,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 +629,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}, 142 if $self->{skip_rels}; my $moniker3 = $monikers->{loader_test3}; my $class3 = $classes->{loader_test3}; @@ -722,6 +727,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 +755,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; @@ -914,26 +924,67 @@ qr/\n__PACKAGE__->(?:belongs_to|has_many|might_have|has_one|many_to_many)\( isa_ok(try { $rs_rel17->single }, $class17); is(try { $rs_rel17->single->id }, 3, "search_related with multiple FKs from same table"); - # XXX test m:m 18 <- 20 -> 19 + # test many_to_many detection 18 -> 20 -> 19 and 19 -> 20 -> 18 ok($class20->column_info('parent')->{is_foreign_key}, 'Foreign key detected'); ok($class20->column_info('child')->{is_foreign_key}, 'Foreign key detected'); - # XXX test double-fk m:m 21 <- 22 -> 21 - ok($class22->column_info('parent')->{is_foreign_key}, 'Foreign key detected'); - ok($class22->column_info('child')->{is_foreign_key}, 'Foreign key detected'); + cmp_deeply( + $class18->_m2m_metadata->{children}, + superhashof({ + relation => 'loader_test20s', + foreign_relation => 'child', + attrs => superhashof({ order_by => 'me.id' }) + }), + 'children m2m correct with ordering' + ); - # test many_to_many detection 18 -> 20 -> 19 and 19 -> 20 -> 18 - my $m2m; + cmp_deeply( + $class19->_m2m_metadata->{parents}, + superhashof({ + relation => 'loader_test20s', + foreign_relation => 'parent', + attrs => superhashof({ order_by => 'me.id' }) + }), + 'parents m2m correct with ordering' + ); - ok($m2m = (try { $class18->_m2m_metadata->{children} }), 'many_to_many created'); - is $m2m->{relation}, 'loader_test20s', 'm2m near rel'; - is $m2m->{foreign_relation}, 'child', 'm2m far rel'; + # test double-fk m:m 21 <- 22 -> 21 + ok($class22->column_info('parent')->{is_foreign_key}, 'Foreign key detected'); + ok($class22->column_info('child')->{is_foreign_key}, 'Foreign key detected'); + is_deeply( + $class21->relationship_info("loader_test22_parents")->{cond}, + { 'foreign.parent' => 'self.id' }, + 'rel to foreign.parent correct' + ); + is_deeply( + $class21->relationship_info("loader_test22_children")->{cond}, + { 'foreign.child' => 'self.id' }, + 'rel to foreign.child correct' + ); - ok($m2m = (try { $class19->_m2m_metadata->{parents} }), 'many_to_many created'); + cmp_deeply( + $class21->_m2m_metadata, + { + parents => superhashof({ + accessor => 'parents', + relation => 'loader_test22_children', + foreign_relation => 'parent', + }), + children => superhashof({ + accessor => 'children', + relation => 'loader_test22_parents', + foreign_relation => 'child', + }), + }, + 'self-m2m correct' + ); + + ok( $class37->relationship_info('parent'), 'parents rel created' ); + ok( $class37->relationship_info('child'), 'child rel created' ); - is $m2m->{relation}, 'loader_test20s', 'm2m near rel'; - is $m2m->{foreign_relation}, 'parent', 'm2m far rel'; + 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; @@ -1080,7 +1131,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 } @@ -1161,8 +1212,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; @@ -1170,18 +1221,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; @@ -1195,12 +1246,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'); @@ -1250,12 +1310,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 } ] @@ -1851,6 +1909,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 = ( @@ -2043,6 +2112,7 @@ sub drop_tables { loader_test28 loader_test29 loader_test27 + loader_test37 loader_test32 loader_test31 loader_test34 @@ -2206,8 +2276,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; @@ -2281,7 +2353,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; } @@ -2291,7 +2363,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 {