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

use strict;
use warnings;
use Test::More;
use File::Path qw/rmtree make_path/;
use Class::Unload;
use File::Temp qw/tempfile tempdir/;
use IO::File;
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;

    IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Quuxs;
sub a_method { 'hlagh' }
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';

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

    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;

    IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
package ${SCHEMA_CLASS}::Quuxs;
sub a_method { 'dongs' }
1;
EOF

    write_v4_schema_pm();

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

    run_v5_tests($res);

    is eval { $schema->resultset('Quux')->find(1)->a_method }, 'dongs',
'external custom content for unsingularized Result was loaded by upgraded ' .
'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
{
    write_v4_schema_pm();

    # now run the loader
    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 "sub a_method { 'mtfnpy' }\n";
            }
            else {
                print;
            }
        }
    }

    # 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
    is eval { $schema->resultset('Quux')->find(1)->a_method }, 'mtfnpy',
        'custom content was carried over from un-singularized Result';
}

done_testing;

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

sub run_loader {
    my %loader_opts = @_;

    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_CLASS}::${source_name}";
    }

    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;
a0e0a56a	4	use File::Path qw/rmtree make_path/;
66afce69	5	use Class::Unload;
ffc705f3	6	use File::Temp qw/tempfile tempdir/;
ffc705f3	7	use IO::File;
66afce69	8	use lib qw(t/lib);
	9	use make_dbictest_db2;
	10
	11	my $DUMP_DIR = './t/_common_dump';
	12	rmtree $DUMP_DIR;
a0e0a56a	13	my $SCHEMA_CLASS = 'DBIXCSL_Test::Schema';
66afce69	14
66afce69	15	# test dynamic schema in 0.04006 mode
	16	{
	17	my $res = run_loader();
a0e0a56a	18	my $warning = $res->{warnings}[0];
66afce69	19
a0e0a56a	20	like $warning, qr/dynamic schema/i,
66afce69	21	'dynamic schema in backcompat mode detected';
a0e0a56a	22	like $warning, qr/run in 0\.04006 mode/i,
66afce69	23	'dynamic schema in 0.04006 mode warning';
a0e0a56a	24	like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
	25	'warning refers to upgrading doc';
	26
	27	run_v4_tests($res);
	28	}
66afce69	29
a0e0a56a	30	# setting naming accessor on dynamic schema should disable warning (even when
	31	# we're setting it to 'v4' .)
	32	{
	33	my $res = run_loader(naming => 'v4');
66afce69	34
a0e0a56a	35	is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
f53dcdf0	36
f53dcdf0	37	run_v4_tests($res);
a0e0a56a	38	}
	39
	40	# test upgraded dynamic schema
	41	{
	42	my $res = run_loader(naming => 'current');
66afce69	43
a0e0a56a	44	# to dump a schema for debugging...
	45	# {
	46	# mkdir '/tmp/HLAGH';
	47	# $schema->_loader->{dump_directory} = '/tmp/HLAGH';
	48	# $schema->_loader->_dump_to_dir(values %{ $res->{classes} });
	49	# }
66afce69	50
a0e0a56a	51	is_deeply $res->{warnings}, [], 'no warnings with naming attribute set';
66afce69	52
a0e0a56a	53	run_v5_tests($res);
	54	}
	55
ffc705f3	56	# test upgraded dynamic schema with external content loaded
	57	{
	58	my $temp_dir = tempdir;
	59	push @INC, $temp_dir;
	60
	61	my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
	62	make_path $external_result_dir;
	63
	64	IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
	65	package ${SCHEMA_CLASS}::Quuxs;
	66	sub a_method { 'hlagh' }
	67	1;
	68	EOF
	69
	70	my $res = run_loader(naming => 'current');
	71	my $schema = $res->{schema};
	72
	73	is scalar @{ $res->{warnings} }, 1,
	74	'correct nummber of warnings for upgraded dynamic schema with external ' .
	75	'content for unsingularized Result.';
	76
	77	my $warning = $res->{warnings}[0];
	78	like $warning, qr/Detected external content/i,
	79	'detected external content warning';
	80
	81	is eval { $schema->resultset('Quux')->find(1)->a_method }, 'hlagh',
	82	'external custom content for unsingularized Result was loaded by upgraded ' .
	83	'dynamic Schema';
	84
	85	run_v5_tests($res);
	86
	87	rmtree $temp_dir;
	88	pop @INC;
	89	}
	90
30a4c064	91	# test upgraded static schema with external content loaded
	92	{
	93	my $temp_dir = tempdir;
	94	push @INC, $temp_dir;
	95
	96	my $external_result_dir = join '/', $temp_dir, split /::/, $SCHEMA_CLASS;
	97	make_path $external_result_dir;
	98
	99	IO::File->new(">$external_result_dir/Quuxs.pm")->print(<<"EOF");
	100	package ${SCHEMA_CLASS}::Quuxs;
	101	sub a_method { 'dongs' }
	102	1;
	103	EOF
	104
	105	write_v4_schema_pm();
	106
	107	my $res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	108	my $schema = $res->{schema};
	109
	110	run_v5_tests($res);
	111
	112	is eval { $schema->resultset('Quux')->find(1)->a_method }, 'dongs',
	113	'external custom content for unsingularized Result was loaded by upgraded ' .
	114	'static Schema';
	115
	116	my $file = $schema->_loader->_get_dump_filename($res->{classes}{quuxs});
	117	my $code = do { local ($/, @ARGV) = (undef, $file); <> };
	118
	119	like $code, qr/package ${SCHEMA_CLASS}::Quux;/,
	120	'package line translated correctly from external custom content in static dump';
	121
	122	like $code, qr/sub a_method { 'dongs' }/,
	123	'external custom content loaded into static dump correctly';
	124
	125	rmtree $temp_dir;
	126	pop @INC;
	127	}
	128
a0e0a56a	129	# test running against v4 schema without upgrade
a0e0a56a	130	{
30a4c064	131	write_v4_schema_pm();
a0e0a56a	132
	133	# now run the loader
	134	my $res = run_loader(dump_directory => $DUMP_DIR);
	135	my $warning = $res->{warnings}[0];
	136
	137	like $warning, qr/static schema/i,
	138	'static schema in backcompat mode detected';
	139	like $warning, qr/0.04006/,
	140	'correct version detected';
	141	like $warning, qr/DBIx::Class::Schema::Loader::Manual::UpgradingFromV4/,
	142	'refers to upgrading doc';
	143
ffc705f3	144	is scalar @{ $res->{warnings} }, 3,
	145	'correct number of warnings for static schema in backcompat mode';
	146
a0e0a56a	147	run_v4_tests($res);
	148
	149	# add some custom content to a Result that will be replaced
	150	my $schema = $res->{schema};
	151	my $quuxs_pm = $schema->_loader
	152	->_get_dump_filename($res->{classes}{quuxs});
	153	{
	154	local ($^I, @ARGV) = ('', $quuxs_pm);
	155	while (<>) {
	156	if (/DO NOT MODIFY THIS OR ANYTHING ABOVE/) {
	157	print;
	158	print "sub a_method { 'mtfnpy' }\n";
	159	}
	160	else {
	161	print;
	162	}
	163	}
	164	}
	165
	166	# now upgrade the schema
	167	$res = run_loader(dump_directory => $DUMP_DIR, naming => 'current');
	168	$schema = $res->{schema};
	169
	170	like $res->{warnings}[0], qr/Dumping manual schema/i,
	171	'correct warnings on upgrading static schema (with "naming" set)';
	172
	173	like $res->{warnings}[1], qr/dump completed/i,
	174	'correct warnings on upgrading static schema (with "naming" set)';
	175
	176	is scalar @{ $res->{warnings} }, 2,
f53dcdf0	177	'correct number of warnings on upgrading static schema (with "naming" set)'
f53dcdf0	178	or diag @{ $res->{warnings} };
a0e0a56a	179
	180	run_v5_tests($res);
	181
	182	(my $result_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s{::}{/}g;
	183	my $result_count =()= glob "$result_dir/*";
	184
	185	is $result_count, 4,
	186	'un-singularized results were replaced during upgrade';
	187
	188	# check that custom content was preserved
	189	is eval { $schema->resultset('Quux')->find(1)->a_method }, 'mtfnpy',
	190	'custom content was carried over from un-singularized Result';
66afce69	191	}
	192
	193	done_testing;
	194
ffc705f3	195	END {
	196	rmtree $DUMP_DIR unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP};
	197	}
a0e0a56a	198
dbe9e0f7	199	sub run_loader {
	200	my %loader_opts = @_;
	201
	202	eval {
	203	foreach my $source_name ($SCHEMA_CLASS->clone->sources) {
	204	Class::Unload->unload("${SCHEMA_CLASS}::${source_name}");
	205	}
	206
	207	Class::Unload->unload($SCHEMA_CLASS);
	208	};
	209	undef $@;
	210
	211	my @connect_info = $make_dbictest_db2::dsn;
	212	my @loader_warnings;
	213	local $SIG{__WARN__} = sub { push(@loader_warnings, $_[0]); };
	214	eval qq{
	215	package $SCHEMA_CLASS;
	216	use base qw/DBIx::Class::Schema::Loader/;
	217
	218	__PACKAGE__->loader_options(\%loader_opts);
	219	__PACKAGE__->connection(\@connect_info);
	220	};
	221
	222	ok(!$@, "Loader initialization") or diag $@;
	223
	224	my $schema = $SCHEMA_CLASS->clone;
	225	my (%monikers, %classes);
	226	foreach my $source_name ($schema->sources) {
	227	my $table_name = $schema->source($source_name)->from;
	228	$monikers{$table_name} = $source_name;
	229	$classes{$table_name} = "${SCHEMA_CLASS}::${source_name}";
	230	}
	231
	232	return {
	233	schema => $schema,
	234	warnings => \@loader_warnings,
	235	monikers => \%monikers,
	236	classes => \%classes,
	237	};
	238	}
	239
30a4c064	240	sub write_v4_schema_pm {
	241	(my $schema_dir = "$DUMP_DIR/$SCHEMA_CLASS") =~ s/::[^:]+\z//;
	242	rmtree $schema_dir;
	243	make_path $schema_dir;
	244	my $schema_pm = "$schema_dir/Schema.pm";
	245	open my $fh, '>', $schema_pm or die $!;
	246	print $fh <<'EOF';
	247	package DBIXCSL_Test::Schema;
	248
	249	use strict;
	250	use warnings;
	251
	252	use base 'DBIx::Class::Schema';
	253
	254	__PACKAGE__->load_classes;
	255
	256
	257	# Created by DBIx::Class::Schema::Loader v0.04006 @ 2009-12-25 01:49:25
	258	# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ibIJTbfM1ji4pyD/lgSEog
	259
	260
	261	# You can replace this text with custom content, and it will be preserved on regeneration
	262	1;
	263	EOF
	264	}
	265
dbe9e0f7	266	sub run_v4_tests {
	267	my $res = shift;
	268	my $schema = $res->{schema};
	269
	270	is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
	271	[qw/Foos Bar Bazs Quuxs/],
	272	'correct monikers in 0.04006 mode';
	273
	274	isa_ok ((my $bar = eval { $schema->resultset('Bar')->find(1) }),
	275	$res->{classes}{bar},
	276	'found a bar');
	277
	278	isa_ok eval { $bar->foo_id }, $res->{classes}{foos},
	279	'correct rel name in 0.04006 mode';
	280
	281	ok my $baz = eval { $schema->resultset('Bazs')->find(1) };
	282
	283	isa_ok eval { $baz->quux }, 'DBIx::Class::ResultSet',
	284	'correct rel type and name for UNIQUE FK in 0.04006 mode';
	285	}
	286
	287	sub run_v5_tests {
	288	my $res = shift;
	289	my $schema = $res->{schema};
	290
	291	is_deeply [ @{ $res->{monikers} }{qw/foos bar bazs quuxs/} ],
	292	[qw/Foo Bar Baz Quux/],
	293	'correct monikers in current mode';
	294
	295	ok my $bar = eval { $schema->resultset('Bar')->find(1) };
	296
	297	isa_ok eval { $bar->foo }, $res->{classes}{foos},
	298	'correct rel name in current mode';
	299
	300	ok my $baz = eval { $schema->resultset('Baz')->find(1) };
	301
	302	isa_ok eval { $baz->quux }, $res->{classes}{quuxs},
	303	'correct rel type and name for UNIQUE FK in current mode';
	304	}