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 DBIx::Class::Schema::Loader (); 10use DBIx::Class::Schema::Loader::Utils 'slurp_file'; 11use Lingua::EN::Inflect::Number (); 12use lib qw(t/lib); 13use make_dbictest_db_with_unique; 14use dbixcsl_test_dir qw/$tdir/; 15 16my $DUMP_DIR = "$tdir/common_dump"; 17rmtree $DUMP_DIR; 18my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema'; 19 20my $RESULT_COUNT = 7; 21 22sub class_content_like; 23 24# test dynamic schema in 0.04006 mode 25{ 26 my $res = run_loader(); 27 my $warning = $res->{warnings}[0]; 28 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'; 35 36 run_v4_tests($res); 37} 38 39# setting naming accessor on dynamic schema should disable warning (even when 40# we're setting it to 'v4' .) 41{ 42 my $res = run_loader(naming => 'v4'); 43 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; 44 run_v4_tests($res); 45} 46 47# test upgraded dynamic schema 48{ 49 my $res = run_loader(naming => 'current'); 50 is_deeply $res->{warnings}, [], 'no warnings with naming attribute set'; 51 run_v7_tests($res); 52} 53 54# test upgraded dynamic schema with external content loaded 55{ 56 my $temp_dir = setup_load_external({ 57 Quuxs => 'Bazs', 58 Bar => 'Foos', 59 }); 60 61 my $res = run_loader(naming => 'current', use_namespaces => 0); 62 my $schema = $res->{schema}; 63 64 is scalar @{ $res->{warnings} }, 1, 65'correct nummber of warnings for upgraded dynamic schema with external ' . 66'content for unsingularized Result.'; 67 68 my $warning = $res->{warnings}[0]; 69 like $warning, qr/Detected external content/i, 70 'detected external content warning'; 71 72 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 73'external custom content for unsingularized Result was loaded by upgraded ' . 74'dynamic Schema'; 75 76 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 77 $res->{classes}{bazs} } 78 'unsingularized class names in external content are translated'; 79 80 lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'hlagh' } 81'external content from unchanged Result class'; 82 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'; 87 88 run_v7_tests($res); 89} 90 91# test upgraded dynamic schema with use_namespaces with external content loaded 92{ 93 my $temp_dir = setup_load_external({ 94 Quuxs => 'Bazs', 95 Bar => 'Foos', 96 }); 97 98 my $res = run_loader(naming => 'current', use_namespaces => 1); 99 my $schema = $res->{schema}; 100 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.'; 104 105 my $warning = $res->{warnings}[0]; 106 like $warning, qr/Detected external content/i, 107 'detected external content warning'; 108 109 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 110'external custom content for unsingularized Result was loaded by upgraded ' . 111'dynamic Schema'; 112 113 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 114 $res->{classes}{bazs} } 115 'unsingularized class names in external content are translated'; 116 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'; 121 122 run_v7_tests($res); 123} 124 125# test upgraded static schema with external content loaded 126{ 127 clean_dumpdir(); 128 129 my $temp_dir = setup_load_external({ 130 Quuxs => 'Bazs', 131 Bar => 'Foos', 132 }); 133 134 write_v4_schema_pm(); 135 136 my $res = run_loader(static => 1, naming => 'current'); 137 my $schema = $res->{schema}; 138 139 run_v7_tests($res); 140 141 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 142'external custom content for unsingularized Result was loaded by upgraded ' . 143'static Schema'; 144 145 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 146 $res->{classes}{bazs} } 147 'unsingularized class names in external content are translated'; 148 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'; 153 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'; 156 157 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, 158'external custom content loaded into static dump correctly'; 159} 160 161# test running against v4 schema without upgrade, twice, then upgrade 162{ 163 clean_dumpdir(); 164 write_v4_schema_pm(); 165 my $res = run_loader(static => 1); 166 my $warning = $res->{warnings}[1]; 167 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'; 174 175 is scalar @{ $res->{warnings} }, 4, 176 'correct number of warnings for static schema in backcompat mode'; 177 178 run_v4_tests($res); 179 180 add_custom_content($res->{schema}, { 181 Quuxs => 'Bazs' 182 }); 183 184 # Rerun the loader in backcompat mode to make sure it's still in backcompat 185 # mode. 186 $res = run_loader(static => 1); 187 run_v4_tests($res); 188 189 # now upgrade the schema 190 $res = run_loader( 191 static => 1, 192 naming => 'current', 193 use_namespaces => 1 194 ); 195 my $schema = $res->{schema}; 196 197 like $res->{warnings}[0], qr/Dumping manual schema/i, 198 'correct warnings on upgrading static schema (with "naming" set)'; 199 200 like $res->{warnings}[1], qr/dump completed/i, 201 'correct warnings on upgrading static schema (with "naming" set)'; 202 203 is scalar @{ $res->{warnings} }, 2, 204'correct number of warnings on upgrading static schema (with "naming" set)' 205 or diag @{ $res->{warnings} }; 206 207 run_v7_tests($res); 208 209 is result_count('Result'), $RESULT_COUNT, 210 'un-singularized results were replaced during upgrade'; 211 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'; 215 216 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 217 $res->{classes}{bazs} } 218 'unsingularized class names in custom content are translated'; 219 220 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, 221'custom content from unsingularized Result loaded into static dump correctly'; 222} 223 224# test running against v4 schema without upgrade, then upgrade with 225# use_namespaces not explicitly set 226{ 227 clean_dumpdir(); 228 write_v4_schema_pm(); 229 my $res = run_loader(static => 1); 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_custom_content($res->{schema}, { 245 Quuxs => 'Bazs' 246 }); 247 248 # now upgrade the schema 249 $res = run_loader( 250 static => 1, 251 naming => 'current' 252 ); 253 my $schema = $res->{schema}; 254 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)'; 258 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)'; 262 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)'; 266 267 is scalar @{ $res->{warnings} }, 3, 268'correct number of warnings on upgrading static schema (with "naming" set)' 269 or diag @{ $res->{warnings} }; 270 271 run_v7_tests($res); 272 273 is result_count(), $RESULT_COUNT, 274 'un-singularized results were replaced during upgrade'; 275 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'; 279 280 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 281 $res->{classes}{bazs} } 282 'unsingularized class names in custom content are translated'; 283 284 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, 285'custom content from unsingularized Result loaded into static dump correctly'; 286} 287 288# test running against v4 schema with load_namespaces, upgrade to current but 289# downgrade to load_classes, with external content 290{ 291 clean_dumpdir(); 292 293 my $temp_dir = setup_load_external({ 294 Quuxs => 'Bazs', 295 Bar => 'Foos', 296 }, { result_namespace => 'Result' }); 297 298 write_v4_schema_pm(use_namespaces => 1); 299 300 my $res = run_loader(static => 1); 301 my $warning = $res->{warnings}[0]; 302 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'; 309 310 is scalar @{ $res->{warnings} }, 3, 311 'correct number of warnings for static schema in backcompat mode'; 312 313 run_v4_tests($res); 314 315 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quuxs', 316 'use_namespaces in backcompat mode'; 317 318 add_custom_content($res->{schema}, { 319 Quuxs => 'Bazs', 320 }, { 321 result_namespace => 'Result', 322 rel_name_map => { QuuxBaz => 'bazrel2' }, 323 }); 324 325 # now upgrade the schema to current but downgrade to load_classes 326 $res = run_loader( 327 static => 1, 328 naming => 'current', 329 use_namespaces => 0, 330 ); 331 my $schema = $res->{schema}; 332 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)'; 336 337 like $res->{warnings}[1], qr/dump completed/i, 338'correct warnings on upgrading static schema (with "naming" set and ' . 339'use_namespaces => 0)'; 340 341 is scalar @{ $res->{warnings} }, 2, 342'correct number of warnings on upgrading static schema (with "naming" set)' 343 or diag @{ $res->{warnings} }; 344 345 run_v7_tests($res); 346 347 is result_count(), $RESULT_COUNT, 348'un-singularized results were replaced during upgrade and Result dir removed'; 349 350 ok ((not -d result_dir('Result')), 351 'Result dir was removed for load_classes downgrade'); 352 353 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 354 'load_classes in upgraded mode'; 355 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'; 359 360 lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' } 361 'external content was carried over from un-singularized Result'; 362 363 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2, 364 $res->{classes}{bazs} } 365 'unsingularized class names in custom content are translated'; 366 367 lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel, 368 $res->{classes}{bazs} } 369 'unsingularized class names in external content are translated'; 370 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'; 375 376 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, 377'external content from unsingularized Result loaded into static dump correctly'; 378 379 class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/, 380'custom content from unsingularized Result loaded into static dump correctly'; 381} 382 383# test a regular schema with use_namespaces => 0 upgraded to 384# use_namespaces => 1 385{ 386 my $res = run_loader( 387 clean_dumpdir => 1, 388 static => 1, 389 use_namespaces => 0, 390 naming => 'current', 391 ); 392 393 like $res->{warnings}[0], qr/Dumping manual schema/i, 394'correct warnings on dumping static schema with use_namespaces => 0'; 395 396 like $res->{warnings}[1], qr/dump completed/i, 397'correct warnings on dumping static schema with use_namespaces => 0'; 398 399 is scalar @{ $res->{warnings} }, 2, 400'correct number of warnings on dumping static schema with use_namespaces => 0' 401 or diag @{ $res->{warnings} }; 402 403 run_v7_tests($res); 404 405 my $schema = $res->{schema}; 406 add_custom_content($res->{schema}, { 407 Quux => 'Baz' 408 }); 409 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'); 413 414 like $res->{warnings}[0], qr/load_classes/i, 415'correct warnings on re-dumping static schema with load_classes'; 416 417 like $res->{warnings}[1], qr/Dumping manual schema/i, 418'correct warnings on re-dumping static schema with load_classes'; 419 420 like $res->{warnings}[2], qr/dump completed/i, 421'correct warnings on re-dumping static schema with load_classes'; 422 423 is scalar @{ $res->{warnings} }, 3, 424'correct number of warnings on re-dumping static schema with load_classes' 425 or diag @{ $res->{warnings} }; 426 427 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 428 'load_classes preserved on re-dump'; 429 430 run_v7_tests($res); 431 432 # now upgrade the schema to use_namespaces 433 $res = run_loader( 434 static => 1, 435 use_namespaces => 1, 436 naming => 'current', 437 ); 438 $schema = $res->{schema}; 439 440 like $res->{warnings}[0], qr/Dumping manual schema/i, 441'correct warnings on upgrading to use_namespaces'; 442 443 like $res->{warnings}[1], qr/dump completed/i, 444'correct warnings on upgrading to use_namespaces'; 445 446 is scalar @{ $res->{warnings} }, 2, 447'correct number of warnings on upgrading to use_namespaces' 448 or diag @{ $res->{warnings} }; 449 450 run_v7_tests($res); 451 452 my @schema_files = schema_files(); 453 454 is 1, (scalar @schema_files), 455 "schema dir contains only 1 entry"; 456 457 like $schema_files[0], qr{/Result\z}, 458 "schema dir contains only a Result/ directory"; 459 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'; 463 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'; 467 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'; 470} 471 472# test a regular schema with default use_namespaces => 1, redump, and downgrade 473# to load_classes 474{ 475 my $res = run_loader(clean_dumpdir => 1, static => 1, naming => 'current'); 476 477 like $res->{warnings}[0], qr/Dumping manual schema/i, 478'correct warnings on dumping static schema'; 479 480 like $res->{warnings}[1], qr/dump completed/i, 481'correct warnings on dumping static schema'; 482 483 is scalar @{ $res->{warnings} }, 2, 484'correct number of warnings on dumping static schema' 485 or diag @{ $res->{warnings} }; 486 487 run_v7_tests($res); 488 489 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 490 'defaults to use_namespaces on regular dump'; 491 492 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' }); 493 494 # test that with no use_namespaces option, use_namespaces is preserved 495 $res = run_loader(static => 1, naming => 'current'); 496 497 like $res->{warnings}[0], qr/Dumping manual schema/i, 498'correct warnings on re-dumping static schema'; 499 500 like $res->{warnings}[1], qr/dump completed/i, 501'correct warnings on re-dumping static schema'; 502 503 is scalar @{ $res->{warnings} }, 2, 504'correct number of warnings on re-dumping static schema' 505 or diag @{ $res->{warnings} }; 506 507 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux', 508 'use_namespaces preserved on re-dump'; 509 510 run_v7_tests($res); 511 512 # now downgrade the schema to load_classes 513 $res = run_loader( 514 static => 1, 515 use_namespaces => 0, 516 naming => 'current', 517 ); 518 my $schema = $res->{schema}; 519 520 like $res->{warnings}[0], qr/Dumping manual schema/i, 521'correct warnings on downgrading to load_classes'; 522 523 like $res->{warnings}[1], qr/dump completed/i, 524'correct warnings on downgrading to load_classes'; 525 526 is scalar @{ $res->{warnings} }, 2, 527'correct number of warnings on downgrading to load_classes' 528 or diag @{ $res->{warnings} }; 529 530 run_v7_tests($res); 531 532 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 533 'load_classes downgrade correct'; 534 535 is result_count(), $RESULT_COUNT, 536'correct number of Results after upgrade and Result dir removed'; 537 538 ok ((not -d result_dir('Result')), 539 'Result dir was removed for load_classes downgrade'); 540 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'; 544 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 '. 548'downgrade'; 549 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'; 553} 554 555# test a regular schema with use_namespaces => 1 and a custom result_namespace 556# downgraded to load_classes 557{ 558 my $res = run_loader( 559 clean_dumpdir => 1, 560 static => 1, 561 result_namespace => 'MyResult', 562 naming => 'current', 563 ); 564 565 like $res->{warnings}[0], qr/Dumping manual schema/i, 566'correct warnings on dumping static schema'; 567 568 like $res->{warnings}[1], qr/dump completed/i, 569'correct warnings on dumping static schema'; 570 571 is scalar @{ $res->{warnings} }, 2, 572'correct number of warnings on dumping static schema' 573 or diag @{ $res->{warnings} }; 574 575 run_v7_tests($res); 576 577 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 578 'defaults to use_namespaces and uses custom result_namespace'; 579 580 add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' }); 581 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'); 585 586 like $res->{warnings}[0], qr/Dumping manual schema/i, 587'correct warnings on re-dumping static schema'; 588 589 like $res->{warnings}[1], qr/dump completed/i, 590'correct warnings on re-dumping static schema'; 591 592 is scalar @{ $res->{warnings} }, 2, 593'correct number of warnings on re-dumping static schema' 594 or diag @{ $res->{warnings} }; 595 596 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 597 'use_namespaces and custom result_namespace preserved on re-dump'; 598 599 run_v7_tests($res); 600 601 # now downgrade the schema to load_classes 602 $res = run_loader( 603 static => 1, 604 use_namespaces => 0, 605 naming => 'current', 606 ); 607 my $schema = $res->{schema}; 608 609 like $res->{warnings}[0], qr/Dumping manual schema/i, 610'correct warnings on downgrading to load_classes'; 611 612 like $res->{warnings}[1], qr/dump completed/i, 613'correct warnings on downgrading to load_classes'; 614 615 is scalar @{ $res->{warnings} }, 2, 616'correct number of warnings on downgrading to load_classes' 617 or diag @{ $res->{warnings} }; 618 619 run_v7_tests($res); 620 621 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux', 622 'load_classes downgrade correct'; 623 624 is result_count(), $RESULT_COUNT, 625'correct number of Results after upgrade and Result dir removed'; 626 627 ok ((not -d result_dir('MyResult')), 628 'Result dir was removed for load_classes downgrade'); 629 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'; 633 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 '. 637'downgrade'; 638 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'; 642} 643 644# rewrite from one result_namespace to another, with external content 645{ 646 clean_dumpdir(); 647 my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' }); 648 649 my $res = run_loader(static => 1, naming => 'current'); 650 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' } }); 653 654 # Rewrite implicit 'Result' to 'MyResult' 655 $res = run_loader( 656 static => 1, 657 result_namespace => 'MyResult', 658 naming => 'current', 659 ); 660 my $schema = $res->{schema}; 661 662 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux', 663 'using new result_namespace'; 664 665 is result_count('MyResult'), $RESULT_COUNT, 666'correct number of Results after rewritten result_namespace'; 667 668 ok ((not -d schema_dir('Result')), 669 'original Result dir was removed when rewriting result_namespace'); 670 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'; 674 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'; 678 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'; 682 683 # Now rewrite 'MyResult' to 'Mtfnpy' 684 $res = run_loader( 685 static => 1, 686 result_namespace => 'Mtfnpy', 687 naming => 'current', 688 ); 689 $schema = $res->{schema}; 690 691 is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux', 692 'using new result_namespace'; 693 694 is result_count('Mtfnpy'), $RESULT_COUNT, 695'correct number of Results after rewritten result_namespace'; 696 697 ok ((not -d result_dir('MyResult')), 698 'original Result dir was removed when rewriting result_namespace'); 699 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'; 703 704 lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' } 705 'custom content was carried over when rewriting result_namespace'; 706 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'; 710 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 '. 714'result_namespace'; 715 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 '. 719'result_namespace'; 720 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'; 724 725 class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/, 726'external content from unsingularized Result loaded into static dump correctly'; 727} 728 729# test upgrading a v4 schema, then check that the version string is correct 730{ 731 clean_dumpdir(); 732 write_v4_schema_pm(); 733 run_loader(static => 1); 734 my $res = run_loader(static => 1, naming => 'current'); 735 my $schema = $res->{schema}; 736 737 my $file = $schema->loader->get_dump_filename($SCHEMA_CLASS); 738 my $code = slurp_file $file; 739 740 my ($dumped_ver) = 741 $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m; 742 743 is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION, 744 'correct version dumped after upgrade of v4 static schema'; 745} 746 747# Test upgrading an already singular result with custom content that refers to 748# old class names. 749{ 750 clean_dumpdir(); 751 write_v4_schema_pm(); 752 my $res = run_loader(static => 1); 753 my $schema = $res->{schema}; 754 run_v4_tests($res); 755 756 # add some custom content to a Result that will be replaced 757 add_custom_content($schema, { Bar => 'Foos' }); 758 759 # now upgrade the schema 760 $res = run_loader(static => 1, naming => 'current'); 761 $schema = $res->{schema}; 762 run_v7_tests($res); 763 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'; 767 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'; 772 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 ' . 775'correctly'; 776} 777 778# test creating static schema in v5 mode then upgrade to current with external 779# content loaded 780{ 781 clean_dumpdir(); 782 783 write_v5_schema_pm(); 784 785 my $res = run_loader(static => 1); 786 787 like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning'; 788 789 run_v5_tests($res); 790 791 my $temp_dir = setup_load_external({ 792 Baz => 'StationsVisited', 793 StationsVisited => 'Quux', 794 }, { result_namespace => 'Result' }); 795 796 add_custom_content($res->{schema}, { 797 Baz => 'StationsVisited', 798 }, { 799 result_namespace => 'Result', 800 rel_name_map => { BazStationsvisited => 'custom_content_rel' }, 801 }); 802 803 $res = run_loader(static => 1, naming => 'current'); 804 my $schema = $res->{schema}; 805 806 run_v7_tests($res); 807 808 lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' } 809 'external custom content loaded for v5 -> v6'; 810 811 lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel, 812 $res->{classes}{stations_visited} } 813 'external content rewritten for v5 -> v6'; 814 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'; 818 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'; 822} 823 824# test creating static schema in v6 mode then upgrade to current with external 825# content loaded 826{ 827 clean_dumpdir(); 828 829 write_v6_schema_pm(); 830 831 my $res = run_loader(static => 1); 832 833 like $res->{warnings}[0], qr/0.06001 static schema/, 'backcompat warning'; 834 835 run_v6_tests($res); 836 837 my $temp_dir = setup_load_external({ 838 Routechange => 'Quux', 839 }, { result_namespace => 'Result' }); 840 841 add_custom_content($res->{schema}, { 842 Routechange => 'Quux', 843 }, { 844 result_namespace => 'Result', 845 rel_name_map => { RoutechangeQuux => 'custom_content_rel' }, 846 }); 847 848 $res = run_loader(static => 1, naming => 'current'); 849 my $schema = $res->{schema}; 850 851 run_v7_tests($res); 852 853 lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' } 854 'external custom content loaded for v6 -> v7'; 855 856 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel, 857 $res->{classes}{quuxs} } 858 'external content rewritten for v6 -> v7'; 859 860 lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel, 861 $res->{classes}{quuxs} } 862 'custom content rewritten for v6 -> v7'; 863} 864 865done_testing; 866 867END { 868 rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; 869} 870 871sub clean_dumpdir { 872 rmtree $DUMP_DIR; 873 make_path $DUMP_DIR; 874} 875 876sub run_loader { 877 my %loader_opts = @_; 878 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'; 881 882 clean_dumpdir() if delete $loader_opts{clean_dumpdir}; 883 884 eval { 885 foreach my $source_name ($SCHEMA_CLASS->clone->sources) { 886 Class::Unload->unload("${SCHEMA_CLASS}::${source_name}"); 887 } 888 889 Class::Unload->unload($SCHEMA_CLASS); 890 }; 891 undef $@; 892 893 my @connect_info = $make_dbictest_db_with_unique::dsn; 894 my @loader_warnings; 895 local $SIG{__WARN__} = sub { push(@loader_warnings, @_); }; 896 eval qq{ 897 package $SCHEMA_CLASS; 898 use base qw/DBIx::Class::Schema::Loader/; 899 900 __PACKAGE__->loader_options(\%loader_opts); 901 __PACKAGE__->connection(\@connect_info); 902 }; 903 904 ok(!$@, "Loader initialization") or diag $@; 905 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; 912 } 913 914 return { 915 schema => $schema, 916 warnings => \@loader_warnings, 917 monikers => \%monikers, 918 classes => \%classes, 919 }; 920} 921 922sub write_v4_schema_pm { 923 my %opts = @_; 924 925 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; 926 rmtree $schema_dir; 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}) { 931 print $fh <<'EOF'; 932package DBIXCSL_Test::Schema; 933 934use strict; 935use warnings; 936 937use base 'DBIx::Class::Schema'; 938 939__PACKAGE__->load_classes; 940 941 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 944 945 946# You can replace this text with custom content, and it will be preserved on regeneration 9471; 948EOF 949 } 950 else { 951 print $fh <<'EOF'; 952package DBIXCSL_Test::Schema; 953 954use strict; 955use warnings; 956 957use base 'DBIx::Class::Schema'; 958 959__PACKAGE__->load_namespaces; 960 961 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 964 965 966# You can replace this text with custom content, and it will be preserved on 967# regeneration 9681; 969EOF 970 } 971} 972 973sub write_v5_schema_pm { 974 my %opts = @_; 975 976 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; 977 rmtree $schema_dir; 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) { 982 print $fh <<'EOF'; 983package DBIXCSL_Test::Schema; 984 985# Created by DBIx::Class::Schema::Loader 986# DO NOT MODIFY THE FIRST PART OF THIS FILE 987 988use strict; 989use warnings; 990 991use base 'DBIx::Class::Schema'; 992 993__PACKAGE__->load_classes; 994 995 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 998 999 1000# You can replace this text with custom content, and it will be preserved on regeneration 10011; 1002EOF 1003 } 1004 else { 1005 print $fh <<'EOF'; 1006package DBIXCSL_Test::Schema; 1007 1008# Created by DBIx::Class::Schema::Loader 1009# DO NOT MODIFY THE FIRST PART OF THIS FILE 1010 1011use strict; 1012use warnings; 1013 1014use base 'DBIx::Class::Schema'; 1015 1016__PACKAGE__->load_namespaces; 1017 1018 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 1021 1022 1023# You can replace this text with custom content, and it will be preserved on regeneration 10241; 1025EOF 1026 } 1027} 1028 1029sub write_v6_schema_pm { 1030 my %opts = @_; 1031 1032 (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//; 1033 rmtree $schema_dir; 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) { 1038 print $fh <<'EOF'; 1039package DBIXCSL_Test::Schema; 1040 1041# Created by DBIx::Class::Schema::Loader 1042# DO NOT MODIFY THE FIRST PART OF THIS FILE 1043 1044use strict; 1045use warnings; 1046 1047use base 'DBIx::Class::Schema'; 1048 1049__PACKAGE__->load_classes; 1050 1051 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 1054 1055 1056# You can replace this text with custom content, and it will be preserved on regeneration 10571; 1058EOF 1059 } 1060 else { 1061 print $fh <<'EOF'; 1062package DBIXCSL_Test::Schema; 1063 1064# Created by DBIx::Class::Schema::Loader 1065# DO NOT MODIFY THE FIRST PART OF THIS FILE 1066 1067use strict; 1068use warnings; 1069 1070use base 'DBIx::Class::Schema'; 1071 1072__PACKAGE__->load_namespaces; 1073 1074 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 1077 1078 1079# You can replace this text with custom content, and it will be preserved on regeneration 10801; 1081EOF 1082 } 1083} 1084 1085sub run_v4_tests { 1086 my $res = shift; 1087 my $schema = $res->{schema}; 1088 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'; 1092 1093 isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }), 1094 $res->{classes}{bar}, 1095 'found a bar'); 1096 1097 isa_ok eval { $bar->foo_id }, $res->{classes}{foos}, 1098 'correct rel name in 0.04006 mode'; 1099 1100 ok my $baz = eval { $schema->resultset('Bazs')->find(1) }; 1101 1102 isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet', 1103 'correct rel type and name for UNIQUE FK in 0.04006 mode'; 1104 1105 ok my $foo = eval { $schema->resultset('Foos')->find(1) }; 1106 1107 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', 1108 'correct rel name inflection in 0.04006 mode'; 1109 1110 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), 1111 'correct column accessor in 0.04006 mode'); 1112 1113 is $schema->resultset('Routechange')->find(1)->foo2bar, 3, 1114 'correct column accessor for column with word ending with digit in v4 mode'; 1115} 1116 1117sub run_v5_tests { 1118 my $res = shift; 1119 my $schema = $res->{schema}; 1120 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'; 1124 1125 ok my $bar = eval { $schema->resultset('Bar')->find(1) }; 1126 1127 isa_ok eval { $bar->foo }, $res->{classes}{foos}, 1128 'correct rel name in v5 mode'; 1129 1130 ok my $baz = eval { $schema->resultset('Baz')->find(1) }; 1131 1132 isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, 1133 'correct rel type and name for UNIQUE FK in v5 mode'; 1134 1135 ok my $foo = eval { $schema->resultset('Foo')->find(1) }; 1136 1137 isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet', 1138 'correct rel name inflection in v5 mode'; 1139 1140 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), 1141 'correct column accessor in v5 mode'); 1142 1143 is $schema->resultset('Routechange')->find(1)->foo2bar, 3, 1144 'correct column accessor for column with word ending with digit in v5 mode'; 1145} 1146 1147sub run_v6_tests { 1148 my $res = shift; 1149 my $schema = $res->{schema}; 1150 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'; 1154 1155 ok my $bar = eval { $schema->resultset('Bar')->find(1) }; 1156 1157 isa_ok eval { $bar->foo }, $res->{classes}{foos}, 1158 'correct rel name in v6 mode'; 1159 1160 ok my $baz = eval { $schema->resultset('Baz')->find(1) }; 1161 1162 isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, 1163 'correct rel type and name for UNIQUE FK in v6 mode'; 1164 1165 ok my $foo = eval { $schema->resultset('Foo')->find(1) }; 1166 1167 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet', 1168 'correct rel name inflection in v6 mode'; 1169 1170 ok my $route_change = eval { $schema->resultset('Routechange')->find(1) }; 1171 1172 isa_ok eval { $route_change->quuxsid }, $res->{classes}{quuxs}, 1173 'correct rel name in v6 mode'; 1174 1175 ok (($schema->resultset('Routechange')->find(1)->can('quuxsid')), 1176 'correct column accessor in v6 mode'); 1177 1178 is $schema->resultset('Routechange')->find(1)->foo2bar, 3, 1179 'correct column accessor for column with word ending with digit in v6 mode'; 1180} 1181 1182sub run_v7_tests { 1183 my $res = shift; 1184 my $schema = $res->{schema}; 1185 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'; 1189 1190 ok my $bar = eval { $schema->resultset('Bar')->find(1) }; 1191 1192 isa_ok eval { $bar->foo }, $res->{classes}{foos}, 1193 'correct rel name in current mode'; 1194 1195 ok my $baz = eval { $schema->resultset('Baz')->find(1) }; 1196 1197 isa_ok eval { $baz->quux }, $res->{classes}{quuxs}, 1198 'correct rel type and name for UNIQUE FK in current mode'; 1199 1200 ok my $foo = eval { $schema->resultset('Foo')->find(1) }; 1201 1202 isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet', 1203 'correct rel name inflection in current mode'; 1204 1205 ok my $route_change = eval { $schema->resultset('RouteChange')->find(1) }; 1206 1207 isa_ok eval { $route_change->quux }, $res->{classes}{quuxs}, 1208 'correct rel name based on mixed-case column name in current mode'; 1209 1210 ok (($schema->resultset('RouteChange')->find(1)->can('quuxs_id')), 1211 'correct column accessor in current mode'); 1212 1213 is $schema->resultset('RouteChange')->find(1)->foo2_bar, 3, 1214 'correct column accessor for column with word ending with digit in current mode'; 1215} 1216 1217{ 1218 package DBICSL::Test::TempExtDir; 1219 1220 use overload '""' => sub { ${$_[0]} }; 1221 1222 sub DESTROY { 1223 pop @INC; 1224 File::Path::rmtree ${$_[0]}; 1225 } 1226} 1227 1228sub setup_load_external { 1229 my ($rels, $opts) = @_; 1230 1231 my $temp_dir = tempdir(CLEANUP => 1); 1232 push @INC, $temp_dir; 1233 1234 my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS), 1235 ($opts->{result_namespace} || ()); 1236 1237 make_path $external_result_dir; 1238 1239 while (my ($from, $to) = each %$rels) { 1240 write_ext_result($external_result_dir, $from, $to, $opts); 1241 } 1242 1243 my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir'; 1244 1245 return $guard; 1246} 1247 1248sub write_ext_result { 1249 my ($result_dir, $from, $to, $opts) = @_; 1250 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); 1255 1256 IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF"); 1257package ${from_class}; 1258sub a_method { 'hlagh' } 1259 1260__PACKAGE__->has_one('$relname', '$to_class', 1261{ $condition }); 1262 12631; 1264EOF 1265 1266 return $relname; 1267} 1268 1269sub _relname { 1270 my $to = shift; 1271 1272 return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel'; 1273} 1274 1275sub _qualify_class { 1276 my ($class, $result_namespace) = @_; 1277 1278 return $SCHEMA_CLASS . '::' 1279 . ($result_namespace ? $result_namespace . '::' : '') 1280 . $class; 1281} 1282 1283sub _rel_key { 1284 my ($from, $to) = @_; 1285 1286 return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to; 1287} 1288 1289sub _rel_condition { 1290 my ($from, $to) = @_; 1291 1292 return +{ 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)}; 1299} 1300 1301sub class_content_like { 1302 my ($schema, $class, $re, $test_name) = @_; 1303 1304 my $file = $schema->loader->get_dump_filename($class); 1305 my $code = slurp_file $file; 1306 1307 like $code, $re, $test_name; 1308} 1309 1310sub add_custom_content { 1311 my ($schema, $rels, $opts) = @_; 1312 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); 1318 1319 my $content = <<"EOF"; 1320package ${from_class}; 1321sub b_method { 'dongs' } 1322 1323__PACKAGE__->has_one('$relname', '$to_class', 1324{ $condition }); 1325 13261; 1327EOF 1328 1329 _write_custom_content($schema, $from_class, $content); 1330 } 1331} 1332 1333sub _write_custom_content { 1334 my ($schema, $class, $content) = @_; 1335 1336 my $pm = $schema->loader->get_dump_filename($class); 1337 { 1338 local ($^I, @ARGV) = ('.bak', $pm); 1339 while (<>) { 1340 if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) { 1341 print; 1342 print $content; 1343 } 1344 else { 1345 print; 1346 } 1347 } 1348 close ARGV; 1349 unlink "${pm}.bak" or die $^E; 1350 } 1351} 1352 1353sub result_count { 1354 my $path = shift || ''; 1355 1356 my $dir = result_dir($path); 1357 1358 my $file_count =()= glob "$dir/*"; 1359 1360 return $file_count; 1361} 1362 1363sub result_files { 1364 my $path = shift || ''; 1365 1366 my $dir = result_dir($path); 1367 1368 return glob "$dir/*"; 1369} 1370 1371sub schema_files { result_files(@_) } 1372 1373sub result_dir { 1374 my $path = shift || ''; 1375 1376 (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g; 1377 $dir =~ s{/+\z}{}; 1378 1379 return $dir; 1380} 1381 1382sub schema_dir { result_dir(@_) } 1383 1384# vim:et sts=4 sw=4 tw=0: 1385