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     );
 390
 391     like $res->{warnings}[0], qr/Dumping manual schema/i,
 392 'correct warnings on dumping static schema with use_namespaces => 0';
 393
 394     like $res->{warnings}[1], qr/dump completed/i,
 395 'correct warnings on dumping static schema with use_namespaces => 0';
 396
 397     is scalar @{ $res->{warnings} }, 2,
 398 'correct number of warnings on dumping static schema with use_namespaces => 0'
 399         or diag @{ $res->{warnings} };
 400
 401     run_v7_tests($res);
 402
 403     my $schema   = $res->{schema};
 404     add_custom_content($res->{schema}, {
 405         Quux => 'Baz'
 406     });
 407
 408     # test that with no use_namespaces option, there is a warning and
 409     # load_classes is preserved
 410     $res = run_loader(static => 1);
 411
 412     like $res->{warnings}[0], qr/load_classes/i,
 413 'correct warnings on re-dumping static schema with load_classes';
 414
 415     like $res->{warnings}[1], qr/Dumping manual schema/i,
 416 'correct warnings on re-dumping static schema with load_classes';
 417
 418     like $res->{warnings}[2], qr/dump completed/i,
 419 'correct warnings on re-dumping static schema with load_classes';
 420
 421     is scalar @{ $res->{warnings} }, 3,
 422 'correct number of warnings on re-dumping static schema with load_classes'
 423         or diag @{ $res->{warnings} };
 424
 425     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
 426         'load_classes preserved on re-dump';
 427
 428     run_v7_tests($res);
 429
 430     # now upgrade the schema to use_namespaces
 431     $res = run_loader(
 432         static => 1,
 433         use_namespaces => 1,
 434     );
 435     $schema = $res->{schema};
 436
 437     like $res->{warnings}[0], qr/Dumping manual schema/i,
 438 'correct warnings on upgrading to use_namespaces';
 439
 440     like $res->{warnings}[1], qr/dump completed/i,
 441 'correct warnings on upgrading to use_namespaces';
 442
 443     is scalar @{ $res->{warnings} }, 2,
 444 'correct number of warnings on upgrading to use_namespaces'
 445         or diag @{ $res->{warnings} };
 446
 447     run_v7_tests($res);
 448
 449     my @schema_files = schema_files();
 450
 451     is 1, (scalar @schema_files),
 452         "schema dir contains only 1 entry";
 453
 454     like $schema_files[0], qr{/Result\z},
 455         "schema dir contains only a Result/ directory";
 456
 457     # check that custom content was preserved
 458     lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
 459         'custom content was carried over during use_namespaces upgrade';
 460
 461     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
 462         $res->{classes}{bazs} }
 463         'un-namespaced class names in custom content are translated';
 464
 465     class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
 466 'custom content from un-namespaced Result loaded into static dump correctly';
 467 }
 468
 469 # test a regular schema with default use_namespaces => 1, redump, and downgrade
 470 # to load_classes
 471 {
 472     my $res = run_loader(clean_dumpdir => 1, static => 1);
 473
 474     like $res->{warnings}[0], qr/Dumping manual schema/i,
 475 'correct warnings on dumping static schema';
 476
 477     like $res->{warnings}[1], qr/dump completed/i,
 478 'correct warnings on dumping static schema';
 479
 480     is scalar @{ $res->{warnings} }, 2,
 481 'correct number of warnings on dumping static schema'
 482         or diag @{ $res->{warnings} };
 483
 484     run_v7_tests($res);
 485
 486     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
 487         'defaults to use_namespaces on regular dump';
 488
 489     add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result' });
 490
 491     # test that with no use_namespaces option, use_namespaces is preserved
 492     $res = run_loader(static => 1);
 493
 494     like $res->{warnings}[0], qr/Dumping manual schema/i,
 495 'correct warnings on re-dumping static schema';
 496
 497     like $res->{warnings}[1], qr/dump completed/i,
 498 'correct warnings on re-dumping static schema';
 499
 500     is scalar @{ $res->{warnings} }, 2,
 501 'correct number of warnings on re-dumping static schema'
 502         or diag @{ $res->{warnings} };
 503
 504     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Result::Quux',
 505         'use_namespaces preserved on re-dump';
 506
 507     run_v7_tests($res);
 508
 509     # now downgrade the schema to load_classes
 510     $res = run_loader(
 511         static => 1,
 512         use_namespaces => 0,
 513     );
 514     my $schema = $res->{schema};
 515
 516     like $res->{warnings}[0], qr/Dumping manual schema/i,
 517 'correct warnings on downgrading to load_classes';
 518
 519     like $res->{warnings}[1], qr/dump completed/i,
 520 'correct warnings on downgrading to load_classes';
 521
 522     is scalar @{ $res->{warnings} }, 2,
 523 'correct number of warnings on downgrading to load_classes'
 524         or diag @{ $res->{warnings} };
 525
 526     run_v7_tests($res);
 527
 528     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
 529         'load_classes downgrade correct';
 530
 531     is result_count(), $RESULT_COUNT,
 532 'correct number of Results after upgrade and Result dir removed';
 533
 534     ok ((not -d result_dir('Result')),
 535         'Result dir was removed for load_classes downgrade');
 536
 537     # check that custom content was preserved
 538     lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
 539         'custom content was carried over during load_classes downgrade';
 540
 541     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
 542         $res->{classes}{bazs} }
 543 'namespaced class names in custom content are translated during load_classes '.
 544 'downgrade';
 545
 546     class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
 547 'custom content from namespaced Result loaded into static dump correctly '.
 548 'during load_classes downgrade';
 549 }
 550
 551 # test a regular schema with use_namespaces => 1 and a custom result_namespace
 552 # downgraded to load_classes
 553 {
 554     my $res = run_loader(
 555         clean_dumpdir => 1,
 556         static => 1,
 557         result_namespace => 'MyResult',
 558     );
 559
 560     like $res->{warnings}[0], qr/Dumping manual schema/i,
 561 'correct warnings on dumping static schema';
 562
 563     like $res->{warnings}[1], qr/dump completed/i,
 564 'correct warnings on dumping static schema';
 565
 566     is scalar @{ $res->{warnings} }, 2,
 567 'correct number of warnings on dumping static schema'
 568         or diag @{ $res->{warnings} };
 569
 570     run_v7_tests($res);
 571
 572     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
 573         'defaults to use_namespaces and uses custom result_namespace';
 574
 575     add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'MyResult' });
 576
 577     # test that with no use_namespaces option, use_namespaces is preserved, and
 578     # the custom result_namespace is preserved
 579     $res = run_loader(static => 1);
 580
 581     like $res->{warnings}[0], qr/Dumping manual schema/i,
 582 'correct warnings on re-dumping static schema';
 583
 584     like $res->{warnings}[1], qr/dump completed/i,
 585 'correct warnings on re-dumping static schema';
 586
 587     is scalar @{ $res->{warnings} }, 2,
 588 'correct number of warnings on re-dumping static schema'
 589         or diag @{ $res->{warnings} };
 590
 591     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
 592         'use_namespaces and custom result_namespace preserved on re-dump';
 593
 594     run_v7_tests($res);
 595
 596     # now downgrade the schema to load_classes
 597     $res = run_loader(
 598         static => 1,
 599         use_namespaces => 0,
 600     );
 601     my $schema = $res->{schema};
 602
 603     like $res->{warnings}[0], qr/Dumping manual schema/i,
 604 'correct warnings on downgrading to load_classes';
 605
 606     like $res->{warnings}[1], qr/dump completed/i,
 607 'correct warnings on downgrading to load_classes';
 608
 609     is scalar @{ $res->{warnings} }, 2,
 610 'correct number of warnings on downgrading to load_classes'
 611         or diag @{ $res->{warnings} };
 612
 613     run_v7_tests($res);
 614
 615     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Quux',
 616         'load_classes downgrade correct';
 617
 618     is result_count(), $RESULT_COUNT,
 619 'correct number of Results after upgrade and Result dir removed';
 620
 621     ok ((not -d result_dir('MyResult')),
 622         'Result dir was removed for load_classes downgrade');
 623
 624     # check that custom content was preserved
 625     lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
 626         'custom content was carried over during load_classes downgrade';
 627
 628     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
 629         $res->{classes}{bazs} }
 630 'namespaced class names in custom content are translated during load_classes '.
 631 'downgrade';
 632
 633     class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
 634 'custom content from namespaced Result loaded into static dump correctly '.
 635 'during load_classes downgrade';
 636 }
 637
 638 # rewrite from one result_namespace to another, with external content
 639 {
 640     clean_dumpdir();
 641     my $temp_dir = setup_load_external({ Quux => 'Baz', Bar => 'Foo' }, { result_namespace => 'Result' });
 642
 643     my $res = run_loader(static => 1);
 644
 645     # add some custom content to a Result that will be replaced
 646     add_custom_content($res->{schema}, { Quux => 'Baz' }, { result_namespace => 'Result', rel_name_map => { QuuxBaz => 'bazrel2' } });
 647
 648     # Rewrite implicit 'Result' to 'MyResult'
 649     $res = run_loader(
 650         static => 1,
 651         result_namespace => 'MyResult',
 652     );
 653     my $schema = $res->{schema};
 654
 655     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::MyResult::Quux',
 656         'using new result_namespace';
 657
 658     is result_count('MyResult'), $RESULT_COUNT,
 659 'correct number of Results after rewritten result_namespace';
 660
 661     ok ((not -d schema_dir('Result')),
 662         'original Result dir was removed when rewriting result_namespace');
 663
 664     # check that custom content was preserved
 665     lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
 666         'custom content was carried over when rewriting result_namespace';
 667
 668     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
 669         $res->{classes}{bazs} }
 670 'class names in custom content are translated when rewriting result_namespace';
 671
 672     class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
 673 'custom content from namespaced Result loaded into static dump correctly '.
 674 'when rewriting result_namespace';
 675
 676     # Now rewrite 'MyResult' to 'Mtfnpy'
 677     $res = run_loader(
 678         static => 1,
 679         result_namespace => 'Mtfnpy',
 680     );
 681     $schema = $res->{schema};
 682
 683     is $res->{classes}{quuxs}, 'DBIXCSL_Test::Schema::Mtfnpy::Quux',
 684         'using new result_namespace';
 685
 686     is result_count('Mtfnpy'), $RESULT_COUNT,
 687 'correct number of Results after rewritten result_namespace';
 688
 689     ok ((not -d result_dir('MyResult')),
 690         'original Result dir was removed when rewriting result_namespace');
 691
 692     # check that custom and external content was preserved
 693     lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
 694         'external content was carried over when rewriting result_namespace';
 695
 696     lives_and { is $schema->resultset('Quux')->find(1)->b_method, 'dongs' }
 697         'custom content was carried over when rewriting result_namespace';
 698
 699     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
 700         $res->{classes}{bazs} }
 701 'class names in custom content are translated when rewriting result_namespace';
 702
 703     lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
 704         $res->{classes}{bazs} }
 705 'class names in external content are translated when rewriting '.
 706 'result_namespace';
 707
 708     lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
 709         $res->{classes}{foos} }
 710 'class names in external content are translated when rewriting '.
 711 'result_namespace';
 712
 713     class_content_like $schema, $res->{classes}{quuxs}, qr/sub b_method { 'dongs' }/,
 714 'custom content from namespaced Result loaded into static dump correctly '.
 715 'when rewriting result_namespace';
 716
 717     class_content_like $schema, $res->{classes}{quuxs}, qr/sub a_method { 'hlagh' }/,
 718 'external content from unsingularized Result loaded into static dump correctly';
 719 }
 720
 721 # test upgrading a v4 schema, then check that the version string is correct
 722 {
 723     clean_dumpdir();
 724     write_v4_schema_pm();
 725     run_loader(static => 1);
 726     my $res = run_loader(static => 1, naming => 'current');
 727     my $schema = $res->{schema};
 728
 729     my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
 730     my $code = slurp $file;
 731
 732     my ($dumped_ver) =
 733         $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
 734
 735     is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
 736         'correct version dumped after upgrade of v4 static schema';
 737 }
 738
 739 # Test upgrading an already singular result with custom content that refers to
 740 # old class names.
 741 {
 742     clean_dumpdir();
 743     write_v4_schema_pm();
 744     my $res = run_loader(static => 1);
 745     my $schema = $res->{schema};
 746     run_v4_tests($res);
 747
 748     # add some custom content to a Result that will be replaced
 749     add_custom_content($schema, { Bar => 'Foos' });
 750
 751     # now upgrade the schema
 752     $res = run_loader(static => 1, naming => 'current');
 753     $schema = $res->{schema};
 754     run_v7_tests($res);
 755
 756     # check that custom content was preserved
 757     lives_and { is $schema->resultset('Bar')->find(1)->b_method, 'dongs' }
 758         'custom content was preserved from Result pre-upgrade';
 759
 760     lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
 761         $res->{classes}{foos} }
 762 'unsingularized class names in custom content from Result with unchanged ' .
 763 'name are translated';
 764
 765     class_content_like $schema, $res->{classes}{bar}, qr/sub b_method { 'dongs' }/,
 766 'custom content from Result with unchanged name loaded into static dump ' .
 767 'correctly';
 768 }
 769
 770 # test creating static schema in v5 mode then upgrade to current with external
 771 # content loaded
 772 {
 773     clean_dumpdir();
 774
 775     write_v5_schema_pm();
 776
 777     my $res = run_loader(static => 1);
 778
 779     like $res->{warnings}[0], qr/0.05003 static schema/, 'backcompat warning';
 780
 781     run_v5_tests($res);
 782
 783     my $temp_dir = setup_load_external({
 784         Baz => 'StationsVisited',
 785         StationsVisited => 'Quux',
 786     }, { result_namespace => 'Result' });
 787
 788     add_custom_content($res->{schema}, {
 789         Baz => 'StationsVisited',
 790     }, {
 791         result_namespace => 'Result',
 792         rel_name_map => { BazStationsvisited => 'custom_content_rel' },
 793     });
 794
 795     $res = run_loader(static => 1, naming => 'current');
 796     my $schema = $res->{schema};
 797
 798     run_v7_tests($res);
 799
 800     lives_and { is $schema->resultset('Baz')->find(1)->a_method, 'hlagh' }
 801         'external custom content loaded for v5 -> v6';
 802
 803     lives_and { isa_ok $schema->resultset('Baz')->find(1)->stationsvisitedrel,
 804         $res->{classes}{stations_visited} }
 805         'external content rewritten for v5 -> v6';
 806
 807     lives_and { isa_ok $schema->resultset('Baz')->find(1)->custom_content_rel,
 808         $res->{classes}{stations_visited} }
 809         'custom content rewritten for v5 -> v6';
 810
 811     lives_and { isa_ok $schema->resultset('StationVisited')->find(1)->quuxrel,
 812         $res->{classes}{quuxs} }
 813         'external content rewritten for v5 -> v6 for upgraded Result class names';
 814 }
 815
 816 # test creating static schema in v6 mode then upgrade to current with external
 817 # content loaded
 818 {
 819     clean_dumpdir();
 820
 821     write_v6_schema_pm();
 822
 823     my $res = run_loader(static => 1);
 824
 825     like $res->{warnings}[0], qr/0.06001 static schema/, 'backcompat warning';
 826
 827     run_v6_tests($res);
 828
 829     my $temp_dir = setup_load_external({
 830         Routechange => 'Quux',
 831     }, { result_namespace => 'Result' });
 832
 833     add_custom_content($res->{schema}, {
 834         Routechange => 'Quux',
 835     }, {
 836         result_namespace => 'Result',
 837         rel_name_map => { RoutechangeQuux => 'custom_content_rel' },
 838     });
 839
 840     $res = run_loader(static => 1, naming => 'current');
 841     my $schema = $res->{schema};
 842
 843     run_v7_tests($res);
 844
 845     lives_and { is $schema->resultset('RouteChange')->find(1)->a_method, 'hlagh' }
 846         'external custom content loaded for v6 -> v7';
 847
 848     lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->quuxrel,
 849         $res->{classes}{quuxs} }
 850         'external content rewritten for v6 -> v7';
 851
 852     lives_and { isa_ok $schema->resultset('RouteChange')->find(1)->custom_content_rel,
 853         $res->{classes}{quuxs} }
 854         'custom content rewritten for v6 -> v7';
 855 }
 856
 857 done_testing;
 858
 859 END {
 860     rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
 861 }
 862
 863 sub clean_dumpdir {
 864     rmtree $DUMP_DIR;
 865     make_path $DUMP_DIR;
 866 }
 867
 868 sub run_loader {
 869     my %loader_opts = @_;
 870
 871     $loader_opts{dump_directory} = $DUMP_DIR if delete $loader_opts{static};
 872
 873     clean_dumpdir() if delete $loader_opts{clean_dumpdir};
 874
 875     eval {
 876         foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
 877             Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
 878         }
 879
 880         Class::Unload->unload($SCHEMA_CLASS);
 881     };
 882     undef $@;
 883
 884     my @connect_info = $make_dbictest_db_with_unique::dsn;
 885     my @loader_warnings;
 886     local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
 887     eval qq{
 888         package $SCHEMA_CLASS;
 889         use base qw/DBIx::Class::Schema::Loader/;
 890
 891         __PACKAGE__->loader_options(\%loader_opts);
 892         __PACKAGE__->connection(\@connect_info);
 893     };
 894
 895     ok(!$@, "Loader initialization") or diag $@;
 896
 897     my $schema = $SCHEMA_CLASS->clone;
 898     my (%monikers, %classes);
 899     foreach my $source_name ($schema->sources) {
 900         my $table_name = $schema->source($source_name)->from;
 901         $monikers{$table_name} = $source_name;
 902         $classes{$table_name}  = $schema->source($source_name)->result_class;
 903     }
 904
 905     return {
 906         schema => $schema,
 907         warnings => \@loader_warnings,
 908         monikers => \%monikers,
 909         classes => \%classes,
 910     };
 911 }
 912
 913 sub write_v4_schema_pm {
 914     my %opts = @_;
 915
 916     (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
 917     rmtree $schema_dir;
 918     make_path $schema_dir;
 919     my $schema_pm = "$schema_dir/Schema.pm";
 920     open my $fh, '>', $schema_pm or die $!;
 921     if (not $opts{use_namespaces}) {
 922         print $fh <<'EOF';
 923 package DBIXCSL_Test::Schema;
 924
 925 use strict;
 926 use warnings;
 927
 928 use base 'DBIx::Class::Schema';
 929
 930 __PACKAGE__->load_classes;
 931
 932
 933 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
 934 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
 935
 936
 937 # You can replace this text with custom content, and it will be preserved on regeneration
 938 1;
 939 EOF
 940     }
 941     else {
 942         print $fh <<'EOF';
 943 package DBIXCSL_Test::Schema;
 944
 945 use strict;
 946 use warnings;
 947
 948 use base 'DBIx::Class::Schema';
 949
 950 __PACKAGE__->load_namespaces;
 951
 952
 953 # Created by DBIx::Class::Schema::Loader v0.04006 @ 2010-01-12 16:04:12
 954 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:d3wRVsHBNisyhxeaWJZcZQ
 955
 956
 957 # You can replace this text with custom content, and it will be preserved on
 958 # regeneration
 959 1;
 960 EOF
 961     }
 962 }
 963
 964 sub write_v5_schema_pm {
 965     my %opts = @_;
 966
 967     (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
 968     rmtree $schema_dir;
 969     make_path $schema_dir;
 970     my $schema_pm = "$schema_dir/Schema.pm";
 971     open my $fh, '>', $schema_pm or die $!;
 972     if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
 973         print $fh <<'EOF';
 974 package DBIXCSL_Test::Schema;
 975
 976 # Created by DBIx::Class::Schema::Loader
 977 # DO NOT MODIFY THE FIRST PART OF THIS FILE
 978
 979 use strict;
 980 use warnings;
 981
 982 use base 'DBIx::Class::Schema';
 983
 984 __PACKAGE__->load_classes;
 985
 986
 987 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-27 17:07:37
 988 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:LIzC/LT5IYvWpgusfbqMrg
 989
 990
 991 # You can replace this text with custom content, and it will be preserved on regeneration
 992 1;
 993 EOF
 994     }
 995     else {
 996         print $fh <<'EOF';
 997 package DBIXCSL_Test::Schema;
 998
 999 # Created by DBIx::Class::Schema::Loader
1000 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1001
1002 use strict;
1003 use warnings;
1004
1005 use base 'DBIx::Class::Schema';
1006
1007 __PACKAGE__->load_namespaces;
1008
1009
1010 # Created by DBIx::Class::Schema::Loader v0.05003 @ 2010-03-29 19:44:52
1011 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:D+MYxtGxz97Ghvido5DTEg
1012
1013
1014 # You can replace this text with custom content, and it will be preserved on regeneration
1015 1;
1016 EOF
1017     }
1018 }
1019
1020 sub write_v6_schema_pm {
1021     my %opts = @_;
1022
1023     (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
1024     rmtree $schema_dir;
1025     make_path $schema_dir;
1026     my $schema_pm = "$schema_dir/Schema.pm";
1027     open my $fh, '>', $schema_pm or die $!;
1028     if (exists $opts{use_namespaces} && $opts{use_namespaces} == 0) {
1029         print $fh <<'EOF';
1030 package DBIXCSL_Test::Schema;
1031
1032 # Created by DBIx::Class::Schema::Loader
1033 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1034
1035 use strict;
1036 use warnings;
1037
1038 use base 'DBIx::Class::Schema';
1039
1040 __PACKAGE__->load_classes;
1041
1042
1043 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:56:03
1044 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:/fqZCb95hsGIe1g5qyQQZg
1045
1046
1047 # You can replace this text with custom content, and it will be preserved on regeneration
1048 1;
1049 EOF
1050     }
1051     else {
1052         print $fh <<'EOF';
1053 package DBIXCSL_Test::Schema;
1054
1055 # Created by DBIx::Class::Schema::Loader
1056 # DO NOT MODIFY THE FIRST PART OF THIS FILE
1057
1058 use strict;
1059 use warnings;
1060
1061 use base 'DBIx::Class::Schema';
1062
1063 __PACKAGE__->load_namespaces;
1064
1065
1066 # Created by DBIx::Class::Schema::Loader v0.06001 @ 2010-04-21 19:54:31
1067 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nwO5Vi47kl0X9SpEoiVO5w
1068
1069
1070 # You can replace this text with custom content, and it will be preserved on regeneration
1071 1;
1072 EOF
1073     }
1074 }
1075
1076 sub run_v4_tests {
1077     my $res = shift;
1078     my $schema = $res->{schema};
1079
1080     is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1081         [qw/Foos Bar Bazs Quuxs StationsVisited Routechange Email/],
1082         'correct monikers in 0.04006 mode';
1083
1084     isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
1085         $res->{classes}{bar},
1086         'found a bar');
1087
1088     isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
1089         'correct rel name in 0.04006 mode';
1090
1091     ok my $baz  = eval { $schema->resultset('Bazs')->find(1) };
1092
1093     isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
1094         'correct rel type and name for UNIQUE FK in 0.04006 mode';
1095
1096     ok my $foo = eval { $schema->resultset('Foos')->find(1) };
1097
1098     isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1099         'correct rel name inflection in 0.04006 mode';
1100 }
1101
1102 sub run_v5_tests {
1103     my $res = shift;
1104     my $schema = $res->{schema};
1105
1106     is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1107         [qw/Foo Bar Baz Quux StationsVisited Routechange Email/],
1108         'correct monikers in v5 mode';
1109
1110     ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1111
1112     isa_ok eval { $bar->foo }, $res->{classes}{foos},
1113         'correct rel name in v5 mode';
1114
1115     ok my $baz  = eval { $schema->resultset('Baz')->find(1) };
1116
1117     isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1118         'correct rel type and name for UNIQUE FK in v5 mode';
1119
1120     ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1121
1122     isa_ok eval { $foo->email_to_ids }, 'DBIx::Class::ResultSet',
1123         'correct rel name inflection in v5 mode';
1124 }
1125
1126 sub run_v6_tests {
1127     my $res = shift;
1128     my $schema = $res->{schema};
1129
1130     is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1131         [qw/Foo Bar Baz Quux StationVisited Routechange Email/],
1132         'correct monikers in v6 mode';
1133
1134     ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1135
1136     isa_ok eval { $bar->foo }, $res->{classes}{foos},
1137         'correct rel name in v6 mode';
1138
1139     ok my $baz  = eval { $schema->resultset('Baz')->find(1) };
1140
1141     isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1142         'correct rel type and name for UNIQUE FK in v6 mode';
1143
1144     ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1145
1146     isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1147         'correct rel name inflection in v6 mode';
1148 }
1149
1150 sub run_v7_tests {
1151     my $res = shift;
1152     my $schema = $res->{schema};
1153
1154     is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs stations_visited RouteChange email/} ],
1155         [qw/Foo Bar Baz Quux StationVisited RouteChange Email/],
1156         'correct monikers in current mode';
1157
1158     ok my $bar = eval { $schema->resultset('Bar')->find(1) };
1159
1160     isa_ok eval { $bar->foo }, $res->{classes}{foos},
1161         'correct rel name in current mode';
1162
1163     ok my $baz  = eval { $schema->resultset('Baz')->find(1) };
1164
1165     isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
1166         'correct rel type and name for UNIQUE FK in current mode';
1167
1168     ok my $foo = eval { $schema->resultset('Foo')->find(1) };
1169
1170     isa_ok eval { $foo->emails_to }, 'DBIx::Class::ResultSet',
1171         'correct rel name inflection in current mode';
1172 }
1173
1174 {
1175     package DBICSL::Test::TempExtDir;
1176
1177     use overload '""' => sub { ${$_[0]} };
1178
1179     sub DESTROY {
1180         pop @INC;
1181         File::Path::rmtree ${$_[0]};
1182     }
1183 }
1184
1185 sub setup_load_external {
1186     my ($rels, $opts) = @_;
1187
1188     my $temp_dir = tempdir(CLEANUP => 1);
1189     push @INC, $temp_dir;
1190
1191     my $external_result_dir = join '/', $temp_dir, (split /::/, $SCHEMA_CLASS),
1192         ($opts->{result_namespace} || ());
1193
1194     make_path $external_result_dir;
1195
1196     while (my ($from, $to) = each %$rels) {
1197         write_ext_result($external_result_dir, $from, $to, $opts);
1198     }
1199
1200     my $guard = bless \$temp_dir, 'DBICSL::Test::TempExtDir';
1201
1202     return $guard;
1203 }
1204
1205 sub write_ext_result {
1206     my ($result_dir, $from, $to, $opts) = @_;
1207
1208     my $relname    = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1209     my $from_class = _qualify_class($from, $opts->{result_namespace});
1210     my $to_class   = _qualify_class($to,   $opts->{result_namespace});
1211     my $condition  = _rel_condition($from, $to);
1212
1213     IO::File->new(">$result_dir/${from}.pm")->print(<<"EOF");
1214 package ${from_class};
1215 sub a_method { 'hlagh' }
1216
1217 __PACKAGE__->has_one('$relname', '$to_class',
1218 { $condition });
1219
1220 1;
1221 EOF
1222
1223     return $relname;
1224 }
1225
1226 sub _relname {
1227     my $to = shift;
1228
1229     return Lingua::EN::Inflect::Number::to_S(lc $to) . 'rel';
1230 }
1231
1232 sub _qualify_class {
1233     my ($class, $result_namespace) = @_;
1234
1235     return $SCHEMA_CLASS . '::'
1236         . ($result_namespace ? $result_namespace . '::' : '')
1237         . $class;
1238 }
1239
1240 sub _rel_key {
1241     my ($from, $to) = @_;
1242
1243     return join '', map ucfirst(Lingua::EN::Inflect::Number::to_S(lc($_))), $from, $to;
1244 }
1245
1246 sub _rel_condition {
1247     my ($from, $to) = @_;
1248
1249     return +{
1250         QuuxBaz => q{'foreign.baz_num' => 'self.baz_id'},
1251         BarFoo  => q{'foreign.fooid'   => 'self.foo_id'},
1252         BazStationsvisited => q{'foreign.id' => 'self.stations_visited_id'},
1253         StationsvisitedQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1254         RoutechangeQuux => q{'foreign.quuxid' => 'self.quuxs_id'},
1255     }->{_rel_key($from, $to)};
1256 }
1257
1258 sub class_content_like {
1259     my ($schema, $class, $re, $test_name) = @_;
1260
1261     my $file = $schema->_loader->_get_dump_filename($class);
1262     my $code = slurp $file;
1263
1264     like $code, $re, $test_name;
1265 }
1266
1267 sub add_custom_content {
1268     my ($schema, $rels, $opts) = @_;
1269
1270     while (my ($from, $to) = each %$rels) {
1271         my $relname    = $opts->{rel_name_map}{_rel_key($from, $to)} || _relname($to);
1272         my $from_class = _qualify_class($from, $opts->{result_namespace});
1273         my $to_class   = _qualify_class($to,   $opts->{result_namespace});
1274         my $condition  = _rel_condition($from, $to);
1275
1276         my $content = <<"EOF";
1277 package ${from_class};
1278 sub b_method { 'dongs' }
1279
1280 __PACKAGE__->has_one('$relname', '$to_class',
1281 { $condition });
1282
1283 1;
1284 EOF
1285
1286         _write_custom_content($schema, $from_class, $content);
1287     }
1288 }
1289
1290 sub _write_custom_content {
1291     my ($schema, $class, $content) = @_;
1292
1293     my $pm = $schema->_loader->_get_dump_filename($class);
1294     {
1295         local ($^I, @ARGV) = ('.bak', $pm);
1296         while (<>) {
1297             if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
1298                 print;
1299                 print $content;
1300             }
1301             else {
1302                 print;
1303             }
1304         }
1305         close ARGV;
1306         unlink "${pm}.bak" or die $^E;
1307     }
1308 }
1309
1310 sub result_count {
1311     my $path = shift || '';
1312
1313     my $dir = result_dir($path);
1314
1315     my $file_count =()= glob "$dir/*";
1316
1317     return $file_count;
1318 }
1319
1320 sub result_files {
1321     my $path = shift || '';
1322
1323     my $dir = result_dir($path);
1324
1325     return glob "$dir/*";
1326 }
1327
1328 sub schema_files { result_files(@_) }
1329
1330 sub result_dir {
1331     my $path = shift || '';
1332
1333     (my $dir = "$DUMP_DIR/$SCHEMA_CLASS/$path") =~ s{::}{/}g;
1334     $dir =~ s{/+\z}{};
1335
1336     return $dir;
1337 }
1338
1339 sub schema_dir { result_dir(@_) }
1340
1341 # vim:et sts=4 sw=4 tw=0: