X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F25backcompat.t;h=477f65461b592c6670ddf8728dab2f31736484c0;hb=3b7ea110ea6e400d497b05e8e366db10e30abfdb;hp=dfb4f4e4b5b04947ecd21849d13b5b43d9e51d0c;hpb=ecf930e6ea3321d8ae6e042b282c824897684c18;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/t/25backcompat.t b/t/25backcompat.t index dfb4f4e..477f654 100644 --- a/t/25backcompat.t +++ b/t/25backcompat.t @@ -6,30 +6,34 @@ use File::Path qw/rmtree make_path/; use Class::Unload; use File::Temp qw/tempfile tempdir/; use IO::File; -use File::Slurp 'slurp'; use DBIx::Class::Schema::Loader (); +use DBIx::Class::Schema::Loader::Utils 'slurp_file'; use Lingua::EN::Inflect::Number (); use lib qw(t/lib); use make_dbictest_db_with_unique; +use dbixcsl_test_dir qw/$tdir/; -my $DUMP_DIR = './t/_common_dump'; +my $DUMP_DIR = "$tdir/common_dump"; rmtree $DUMP_DIR; my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; -sub class_content_like; +my $RESULT_COUNT = 7; + +sub class_content_contains; +sub contains; # test dynamic schema in 0.04006 mode { my $res = run_loader(); my $warning = $res->{warnings}[0]; - like $warning, qr/dynamic schema/i, + contains $warning, 'Dynamic schema', 'dynamic schema in backcompat mode detected'; - like $warning, qr/run in 0\.04006 mode/i, + contains $warning, 'run in 0.04006 mode', 'dynamic schema in 0.04006 mode warning'; - like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, + contains $warning, 'DBIx::Class::Schema::Loader::Manual::UpgradingFromV4', 'warning refers to upgrading doc'; - + run_v4_tests($res); } @@ -45,7 +49,7 @@ sub class_content_like; { my $res = run_loader(naming => 'current'); is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; - run_v6_tests($res); + run_v7_tests($res); } # test upgraded dynamic schema with external content loaded @@ -55,7 +59,7 @@ sub class_content_like; Bar => 'Foos', }); - my $res = run_loader(naming => 'current'); + my $res = run_loader(naming => 'current', use_namespaces => 0); my $schema = $res->{schema}; is scalar @{ $res->{warnings} }, 1, @@ -63,7 +67,7 @@ sub class_content_like; 'content for unsingularized Result.'; my $warning = $res->{warnings}[0]; - like $warning, qr/Detected external content/i, + contains $warning, 'Detected external content', 'detected external content warning'; lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } @@ -82,7 +86,7 @@ sub class_content_like; 'unsingularized class names in external content from unchanged Result class ' . 'names are translated'; - run_v6_tests($res); + run_v7_tests($res); } # test upgraded dynamic schema with use_namespaces with external content loaded @@ -100,7 +104,7 @@ sub class_content_like; 'content for unsingularized Result with use_namespaces.'; my $warning = $res->{warnings}[0]; - like $warning, qr/Detected external content/i, + contains $warning, "Detected external content", 'detected external content warning'; lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } @@ -116,7 +120,7 @@ sub class_content_like; 'unsingularized class names in external content from unchanged Result class ' . 'names are translated'; - run_v6_tests($res); + run_v7_tests($res); } # test upgraded static schema with external content loaded @@ -133,7 +137,7 @@ sub class_content_like; my $res = run_loader(static => 1, naming => 'current'); my $schema = $res->{schema}; - run_v6_tests($res); + run_v7_tests($res); lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 'external custom content for unsingularized Result was loaded by upgraded ' . @@ -148,36 +152,13 @@ sub class_content_like; 'unsingularized class names in external content from unchanged Result class ' . 'names are translated in static schema'; - class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/, + class_content_contains $schema, $res->{classes}{quuxs}, "package ${SCHEMA_CLASS}::Quux;", 'package line translated correctly from external custom content in static dump'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }", 'external custom content loaded into static dump correctly'; } -# test creating static schema in v5 mode then upgrade to current with external -# content loaded -# XXX needs real load_external tests -{ - clean_dumpdir(); - - my $temp_dir = setup_load_external({ - Quux => 'Baz', - Bar => 'Foo', - }, { result_namespace => 'Result' }); - - write_v5_schema_pm(); - - my $res = run_loader(static => 1); - - run_v5_tests($res); - - $res = run_loader(static => 1, naming => 'current'); - my $schema = $res->{schema}; - - run_v6_tests($res); -} - # test running against v4 schema without upgrade, twice, then upgrade { clean_dumpdir(); @@ -185,11 +166,11 @@ sub class_content_like; my $res = run_loader(static => 1); my $warning = $res->{warnings}[1]; - like $warning, qr/static schema/i, + contains $warning, "static schema", 'static schema in backcompat mode detected'; - like $warning, qr/0.04006/, + contains $warning, "0.04006", 'correct version detected'; - like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, + contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4", 'refers to upgrading doc'; is scalar @{ $res->{warnings} }, 4, @@ -214,19 +195,19 @@ sub class_content_like; ); my $schema = $res->{schema}; - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on upgrading static schema (with "naming" set)'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on upgrading static schema (with "naming" set)'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on upgrading static schema (with "naming" set)' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); - is result_count('Result'), 6, + is result_count('Result'), $RESULT_COUNT, 'un-singularized results were replaced during upgrade'; # check that custom content was preserved @@ -237,7 +218,7 @@ sub class_content_like; $res->{classes}{bazs} } 'unsingularized class names in custom content are translated'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from unsingularized Result loaded into static dump correctly'; } @@ -249,11 +230,11 @@ sub class_content_like; my $res = run_loader(static => 1); my $warning = $res->{warnings}[1]; - like $warning, qr/static schema/i, + contains $warning, "static schema", 'static schema in backcompat mode detected'; - like $warning, qr/0.04006/, + contains $warning, "0.04006", 'correct version detected'; - like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, + contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4", 'refers to upgrading doc'; is scalar @{ $res->{warnings} }, 4, @@ -272,15 +253,15 @@ sub class_content_like; ); my $schema = $res->{schema}; - like $res->{warnings}[0], qr/load_classes/i, + contains $res->{warnings}[0], "load_classes", 'correct warnings on upgrading static schema (with "naming" set and ' . 'use_namespaces not set)'; - like $res->{warnings}[1], qr/Dumping manual schema/i, + contains $res->{warnings}[1], "Dumping manual schema", 'correct warnings on upgrading static schema (with "naming" set and ' . 'use_namespaces not set)'; - like $res->{warnings}[2], qr/dump completed/i, + contains $res->{warnings}[2], "dump completed", 'correct warnings on upgrading static schema (with "naming" set and ' . 'use_namespaces not set)'; @@ -288,9 +269,9 @@ sub class_content_like; 'correct number of warnings on upgrading static schema (with "naming" set)' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); - is result_count(), 6, + is result_count(), $RESULT_COUNT, 'un-singularized results were replaced during upgrade'; # check that custom content was preserved @@ -301,7 +282,7 @@ sub class_content_like; $res->{classes}{bazs} } 'unsingularized class names in custom content are translated'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from unsingularized Result loaded into static dump correctly'; } @@ -320,11 +301,11 @@ sub class_content_like; my $res = run_loader(static => 1); my $warning = $res->{warnings}[0]; - like $warning, qr/static schema/i, + contains $warning, "static schema", 'static schema in backcompat mode detected'; - like $warning, qr/0.04006/, + contains $warning, "0.04006", 'correct version detected'; - like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, + contains $warning, "DBIx::Class::Schema::Loader::Manual::UpgradingFromV4", 'refers to upgrading doc'; is scalar @{ $res->{warnings} }, 3, @@ -350,11 +331,11 @@ sub class_content_like; ); my $schema = $res->{schema}; - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on upgrading static schema (with "naming" set and ' . 'use_namespaces => 0)'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on upgrading static schema (with "naming" set and ' . 'use_namespaces => 0)'; @@ -362,9 +343,9 @@ sub class_content_like; 'correct number of warnings on upgrading static schema (with "naming" set)' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); - is result_count(), 6, + is result_count(), $RESULT_COUNT, 'un-singularized results were replaced during upgrade and Result dir removed'; ok ((not -d result_dir('Result')), @@ -393,10 +374,10 @@ sub class_content_like; 'unsingularized class names in external content from unchanged Result class ' . 'names are translated in static schema'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }", 'external content from unsingularized Result loaded into static dump correctly'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from unsingularized Result loaded into static dump correctly'; } @@ -407,19 +388,20 @@ sub class_content_like; clean_dumpdir => 1, static => 1, use_namespaces => 0, + naming => 'current', ); - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on dumping static schema with use_namespaces => 0'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on dumping static schema with use_namespaces => 0'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on dumping static schema with use_namespaces => 0' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); my $schema = $res->{schema}; add_custom_content($res->{schema}, { @@ -428,15 +410,15 @@ sub class_content_like; # test that with no use_namespaces option, there is a warning and # load_classes is preserved - $res = run_loader(static => 1); + $res = run_loader(static => 1, naming => 'current'); - like $res->{warnings}[0], qr/load_classes/i, + contains $res->{warnings}[0], "load_classes", 'correct warnings on re-dumping static schema with load_classes'; - like $res->{warnings}[1], qr/Dumping manual schema/i, + contains $res->{warnings}[1], "Dumping manual schema", 'correct warnings on re-dumping static schema with load_classes'; - like $res->{warnings}[2], qr/dump completed/i, + contains $res->{warnings}[2], "dump completed", 'correct warnings on re-dumping static schema with load_classes'; is scalar @{ $res->{warnings} }, 3, @@ -446,26 +428,27 @@ sub class_content_like; is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 'load_classes preserved on re-dump'; - run_v6_tests($res); + run_v7_tests($res); # now upgrade the schema to use_namespaces $res = run_loader( static => 1, use_namespaces => 1, + naming => 'current', ); $schema = $res->{schema}; - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on upgrading to use_namespaces'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on upgrading to use_namespaces'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on upgrading to use_namespaces' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); my @schema_files = schema_files(); @@ -483,26 +466,26 @@ sub class_content_like; $res->{classes}{bazs} } 'un-namespaced class names in custom content are translated'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from un-namespaced Result loaded into static dump correctly'; } # test a regular schema with default use_namespaces => 1, redump, and downgrade # to load_classes { - my $res = run_loader(clean_dumpdir => 1, static => 1); + my $res = run_loader(clean_dumpdir => 1, static => 1, naming => 'current'); - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on dumping static schema'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on dumping static schema'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on dumping static schema' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 'defaults to use_namespaces on regular dump'; @@ -510,12 +493,12 @@ sub class_content_like; add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' }); # test that with no use_namespaces option, use_namespaces is preserved - $res = run_loader(static => 1); + $res = run_loader(static => 1, naming => 'current'); - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on re-dumping static schema'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on re-dumping static schema'; is scalar @{ $res->{warnings} }, 2, @@ -525,31 +508,32 @@ sub class_content_like; is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 'use_namespaces preserved on re-dump'; - run_v6_tests($res); + run_v7_tests($res); # now downgrade the schema to load_classes $res = run_loader( static => 1, use_namespaces => 0, + naming => 'current', ); my $schema = $res->{schema}; - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on downgrading to load_classes'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on downgrading to load_classes'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on downgrading to load_classes' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 'load_classes downgrade correct'; - is result_count(), 6, + is result_count(), $RESULT_COUNT, 'correct number of Results after upgrade and Result dir removed'; ok ((not -d result_dir('Result')), @@ -564,7 +548,7 @@ sub class_content_like; 'namespaced class names in custom content are translated during load_classes '. 'downgrade'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from namespaced Result loaded into static dump correctly '. 'during load_classes downgrade'; } @@ -576,19 +560,20 @@ sub class_content_like; clean_dumpdir => 1, static => 1, result_namespace => 'MyResult', + naming => 'current', ); - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on dumping static schema'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on dumping static schema'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on dumping static schema' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 'defaults to use_namespaces and uses custom result_namespace'; @@ -597,12 +582,12 @@ sub class_content_like; # test that with no use_namespaces option, use_namespaces is preserved, and # the custom result_namespace is preserved - $res = run_loader(static => 1); + $res = run_loader(static => 1, naming => 'current'); - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on re-dumping static schema'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on re-dumping static schema'; is scalar @{ $res->{warnings} }, 2, @@ -612,31 +597,32 @@ sub class_content_like; is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 'use_namespaces and custom result_namespace preserved on re-dump'; - run_v6_tests($res); + run_v7_tests($res); # now downgrade the schema to load_classes $res = run_loader( static => 1, use_namespaces => 0, + naming => 'current', ); my $schema = $res->{schema}; - like $res->{warnings}[0], qr/Dumping manual schema/i, + contains $res->{warnings}[0], "Dumping manual schema", 'correct warnings on downgrading to load_classes'; - like $res->{warnings}[1], qr/dump completed/i, + contains $res->{warnings}[1], "dump completed", 'correct warnings on downgrading to load_classes'; is scalar @{ $res->{warnings} }, 2, 'correct number of warnings on downgrading to load_classes' or diag @{ $res->{warnings} }; - run_v6_tests($res); + run_v7_tests($res); is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 'load_classes downgrade correct'; - is result_count(), 6, + is result_count(), $RESULT_COUNT, 'correct number of Results after upgrade and Result dir removed'; ok ((not -d result_dir('MyResult')), @@ -651,7 +637,7 @@ sub class_content_like; 'namespaced class names in custom content are translated during load_classes '. 'downgrade'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from namespaced Result loaded into static dump correctly '. 'during load_classes downgrade'; } @@ -661,7 +647,7 @@ sub class_content_like; clean_dumpdir(); my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' }); - my $res = run_loader(static => 1); + my $res = run_loader(static => 1, naming => 'current'); # add some custom content to a Result that will be replaced add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } }); @@ -670,13 +656,14 @@ sub class_content_like; $res = run_loader( static => 1, result_namespace => 'MyResult', + naming => 'current', ); my $schema = $res->{schema}; is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 'using new result_namespace'; - is result_count('MyResult'), 6, + is result_count('MyResult'), $RESULT_COUNT, 'correct number of Results after rewritten result_namespace'; ok ((not -d schema_dir('Result')), @@ -690,7 +677,7 @@ sub class_content_like; $res->{classes}{bazs} } 'class names in custom content are translated when rewriting result_namespace'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from namespaced Result loaded into static dump correctly '. 'when rewriting result_namespace'; @@ -698,13 +685,14 @@ sub class_content_like; $res = run_loader( static => 1, result_namespace => 'Mtfnpy', + naming => 'current', ); $schema = $res->{schema}; is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux', 'using new result_namespace'; - is result_count('Mtfnpy'), 6, + is result_count('Mtfnpy'), $RESULT_COUNT, 'correct number of Results after rewritten result_namespace'; ok ((not -d result_dir('MyResult')), @@ -731,11 +719,11 @@ sub class_content_like; 'class names in external content are translated when rewriting '. 'result_namespace'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub b_method { 'dongs' }", 'custom content from namespaced Result loaded into static dump correctly '. 'when rewriting result_namespace'; - class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, + class_content_contains $schema, $res->{classes}{quuxs}, "sub a_method { 'hlagh' }", 'external content from unsingularized Result loaded into static dump correctly'; } @@ -747,8 +735,8 @@ sub class_content_like; my $res = run_loader(static => 1, naming => 'current'); my $schema = $res->{schema}; - my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS); - my $code = slurp $file; + my $file = $schema->loader->get_dump_filename($SCHEMA_CLASS); + my $code = slurp_file $file; my ($dumped_ver) = $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m; @@ -772,7 +760,7 @@ sub class_content_like; # now upgrade the schema $res = run_loader(static => 1, naming => 'current'); $schema = $res->{schema}; - run_v6_tests($res); + run_v7_tests($res); # check that custom content was preserved lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' } @@ -783,11 +771,98 @@ sub class_content_like; 'unsingularized class names in custom content from Result with unchanged ' . 'name are translated'; - class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/, + class_content_contains $schema, $res->{classes}{bar}, "sub b_method { 'dongs' }", 'custom content from Result with unchanged name loaded into static dump ' . 'correctly'; } +# test creating static schema in v5 mode then upgrade to current with external +# content loaded +{ + clean_dumpdir(); + + write_v5_schema_pm(); + + my $res = run_loader(static => 1); + + contains $res->{warnings}[0], "0.05003 static schema", 'backcompat warning'; + + run_v5_tests($res); + + my $temp_dir = setup_load_external({ + Baz => 'StationsVisited', + StationsVisited => 'Quux', + }, { result_namespace => 'Result' }); + + add_custom_content($res->{schema}, { + Baz => 'StationsVisited', + }, { + result_namespace => 'Result', + rel_name_map => { BazStationsvisited => 'custom_content_rel' }, + }); + + $res = run_loader(static => 1, naming => 'current'); + my $schema = $res->{schema}; + + run_v7_tests($res); + + lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' } + 'external custom content loaded for v5 -> v6'; + + lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel, + $res->{classes}{stations_visited} } + 'external content rewritten for v5 -> v6'; + + lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel, + $res->{classes}{stations_visited} } + 'custom content rewritten for v5 -> v6'; + + lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel, + $res->{classes}{quuxs} } + 'external content rewritten for v5 -> v6 for upgraded Result class names'; +} + +# test creating static schema in v6 mode then upgrade to current with external +# content loaded +{ + clean_dumpdir(); + + write_v6_schema_pm(); + + my $res = run_loader(static => 1); + + contains $res->{warnings}[0], "0.06001 static schema", 'backcompat warning'; + + run_v6_tests($res); + + my $temp_dir = setup_load_external({ + Routechange => 'Quux', + }, { result_namespace => 'Result' }); + + add_custom_content($res->{schema}, { + Routechange => 'Quux', + }, { + result_namespace => 'Result', + rel_name_map => { RoutechangeQuux => 'custom_content_rel' }, + }); + + $res = run_loader(static => 1, naming => 'current'); + my $schema = $res->{schema}; + + run_v7_tests($res); + + lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' } + 'external custom content loaded for v6 -> v7'; + + lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel, + $res->{classes}{quuxs} } + 'external content rewritten for v6 -> v7'; + + lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel, + $res->{classes}{quuxs} } + 'custom content rewritten for v6 -> v7'; +} + done_testing; END { @@ -803,6 +878,7 @@ sub run_loader { my %loader_opts = @_; $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static}; + $loader_opts{preserve_case} = 1 if $loader_opts{naming} && $loader_opts{naming} eq 'current'; clean_dumpdir() if delete $loader_opts{clean_dumpdir}; @@ -817,7 +893,7 @@ sub run_loader { my @connect_info = $make_dbictest_db_with_unique::dsn; my @loader_warnings; - local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; + local $SIG{__WARN__} = sub { push(@loader_warnings, @_); }; eval qq{ package $SCHEMA_CLASS; use base qw/DBIx::Class::Schema::Loader/; @@ -938,11 +1014,67 @@ use warnings; use base 'DBIx::Class::Schema'; +__PACKAGE__->load_namespaces; + + +# Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg + + +# You can replace this text with custom content, and it will be preserved on regeneration +1; +EOF + } +} + +sub write_v6_schema_pm { + my %opts = @_; + + (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; + rmtree $schema_dir; + make_path $schema_dir; + my $schema_pm = "$schema_dir/Schema.pm"; + open my $fh, '>', $schema_pm or die $!; + if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) { + print $fh <<'EOF'; +package DBIXCSL_Test::Schema; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Schema'; + __PACKAGE__->load_classes; -# Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg +# Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:56:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:/fqZCb95hsGIe1g5qyQQZg + + +# You can replace this text with custom content, and it will be preserved on regeneration +1; +EOF + } + else { + print $fh <<'EOF'; +package DBIXCSL_Test::Schema; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Schema'; + +__PACKAGE__->load_namespaces; + + +# Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:54:31 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nwO5Vi47kl0X9SpEoiVO5w # You can replace this text with custom content, and it will be preserved on regeneration @@ -955,8 +1087,8 @@ sub run_v4_tests { my $res = shift; my $schema = $res->{schema}; - is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], - [qw/Foos Bar Bazs Quuxs StationsVisited Email/], + is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ], + [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/], 'correct monikers in 0.04006 mode'; isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }), @@ -975,15 +1107,21 @@ sub run_v4_tests { isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', 'correct rel name inflection in 0.04006 mode'; + + ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), + 'correct column accessor in 0.04006 mode'); + + is $schema->resultset('Routechange')->find(1)->foo2bar, 3, + 'correct column accessor for column with word ending with digit in v4 mode'; } sub run_v5_tests { my $res = shift; my $schema = $res->{schema}; - is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], - [qw/Foo Bar Baz Quux StationsVisited Email/], - 'correct monikers in current mode'; + is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ], + [qw/Foo Bar Baz Quux StationsVisited Routechange Email/], + 'correct monikers in v5 mode'; ok my $bar = eval { $schema->resultset('Bar')->find(1) }; @@ -999,14 +1137,55 @@ sub run_v5_tests { isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', 'correct rel name inflection in v5 mode'; + + ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), + 'correct column accessor in v5 mode'); + + is $schema->resultset('Routechange')->find(1)->foo2bar, 3, + 'correct column accessor for column with word ending with digit in v5 mode'; } sub run_v6_tests { my $res = shift; my $schema = $res->{schema}; - is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited email/} ], - [qw/Foo Bar Baz Quux StationVisited Email/], + is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ], + [qw/Foo Bar Baz Quux StationVisited Routechange Email/], + 'correct monikers in v6 mode'; + + ok my $bar = eval { $schema->resultset('Bar')->find(1) }; + + isa_ok eval { $bar->foo }, $res->{classes}{foos}, + 'correct rel name in v6 mode'; + + ok my $baz = eval { $schema->resultset('Baz')->find(1) }; + + isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, + 'correct rel type and name for UNIQUE FK in v6 mode'; + + ok my $foo = eval { $schema->resultset('Foo')->find(1) }; + + isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet', + 'correct rel name inflection in v6 mode'; + + ok my $route_change = eval { $schema->resultset('Routechange')->find(1) }; + + isa_ok eval { $route_change->quuxsid }, $res->{classes}{quuxs}, + 'correct rel name in v6 mode'; + + ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), + 'correct column accessor in v6 mode'); + + is $schema->resultset('Routechange')->find(1)->foo2bar, 3, + 'correct column accessor for column with word ending with digit in v6 mode'; +} + +sub run_v7_tests { + my $res = shift; + my $schema = $res->{schema}; + + is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ], + [qw/Foo Bar Baz Quux StationVisited RouteChange Email/], 'correct monikers in current mode'; ok my $bar = eval { $schema->resultset('Bar')->find(1) }; @@ -1023,6 +1202,17 @@ sub run_v6_tests { isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet', 'correct rel name inflection in current mode'; + + ok my $route_change = eval { $schema->resultset('RouteChange')->find(1) }; + + isa_ok eval { $route_change->quux }, $res->{classes}{quuxs}, + 'correct rel name based on mixed-case column name in current mode'; + + ok (($schema->resultset('RouteChange')->find(1)->can('quuxs_id')), + 'correct column accessor in current mode'); + + is $schema->resultset('RouteChange')->find(1)->foo2_bar, 3, + 'correct column accessor for column with word ending with digit in current mode'; } { @@ -1103,16 +1293,29 @@ sub _rel_condition { return +{ QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'}, BarFoo => q{'foreign.fooid' => 'self.foo_id'}, + BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'}, + StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'}, + RoutechangeQuux => q{'foreign.quuxid' => 'self.QuuxsId'}, }->{_rel_key($from, $to)}; } -sub class_content_like { - my ($schema, $class, $re, $test_name) = @_; +sub class_content_contains { + my ($schema, $class, $substr, $test_name) = @_; + + my $file = $schema->loader->get_dump_filename($class); + my $code = slurp_file $file; + + local $Test::Builder::Level = $Test::Builder::Level + 1; + + contains $code, $substr, $test_name; +} + +sub contains { + my ($haystack, $needle, $test_name) = @_; - my $file = $schema->_loader->_get_dump_filename($class); - my $code = slurp $file; + local $Test::Builder::Level = $Test::Builder::Level + 1; - like $code, $re, $test_name; + like $haystack, qr/\Q$needle\E/, $test_name; } sub add_custom_content { @@ -1141,7 +1344,7 @@ EOF sub _write_custom_content { my ($schema, $class, $content) = @_; - my $pm = $schema->_loader->_get_dump_filename($class); + my $pm = $schema->loader->get_dump_filename($class); { local ($^I, @ARGV) = ('.bak', $pm); while (<>) {