[dbsrgits/DBIx-Class-Schema-Loader.git] / t / 25backcompat_v4.t

use strict;
use warnings;
use Test::More;
use Test::Exception;
use File::Path qw/rmtree make_path/;
use Class::Unload;
use File::Temp qw/tempfile tempdir/;
use IO::File;
use DBIx::Class::Schema::Loader ();
use lib qw(t/lib);
use make_dbictest_db2;

my $DUMP_DIR = './t/_common_dump';
rmtree $DUMP_DIR;
my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';

# test dynamic schema in 0.04006 mode
{
    my $res = run_loader();
    my $warning = $res->{warnings}[0];

    like $warning, qr/dynamic schema/i,
        'dynamic schema in backcompat mode detected';
    like $warning, qr/run in 0\.04006 mode/i,
        'dynamic schema in 0.04006 mode warning';
    like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
        'warning refers to upgrading doc';
    
    run_v4_tests($res);
}

# setting naming accessor on dynamic schema should disable warning (even when
# we're setting it to 'v4' .)
{
    my $res = run_loader(naming => 'v4');

    is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';

    run_v4_tests($res);
}

# test upgraded dynamic schema
{
    my $res = run_loader(naming => 'current');

# to dump a schema for debugging...
#    {
#        mkdir '/tmp/HLAGH';
#        $schema->_loader->{dump_directory} = '/tmp/HLAGH';
#        $schema->_loader->_dump_to_dir(values %{ $res->{classes} });
#    }

    is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';

    run_v5_tests($res);
}

# test upgraded dynamic schema with external content loaded
{
    my $temp_dir = tempdir;
    push @INC, $temp_dir;

    my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
    make_path $external_result_dir;

    # make external content for Result that will be singularized
    IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Quuxs;
sub a_method { 'hlagh' }

__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs',
    { 'foreign.baz_num' => 'self.baz_id' });

1;
EOF

    # make external content for Result that will NOT be singularized
    IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Bar;

__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos',
    { 'foreign.fooid' => 'self.foo_id' });

1;
EOF

    my $res = run_loader(naming => 'current');
    my $schema = $res->{schema};

    is scalar @{ $res->{warnings} }, 1,
'correct nummber of warnings for upgraded dynamic schema with external ' .
'content for unsingularized Result.';

    my $warning = $res->{warnings}[0];
    like $warning, qr/Detected external content/i,
        'detected external content warning';

    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
'external custom content for unsingularized Result was loaded by upgraded ' .
'dynamic Schema';

    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
        $res->{classes}{bazs} }
        'unsingularized class names in external content are translated';

    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
        $res->{classes}{foos} }
'unsingularized class names in external content from unchanged Result class ' .
'names are translated';

    run_v5_tests($res);

    rmtree $temp_dir;
    pop @INC;
}

# test upgraded dynamic schema with use_namespaces with external content loaded
{
    my $temp_dir = tempdir;
    push @INC, $temp_dir;

    my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
    make_path $external_result_dir;

    # make external content for Result that will be singularized
    IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Quuxs;
sub a_method { 'hlagh' }

__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs',
    { 'foreign.baz_num' => 'self.baz_id' });

1;
EOF

    # make external content for Result that will NOT be singularized
    IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Bar;

__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos',
    { 'foreign.fooid' => 'self.foo_id' });

1;
EOF

    my $res = run_loader(naming => 'current', use_namespaces => 1);
    my $schema = $res->{schema};

    is scalar @{ $res->{warnings} }, 2,
'correct nummber of warnings for upgraded dynamic schema with external ' .
'content for unsingularized Result with use_namespaces.';

    my $warning = $res->{warnings}[0];
    like $warning, qr/Detected external content/i,
        'detected external content warning';

    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
'external custom content for unsingularized Result was loaded by upgraded ' .
'dynamic Schema';

    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
        $res->{classes}{bazs} }
        'unsingularized class names in external content are translated';

    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
        $res->{classes}{foos} }
'unsingularized class names in external content from unchanged Result class ' .
'names are translated';

    run_v5_tests($res);

    rmtree $temp_dir;
    pop @INC;
}


# test upgraded static schema with external content loaded
{
    my $temp_dir = tempdir;
    push @INC, $temp_dir;

    my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
    make_path $external_result_dir;

    # make external content for Result that will be singularized
    IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Quuxs;
sub a_method { 'dongs' }

__PACKAGE__->has_one('bazrel2', 'DBIXCSL_Test::Schema::Bazs',
    { 'foreign.baz_num' => 'self.baz_id' });

1;
EOF

    # make external content for Result that will NOT be singularized
    IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Bar;

__PACKAGE__->has_one('foorel2', 'DBIXCSL_Test::Schema::Foos',
    { 'foreign.fooid' => 'self.foo_id' });

1;
EOF

    write_v4_schema_pm();

    my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
    my $schema = $res->{schema};

    run_v5_tests($res);

    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'dongs' }
'external custom content for unsingularized Result was loaded by upgraded ' .
'static Schema';

    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
        $res->{classes}{bazs} }
        'unsingularized class names in external content are translated';

    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel2,
        $res->{classes}{foos} }
'unsingularized class names in external content from unchanged Result class ' .
'names are translated in static schema';

    my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
    my $code = do { local ($/, @ARGV) = (undef, $file); <> };

    like $code, qr/package ${SCHEMA_CLASS}::Quux;/,
'package line translated correctly from external custom content in static dump';

    like $code, qr/sub a_method { 'dongs' }/,
'external custom content loaded into static dump correctly';

    rmtree $temp_dir;
    pop @INC;
}

# test running against v4 schema without upgrade, twice, then upgrade
{
    write_v4_schema_pm();
    my $res = run_loader(dump_directory => $DUMP_DIR);
    my $warning = $res->{warnings}[0];

    like $warning, qr/static schema/i,
        'static schema in backcompat mode detected';
    like $warning, qr/0.04006/,
        'correct version detected';
    like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
        'refers to upgrading doc';

    is scalar @{ $res->{warnings} }, 3,
        'correct number of warnings for static schema in backcompat mode';

    run_v4_tests($res);

    # add some custom content to a Result that will be replaced
    my $schema   = $res->{schema};
    my $quuxs_pm = $schema->_loader
        ->_get_dump_filename($res->{classes}{quuxs});
    {
        local ($^I, @ARGV) = ('', $quuxs_pm);
        while (<>) {
            if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
                print;
                print <<EOF;
sub a_method { 'mtfnpy' }

__PACKAGE__->has_one('bazrel3', 'DBIXCSL_Test::Schema::Bazs',
    { 'foreign.baz_num' => 'self.baz_id' });
EOF
            }
            else {
                print;
            }
        }
    }

    # Rerun the loader in backcompat mode to make sure it's still in backcompat
    # mode.
    $res = run_loader(dump_directory => $DUMP_DIR);
    run_v4_tests($res);

    # now upgrade the schema
    $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
    $schema = $res->{schema};

    like $res->{warnings}[0], qr/Dumping manual schema/i,
        'correct warnings on upgrading static schema (with "naming" set)';

    like $res->{warnings}[1], qr/dump completed/i,
        'correct warnings on upgrading static schema (with "naming" set)';

    is scalar @{ $res->{warnings} }, 2,
'correct number of warnings on upgrading static schema (with "naming" set)'
        or diag @{ $res->{warnings} };

    run_v5_tests($res);

    (my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g;
    my $result_count =()= glob "$result_dir/*";

    is $result_count, 4,
        'un-singularized results were replaced during upgrade';

    # check that custom content was preserved
    lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' }
        'custom content was carried over from un-singularized Result';

    lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel3,
        $res->{classes}{bazs} }
        'unsingularized class names in custom content are translated';

    my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
    my $code = do { local ($/, @ARGV) = (undef, $file); <> };

    like $code, qr/sub a_method { 'mtfnpy' }/,
'custom content from unsingularized Result loaded into static dump correctly';
}

# test upgrading a v4 schema, the check that the version string is correct
{
    write_v4_schema_pm();
    run_loader(dump_directory => $DUMP_DIR);
    my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
    my $schema = $res->{schema};

    my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
    my $code = do { local ($/, @ARGV) = (undef, $file); <> };

    my ($dumped_ver) =
        $code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;

    is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
        'correct version dumped after upgrade of v4 static schema';
}

# Test upgrading an already singular result with custom content that refers to
# old class names.
{
    write_v4_schema_pm();
    my $res = run_loader(dump_directory => $DUMP_DIR);
    my $schema   = $res->{schema};
    run_v4_tests($res);

    # add some custom content to a Result that will be replaced
    my $bar_pm = $schema->_loader
        ->_get_dump_filename($res->{classes}{bar});
    {
        local ($^I, @ARGV) = ('', $bar_pm);
        while (<>) {
            if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
                print;
                print <<EOF;
sub a_method { 'lalala' }

__PACKAGE__->has_one('foorel3', 'DBIXCSL_Test::Schema::Foos',
    { 'foreign.fooid' => 'self.foo_id' });
EOF
            }
            else {
                print;
            }
        }
    }

    # now upgrade the schema
    $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
    $schema = $res->{schema};
    run_v5_tests($res);

    # check that custom content was preserved
    lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'lalala' }
        'custom content was preserved from Result pre-upgrade';

    lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel3,
        $res->{classes}{foos} }
'unsingularized class names in custom content from Result with unchanged ' .
'name are translated';

    my $file = $schema->_loader->_get_dump_filename($res->{classes}{bar});
    my $code = do { local ($/, @ARGV) = (undef, $file); <> };

    like $code, qr/sub a_method { 'lalala' }/,
'custom content from Result with unchanged name loaded into static dump ' .
'correctly';
}

done_testing;

END {
    rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
}

sub run_loader {
    my %loader_opts = @_;

    $loader_opts{use_namespaces} = 0
        unless exists $loader_opts{use_namespaces};

    eval {
        foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
            Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
        }

        Class::Unload->unload($SCHEMA_CLASS);
    };
    undef $@;

    my @connect_info = $make_dbictest_db2::dsn;
    my @loader_warnings;
    local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
    eval qq{
        package $SCHEMA_CLASS;
        use base qw/DBIx::Class::Schema::Loader/;

        __PACKAGE__->loader_options(\%loader_opts);
        __PACKAGE__->connection(\@connect_info);
    };

    ok(!$@, "Loader initialization") or diag $@;

    my $schema = $SCHEMA_CLASS->clone;
    my (%monikers, %classes);
    foreach my $source_name ($schema->sources) {
        my $table_name = $schema->source($source_name)->from;
        $monikers{$table_name} = $source_name;
        $classes{$table_name}  = $schema->source($source_name)->result_class;
    }

    return {
        schema => $schema,
        warnings => \@loader_warnings,
        monikers => \%monikers,
        classes => \%classes,
    };
}

sub write_v4_schema_pm {
    (my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
    rmtree $schema_dir;
    make_path $schema_dir;
    my $schema_pm = "$schema_dir/Schema.pm";
    open my $fh, '>', $schema_pm or die $!;
    print $fh <<'EOF';
package DBIXCSL_Test::Schema;

use strict;
use warnings;

use base 'DBIx::Class::Schema';

__PACKAGE__->load_classes;


# Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog


# You can replace this text with custom content, and it will be preserved on regeneration
1;
EOF
}

sub run_v4_tests {
    my $res = shift;
    my $schema = $res->{schema};

    is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
        [qw/Foos Bar Bazs Quuxs/],
        'correct monikers in 0.04006 mode';

    isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
        $res->{classes}{bar},
        'found a bar');

    isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
        'correct rel name in 0.04006 mode';

    ok my $baz  = eval { $schema->resultset('Bazs')->find(1) };

    isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
        'correct rel type and name for UNIQUE FK in 0.04006 mode';
}

sub run_v5_tests {
    my $res = shift;
    my $schema = $res->{schema};

    is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
        [qw/Foo Bar Baz Quux/],
        'correct monikers in current mode';

    ok my $bar = eval { $schema->resultset('Bar')->find(1) };

    isa_ok eval { $bar->foo }, $res->{classes}{foos},
        'correct rel name in current mode';

    ok my $baz  = eval { $schema->resultset('Baz')->find(1) };

    isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
        'correct rel type and name for UNIQUE FK in current mode';
}
Commit	Line	Data
66afce69	1	use strict;
	2	use warnings;
	3	use Test::More;
b24cb177	4	use Test::Exception;
a0e0a56a	5	use File::Path qw/rmtree make_path/;
66afce69	6	use Class::Unload;
ffc705f3	7	use File::Temp qw/tempfile tempdir/;
ffc705f3	8	use IO::File;
68d49e50	9	use DBIx::Class::Schema::Loader ();
66afce69	10	use lib qw(t/lib);
	11	use make_dbictest_db2;
	12
	13	my $DUMP_DIR = './t/_common_dump';
	14	rmtree $DUMP_DIR;
a0e0a56a	15	my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
66afce69	16
66afce69	17	# test dynamic schema in 0.04006 mode
	18	{
	19	my $res = run_loader();
a0e0a56a	20	my $warning = $res->{warnings}[0];
66afce69	21
a0e0a56a	22	like $warning, qr/dynamic schema/i,
66afce69	23	'dynamic schema in backcompat mode detected';
a0e0a56a	24	like $warning, qr/run in 0\.04006 mode/i,
66afce69	25	'dynamic schema in 0.04006 mode warning';
a0e0a56a	26	like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
	27	'warning refers to upgrading doc';
	28
	29	run_v4_tests($res);
	30	}
66afce69	31
a0e0a56a	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');
66afce69	36
a0e0a56a	37	is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
f53dcdf0	38
f53dcdf0	39	run_v4_tests($res);
a0e0a56a	40	}
	41
	42	# test upgraded dynamic schema
	43	{
	44	my $res = run_loader(naming => 'current');
66afce69	45
a0e0a56a	46	# to dump a schema for debugging...
	47	# {
	48	# mkdir '/tmp/HLAGH';
	49	# $schema->_loader->{dump_directory} = '/tmp/HLAGH';
	50	# $schema->_loader->_dump_to_dir(values %{ $res->{classes} });
	51	# }
66afce69	52
a0e0a56a	53	is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
66afce69	54
a0e0a56a	55	run_v5_tests($res);
	56	}
	57
ffc705f3	58	# test upgraded dynamic schema with external content loaded
	59	{
	60	my $temp_dir = tempdir;
	61	push @INC, $temp_dir;
	62
	63	my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
	64	make_path $external_result_dir;
	65
b24cb177	66	# make external content for Result that will be singularized
ffc705f3	67	IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
	68	package ${SCHEMA_CLASS}::Quuxs;
	69	sub a_method { 'hlagh' }
b24cb177	70
	71	__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs',
	72	{ 'foreign.baz_num' => 'self.baz_id' });
	73
	74	1;
	75	EOF
	76
	77	# make external content for Result that will NOT be singularized
	78	IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
	79	package ${SCHEMA_CLASS}::Bar;
	80
	81	__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos',
	82	{ 'foreign.fooid' => 'self.foo_id' });
	83
ffc705f3	84	1;
	85	EOF
	86
	87	my $res = run_loader(naming => 'current');
	88	my $schema = $res->{schema};
	89
	90	is scalar @{ $res->{warnings} }, 1,
	91	'correct nummber of warnings for upgraded dynamic schema with external ' .
	92	'content for unsingularized Result.';
	93
	94	my $warning = $res->{warnings}[0];
	95	like $warning, qr/Detected external content/i,
	96	'detected external content warning';
	97
b24cb177	98	lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
ffc705f3	99	'external custom content for unsingularized Result was loaded by upgraded ' .
	100	'dynamic Schema';
	101
b24cb177	102	lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
	103	$res->{classes}{bazs} }
	104	'unsingularized class names in external content are translated';
	105
	106	lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
	107	$res->{classes}{foos} }
	108	'unsingularized class names in external content from unchanged Result class ' .
	109	'names are translated';
	110
ffc705f3	111	run_v5_tests($res);
	112
	113	rmtree $temp_dir;
	114	pop @INC;
	115	}
	116
805dbe0a	117	# test upgraded dynamic schema with use_namespaces with external content loaded
	118	{
	119	my $temp_dir = tempdir;
	120	push @INC, $temp_dir;
	121
	122	my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
	123	make_path $external_result_dir;
	124
	125	# make external content for Result that will be singularized
	126	IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
	127	package ${SCHEMA_CLASS}::Quuxs;
	128	sub a_method { 'hlagh' }
	129
	130	__PACKAGE__->has_one('bazrel', 'DBIXCSL_Test::Schema::Bazs',
	131	{ 'foreign.baz_num' => 'self.baz_id' });
	132
	133	1;
	134	EOF
	135
	136	# make external content for Result that will NOT be singularized
	137	IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
	138	package ${SCHEMA_CLASS}::Bar;
	139
	140	__PACKAGE__->has_one('foorel', 'DBIXCSL_Test::Schema::Foos',
	141	{ 'foreign.fooid' => 'self.foo_id' });
	142
	143	1;
	144	EOF
	145
	146	my $res = run_loader(naming => 'current', use_namespaces => 1);
	147	my $schema = $res->{schema};
	148
	149	is scalar @{ $res->{warnings} }, 2,
	150	'correct nummber of warnings for upgraded dynamic schema with external ' .
	151	'content for unsingularized Result with use_namespaces.';
	152
	153	my $warning = $res->{warnings}[0];
	154	like $warning, qr/Detected external content/i,
	155	'detected external content warning';
	156
	157	lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'hlagh' }
	158	'external custom content for unsingularized Result was loaded by upgraded ' .
	159	'dynamic Schema';
	160
	161	lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel,
	162	$res->{classes}{bazs} }
	163	'unsingularized class names in external content are translated';
	164
	165	lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel,
	166	$res->{classes}{foos} }
	167	'unsingularized class names in external content from unchanged Result class ' .
	168	'names are translated';
	169
	170	run_v5_tests($res);
	171
	172	rmtree $temp_dir;
	173	pop @INC;
	174	}
	175
	176
30a4c064	177	# test upgraded static schema with external content loaded
	178	{
	179	my $temp_dir = tempdir;
	180	push @INC, $temp_dir;
	181
	182	my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
	183	make_path $external_result_dir;
	184
b24cb177	185	# make external content for Result that will be singularized
30a4c064	186	IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
	187	package ${SCHEMA_CLASS}::Quuxs;
	188	sub a_method { 'dongs' }
b24cb177	189
	190	__PACKAGE__->has_one('bazrel2', 'DBIXCSL_Test::Schema::Bazs',
	191	{ 'foreign.baz_num' => 'self.baz_id' });
	192
	193	1;
	194	EOF
	195
	196	# make external content for Result that will NOT be singularized
	197	IO::File->new(">$external_result_dir/Bar.pm")->print(<<"EOF");
	198	package ${SCHEMA_CLASS}::Bar;
	199
	200	__PACKAGE__->has_one('foorel2', 'DBIXCSL_Test::Schema::Foos',
	201	{ 'foreign.fooid' => 'self.foo_id' });
	202
30a4c064	203	1;
	204	EOF
	205
	206	write_v4_schema_pm();
	207
	208	my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	209	my $schema = $res->{schema};
	210
	211	run_v5_tests($res);
	212
b24cb177	213	lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'dongs' }
30a4c064	214	'external custom content for unsingularized Result was loaded by upgraded ' .
	215	'static Schema';
	216
b24cb177	217	lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel2,
	218	$res->{classes}{bazs} }
	219	'unsingularized class names in external content are translated';
	220
	221	lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel2,
	222	$res->{classes}{foos} }
	223	'unsingularized class names in external content from unchanged Result class ' .
	224	'names are translated in static schema';
	225
30a4c064	226	my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
	227	my $code = do { local ($/, @ARGV) = (undef, $file); <> };
	228
	229	like $code, qr/package ${SCHEMA_CLASS}::Quux;/,
	230	'package line translated correctly from external custom content in static dump';
	231
	232	like $code, qr/sub a_method { 'dongs' }/,
	233	'external custom content loaded into static dump correctly';
	234
	235	rmtree $temp_dir;
	236	pop @INC;
	237	}
	238
b24cb177	239	# test running against v4 schema without upgrade, twice, then upgrade
a0e0a56a	240	{
30a4c064	241	write_v4_schema_pm();
a0e0a56a	242	my $res = run_loader(dump_directory => $DUMP_DIR);
	243	my $warning = $res->{warnings}[0];
	244
	245	like $warning, qr/static schema/i,
	246	'static schema in backcompat mode detected';
	247	like $warning, qr/0.04006/,
	248	'correct version detected';
	249	like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
	250	'refers to upgrading doc';
	251
ffc705f3	252	is scalar @{ $res->{warnings} }, 3,
	253	'correct number of warnings for static schema in backcompat mode';
	254
a0e0a56a	255	run_v4_tests($res);
	256
	257	# add some custom content to a Result that will be replaced
	258	my $schema = $res->{schema};
	259	my $quuxs_pm = $schema->_loader
	260	->_get_dump_filename($res->{classes}{quuxs});
	261	{
	262	local ($^I, @ARGV) = ('', $quuxs_pm);
	263	while (<>) {
	264	if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
	265	print;
b24cb177	266	print <<EOF;
	267	sub a_method { 'mtfnpy' }
	268
	269	__PACKAGE__->has_one('bazrel3', 'DBIXCSL_Test::Schema::Bazs',
	270	{ 'foreign.baz_num' => 'self.baz_id' });
	271	EOF
a0e0a56a	272	}
	273	else {
	274	print;
	275	}
	276	}
	277	}
	278
b24cb177	279	# Rerun the loader in backcompat mode to make sure it's still in backcompat
	280	# mode.
	281	$res = run_loader(dump_directory => $DUMP_DIR);
	282	run_v4_tests($res);
	283
a0e0a56a	284	# now upgrade the schema
	285	$res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	286	$schema = $res->{schema};
	287
	288	like $res->{warnings}[0], qr/Dumping manual schema/i,
	289	'correct warnings on upgrading static schema (with "naming" set)';
	290
	291	like $res->{warnings}[1], qr/dump completed/i,
	292	'correct warnings on upgrading static schema (with "naming" set)';
	293
	294	is scalar @{ $res->{warnings} }, 2,
f53dcdf0	295	'correct number of warnings on upgrading static schema (with "naming" set)'
f53dcdf0	296	or diag @{ $res->{warnings} };
a0e0a56a	297
	298	run_v5_tests($res);
	299
	300	(my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g;
	301	my $result_count =()= glob "$result_dir/*";
	302
	303	is $result_count, 4,
	304	'un-singularized results were replaced during upgrade';
	305
	306	# check that custom content was preserved
b24cb177	307	lives_and { is $schema->resultset('Quux')->find(1)->a_method, 'mtfnpy' }
a0e0a56a	308	'custom content was carried over from un-singularized Result';
b24cb177	309
	310	lives_and { isa_ok $schema->resultset('Quux')->find(1)->bazrel3,
	311	$res->{classes}{bazs} }
	312	'unsingularized class names in custom content are translated';
	313
	314	my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
	315	my $code = do { local ($/, @ARGV) = (undef, $file); <> };
	316
	317	like $code, qr/sub a_method { 'mtfnpy' }/,
	318	'custom content from unsingularized Result loaded into static dump correctly';
	319	}
	320
68d49e50	321	# test upgrading a v4 schema, the check that the version string is correct
	322	{
	323	write_v4_schema_pm();
	324	run_loader(dump_directory => $DUMP_DIR);
	325	my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	326	my $schema = $res->{schema};
	327
	328	my $file = $schema->_loader->_get_dump_filename($SCHEMA_CLASS);
	329	my $code = do { local ($/, @ARGV) = (undef, $file); <> };
	330
	331	my ($dumped_ver) =
	332	$code =~ /^# Created by DBIx::Class::Schema::Loader v(\S+)/m;
	333
	334	is $dumped_ver, $DBIx::Class::Schema::Loader::VERSION,
	335	'correct version dumped after upgrade of v4 static schema';
	336	}
	337
b24cb177	338	# Test upgrading an already singular result with custom content that refers to
	339	# old class names.
	340	{
	341	write_v4_schema_pm();
	342	my $res = run_loader(dump_directory => $DUMP_DIR);
	343	my $schema = $res->{schema};
	344	run_v4_tests($res);
	345
	346	# add some custom content to a Result that will be replaced
	347	my $bar_pm = $schema->_loader
	348	->_get_dump_filename($res->{classes}{bar});
	349	{
	350	local ($^I, @ARGV) = ('', $bar_pm);
	351	while (<>) {
	352	if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
	353	print;
	354	print <<EOF;
	355	sub a_method { 'lalala' }
	356
	357	__PACKAGE__->has_one('foorel3', 'DBIXCSL_Test::Schema::Foos',
	358	{ 'foreign.fooid' => 'self.foo_id' });
	359	EOF
	360	}
	361	else {
	362	print;
	363	}
	364	}
	365	}
	366
	367	# now upgrade the schema
	368	$res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	369	$schema = $res->{schema};
	370	run_v5_tests($res);
	371
	372	# check that custom content was preserved
	373	lives_and { is $schema->resultset('Bar')->find(1)->a_method, 'lalala' }
	374	'custom content was preserved from Result pre-upgrade';
	375
	376	lives_and { isa_ok $schema->resultset('Bar')->find(1)->foorel3,
	377	$res->{classes}{foos} }
	378	'unsingularized class names in custom content from Result with unchanged ' .
	379	'name are translated';
	380
	381	my $file = $schema->_loader->_get_dump_filename($res->{classes}{bar});
	382	my $code = do { local ($/, @ARGV) = (undef, $file); <> };
	383
	384	like $code, qr/sub a_method { 'lalala' }/,
	385	'custom content from Result with unchanged name loaded into static dump ' .
	386	'correctly';
66afce69	387	}
	388
	389	done_testing;
	390
ffc705f3	391	END {
	392	rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
	393	}
a0e0a56a	394
dbe9e0f7	395	sub run_loader {
	396	my %loader_opts = @_;
	397
f22644d7	398	$loader_opts{use_namespaces} = 0
	399	unless exists $loader_opts{use_namespaces};
	400
dbe9e0f7	401	eval {
	402	foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
	403	Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
	404	}
	405
	406	Class::Unload->unload($SCHEMA_CLASS);
	407	};
	408	undef $@;
	409
	410	my @connect_info = $make_dbictest_db2::dsn;
	411	my @loader_warnings;
	412	local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
	413	eval qq{
	414	package $SCHEMA_CLASS;
	415	use base qw/DBIx::Class::Schema::Loader/;
	416
	417	__PACKAGE__->loader_options(\%loader_opts);
	418	__PACKAGE__->connection(\@connect_info);
	419	};
	420
	421	ok(!$@, "Loader initialization") or diag $@;
	422
	423	my $schema = $SCHEMA_CLASS->clone;
	424	my (%monikers, %classes);
	425	foreach my $source_name ($schema->sources) {
	426	my $table_name = $schema->source($source_name)->from;
	427	$monikers{$table_name} = $source_name;
d073740e	428	$classes{$table_name} = $schema->source($source_name)->result_class;
dbe9e0f7	429	}
	430
	431	return {
	432	schema => $schema,
	433	warnings => \@loader_warnings,
	434	monikers => \%monikers,
	435	classes => \%classes,
	436	};
	437	}
	438
30a4c064	439	sub write_v4_schema_pm {
	440	(my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
	441	rmtree $schema_dir;
	442	make_path $schema_dir;
	443	my $schema_pm = "$schema_dir/Schema.pm";
	444	open my $fh, '>', $schema_pm or die $!;
	445	print $fh <<'EOF';
	446	package DBIXCSL_Test::Schema;
	447
	448	use strict;
	449	use warnings;
	450
	451	use base 'DBIx::Class::Schema';
	452
	453	__PACKAGE__->load_classes;
	454
	455
	456	# Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
	457	# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
	458
	459
	460	# You can replace this text with custom content, and it will be preserved on regeneration
	461	1;
	462	EOF
	463	}
	464
dbe9e0f7	465	sub run_v4_tests {
	466	my $res = shift;
	467	my $schema = $res->{schema};
	468
	469	is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
	470	[qw/Foos Bar Bazs Quuxs/],
	471	'correct monikers in 0.04006 mode';
	472
	473	isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
	474	$res->{classes}{bar},
	475	'found a bar');
	476
	477	isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
	478	'correct rel name in 0.04006 mode';
	479
	480	ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
	481
	482	isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
	483	'correct rel type and name for UNIQUE FK in 0.04006 mode';
	484	}
	485
	486	sub run_v5_tests {
	487	my $res = shift;
	488	my $schema = $res->{schema};
	489
	490	is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
	491	[qw/Foo Bar Baz Quux/],
	492	'correct monikers in current mode';
	493
	494	ok my $bar = eval { $schema->resultset('Bar')->find(1) };
	495
	496	isa_ok eval { $bar->foo }, $res->{classes}{foos},
	497	'correct rel name in current mode';
	498
	499	ok my $baz = eval { $schema->resultset('Baz')->find(1) };
	500
	501	isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
	502	'correct rel type and name for UNIQUE FK in current mode';
	503	}