t/25backcompat.t

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