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