1use strict; 2use warnings; 3use Test::More; 4use Test::Exception; 5use File::Path qw/rmtree make_path/; 6use Class::Unload; 7use File::Temp qw/tempfile tempdir/; 8use IO::File; 9use File::Slurp 'slurp'; 10use DBIx::Class::Schema::Loader (); 11use lib qw(t/lib); 12use make_dbictest_db2; 13 14my $DUMP_DIR = './t/_common_dump'; 15rmtree $DUMP_DIR; 16my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; 17 18# test dynamic schema in 0.04006 mode 19{ 20 my $res = run_loader(); 21 my $warning = $res->{warnings}[0]; 22 23 like $warning, qr/dynamic schema/i, 24 'dynamic schema in backcompat mode detected'; 25 like $warning, qr/run in 0\.04006 mode/i, 26 'dynamic schema in 0.04006 mode warning'; 27 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, 28 'warning refers to upgrading doc'; 29 30 run_v4_tests($res); 31} 32 33# setting naming accessor on dynamic schema should disable warning (even when 34# we're setting it to 'v4' .) 35{ 36 my $res = run_loader(naming => 'v4'); 37 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; 38 run_v4_tests($res); 39} 40 41# test upgraded dynamic schema 42{ 43 my $res = run_loader(naming => 'current'); 44 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; 45 run_v5_tests($res); 46} 47 48# test upgraded dynamic schema with external content loaded 49{ 50 my $temp_dir = tempdir(CLEANUP => 1); 51 push @INC, $temp_dir; 52 53 my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS; 54 make_path $external_result_dir; 55 56 # make external content for Result that will be singularized 57 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); 58package ${SCHEMA_CLASS}::Quuxs; 59sub a_method { 'hlagh' } 60 61__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs', 62 { 'foreign.baz_num' => 'self.baz_id' }); 63 641; 65EOF 66 67 # make external content for Result that will NOT be singularized 68 IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); 69package ${SCHEMA_CLASS}::Bar; 70 71__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos', 72 { 'foreign.fooid' => 'self.foo_id' }); 73 741; 75EOF 76 77 my $res = run_loader(naming => 'current'); 78 my $schema = $res->{schema}; 79 80 is scalar @{ $res->{warnings} }, 1, 81'correct nummber of warnings for upgraded dynamic schema with external ' . 82'content for unsingularized Result.'; 83 84 my $warning = $res->{warnings}[0]; 85 like $warning, qr/Detected external content/i, 86 'detected external content warning'; 87 88 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 89'external custom content for unsingularized Result was loaded by upgraded ' . 90'dynamic Schema'; 91 92 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 93 $res->{classes}{bazs} } 94 'unsingularized class names in external content are translated'; 95 96 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel, 97 $res->{classes}{foos} } 98'unsingularized class names in external content from unchanged Result class ' . 99'names are translated'; 100 101 run_v5_tests($res); 102 103 pop @INC; 104} 105 106# test upgraded dynamic schema with use_namespaces with external content loaded 107{ 108 my $temp_dir = tempdir(CLEANUP => 1); 109 push @INC, $temp_dir; 110 111 my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS; 112 make_path $external_result_dir; 113 114 # make external content for Result that will be singularized 115 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); 116package ${SCHEMA_CLASS}::Quuxs; 117sub a_method { 'hlagh' } 118 119__PACKAGE__->has_one('bazrel4', 'DBIXCSL_Test::Schema::Bazs', 120 { 'foreign.baz_num' => 'self.baz_id' }); 121 1221; 123EOF 124 125 # make external content for Result that will NOT be singularized 126 IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); 127package ${SCHEMA_CLASS}::Bar; 128 129__PACKAGE__->has_one('foorel4', 'DBIXCSL_Test::Schema::Foos', 130 { 'foreign.fooid' => 'self.foo_id' }); 131 1321; 133EOF 134 135 my $res = run_loader(naming => 'current', use_namespaces => 1); 136 my $schema = $res->{schema}; 137 138 is scalar @{ $res->{warnings} }, 2, 139'correct nummber of warnings for upgraded dynamic schema with external ' . 140'content for unsingularized Result with use_namespaces.'; 141 142 my $warning = $res->{warnings}[0]; 143 like $warning, qr/Detected external content/i, 144 'detected external content warning'; 145 146 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 147'external custom content for unsingularized Result was loaded by upgraded ' . 148'dynamic Schema'; 149 150 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel4, 151 $res->{classes}{bazs} } 152 'unsingularized class names in external content are translated'; 153 154 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel4, 155 $res->{classes}{foos} } 156'unsingularized class names in external content from unchanged Result class ' . 157'names are translated'; 158 159 run_v5_tests($res); 160 161 pop @INC; 162} 163 164 165# test upgraded static schema with external content loaded 166{ 167 my $temp_dir = tempdir(CLEANUP => 1); 168 push @INC, $temp_dir; 169 170 my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS; 171 make_path $external_result_dir; 172 173 # make external content for Result that will be singularized 174 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); 175package ${SCHEMA_CLASS}::Quuxs; 176sub a_method { 'dongs' } 177 178__PACKAGE__->has_one('bazrel2', 'DBIXCSL_Test::Schema::Bazs', 179 { 'foreign.baz_num' => 'self.baz_id' }); 180 1811; 182EOF 183 184 # make external content for Result that will NOT be singularized 185 IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); 186package ${SCHEMA_CLASS}::Bar; 187 188__PACKAGE__->has_one('foorel2', 'DBIXCSL_Test::Schema::Foos', 189 { 'foreign.fooid' => 'self.foo_id' }); 190 1911; 192EOF 193 194 write_v4_schema_pm(); 195 196 my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); 197 my $schema = $res->{schema}; 198 199 run_v5_tests($res); 200 201 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'dongs' } 202'external custom content for unsingularized Result was loaded by upgraded ' . 203'static Schema'; 204 205 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, 206 $res->{classes}{bazs} } 207 'unsingularized class names in external content are translated'; 208 209 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel2, 210 $res->{classes}{foos} } 211'unsingularized class names in external content from unchanged Result class ' . 212'names are translated in static schema'; 213 214 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 215 my $code = slurp $file; 216 217 like $code, qr/package ${SCHEMA_CLASS}::Quux;/, 218'package line translated correctly from external custom content in static dump'; 219 220 like $code, qr/sub a_method { 'dongs' }/, 221'external custom content loaded into static dump correctly'; 222 223 pop @INC; 224} 225 226# test running against v4 schema without upgrade, twice, then upgrade 227{ 228 write_v4_schema_pm(); 229 my $res = run_loader(dump_directory => $DUMP_DIR); 230 my $warning = $res->{warnings}[1]; 231 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'; 238 239 is scalar @{ $res->{warnings} }, 4, 240 'correct number of warnings for static schema in backcompat mode'; 241 242 run_v4_tests($res); 243 244 # add some custom content to a Result that will be replaced 245 my $schema = $res->{schema}; 246 my $quuxs_pm = $schema->_loader 247 ->_get_dump_filename($res->{classes}{quuxs}); 248 { 249 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 250 while (<>) { 251 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 252 print; 253 print <<EOF; 254sub a_method { 'mtfnpy' } 255 256__PACKAGE__->has_one('bazrel3', 'DBIXCSL_Test::Schema::Bazs', 257 { 'foreign.baz_num' => 'self.baz_id' }); 258EOF 259 } 260 else { 261 print; 262 } 263 } 264 close ARGV; 265 unlink "${quuxs_pm}.bak" or die $^E; 266 } 267 268 # Rerun the loader in backcompat mode to make sure it's still in backcompat 269 # mode. 270 $res = run_loader(dump_directory => $DUMP_DIR); 271 run_v4_tests($res); 272 273 # now upgrade the schema 274 $res = run_loader( 275 dump_directory => $DUMP_DIR, 276 naming => 'current', 277 use_namespaces => 1 278 ); 279 $schema = $res->{schema}; 280 281 like $res->{warnings}[0], qr/Dumping manual schema/i, 282 'correct warnings on upgrading static schema (with "naming" set)'; 283 284 like $res->{warnings}[1], qr/dump completed/i, 285 'correct warnings on upgrading static schema (with "naming" set)'; 286 287 is scalar @{ $res->{warnings} }, 2, 288'correct number of warnings on upgrading static schema (with "naming" set)' 289 or diag @{ $res->{warnings} }; 290 291 run_v5_tests($res); 292 293 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS/Result") =~ s{::}{/}g; 294 my $result_count =()= glob "$result_dir/*"; 295 296 is $result_count, 4, 297 'un-singularized results were replaced during upgrade'; 298 299 # check that custom content was preserved 300 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 301 'custom content was carried over from un-singularized Result'; 302 303 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel3, 304 $res->{classes}{bazs} } 305 'unsingularized class names in custom content are translated'; 306 307 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 308 my $code = slurp $file; 309 310 like $code, qr/sub a_method { 'mtfnpy' }/, 311'custom content from unsingularized Result loaded into static dump correctly'; 312} 313 314# test running against v4 schema without upgrade, then upgrade with 315# use_namespaces not explicitly set 316{ 317 write_v4_schema_pm(); 318 my $res = run_loader(dump_directory => $DUMP_DIR); 319 my $warning = $res->{warnings}[1]; 320 321 like $warning, qr/static schema/i, 322 'static schema in backcompat mode detected'; 323 like $warning, qr/0.04006/, 324 'correct version detected'; 325 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, 326 'refers to upgrading doc'; 327 328 is scalar @{ $res->{warnings} }, 4, 329 'correct number of warnings for static schema in backcompat mode'; 330 331 run_v4_tests($res); 332 333 # add some custom content to a Result that will be replaced 334 my $schema = $res->{schema}; 335 my $quuxs_pm = $schema->_loader 336 ->_get_dump_filename($res->{classes}{quuxs}); 337 { 338 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 339 while (<>) { 340 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 341 print; 342 print <<EOF; 343sub a_method { 'mtfnpy' } 344 345__PACKAGE__->has_one('bazrel5', 'DBIXCSL_Test::Schema::Bazs', 346 { 'foreign.baz_num' => 'self.baz_id' }); 347EOF 348 } 349 else { 350 print; 351 } 352 } 353 close ARGV; 354 unlink "${quuxs_pm}.bak" or die $^E; 355 } 356 357 # now upgrade the schema 358 $res = run_loader( 359 dump_directory => $DUMP_DIR, 360 naming => 'current' 361 ); 362 $schema = $res->{schema}; 363 364 like $res->{warnings}[0], qr/load_classes/i, 365'correct warnings on upgrading static schema (with "naming" set and ' . 366'use_namespaces not set)'; 367 368 like $res->{warnings}[1], qr/Dumping manual schema/i, 369'correct warnings on upgrading static schema (with "naming" set and ' . 370'use_namespaces not set)'; 371 372 like $res->{warnings}[2], qr/dump completed/i, 373'correct warnings on upgrading static schema (with "naming" set and ' . 374'use_namespaces not set)'; 375 376 is scalar @{ $res->{warnings} }, 3, 377'correct number of warnings on upgrading static schema (with "naming" set)' 378 or diag @{ $res->{warnings} }; 379 380 run_v5_tests($res); 381 382 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 383 my $result_count =()= glob "$result_dir/*"; 384 385 is $result_count, 4, 386 'un-singularized results were replaced during upgrade'; 387 388 # check that custom content was preserved 389 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 390 'custom content was carried over from un-singularized Result'; 391 392 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel5, 393 $res->{classes}{bazs} } 394 'unsingularized class names in custom content are translated'; 395 396 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 397 my $code = slurp $file; 398 399 like $code, qr/sub a_method { 'mtfnpy' }/, 400'custom content from unsingularized Result loaded into static dump correctly'; 401} 402 403# test running against v4 schema with load_namespaces, upgrade to v5 but 404# downgrade to load_classes, with external content 405{ 406 my $temp_dir = tempdir(CLEANUP => 1); 407 push @INC, $temp_dir; 408 409 my $external_result_dir = join '/', $temp_dir, split /::/, 410 "${SCHEMA_CLASS}::Result"; 411 412 make_path $external_result_dir; 413 414 # make external content for Result that will be singularized 415 IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF"); 416package ${SCHEMA_CLASS}::Result::Quuxs; 417sub b_method { 'dongs' } 418 419__PACKAGE__->has_one('bazrel11', 'DBIXCSL_Test::Schema::Result::Bazs', 420 { 'foreign.baz_num' => 'self.baz_id' }); 421 4221; 423EOF 424 425 # make external content for Result that will NOT be singularized 426 IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); 427package ${SCHEMA_CLASS}::Result::Bar; 428 429__PACKAGE__->has_one('foorel5', 'DBIXCSL_Test::Schema::Result::Foos', 430 { 'foreign.fooid' => 'self.foo_id' }); 431 4321; 433EOF 434 435 write_v4_schema_pm(use_namespaces => 1); 436 437 my $res = run_loader(dump_directory => $DUMP_DIR); 438 my $warning = $res->{warnings}[0]; 439 440 like $warning, qr/static schema/i, 441 'static schema in backcompat mode detected'; 442 like $warning, qr/0.04006/, 443 'correct version detected'; 444 like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/, 445 'refers to upgrading doc'; 446 447 is scalar @{ $res->{warnings} }, 3, 448 'correct number of warnings for static schema in backcompat mode'; 449 450 run_v4_tests($res); 451 452 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs', 453 'use_namespaces in backcompat mode'; 454 455 # add some custom content to a Result that will be replaced 456 my $schema = $res->{schema}; 457 my $quuxs_pm = $schema->_loader 458 ->_get_dump_filename($res->{classes}{quuxs}); 459 { 460 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 461 while (<>) { 462 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 463 print; 464 print <<EOF; 465sub a_method { 'mtfnpy' } 466 467__PACKAGE__->has_one('bazrel6', 'DBIXCSL_Test::Schema::Result::Bazs', 468 { 'foreign.baz_num' => 'self.baz_id' }); 469EOF 470 } 471 else { 472 print; 473 } 474 } 475 close ARGV; 476 unlink "${quuxs_pm}.bak" or die $^E; 477 } 478 479 # now upgrade the schema to v5 but downgrade to load_classes 480 $res = run_loader( 481 dump_directory => $DUMP_DIR, 482 naming => 'current', 483 use_namespaces => 0, 484 ); 485 $schema = $res->{schema}; 486 487 like $res->{warnings}[0], qr/Dumping manual schema/i, 488'correct warnings on upgrading static schema (with "naming" set and ' . 489'use_namespaces => 0)'; 490 491 like $res->{warnings}[1], qr/dump completed/i, 492'correct warnings on upgrading static schema (with "naming" set and ' . 493'use_namespaces => 0)'; 494 495 is scalar @{ $res->{warnings} }, 2, 496'correct number of warnings on upgrading static schema (with "naming" set)' 497 or diag @{ $res->{warnings} }; 498 499 run_v5_tests($res); 500 501 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 502 my $result_count =()= glob "$result_dir/*"; 503 504 is $result_count, 4, 505'un-singularized results were replaced during upgrade and Result dir removed'; 506 507 ok ((not -d "$result_dir/Result"), 508 'Result dir was removed for load_classes downgrade'); 509 510 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 511 'load_classes in upgraded mode'; 512 513 # check that custom and external content was preserved 514 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 515 'custom content was carried over from un-singularized Result'; 516 517 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } 518 'external content was carried over from un-singularized Result'; 519 520 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel6, 521 $res->{classes}{bazs} } 522 'unsingularized class names in custom content are translated'; 523 524 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel11, 525 $res->{classes}{bazs} } 526 'unsingularized class names in external content are translated'; 527 528 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel5, 529 $res->{classes}{foos} } 530'unsingularized class names in external content from unchanged Result class ' . 531'names are translated in static schema'; 532 533 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 534 my $code = slurp $file; 535 536 like $code, qr/sub a_method { 'mtfnpy' }/, 537'custom content from unsingularized Result loaded into static dump correctly'; 538 539 like $code, qr/sub b_method { 'dongs' }/, 540'external content from unsingularized Result loaded into static dump correctly'; 541 542 pop @INC; 543} 544 545# test a regular schema with use_namespaces => 0 upgraded to 546# use_namespaces => 1 547{ 548 rmtree $DUMP_DIR; 549 mkdir $DUMP_DIR; 550 551 my $res = run_loader( 552 dump_directory => $DUMP_DIR, 553 use_namespaces => 0, 554 ); 555 556 like $res->{warnings}[0], qr/Dumping manual schema/i, 557'correct warnings on dumping static schema with use_namespaces => 0'; 558 559 like $res->{warnings}[1], qr/dump completed/i, 560'correct warnings on dumping static schema with use_namespaces => 0'; 561 562 is scalar @{ $res->{warnings} }, 2, 563'correct number of warnings on dumping static schema with use_namespaces => 0' 564 or diag @{ $res->{warnings} }; 565 566 run_v5_tests($res); 567 568 # add some custom content to a Result that will be replaced 569 my $schema = $res->{schema}; 570 my $quuxs_pm = $schema->_loader 571 ->_get_dump_filename($res->{classes}{quuxs}); 572 { 573 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 574 while (<>) { 575 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 576 print; 577 print <<EOF; 578sub a_method { 'mtfnpy' } 579 580__PACKAGE__->has_one('bazrel7', 'DBIXCSL_Test::Schema::Baz', 581 { 'foreign.baz_num' => 'self.baz_id' }); 582EOF 583 } 584 else { 585 print; 586 } 587 } 588 close ARGV; 589 unlink "${quuxs_pm}.bak" or die $^E; 590 } 591 592 # test that with no use_namespaces option, there is a warning and 593 # load_classes is preserved 594 $res = run_loader(dump_directory => $DUMP_DIR); 595 596 like $res->{warnings}[0], qr/load_classes/i, 597'correct warnings on re-dumping static schema with load_classes'; 598 599 like $res->{warnings}[1], qr/Dumping manual schema/i, 600'correct warnings on re-dumping static schema with load_classes'; 601 602 like $res->{warnings}[2], qr/dump completed/i, 603'correct warnings on re-dumping static schema with load_classes'; 604 605 is scalar @{ $res->{warnings} }, 3, 606'correct number of warnings on re-dumping static schema with load_classes' 607 or diag @{ $res->{warnings} }; 608 609 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 610 'load_classes preserved on re-dump'; 611 612 run_v5_tests($res); 613 614 # now upgrade the schema to use_namespaces 615 $res = run_loader( 616 dump_directory => $DUMP_DIR, 617 use_namespaces => 1, 618 ); 619 $schema = $res->{schema}; 620 621 like $res->{warnings}[0], qr/Dumping manual schema/i, 622'correct warnings on upgrading to use_namespaces'; 623 624 like $res->{warnings}[1], qr/dump completed/i, 625'correct warnings on upgrading to use_namespaces'; 626 627 is scalar @{ $res->{warnings} }, 2, 628'correct number of warnings on upgrading to use_namespaces' 629 or diag @{ $res->{warnings} }; 630 631 run_v5_tests($res); 632 633 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 634 my @schema_files = glob "$schema_dir/*"; 635 636 is 1, (scalar @schema_files), 637 "schema dir $schema_dir contains only 1 entry"; 638 639 like $schema_files[0], qr{/Result\z}, 640 "schema dir contains only a Result/ directory"; 641 642 # check that custom content was preserved 643 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 644 'custom content was carried over during use_namespaces upgrade'; 645 646 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel7, 647 $res->{classes}{bazs} } 648 'un-namespaced class names in custom content are translated'; 649 650 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 651 my $code = slurp $file; 652 653 like $code, qr/sub a_method { 'mtfnpy' }/, 654'custom content from un-namespaced Result loaded into static dump correctly'; 655} 656 657# test a regular schema with default use_namespaces => 1, redump, and downgrade 658# to load_classes 659{ 660 rmtree $DUMP_DIR; 661 mkdir $DUMP_DIR; 662 663 my $res = run_loader(dump_directory => $DUMP_DIR); 664 665 like $res->{warnings}[0], qr/Dumping manual schema/i, 666'correct warnings on dumping static schema'; 667 668 like $res->{warnings}[1], qr/dump completed/i, 669'correct warnings on dumping static schema'; 670 671 is scalar @{ $res->{warnings} }, 2, 672'correct number of warnings on dumping static schema' 673 or diag @{ $res->{warnings} }; 674 675 run_v5_tests($res); 676 677 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 678 'defaults to use_namespaces on regular dump'; 679 680 # add some custom content to a Result that will be replaced 681 my $schema = $res->{schema}; 682 my $quuxs_pm = $schema->_loader 683 ->_get_dump_filename($res->{classes}{quuxs}); 684 { 685 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 686 while (<>) { 687 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 688 print; 689 print <<EOF; 690sub a_method { 'mtfnpy' } 691 692__PACKAGE__->has_one('bazrel8', 'DBIXCSL_Test::Schema::Result::Baz', 693 { 'foreign.baz_num' => 'self.baz_id' }); 694EOF 695 } 696 else { 697 print; 698 } 699 } 700 close ARGV; 701 unlink "${quuxs_pm}.bak" or die $^E; 702 } 703 704 # test that with no use_namespaces option, use_namespaces is preserved 705 $res = run_loader(dump_directory => $DUMP_DIR); 706 707 like $res->{warnings}[0], qr/Dumping manual schema/i, 708'correct warnings on re-dumping static schema'; 709 710 like $res->{warnings}[1], qr/dump completed/i, 711'correct warnings on re-dumping static schema'; 712 713 is scalar @{ $res->{warnings} }, 2, 714'correct number of warnings on re-dumping static schema' 715 or diag @{ $res->{warnings} }; 716 717 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 718 'use_namespaces preserved on re-dump'; 719 720 run_v5_tests($res); 721 722 # now downgrade the schema to load_classes 723 $res = run_loader( 724 dump_directory => $DUMP_DIR, 725 use_namespaces => 0, 726 ); 727 $schema = $res->{schema}; 728 729 like $res->{warnings}[0], qr/Dumping manual schema/i, 730'correct warnings on downgrading to load_classes'; 731 732 like $res->{warnings}[1], qr/dump completed/i, 733'correct warnings on downgrading to load_classes'; 734 735 is scalar @{ $res->{warnings} }, 2, 736'correct number of warnings on downgrading to load_classes' 737 or diag @{ $res->{warnings} }; 738 739 run_v5_tests($res); 740 741 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 742 'load_classes downgrade correct'; 743 744 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 745 my $result_count =()= glob "$result_dir/*"; 746 747 is $result_count, 4, 748'correct number of Results after upgrade and Result dir removed'; 749 750 ok ((not -d "$result_dir/Result"), 751 'Result dir was removed for load_classes downgrade'); 752 753 # check that custom content was preserved 754 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 755 'custom content was carried over during load_classes downgrade'; 756 757 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel8, 758 $res->{classes}{bazs} } 759'namespaced class names in custom content are translated during load_classes '. 760'downgrade'; 761 762 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 763 my $code = slurp $file; 764 765 like $code, qr/sub a_method { 'mtfnpy' }/, 766'custom content from namespaced Result loaded into static dump correctly '. 767'during load_classes downgrade'; 768} 769 770# test a regular schema with use_namespaces => 1 and a custom result_namespace 771# downgraded to load_classes 772{ 773 rmtree $DUMP_DIR; 774 mkdir $DUMP_DIR; 775 776 my $res = run_loader( 777 dump_directory => $DUMP_DIR, 778 result_namespace => 'MyResult', 779 ); 780 781 like $res->{warnings}[0], qr/Dumping manual schema/i, 782'correct warnings on dumping static schema'; 783 784 like $res->{warnings}[1], qr/dump completed/i, 785'correct warnings on dumping static schema'; 786 787 is scalar @{ $res->{warnings} }, 2, 788'correct number of warnings on dumping static schema' 789 or diag @{ $res->{warnings} }; 790 791 run_v5_tests($res); 792 793 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 794 'defaults to use_namespaces and uses custom result_namespace'; 795 796 # add some custom content to a Result that will be replaced 797 my $schema = $res->{schema}; 798 my $quuxs_pm = $schema->_loader 799 ->_get_dump_filename($res->{classes}{quuxs}); 800 { 801 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 802 while (<>) { 803 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 804 print; 805 print <<EOF; 806sub a_method { 'mtfnpy' } 807 808__PACKAGE__->has_one('bazrel9', 'DBIXCSL_Test::Schema::MyResult::Baz', 809 { 'foreign.baz_num' => 'self.baz_id' }); 810EOF 811 } 812 else { 813 print; 814 } 815 } 816 close ARGV; 817 unlink "${quuxs_pm}.bak" or die $^E; 818 } 819 820 # test that with no use_namespaces option, use_namespaces is preserved, and 821 # the custom result_namespace is preserved 822 $res = run_loader(dump_directory => $DUMP_DIR); 823 824 like $res->{warnings}[0], qr/Dumping manual schema/i, 825'correct warnings on re-dumping static schema'; 826 827 like $res->{warnings}[1], qr/dump completed/i, 828'correct warnings on re-dumping static schema'; 829 830 is scalar @{ $res->{warnings} }, 2, 831'correct number of warnings on re-dumping static schema' 832 or diag @{ $res->{warnings} }; 833 834 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 835 'use_namespaces and custom result_namespace preserved on re-dump'; 836 837 run_v5_tests($res); 838 839 # now downgrade the schema to load_classes 840 $res = run_loader( 841 dump_directory => $DUMP_DIR, 842 use_namespaces => 0, 843 ); 844 $schema = $res->{schema}; 845 846 like $res->{warnings}[0], qr/Dumping manual schema/i, 847'correct warnings on downgrading to load_classes'; 848 849 like $res->{warnings}[1], qr/dump completed/i, 850'correct warnings on downgrading to load_classes'; 851 852 is scalar @{ $res->{warnings} }, 2, 853'correct number of warnings on downgrading to load_classes' 854 or diag @{ $res->{warnings} }; 855 856 run_v5_tests($res); 857 858 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 859 'load_classes downgrade correct'; 860 861 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 862 my $result_count =()= glob "$result_dir/*"; 863 864 is $result_count, 4, 865'correct number of Results after upgrade and Result dir removed'; 866 867 ok ((not -d "$result_dir/MyResult"), 868 'Result dir was removed for load_classes downgrade'); 869 870 # check that custom content was preserved 871 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 872 'custom content was carried over during load_classes downgrade'; 873 874 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel9, 875 $res->{classes}{bazs} } 876'namespaced class names in custom content are translated during load_classes '. 877'downgrade'; 878 879 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 880 my $code = slurp $file; 881 882 like $code, qr/sub a_method { 'mtfnpy' }/, 883'custom content from namespaced Result loaded into static dump correctly '. 884'during load_classes downgrade'; 885} 886 887# rewrite from one result_namespace to another, with external content 888{ 889 rmtree $DUMP_DIR; 890 mkdir $DUMP_DIR; 891 my $temp_dir = tempdir(CLEANUP => 1); 892 push @INC, $temp_dir; 893 894 my $external_result_dir = join '/', $temp_dir, split /::/, 895 "${SCHEMA_CLASS}::Result"; 896 897 make_path $external_result_dir; 898 899 IO::File->new(">$external_result_dir/Quux.pm")->print(<<"EOF"); 900package ${SCHEMA_CLASS}::Result::Quux; 901sub c_method { 'dongs' } 902 903__PACKAGE__->has_one('bazrel12', 'DBIXCSL_Test::Schema::Result::Baz', 904 { 'foreign.baz_num' => 'self.baz_id' }); 905 9061; 907EOF 908 909 IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF"); 910package ${SCHEMA_CLASS}::Result::Bar; 911 912__PACKAGE__->has_one('foorel6', 'DBIXCSL_Test::Schema::Result::Foo', 913 { 'foreign.fooid' => 'self.foo_id' }); 914 9151; 916EOF 917 918 my $res = run_loader(dump_directory => $DUMP_DIR); 919 920 # add some custom content to a Result that will be replaced 921 my $schema = $res->{schema}; 922 my $quuxs_pm = $schema->_loader 923 ->_get_dump_filename($res->{classes}{quuxs}); 924 { 925 local ($^I, @ARGV) = ('.bak', $quuxs_pm); 926 while (<>) { 927 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 928 print; 929 print <<EOF; 930sub a_method { 'mtfnpy' } 931 932__PACKAGE__->has_one('bazrel10', 'DBIXCSL_Test::Schema::Result::Baz', 933 { 'foreign.baz_num' => 'self.baz_id' }); 934EOF 935 } 936 else { 937 print; 938 } 939 } 940 close ARGV; 941 unlink "${quuxs_pm}.bak" or die $^E; 942 } 943 944 # Rewrite implicit 'Result' to 'MyResult' 945 $res = run_loader( 946 dump_directory => $DUMP_DIR, 947 result_namespace => 'MyResult', 948 ); 949 $schema = $res->{schema}; 950 951 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 952 'using new result_namespace'; 953 954 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 955 (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS/MyResult") =~ s{::}{/}g; 956 my $result_count =()= glob "$result_dir/*"; 957 958 is $result_count, 4, 959'correct number of Results after rewritten result_namespace'; 960 961 ok ((not -d "$schema_dir/Result"), 962 'original Result dir was removed when rewriting result_namespace'); 963 964 # check that custom content was preserved 965 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 966 'custom content was carried over when rewriting result_namespace'; 967 968 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel10, 969 $res->{classes}{bazs} } 970'class names in custom content are translated when rewriting result_namespace'; 971 972 my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 973 my $code = slurp $file; 974 975 like $code, qr/sub a_method { 'mtfnpy' }/, 976'custom content from namespaced Result loaded into static dump correctly '. 977'when rewriting result_namespace'; 978 979 # Now rewrite 'MyResult' to 'Mtfnpy' 980 $res = run_loader( 981 dump_directory => $DUMP_DIR, 982 result_namespace => 'Mtfnpy', 983 ); 984 $schema = $res->{schema}; 985 986 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux', 987 'using new result_namespace'; 988 989 ($schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g; 990 ($result_dir = "$DUMP_DIR/$SCHEMA_CLASS/Mtfnpy") =~ s{::}{/}g; 991 $result_count =()= glob "$result_dir/*"; 992 993 is $result_count, 4, 994'correct number of Results after rewritten result_namespace'; 995 996 ok ((not -d "$schema_dir/MyResult"), 997 'original Result dir was removed when rewriting result_namespace'); 998 999 # check that custom and external content was preserved 1000 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' } 1001 'custom content was carried over when rewriting result_namespace'; 1002 1003 lives_and { is $schema->resultset('Quux')->find(1)->c_method, 'dongs' } 1004 'custom content was carried over when rewriting result_namespace'; 1005 1006 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel10, 1007 $res->{classes}{bazs} } 1008'class names in custom content are translated when rewriting result_namespace'; 1009 1010 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel12, 1011 $res->{classes}{bazs} } 1012'class names in external content are translated when rewriting '. 1013'result_namespace'; 1014 1015 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel6, 1016 $res->{classes}{foos} } 1017'class names in external content are translated when rewriting '. 1018'result_namespace'; 1019 1020 $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs}); 1021 $code = slurp $file; 1022 1023 like $code, qr/sub a_method { 'mtfnpy' }/, 1024'custom content from namespaced Result loaded into static dump correctly '. 1025'when rewriting result_namespace'; 1026 1027 like $code, qr/sub c_method { 'dongs' }/, 1028'external content from unsingularized Result loaded into static dump correctly'; 1029 1030 pop @INC; 1031} 1032 1033# test upgrading a v4 schema, the check that the version string is correct 1034{ 1035 write_v4_schema_pm(); 1036 run_loader(dump_directory => $DUMP_DIR); 1037 my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); 1038 my $schema = $res->{schema}; 1039 1040 my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS); 1041 my $code = slurp $file; 1042 1043 my ($dumped_ver) = 1044 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m; 1045 1046 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION, 1047 'correct version dumped after upgrade of v4 static schema'; 1048} 1049 1050# Test upgrading an already singular result with custom content that refers to 1051# old class names. 1052{ 1053 write_v4_schema_pm(); 1054 my $res = run_loader(dump_directory => $DUMP_DIR); 1055 my $schema = $res->{schema}; 1056 run_v4_tests($res); 1057 1058 # add some custom content to a Result that will be replaced 1059 my $bar_pm = $schema->_loader 1060 ->_get_dump_filename($res->{classes}{bar}); 1061 { 1062 local ($^I, @ARGV) = ('.bak', $bar_pm); 1063 while (<>) { 1064 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 1065 print; 1066 print <<EOF; 1067sub a_method { 'lalala' } 1068 1069__PACKAGE__->has_one('foorel3', 'DBIXCSL_Test::Schema::Foos', 1070 { 'foreign.fooid' => 'self.foo_id' }); 1071EOF 1072 } 1073 else { 1074 print; 1075 } 1076 } 1077 close ARGV; 1078 unlink "${bar_pm}.bak" or die $^E; 1079 } 1080 1081 # now upgrade the schema 1082 $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current'); 1083 $schema = $res->{schema}; 1084 run_v5_tests($res); 1085 1086 # check that custom content was preserved 1087 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'lalala' } 1088 'custom content was preserved from Result pre-upgrade'; 1089 1090 lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel3, 1091 $res->{classes}{foos} } 1092'unsingularized class names in custom content from Result with unchanged ' . 1093'name are translated'; 1094 1095 my $file = $schema->_loader->_get_dump_filename($res->{classes}{bar}); 1096 my $code = slurp $file; 1097 1098 like $code, qr/sub a_method { 'lalala' }/, 1099'custom content from Result with unchanged name loaded into static dump ' . 1100'correctly'; 1101} 1102 1103done_testing; 1104 1105END { 1106 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; 1107} 1108 1109sub run_loader { 1110 my %loader_opts = @_; 1111 1112 eval { 1113 foreach my $source_name ($SCHEMA_CLASS->clone->sources) { 1114 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}"); 1115 } 1116 1117 Class::Unload->unload($SCHEMA_CLASS); 1118 }; 1119 undef $@; 1120 1121 my @connect_info = $make_dbictest_db2::dsn; 1122 my @loader_warnings; 1123 local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); }; 1124 eval qq{ 1125 package $SCHEMA_CLASS; 1126 use base qw/DBIx::Class::Schema::Loader/; 1127 1128 __PACKAGE__->loader_options(\%loader_opts); 1129 __PACKAGE__->connection(\@connect_info); 1130 }; 1131 1132 ok(!$@, "Loader initialization") or diag $@; 1133 1134 my $schema = $SCHEMA_CLASS->clone; 1135 my (%monikers, %classes); 1136 foreach my $source_name ($schema->sources) { 1137 my $table_name = $schema->source($source_name)->from; 1138 $monikers{$table_name} = $source_name; 1139 $classes{$table_name} = $schema->source($source_name)->result_class; 1140 } 1141 1142 return { 1143 schema => $schema, 1144 warnings => \@loader_warnings, 1145 monikers => \%monikers, 1146 classes => \%classes, 1147 }; 1148} 1149 1150sub write_v4_schema_pm { 1151 my %opts = @_; 1152 1153 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; 1154 rmtree $schema_dir; 1155 make_path $schema_dir; 1156 my $schema_pm = "$schema_dir/Schema.pm"; 1157 open my $fh, '>', $schema_pm or die $!; 1158 if (not $opts{use_namespaces}) { 1159 print $fh <<'EOF'; 1160package DBIXCSL_Test::Schema; 1161 1162use strict; 1163use warnings; 1164 1165use base 'DBIx::Class::Schema'; 1166 1167__PACKAGE__->load_classes; 1168 1169 1170# Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25 1171# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog 1172 1173 1174# You can replace this text with custom content, and it will be preserved on regeneration 11751; 1176EOF 1177 } 1178 else { 1179 print $fh <<'EOF'; 1180package DBIXCSL_Test::Schema; 1181 1182use strict; 1183use warnings; 1184 1185use base 'DBIx::Class::Schema'; 1186 1187__PACKAGE__->load_namespaces; 1188 1189 1190# Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12 1191# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ 1192 1193 1194# You can replace this text with custom content, and it will be preserved on 1195# regeneration 11961; 1197EOF 1198 } 1199} 1200 1201sub run_v4_tests { 1202 my $res = shift; 1203 my $schema = $res->{schema}; 1204 1205 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], 1206 [qw/Foos Bar Bazs Quuxs/], 1207 'correct monikers in 0.04006 mode'; 1208 1209 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }), 1210 $res->{classes}{bar}, 1211 'found a bar'); 1212 1213 isa_ok eval { $bar->foo_id }, $res->{classes}{foos}, 1214 'correct rel name in 0.04006 mode'; 1215 1216 ok my $baz = eval { $schema->resultset('Bazs')->find(1) }; 1217 1218 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet', 1219 'correct rel type and name for UNIQUE FK in 0.04006 mode'; 1220} 1221 1222sub run_v5_tests { 1223 my $res = shift; 1224 my $schema = $res->{schema}; 1225 1226 is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ], 1227 [qw/Foo Bar Baz Quux/], 1228 'correct monikers in current mode'; 1229 1230 ok my $bar = eval { $schema->resultset('Bar')->find(1) }; 1231 1232 isa_ok eval { $bar->foo }, $res->{classes}{foos}, 1233 'correct rel name in current mode'; 1234 1235 ok my $baz = eval { $schema->resultset('Baz')->find(1) }; 1236 1237 isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, 1238 'correct rel type and name for UNIQUE FK in current mode'; 1239} 1240