t/25backcompat.t

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