5 use File::Path qw/rmtree make_path/;
7 use File::Temp qw/tempfile tempdir/;
9 use File::Slurp 'slurp';
10 use DBIx::Class::Schema::Loader ();
11 use Lingua::EN::Inflect::Number ();
13 use make_dbictest_db2;
15 my $DUMP_DIR = './t/_common_dump';
17 my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
19 sub class_content_like;
21 # test dynamic schema in 0.04006 mode
23 my $res = run_loader();
24 my $warning = $res->{warnings}[0];
26 like $warning, qr/dynamic schema/i,
27 'dynamic schema in backcompat mode detected';
28 like $warning, qr/run in 0\.04006 mode/i,
29 'dynamic schema in 0.04006 mode warning';
30 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
31 'warning refers to upgrading doc';
36 # setting naming accessor on dynamic schema should disable warning (even when
37 # we're setting it to 'v4' .)
39 my $res = run_loader(naming => 'v4');
40 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
44 # test upgraded dynamic schema
46 my $res = run_loader(naming => 'current');
47 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
51 # test upgraded dynamic schema with external content loaded
53 my $temp_dir = setup_load_external({
58 my $res = run_loader(naming => 'current');
59 my $schema = $res->{schema};
61 is scalar @{ $res->{warnings} }, 1,
62 'correct nummber of warnings for upgraded dynamic schema with external ' .
63 'content for unsingularized Result.';
65 my $warning = $res->{warnings}[0];
66 like $warning, qr/Detected external content/i,
67 'detected external content warning';
69 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
70 'external custom content for unsingularized Result was loaded by upgraded ' .
73 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
74 $res->{classes}{bazs} }
75 'unsingularized class names in external content are translated';
77 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' }
78 'external content from unchanged Result class';
80 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
81 $res->{classes}{foos} }
82 'unsingularized class names in external content from unchanged Result class ' .
83 'names are translated';
88 # test upgraded dynamic schema with use_namespaces with external content loaded
90 my $temp_dir = setup_load_external({
95 my $res = run_loader(naming => 'current', use_namespaces => 1);
96 my $schema = $res->{schema};
98 is scalar @{ $res->{warnings} }, 2,
99 'correct nummber of warnings for upgraded dynamic schema with external ' .
100 'content for unsingularized Result with use_namespaces.';
102 my $warning = $res->{warnings}[0];
103 like $warning, qr/Detected external content/i,
104 'detected external content warning';
106 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
107 'external custom content for unsingularized Result was loaded by upgraded ' .
110 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
111 $res->{classes}{bazs} }
112 'unsingularized class names in external content are translated';
114 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
115 $res->{classes}{foos} }
116 'unsingularized class names in external content from unchanged Result class ' .
117 'names are translated';
122 # test upgraded static schema with external content loaded
126 my $temp_dir = setup_load_external({
131 write_v4_schema_pm();
133 my $res = run_loader(static => 1, naming => 'current');
134 my $schema = $res->{schema};
138 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
139 'external custom content for unsingularized Result was loaded by upgraded ' .
142 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
143 $res->{classes}{bazs} }
144 'unsingularized class names in external content are translated';
146 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
147 $res->{classes}{foos} }
148 'unsingularized class names in external content from unchanged Result class ' .
149 'names are translated in static schema';
151 class_content_like $schema, $res->{classes}{quuxs}, qr/package ${SCHEMA_CLASS}::Quux;/,
152 'package line translated correctly from external custom content in static dump';
154 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
155 'external custom content loaded into static dump correctly';
158 # test running against v4 schema without upgrade, twice, then upgrade
161 write_v4_schema_pm();
162 my $res = run_loader(static => 1);
163 my $warning = $res->{warnings}[1];
165 like $warning, qr/static schema/i,
166 'static schema in backcompat mode detected';
167 like $warning, qr/0.04006/,
168 'correct version detected';
169 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
170 'refers to upgrading doc';
172 is scalar @{ $res->{warnings} }, 4,
173 'correct number of warnings for static schema in backcompat mode';
177 add_custom_content($res->{schema}, {
181 # Rerun the loader in backcompat mode to make sure it's still in backcompat
183 $res = run_loader(static => 1);
186 # now upgrade the schema
192 my $schema = $res->{schema};
194 like $res->{warnings}[0], qr/Dumping manual schema/i,
195 'correct warnings on upgrading static schema (with "naming" set)';
197 like $res->{warnings}[1], qr/dump completed/i,
198 'correct warnings on upgrading static schema (with "naming" set)';
200 is scalar @{ $res->{warnings} }, 2,
201 'correct number of warnings on upgrading static schema (with "naming" set)'
202 or diag @{ $res->{warnings} };
206 is result_count('Result'), 4,
207 'un-singularized results were replaced during upgrade';
209 # check that custom content was preserved
210 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
211 'custom content was carried over from un-singularized Result';
213 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
214 $res->{classes}{bazs} }
215 'unsingularized class names in custom content are translated';
217 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
218 'custom content from unsingularized Result loaded into static dump correctly';
221 # test running against v4 schema without upgrade, then upgrade with
222 # use_namespaces not explicitly set
225 write_v4_schema_pm();
226 my $res = run_loader(static => 1);
227 my $warning = $res->{warnings}[1];
229 like $warning, qr/static schema/i,
230 'static schema in backcompat mode detected';
231 like $warning, qr/0.04006/,
232 'correct version detected';
233 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
234 'refers to upgrading doc';
236 is scalar @{ $res->{warnings} }, 4,
237 'correct number of warnings for static schema in backcompat mode';
241 add_custom_content($res->{schema}, {
245 # now upgrade the schema
250 my $schema = $res->{schema};
252 like $res->{warnings}[0], qr/load_classes/i,
253 'correct warnings on upgrading static schema (with "naming" set and ' .
254 'use_namespaces not set)';
256 like $res->{warnings}[1], qr/Dumping manual schema/i,
257 'correct warnings on upgrading static schema (with "naming" set and ' .
258 'use_namespaces not set)';
260 like $res->{warnings}[2], qr/dump completed/i,
261 'correct warnings on upgrading static schema (with "naming" set and ' .
262 'use_namespaces not set)';
264 is scalar @{ $res->{warnings} }, 3,
265 'correct number of warnings on upgrading static schema (with "naming" set)'
266 or diag @{ $res->{warnings} };
270 is result_count(), 4,
271 'un-singularized results were replaced during upgrade';
273 # check that custom content was preserved
274 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
275 'custom content was carried over from un-singularized Result';
277 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
278 $res->{classes}{bazs} }
279 'unsingularized class names in custom content are translated';
281 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
282 'custom content from unsingularized Result loaded into static dump correctly';
285 # test running against v4 schema with load_namespaces, upgrade to v5 but
286 # downgrade to load_classes, with external content
290 my $temp_dir = setup_load_external({
293 }, { result_namespace => 'Result' });
295 write_v4_schema_pm(use_namespaces => 1);
297 my $res = run_loader(static => 1);
298 my $warning = $res->{warnings}[0];
300 like $warning, qr/static schema/i,
301 'static schema in backcompat mode detected';
302 like $warning, qr/0.04006/,
303 'correct version detected';
304 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
305 'refers to upgrading doc';
307 is scalar @{ $res->{warnings} }, 3,
308 'correct number of warnings for static schema in backcompat mode';
312 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs',
313 'use_namespaces in backcompat mode';
315 add_custom_content($res->{schema}, {
318 result_namespace => 'Result',
319 rel_name_map => { QuuxBaz => 'bazrel2' },
322 # now upgrade the schema to v5 but downgrade to load_classes
328 my $schema = $res->{schema};
330 like $res->{warnings}[0], qr/Dumping manual schema/i,
331 'correct warnings on upgrading static schema (with "naming" set and ' .
332 'use_namespaces => 0)';
334 like $res->{warnings}[1], qr/dump completed/i,
335 'correct warnings on upgrading static schema (with "naming" set and ' .
336 'use_namespaces => 0)';
338 is scalar @{ $res->{warnings} }, 2,
339 'correct number of warnings on upgrading static schema (with "naming" set)'
340 or diag @{ $res->{warnings} };
344 is result_count(), 4,
345 'un-singularized results were replaced during upgrade and Result dir removed';
347 ok ((not -d result_dir('Result')),
348 'Result dir was removed for load_classes downgrade');
350 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
351 'load_classes in upgraded mode';
353 # check that custom and external content was preserved
354 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
355 'custom content was carried over from un-singularized Result';
357 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
358 'external content was carried over from un-singularized Result';
360 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
361 $res->{classes}{bazs} }
362 'unsingularized class names in custom content are translated';
364 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
365 $res->{classes}{bazs} }
366 'unsingularized class names in external content are translated';
368 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
369 $res->{classes}{foos} }
370 'unsingularized class names in external content from unchanged Result class ' .
371 'names are translated in static schema';
373 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
374 'external content from unsingularized Result loaded into static dump correctly';
376 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
377 'custom content from unsingularized Result loaded into static dump correctly';
380 # test a regular schema with use_namespaces => 0 upgraded to
381 # use_namespaces => 1
383 my $res = run_loader(
389 like $res->{warnings}[0], qr/Dumping manual schema/i,
390 'correct warnings on dumping static schema with use_namespaces => 0';
392 like $res->{warnings}[1], qr/dump completed/i,
393 'correct warnings on dumping static schema with use_namespaces => 0';
395 is scalar @{ $res->{warnings} }, 2,
396 'correct number of warnings on dumping static schema with use_namespaces => 0'
397 or diag @{ $res->{warnings} };
401 my $schema = $res->{schema};
402 add_custom_content($res->{schema}, {
406 # test that with no use_namespaces option, there is a warning and
407 # load_classes is preserved
408 $res = run_loader(static => 1);
410 like $res->{warnings}[0], qr/load_classes/i,
411 'correct warnings on re-dumping static schema with load_classes';
413 like $res->{warnings}[1], qr/Dumping manual schema/i,
414 'correct warnings on re-dumping static schema with load_classes';
416 like $res->{warnings}[2], qr/dump completed/i,
417 'correct warnings on re-dumping static schema with load_classes';
419 is scalar @{ $res->{warnings} }, 3,
420 'correct number of warnings on re-dumping static schema with load_classes'
421 or diag @{ $res->{warnings} };
423 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
424 'load_classes preserved on re-dump';
428 # now upgrade the schema to use_namespaces
433 $schema = $res->{schema};
435 like $res->{warnings}[0], qr/Dumping manual schema/i,
436 'correct warnings on upgrading to use_namespaces';
438 like $res->{warnings}[1], qr/dump completed/i,
439 'correct warnings on upgrading to use_namespaces';
441 is scalar @{ $res->{warnings} }, 2,
442 'correct number of warnings on upgrading to use_namespaces'
443 or diag @{ $res->{warnings} };
447 my @schema_files = schema_files();
449 is 1, (scalar @schema_files),
450 "schema dir contains only 1 entry";
452 like $schema_files[0], qr{/Result\z},
453 "schema dir contains only a Result/ directory";
455 # check that custom content was preserved
456 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
457 'custom content was carried over during use_namespaces upgrade';
459 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
460 $res->{classes}{bazs} }
461 'un-namespaced class names in custom content are translated';
463 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
464 'custom content from un-namespaced Result loaded into static dump correctly';
467 # test a regular schema with default use_namespaces => 1, redump, and downgrade
470 my $res = run_loader(clean_dumpdir => 1, static => 1);
472 like $res->{warnings}[0], qr/Dumping manual schema/i,
473 'correct warnings on dumping static schema';
475 like $res->{warnings}[1], qr/dump completed/i,
476 'correct warnings on dumping static schema';
478 is scalar @{ $res->{warnings} }, 2,
479 'correct number of warnings on dumping static schema'
480 or diag @{ $res->{warnings} };
484 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
485 'defaults to use_namespaces on regular dump';
487 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
489 # test that with no use_namespaces option, use_namespaces is preserved
490 $res = run_loader(static => 1);
492 like $res->{warnings}[0], qr/Dumping manual schema/i,
493 'correct warnings on re-dumping static schema';
495 like $res->{warnings}[1], qr/dump completed/i,
496 'correct warnings on re-dumping static schema';
498 is scalar @{ $res->{warnings} }, 2,
499 'correct number of warnings on re-dumping static schema'
500 or diag @{ $res->{warnings} };
502 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
503 'use_namespaces preserved on re-dump';
507 # now downgrade the schema to load_classes
512 my $schema = $res->{schema};
514 like $res->{warnings}[0], qr/Dumping manual schema/i,
515 'correct warnings on downgrading to load_classes';
517 like $res->{warnings}[1], qr/dump completed/i,
518 'correct warnings on downgrading to load_classes';
520 is scalar @{ $res->{warnings} }, 2,
521 'correct number of warnings on downgrading to load_classes'
522 or diag @{ $res->{warnings} };
526 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
527 'load_classes downgrade correct';
529 is result_count(), 4,
530 'correct number of Results after upgrade and Result dir removed';
532 ok ((not -d result_dir('Result')),
533 'Result dir was removed for load_classes downgrade');
535 # check that custom content was preserved
536 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
537 'custom content was carried over during load_classes downgrade';
539 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
540 $res->{classes}{bazs} }
541 'namespaced class names in custom content are translated during load_classes '.
544 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
545 'custom content from namespaced Result loaded into static dump correctly '.
546 'during load_classes downgrade';
549 # test a regular schema with use_namespaces => 1 and a custom result_namespace
550 # downgraded to load_classes
552 my $res = run_loader(
555 result_namespace => 'MyResult',
558 like $res->{warnings}[0], qr/Dumping manual schema/i,
559 'correct warnings on dumping static schema';
561 like $res->{warnings}[1], qr/dump completed/i,
562 'correct warnings on dumping static schema';
564 is scalar @{ $res->{warnings} }, 2,
565 'correct number of warnings on dumping static schema'
566 or diag @{ $res->{warnings} };
570 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
571 'defaults to use_namespaces and uses custom result_namespace';
573 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
575 # test that with no use_namespaces option, use_namespaces is preserved, and
576 # the custom result_namespace is preserved
577 $res = run_loader(static => 1);
579 like $res->{warnings}[0], qr/Dumping manual schema/i,
580 'correct warnings on re-dumping static schema';
582 like $res->{warnings}[1], qr/dump completed/i,
583 'correct warnings on re-dumping static schema';
585 is scalar @{ $res->{warnings} }, 2,
586 'correct number of warnings on re-dumping static schema'
587 or diag @{ $res->{warnings} };
589 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
590 'use_namespaces and custom result_namespace preserved on re-dump';
594 # now downgrade the schema to load_classes
599 my $schema = $res->{schema};
601 like $res->{warnings}[0], qr/Dumping manual schema/i,
602 'correct warnings on downgrading to load_classes';
604 like $res->{warnings}[1], qr/dump completed/i,
605 'correct warnings on downgrading to load_classes';
607 is scalar @{ $res->{warnings} }, 2,
608 'correct number of warnings on downgrading to load_classes'
609 or diag @{ $res->{warnings} };
613 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
614 'load_classes downgrade correct';
616 is result_count(), 4,
617 'correct number of Results after upgrade and Result dir removed';
619 ok ((not -d result_dir('MyResult')),
620 'Result dir was removed for load_classes downgrade');
622 # check that custom content was preserved
623 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
624 'custom content was carried over during load_classes downgrade';
626 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
627 $res->{classes}{bazs} }
628 'namespaced class names in custom content are translated during load_classes '.
631 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
632 'custom content from namespaced Result loaded into static dump correctly '.
633 'during load_classes downgrade';
636 # rewrite from one result_namespace to another, with external content
639 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
641 my $res = run_loader(static => 1);
643 # add some custom content to a Result that will be replaced
644 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
646 # Rewrite implicit 'Result' to 'MyResult'
649 result_namespace => 'MyResult',
651 my $schema = $res->{schema};
653 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
654 'using new result_namespace';
656 is result_count('MyResult'), 4,
657 'correct number of Results after rewritten result_namespace';
659 ok ((not -d schema_dir('Result')),
660 'original Result dir was removed when rewriting result_namespace');
662 # check that custom content was preserved
663 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
664 'custom content was carried over when rewriting result_namespace';
666 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
667 $res->{classes}{bazs} }
668 'class names in custom content are translated when rewriting result_namespace';
670 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
671 'custom content from namespaced Result loaded into static dump correctly '.
672 'when rewriting result_namespace';
674 # Now rewrite 'MyResult' to 'Mtfnpy'
677 result_namespace => 'Mtfnpy',
679 $schema = $res->{schema};
681 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
682 'using new result_namespace';
684 is result_count('Mtfnpy'), 4,
685 'correct number of Results after rewritten result_namespace';
687 ok ((not -d result_dir('MyResult')),
688 'original Result dir was removed when rewriting result_namespace');
690 # check that custom and external content was preserved
691 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
692 'external content was carried over when rewriting result_namespace';
694 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
695 'custom content was carried over when rewriting result_namespace';
697 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
698 $res->{classes}{bazs} }
699 'class names in custom content are translated when rewriting result_namespace';
701 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
702 $res->{classes}{bazs} }
703 'class names in external content are translated when rewriting '.
706 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
707 $res->{classes}{foos} }
708 'class names in external content are translated when rewriting '.
711 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
712 'custom content from namespaced Result loaded into static dump correctly '.
713 'when rewriting result_namespace';
715 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
716 'external content from unsingularized Result loaded into static dump correctly';
719 # test upgrading a v4 schema, then check that the version string is correct
722 write_v4_schema_pm();
723 run_loader(static => 1);
724 my $res = run_loader(static => 1, naming => 'current');
725 my $schema = $res->{schema};
727 my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
728 my $code = slurp $file;
731 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
733 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
734 'correct version dumped after upgrade of v4 static schema';
737 # Test upgrading an already singular result with custom content that refers to
741 write_v4_schema_pm();
742 my $res = run_loader(static => 1);
743 my $schema = $res->{schema};
746 # add some custom content to a Result that will be replaced
747 add_custom_content($schema, { Bar => 'Foos' });
749 # now upgrade the schema
750 $res = run_loader(static => 1, naming => 'current');
751 $schema = $res->{schema};
754 # check that custom content was preserved
755 lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
756 'custom content was preserved from Result pre-upgrade';
758 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
759 $res->{classes}{foos} }
760 'unsingularized class names in custom content from Result with unchanged ' .
761 'name are translated';
763 class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
764 'custom content from Result with unchanged name loaded into static dump ' .
771 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
780 my %loader_opts = @_;
782 $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
784 clean_dumpdir() if delete $loader_opts{clean_dumpdir};
787 foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
788 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
791 Class::Unload->unload($SCHEMA_CLASS);
795 my @connect_info = $make_dbictest_db2::dsn;
797 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
799 package $SCHEMA_CLASS;
800 use base qw/DBIx::Class::Schema::Loader/;
802 __PACKAGE__->loader_options(\%loader_opts);
803 __PACKAGE__->connection(\@connect_info);
806 ok(!$@, "Loader initialization") or diag $@;
808 my $schema = $SCHEMA_CLASS->clone;
809 my (%monikers, %classes);
810 foreach my $source_name ($schema->sources) {
811 my $table_name = $schema->source($source_name)->from;
812 $monikers{$table_name} = $source_name;
813 $classes{$table_name} = $schema->source($source_name)->result_class;
818 warnings => \@loader_warnings,
819 monikers => \%monikers,
820 classes => \%classes,
824 sub write_v4_schema_pm {
827 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
829 make_path $schema_dir;
830 my $schema_pm = "$schema_dir/Schema.pm";
831 open my $fh, '>', $schema_pm or die $!;
832 if (not $opts{use_namespaces}) {
834 package DBIXCSL_Test::Schema;
839 use base 'DBIx::Class::Schema';
841 __PACKAGE__->load_classes;
844 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
845 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
848 # You can replace this text with custom content, and it will be preserved on regeneration
854 package DBIXCSL_Test::Schema;
859 use base 'DBIx::Class::Schema';
861 __PACKAGE__->load_namespaces;
864 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
865 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
868 # You can replace this text with custom content, and it will be preserved on
877 my $schema = $res->{schema};
879 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
880 [qw/Foos Bar Bazs Quuxs/],
881 'correct monikers in 0.04006 mode';
883 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
884 $res->{classes}{bar},
887 isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
888 'correct rel name in 0.04006 mode';
890 ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
892 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
893 'correct rel type and name for UNIQUE FK in 0.04006 mode';
898 my $schema = $res->{schema};
900 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
901 [qw/Foo Bar Baz Quux/],
902 'correct monikers in current mode';
904 ok my $bar = eval { $schema->resultset('Bar')->find(1) };
906 isa_ok eval { $bar->foo }, $res->{classes}{foos},
907 'correct rel name in current mode';
909 ok my $baz = eval { $schema->resultset('Baz')->find(1) };
911 isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
912 'correct rel type and name for UNIQUE FK in current mode';
916 package DBICSL::Test::TempExtDir;
918 use overload '""' => sub { ${$_[0]} };
922 File::Path::rmtree ${$_[0]} unless $^O =~ /win32|cygwin/i;
926 sub setup_load_external {
927 my ($rels, $opts) = @_;
929 my $temp_dir = tempdir(CLEANUP => 1);
930 push @INC, $temp_dir;
932 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
933 ($opts->{result_namespace} || ());
935 make_path $external_result_dir;
937 while (my ($from, $to) = each %$rels) {
938 write_ext_result($external_result_dir, $from, $to, $opts);
941 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
946 sub write_ext_result {
947 my ($result_dir, $from, $to, $opts) = @_;
949 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
950 my $from_class = _qualify_class($from, $opts->{result_namespace});
951 my $to_class = _qualify_class($to, $opts->{result_namespace});
952 my $condition = _rel_condition($from, $to);
954 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
955 package ${from_class};
956 sub a_method { 'hlagh' }
958 __PACKAGE__->has_one('$relname', '$to_class',
970 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
974 my ($class, $result_namespace) = @_;
976 return $SCHEMA_CLASS . '::'
977 . ($result_namespace ? $result_namespace . '::' : '')
982 my ($from, $to) = @_;
984 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
988 my ($from, $to) = @_;
991 QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
992 BarFoo => q{'foreign.fooid' => 'self.foo_id'},
993 }->{_rel_key($from, $to)};
996 sub class_content_like {
997 my ($schema, $class, $re, $test_name) = @_;
999 my $file = $schema->_loader->_get_dump_filename($class);
1000 my $code = slurp $file;
1002 like $code, $re, $test_name;
1005 sub add_custom_content {
1006 my ($schema, $rels, $opts) = @_;
1008 while (my ($from, $to) = each %$rels) {
1009 my $relname = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1010 my $from_class = _qualify_class($from, $opts->{result_namespace});
1011 my $to_class = _qualify_class($to, $opts->{result_namespace});
1012 my $condition = _rel_condition($from, $to);
1014 my $content = <<"EOF";
1015 package ${from_class};
1016 sub b_method { 'dongs' }
1018 __PACKAGE__->has_one('$relname', '$to_class',
1024 _write_custom_content($schema, $from_class, $content);
1028 sub _write_custom_content {
1029 my ($schema, $class, $content) = @_;
1031 my $pm = $schema->_loader->_get_dump_filename($class);
1033 local ($^I, @ARGV) = ('.bak', $pm);
1035 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1044 unlink "${pm}.bak" or die $^E;
1049 my $path = shift || '';
1051 my $dir = result_dir($path);
1053 my $file_count =()= glob "$dir/*";
1059 my $path = shift || '';
1061 my $dir = result_dir($path);
1063 return glob "$dir/*";
1066 sub schema_files { result_files(@_) }
1069 my $path = shift || '';
1071 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1077 sub schema_dir { result_dir(@_) }