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