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