5 use File::Path qw/rmtree make_path/;
7 use File::Temp qw/tempfile tempdir/;
9 use DBIx::Class::Schema::Loader ();
10 use DBIx::Class::Schema::Loader::Utils 'slurp_file';
11 use Lingua::EN::Inflect::Number ();
13 use make_dbictest_db_with_unique;
14 use dbixcsl_test_dir qw/$tdir/;
16 my $DUMP_DIR = "$tdir/common_dump";
18 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
22 sub class_content_like;
24 # test dynamic schema in 0.04006 mode
26 my $res = run_loader();
27 my $warning = $res->{warnings}[0];
29 like $warning, qr/dynamic schema/i,
30 'dynamic schema in backcompat mode detected';
31 like $warning, qr/run in 0\.04006 mode/i,
32 'dynamic schema in 0.04006 mode warning';
33 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
34 'warning refers to upgrading doc';
39 # setting naming accessor on dynamic schema should disable warning (even when
40 # we're setting it to 'v4' .)
42 my $res = run_loader(naming => 'v4');
43 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
47 # test upgraded dynamic schema
49 my $res = run_loader(naming => 'current');
50 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
54 # test upgraded dynamic schema with external content loaded
56 my $temp_dir = setup_load_external({
61 my $res = run_loader(naming => 'current', use_namespaces => 0);
62 my $schema = $res->{schema};
64 is scalar @{ $res->{warnings} }, 1,
65 'correct nummber of warnings for upgraded dynamic schema with external ' .
66 'content for unsingularized Result.';
68 my $warning = $res->{warnings}[0];
69 like $warning, qr/Detected external content/i,
70 'detected external content warning';
72 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
73 'external custom content for unsingularized Result was loaded by upgraded ' .
76 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
77 $res->{classes}{bazs} }
78 'unsingularized class names in external content are translated';
80 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' }
81 'external content from unchanged Result class';
83 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
84 $res->{classes}{foos} }
85 'unsingularized class names in external content from unchanged Result class ' .
86 'names are translated';
91 # test upgraded dynamic schema with use_namespaces with external content loaded
93 my $temp_dir = setup_load_external({
98 my $res = run_loader(naming => 'current', use_namespaces => 1);
99 my $schema = $res->{schema};
101 is scalar @{ $res->{warnings} }, 2,
102 'correct nummber of warnings for upgraded dynamic schema with external ' .
103 'content for unsingularized Result with use_namespaces.';
105 my $warning = $res->{warnings}[0];
106 like $warning, qr/Detected external content/i,
107 'detected external content warning';
109 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
110 'external custom content for unsingularized Result was loaded by upgraded ' .
113 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
114 $res->{classes}{bazs} }
115 'unsingularized class names in external content are translated';
117 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
118 $res->{classes}{foos} }
119 'unsingularized class names in external content from unchanged Result class ' .
120 'names are translated';
125 # test upgraded static schema with external content loaded
129 my $temp_dir = setup_load_external({
134 write_v4_schema_pm();
136 my $res = run_loader(static => 1, naming => 'current');
137 my $schema = $res->{schema};
141 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
142 'external custom content for unsingularized Result was loaded by upgraded ' .
145 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
146 $res->{classes}{bazs} }
147 'unsingularized class names in external content are translated';
149 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
150 $res->{classes}{foos} }
151 'unsingularized class names in external content from unchanged Result class ' .
152 'names are translated in static schema';
154 class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/,
155 'package line translated correctly from external custom content in static dump';
157 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
158 'external custom content loaded into static dump correctly';
161 # test running against v4 schema without upgrade, twice, then upgrade
164 write_v4_schema_pm();
165 my $res = run_loader(static => 1);
166 my $warning = $res->{warnings}[1];
168 like $warning, qr/static schema/i,
169 'static schema in backcompat mode detected';
170 like $warning, qr/0.04006/,
171 'correct version detected';
172 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
173 'refers to upgrading doc';
175 is scalar @{ $res->{warnings} }, 4,
176 'correct number of warnings for static schema in backcompat mode';
180 add_custom_content($res->{schema}, {
184 # Rerun the loader in backcompat mode to make sure it's still in backcompat
186 $res = run_loader(static => 1);
189 # now upgrade the schema
195 my $schema = $res->{schema};
197 like $res->{warnings}[0], qr/Dumping manual schema/i,
198 'correct warnings on upgrading static schema (with "naming" set)';
200 like $res->{warnings}[1], qr/dump completed/i,
201 'correct warnings on upgrading static schema (with "naming" set)';
203 is scalar @{ $res->{warnings} }, 2,
204 'correct number of warnings on upgrading static schema (with "naming" set)'
205 or diag @{ $res->{warnings} };
209 is result_count('Result'), $RESULT_COUNT,
210 'un-singularized results were replaced during upgrade';
212 # check that custom content was preserved
213 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
214 'custom content was carried over from un-singularized Result';
216 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
217 $res->{classes}{bazs} }
218 'unsingularized class names in custom content are translated';
220 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
221 'custom content from unsingularized Result loaded into static dump correctly';
224 # test running against v4 schema without upgrade, then upgrade with
225 # use_namespaces not explicitly set
228 write_v4_schema_pm();
229 my $res = run_loader(static => 1);
230 my $warning = $res->{warnings}[1];
232 like $warning, qr/static schema/i,
233 'static schema in backcompat mode detected';
234 like $warning, qr/0.04006/,
235 'correct version detected';
236 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
237 'refers to upgrading doc';
239 is scalar @{ $res->{warnings} }, 4,
240 'correct number of warnings for static schema in backcompat mode';
244 add_custom_content($res->{schema}, {
248 # now upgrade the schema
253 my $schema = $res->{schema};
255 like $res->{warnings}[0], qr/load_classes/i,
256 'correct warnings on upgrading static schema (with "naming" set and ' .
257 'use_namespaces not set)';
259 like $res->{warnings}[1], qr/Dumping manual schema/i,
260 'correct warnings on upgrading static schema (with "naming" set and ' .
261 'use_namespaces not set)';
263 like $res->{warnings}[2], qr/dump completed/i,
264 'correct warnings on upgrading static schema (with "naming" set and ' .
265 'use_namespaces not set)';
267 is scalar @{ $res->{warnings} }, 3,
268 'correct number of warnings on upgrading static schema (with "naming" set)'
269 or diag @{ $res->{warnings} };
273 is result_count(), $RESULT_COUNT,
274 'un-singularized results were replaced during upgrade';
276 # check that custom content was preserved
277 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
278 'custom content was carried over from un-singularized Result';
280 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
281 $res->{classes}{bazs} }
282 'unsingularized class names in custom content are translated';
284 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
285 'custom content from unsingularized Result loaded into static dump correctly';
288 # test running against v4 schema with load_namespaces, upgrade to current but
289 # downgrade to load_classes, with external content
293 my $temp_dir = setup_load_external({
296 }, { result_namespace => 'Result' });
298 write_v4_schema_pm(use_namespaces => 1);
300 my $res = run_loader(static => 1);
301 my $warning = $res->{warnings}[0];
303 like $warning, qr/static schema/i,
304 'static schema in backcompat mode detected';
305 like $warning, qr/0.04006/,
306 'correct version detected';
307 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
308 'refers to upgrading doc';
310 is scalar @{ $res->{warnings} }, 3,
311 'correct number of warnings for static schema in backcompat mode';
315 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs',
316 'use_namespaces in backcompat mode';
318 add_custom_content($res->{schema}, {
321 result_namespace => 'Result',
322 rel_name_map => { QuuxBaz => 'bazrel2' },
325 # now upgrade the schema to current but downgrade to load_classes
331 my $schema = $res->{schema};
333 like $res->{warnings}[0], qr/Dumping manual schema/i,
334 'correct warnings on upgrading static schema (with "naming" set and ' .
335 'use_namespaces => 0)';
337 like $res->{warnings}[1], qr/dump completed/i,
338 'correct warnings on upgrading static schema (with "naming" set and ' .
339 'use_namespaces => 0)';
341 is scalar @{ $res->{warnings} }, 2,
342 'correct number of warnings on upgrading static schema (with "naming" set)'
343 or diag @{ $res->{warnings} };
347 is result_count(), $RESULT_COUNT,
348 'un-singularized results were replaced during upgrade and Result dir removed';
350 ok ((not -d result_dir('Result')),
351 'Result dir was removed for load_classes downgrade');
353 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
354 'load_classes in upgraded mode';
356 # check that custom and external content was preserved
357 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
358 'custom content was carried over from un-singularized Result';
360 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
361 'external content was carried over from un-singularized Result';
363 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
364 $res->{classes}{bazs} }
365 'unsingularized class names in custom content are translated';
367 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
368 $res->{classes}{bazs} }
369 'unsingularized class names in external content are translated';
371 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
372 $res->{classes}{foos} }
373 'unsingularized class names in external content from unchanged Result class ' .
374 'names are translated in static schema';
376 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
377 'external content from unsingularized Result loaded into static dump correctly';
379 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
380 'custom content from unsingularized Result loaded into static dump correctly';
383 # test a regular schema with use_namespaces => 0 upgraded to
384 # use_namespaces => 1
386 my $res = run_loader(
393 like $res->{warnings}[0], qr/Dumping manual schema/i,
394 'correct warnings on dumping static schema with use_namespaces => 0';
396 like $res->{warnings}[1], qr/dump completed/i,
397 'correct warnings on dumping static schema with use_namespaces => 0';
399 is scalar @{ $res->{warnings} }, 2,
400 'correct number of warnings on dumping static schema with use_namespaces => 0'
401 or diag @{ $res->{warnings} };
405 my $schema = $res->{schema};
406 add_custom_content($res->{schema}, {
410 # test that with no use_namespaces option, there is a warning and
411 # load_classes is preserved
412 $res = run_loader(static => 1, naming => 'current');
414 like $res->{warnings}[0], qr/load_classes/i,
415 'correct warnings on re-dumping static schema with load_classes';
417 like $res->{warnings}[1], qr/Dumping manual schema/i,
418 'correct warnings on re-dumping static schema with load_classes';
420 like $res->{warnings}[2], qr/dump completed/i,
421 'correct warnings on re-dumping static schema with load_classes';
423 is scalar @{ $res->{warnings} }, 3,
424 'correct number of warnings on re-dumping static schema with load_classes'
425 or diag @{ $res->{warnings} };
427 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
428 'load_classes preserved on re-dump';
432 # now upgrade the schema to use_namespaces
438 $schema = $res->{schema};
440 like $res->{warnings}[0], qr/Dumping manual schema/i,
441 'correct warnings on upgrading to use_namespaces';
443 like $res->{warnings}[1], qr/dump completed/i,
444 'correct warnings on upgrading to use_namespaces';
446 is scalar @{ $res->{warnings} }, 2,
447 'correct number of warnings on upgrading to use_namespaces'
448 or diag @{ $res->{warnings} };
452 my @schema_files = schema_files();
454 is 1, (scalar @schema_files),
455 "schema dir contains only 1 entry";
457 like $schema_files[0], qr{/Result\z},
458 "schema dir contains only a Result/ directory";
460 # check that custom content was preserved
461 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
462 'custom content was carried over during use_namespaces upgrade';
464 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
465 $res->{classes}{bazs} }
466 'un-namespaced class names in custom content are translated';
468 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
469 'custom content from un-namespaced Result loaded into static dump correctly';
472 # test a regular schema with default use_namespaces => 1, redump, and downgrade
475 my $res = run_loader(clean_dumpdir => 1, static => 1, naming => 'current');
477 like $res->{warnings}[0], qr/Dumping manual schema/i,
478 'correct warnings on dumping static schema';
480 like $res->{warnings}[1], qr/dump completed/i,
481 'correct warnings on dumping static schema';
483 is scalar @{ $res->{warnings} }, 2,
484 'correct number of warnings on dumping static schema'
485 or diag @{ $res->{warnings} };
489 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
490 'defaults to use_namespaces on regular dump';
492 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
494 # test that with no use_namespaces option, use_namespaces is preserved
495 $res = run_loader(static => 1, naming => 'current');
497 like $res->{warnings}[0], qr/Dumping manual schema/i,
498 'correct warnings on re-dumping static schema';
500 like $res->{warnings}[1], qr/dump completed/i,
501 'correct warnings on re-dumping static schema';
503 is scalar @{ $res->{warnings} }, 2,
504 'correct number of warnings on re-dumping static schema'
505 or diag @{ $res->{warnings} };
507 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
508 'use_namespaces preserved on re-dump';
512 # now downgrade the schema to load_classes
518 my $schema = $res->{schema};
520 like $res->{warnings}[0], qr/Dumping manual schema/i,
521 'correct warnings on downgrading to load_classes';
523 like $res->{warnings}[1], qr/dump completed/i,
524 'correct warnings on downgrading to load_classes';
526 is scalar @{ $res->{warnings} }, 2,
527 'correct number of warnings on downgrading to load_classes'
528 or diag @{ $res->{warnings} };
532 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
533 'load_classes downgrade correct';
535 is result_count(), $RESULT_COUNT,
536 'correct number of Results after upgrade and Result dir removed';
538 ok ((not -d result_dir('Result')),
539 'Result dir was removed for load_classes downgrade');
541 # check that custom content was preserved
542 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
543 'custom content was carried over during load_classes downgrade';
545 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
546 $res->{classes}{bazs} }
547 'namespaced class names in custom content are translated during load_classes '.
550 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
551 'custom content from namespaced Result loaded into static dump correctly '.
552 'during load_classes downgrade';
555 # test a regular schema with use_namespaces => 1 and a custom result_namespace
556 # downgraded to load_classes
558 my $res = run_loader(
561 result_namespace => 'MyResult',
565 like $res->{warnings}[0], qr/Dumping manual schema/i,
566 'correct warnings on dumping static schema';
568 like $res->{warnings}[1], qr/dump completed/i,
569 'correct warnings on dumping static schema';
571 is scalar @{ $res->{warnings} }, 2,
572 'correct number of warnings on dumping static schema'
573 or diag @{ $res->{warnings} };
577 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
578 'defaults to use_namespaces and uses custom result_namespace';
580 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
582 # test that with no use_namespaces option, use_namespaces is preserved, and
583 # the custom result_namespace is preserved
584 $res = run_loader(static => 1, naming => 'current');
586 like $res->{warnings}[0], qr/Dumping manual schema/i,
587 'correct warnings on re-dumping static schema';
589 like $res->{warnings}[1], qr/dump completed/i,
590 'correct warnings on re-dumping static schema';
592 is scalar @{ $res->{warnings} }, 2,
593 'correct number of warnings on re-dumping static schema'
594 or diag @{ $res->{warnings} };
596 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
597 'use_namespaces and custom result_namespace preserved on re-dump';
601 # now downgrade the schema to load_classes
607 my $schema = $res->{schema};
609 like $res->{warnings}[0], qr/Dumping manual schema/i,
610 'correct warnings on downgrading to load_classes';
612 like $res->{warnings}[1], qr/dump completed/i,
613 'correct warnings on downgrading to load_classes';
615 is scalar @{ $res->{warnings} }, 2,
616 'correct number of warnings on downgrading to load_classes'
617 or diag @{ $res->{warnings} };
621 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
622 'load_classes downgrade correct';
624 is result_count(), $RESULT_COUNT,
625 'correct number of Results after upgrade and Result dir removed';
627 ok ((not -d result_dir('MyResult')),
628 'Result dir was removed for load_classes downgrade');
630 # check that custom content was preserved
631 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
632 'custom content was carried over during load_classes downgrade';
634 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
635 $res->{classes}{bazs} }
636 'namespaced class names in custom content are translated during load_classes '.
639 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
640 'custom content from namespaced Result loaded into static dump correctly '.
641 'during load_classes downgrade';
644 # rewrite from one result_namespace to another, with external content
647 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
649 my $res = run_loader(static => 1, naming => 'current');
651 # add some custom content to a Result that will be replaced
652 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
654 # Rewrite implicit 'Result' to 'MyResult'
657 result_namespace => 'MyResult',
660 my $schema = $res->{schema};
662 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
663 'using new result_namespace';
665 is result_count('MyResult'), $RESULT_COUNT,
666 'correct number of Results after rewritten result_namespace';
668 ok ((not -d schema_dir('Result')),
669 'original Result dir was removed when rewriting result_namespace');
671 # check that custom content was preserved
672 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
673 'custom content was carried over when rewriting result_namespace';
675 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
676 $res->{classes}{bazs} }
677 'class names in custom content are translated when rewriting result_namespace';
679 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
680 'custom content from namespaced Result loaded into static dump correctly '.
681 'when rewriting result_namespace';
683 # Now rewrite 'MyResult' to 'Mtfnpy'
686 result_namespace => 'Mtfnpy',
689 $schema = $res->{schema};
691 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
692 'using new result_namespace';
694 is result_count('Mtfnpy'), $RESULT_COUNT,
695 'correct number of Results after rewritten result_namespace';
697 ok ((not -d result_dir('MyResult')),
698 'original Result dir was removed when rewriting result_namespace');
700 # check that custom and external content was preserved
701 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
702 'external content was carried over when rewriting result_namespace';
704 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
705 'custom content was carried over when rewriting result_namespace';
707 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
708 $res->{classes}{bazs} }
709 'class names in custom content are translated when rewriting result_namespace';
711 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
712 $res->{classes}{bazs} }
713 'class names in external content are translated when rewriting '.
716 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
717 $res->{classes}{foos} }
718 'class names in external content are translated when rewriting '.
721 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
722 'custom content from namespaced Result loaded into static dump correctly '.
723 'when rewriting result_namespace';
725 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
726 'external content from unsingularized Result loaded into static dump correctly';
729 # test upgrading a v4 schema, then check that the version string is correct
732 write_v4_schema_pm();
733 run_loader(static => 1);
734 my $res = run_loader(static => 1, naming => 'current');
735 my $schema = $res->{schema};
737 my $file = $schema->loader->get_dump_filename($SCHEMA_CLASS);
738 my $code = slurp_file $file;
741 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
743 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
744 'correct version dumped after upgrade of v4 static schema';
747 # Test upgrading an already singular result with custom content that refers to
751 write_v4_schema_pm();
752 my $res = run_loader(static => 1);
753 my $schema = $res->{schema};
756 # add some custom content to a Result that will be replaced
757 add_custom_content($schema, { Bar => 'Foos' });
759 # now upgrade the schema
760 $res = run_loader(static => 1, naming => 'current');
761 $schema = $res->{schema};
764 # check that custom content was preserved
765 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
766 'custom content was preserved from Result pre-upgrade';
768 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
769 $res->{classes}{foos} }
770 'unsingularized class names in custom content from Result with unchanged ' .
771 'name are translated';
773 class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
774 'custom content from Result with unchanged name loaded into static dump ' .
778 # test creating static schema in v5 mode then upgrade to current with external
783 write_v5_schema_pm();
785 my $res = run_loader(static => 1);
787 like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning';
791 my $temp_dir = setup_load_external({
792 Baz => 'StationsVisited',
793 StationsVisited => 'Quux',
794 }, { result_namespace => 'Result' });
796 add_custom_content($res->{schema}, {
797 Baz => 'StationsVisited',
799 result_namespace => 'Result',
800 rel_name_map => { BazStationsvisited => 'custom_content_rel' },
803 $res = run_loader(static => 1, naming => 'current');
804 my $schema = $res->{schema};
808 lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' }
809 'external custom content loaded for v5 -> v6';
811 lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel,
812 $res->{classes}{stations_visited} }
813 'external content rewritten for v5 -> v6';
815 lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel,
816 $res->{classes}{stations_visited} }
817 'custom content rewritten for v5 -> v6';
819 lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel,
820 $res->{classes}{quuxs} }
821 'external content rewritten for v5 -> v6 for upgraded Result class names';
824 # test creating static schema in v6 mode then upgrade to current with external
829 write_v6_schema_pm();
831 my $res = run_loader(static => 1);
833 like $res->{warnings}[0], qr/0.06001 static schema/, 'backcompat warning';
837 my $temp_dir = setup_load_external({
838 Routechange => 'Quux',
839 }, { result_namespace => 'Result' });
841 add_custom_content($res->{schema}, {
842 Routechange => 'Quux',
844 result_namespace => 'Result',
845 rel_name_map => { RoutechangeQuux => 'custom_content_rel' },
848 $res = run_loader(static => 1, naming => 'current');
849 my $schema = $res->{schema};
853 lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' }
854 'external custom content loaded for v6 -> v7';
856 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel,
857 $res->{classes}{quuxs} }
858 'external content rewritten for v6 -> v7';
860 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel,
861 $res->{classes}{quuxs} }
862 'custom content rewritten for v6 -> v7';
868 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
877 my %loader_opts = @_;
879 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
880 $loader_opts{preserve_case} = 1 if $loader_opts{naming} && $loader_opts{naming} eq 'current';
882 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
885 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
886 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
889 Class::Unload->unload($SCHEMA_CLASS);
893 my @connect_info = $make_dbictest_db_with_unique::dsn;
895 local $SIG{__WARN__} = sub { push(@loader_warnings, @_); };
897 package $SCHEMA_CLASS;
898 use base qw/DBIx::Class::Schema::Loader/;
900 __PACKAGE__->loader_options(\%loader_opts);
901 __PACKAGE__->connection(\@connect_info);
904 ok(!$@, "Loader initialization") or diag $@;
906 my $schema = $SCHEMA_CLASS->clone;
907 my (%monikers, %classes);
908 foreach my $source_name ($schema->sources) {
909 my $table_name = $schema->source($source_name)->from;
910 $monikers{$table_name} = $source_name;
911 $classes{$table_name} = $schema->source($source_name)->result_class;
916 warnings => \@loader_warnings,
917 monikers => \%monikers,
918 classes => \%classes,
922 sub write_v4_schema_pm {
925 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
927 make_path $schema_dir;
928 my $schema_pm = "$schema_dir/Schema.pm";
929 open my $fh, '>', $schema_pm or die $!;
930 if (not $opts{use_namespaces}) {
932 package DBIXCSL_Test::Schema;
937 use base 'DBIx::Class::Schema';
939 __PACKAGE__->load_classes;
942 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
943 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
946 # You can replace this text with custom content, and it will be preserved on regeneration
952 package DBIXCSL_Test::Schema;
957 use base 'DBIx::Class::Schema';
959 __PACKAGE__->load_namespaces;
962 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
963 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
966 # You can replace this text with custom content, and it will be preserved on
973 sub write_v5_schema_pm {
976 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
978 make_path $schema_dir;
979 my $schema_pm = "$schema_dir/Schema.pm";
980 open my $fh, '>', $schema_pm or die $!;
981 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
983 package DBIXCSL_Test::Schema;
985 # Created by DBIx::Class::Schema::Loader
986 # DO NOT MODIFY THE FIRST PART OF THIS FILE
991 use base 'DBIx::Class::Schema';
993 __PACKAGE__->load_classes;
996 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
997 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
1000 # You can replace this text with custom content, and it will be preserved on regeneration
1006 package DBIXCSL_Test::Schema;
1008 # Created by DBIx::Class::Schema::Loader
1009 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1014 use base 'DBIx::Class::Schema';
1016 __PACKAGE__->load_namespaces;
1019 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52
1020 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg
1023 # You can replace this text with custom content, and it will be preserved on regeneration
1029 sub write_v6_schema_pm {
1032 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
1034 make_path $schema_dir;
1035 my $schema_pm = "$schema_dir/Schema.pm";
1036 open my $fh, '>', $schema_pm or die $!;
1037 if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
1039 package DBIXCSL_Test::Schema;
1041 # Created by DBIx::Class::Schema::Loader
1042 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1047 use base 'DBIx::Class::Schema';
1049 __PACKAGE__->load_classes;
1052 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:56:03
1053 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:/fqZCb95hsGIe1g5qyQQZg
1056 # You can replace this text with custom content, and it will be preserved on regeneration
1062 package DBIXCSL_Test::Schema;
1064 # Created by DBIx::Class::Schema::Loader
1065 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1070 use base 'DBIx::Class::Schema';
1072 __PACKAGE__->load_namespaces;
1075 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:54:31
1076 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nwO5Vi47kl0X9SpEoiVO5w
1079 # You can replace this text with custom content, and it will be preserved on regeneration
1087 my $schema = $res->{schema};
1089 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1090 [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/],
1091 'correct monikers in 0.04006 mode';
1093 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
1094 $res->{classes}{bar},
1097 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
1098 'correct rel name in 0.04006 mode';
1100 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
1102 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
1103 'correct rel type and name for UNIQUE FK in 0.04006 mode';
1105 ok my $foo = eval { $schema->resultset('Foos')->find(1) };
1107 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1108 'correct rel name inflection in 0.04006 mode';
1110 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1111 'correct column accessor in 0.04006 mode');
1113 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1114 'correct column accessor for column with word ending with digit in v4 mode';
1119 my $schema = $res->{schema};
1121 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1122 [qw/Foo Bar Baz Quux StationsVisited Routechange Email/],
1123 'correct monikers in v5 mode';
1125 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1127 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1128 'correct rel name in v5 mode';
1130 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1132 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1133 'correct rel type and name for UNIQUE FK in v5 mode';
1135 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1137 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1138 'correct rel name inflection in v5 mode';
1140 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1141 'correct column accessor in v5 mode');
1143 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1144 'correct column accessor for column with word ending with digit in v5 mode';
1149 my $schema = $res->{schema};
1151 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1152 [qw/Foo Bar Baz Quux StationVisited Routechange Email/],
1153 'correct monikers in v6 mode';
1155 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1157 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1158 'correct rel name in v6 mode';
1160 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1162 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1163 'correct rel type and name for UNIQUE FK in v6 mode';
1165 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1167 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1168 'correct rel name inflection in v6 mode';
1170 ok my $route_change = eval { $schema->resultset('Routechange')->find(1) };
1172 isa_ok eval { $route_change->quuxsid }, $res->{classes}{quuxs},
1173 'correct rel name in v6 mode';
1175 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')),
1176 'correct column accessor in v6 mode');
1178 is $schema->resultset('Routechange')->find(1)->foo2bar, 3,
1179 'correct column accessor for column with word ending with digit in v6 mode';
1184 my $schema = $res->{schema};
1186 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1187 [qw/Foo Bar Baz Quux StationVisited RouteChange Email/],
1188 'correct monikers in current mode';
1190 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1192 isa_ok eval { $bar->foo }, $res->{classes}{foos},
1193 'correct rel name in current mode';
1195 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
1197 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1198 'correct rel type and name for UNIQUE FK in current mode';
1200 ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1202 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1203 'correct rel name inflection in current mode';
1205 ok my $route_change = eval { $schema->resultset('RouteChange')->find(1) };
1207 isa_ok eval { $route_change->quux }, $res->{classes}{quuxs},
1208 'correct rel name based on mixed-case column name in current mode';
1210 ok (($schema->resultset('RouteChange')->find(1)->can('quuxs_id')),
1211 'correct column accessor in current mode');
1213 is $schema->resultset('RouteChange')->find(1)->foo2_bar, 3,
1214 'correct column accessor for column with word ending with digit in current mode';
1218 package DBICSL::Test::TempExtDir;
1220 use overload '""' => sub { ${$_[0]} };
1224 File::Path::rmtree ${$_[0]};
1228 sub setup_load_external {
1229 my ($rels, $opts) = @_;
1231 my $temp_dir = tempdir(CLEANUP => 1);
1232 push @INC, $temp_dir;
1234 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1235 ($opts->{result_namespace} || ());
1237 make_path $external_result_dir;
1239 while (my ($from, $to) = each %$rels) {
1240 write_ext_result($external_result_dir, $from, $to, $opts);
1243 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1248 sub write_ext_result {
1249 my ($result_dir, $from, $to, $opts) = @_;
1251 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1252 my $from_class = _qualify_class($from, $opts->{result_namespace});
1253 my $to_class = _qualify_class($to, $opts->{result_namespace});
1254 my $condition = _rel_condition($from, $to);
1256 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1257 package ${from_class};
1258 sub a_method { 'hlagh' }
1260 __PACKAGE__->has_one('$relname', '$to_class',
1272 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1275 sub _qualify_class {
1276 my ($class, $result_namespace) = @_;
1278 return $SCHEMA_CLASS . '::'
1279 . ($result_namespace ? $result_namespace . '::' : '')
1284 my ($from, $to) = @_;
1286 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1289 sub _rel_condition {
1290 my ($from, $to) = @_;
1293 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1294 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
1295 BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'},
1296 StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1297 RoutechangeQuux => q{'foreign.quuxid' => 'self.QuuxsId'},
1298 }->{_rel_key($from, $to)};
1301 sub class_content_like {
1302 my ($schema, $class, $re, $test_name) = @_;
1304 my $file = $schema->loader->get_dump_filename($class);
1305 my $code = slurp_file $file;
1307 like $code, $re, $test_name;
1310 sub add_custom_content {
1311 my ($schema, $rels, $opts) = @_;
1313 while (my ($from, $to) = each %$rels) {
1314 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1315 my $from_class = _qualify_class($from, $opts->{result_namespace});
1316 my $to_class = _qualify_class($to, $opts->{result_namespace});
1317 my $condition = _rel_condition($from, $to);
1319 my $content = <<"EOF";
1320 package ${from_class};
1321 sub b_method { 'dongs' }
1323 __PACKAGE__->has_one('$relname', '$to_class',
1329 _write_custom_content($schema, $from_class, $content);
1333 sub _write_custom_content {
1334 my ($schema, $class, $content) = @_;
1336 my $pm = $schema->loader->get_dump_filename($class);
1338 local ($^I, @ARGV) = ('.bak', $pm);
1340 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1349 unlink "${pm}.bak" or die $^E;
1354 my $path = shift || '';
1356 my $dir = result_dir($path);
1358 my $file_count =()= glob "$dir/*";
1364 my $path = shift || '';
1366 my $dir = result_dir($path);
1368 return glob "$dir/*";
1371 sub schema_files { result_files(@_) }
1374 my $path = shift || '';
1376 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1382 sub schema_dir { result_dir(@_) }
1384 # vim:et sts=4 sw=4 tw=0: