From: Rafael Kitover Date: Fri, 25 Dec 2009 00:56:55 +0000 (+0000) Subject: start of backcompat tests X-Git-Tag: 0.04999_13~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66afce697a89ad75d60a55e1146c8760c5a8ec15;p=dbsrgits%2FDBIx-Class-Schema-Loader.git start of backcompat tests --- diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm index ea22c4f..5403cc2 100644 --- a/lib/DBIx/Class/Schema/Loader/Base.pm +++ b/lib/DBIx/Class/Schema/Loader/Base.pm @@ -291,6 +291,8 @@ can also be found via standard L methods somehow. =cut +use constant CURRENT_V => 'v5'; + # ensure that a peice of object data is a valid arrayref, creating # an empty one or encapsulating whatever's there. sub _ensure_arrayref { @@ -348,7 +350,7 @@ sub new { $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION); $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION); - if (not ref $self->naming && defined $self->naming) { + if ((not ref $self->naming) && defined $self->naming) { my $naming_ver = $self->naming; $self->{naming} = { relationships => $naming_ver, @@ -356,6 +358,13 @@ sub new { }; } + if ($self->naming) { + for (values %{ $self->naming }) { + $_ = CURRENT_V if $_ eq 'current'; + } + } + $self->{naming} ||= {}; + $self->_check_back_compat; $self; @@ -369,6 +378,16 @@ sub _check_back_compat { # just in case, though no one is likely to dump a dynamic schema $self->schema_version_to_dump('0.04006'); + if (not %{ $self->naming }) { + warn <naming->{relationships} ||= 'v4'; $self->naming->{monikers} ||= 'v4'; @@ -516,6 +535,7 @@ sub rescan { } sub _relbuilder { + no warnings 'uninitialized'; my ($self) = @_; return if $self->{skip_relationships}; @@ -963,6 +983,7 @@ sub tables { # Make a moniker from a table sub _default_table2moniker { + no warnings 'uninitialized'; my ($self, $table) = @_; if ($self->naming->{monikers} eq 'v4') { diff --git a/t/25backcompat_v4.t b/t/25backcompat_v4.t new file mode 100644 index 0000000..a7e3575 --- /dev/null +++ b/t/25backcompat_v4.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +use Test::More; +use File::Path; +use Class::Unload; +use lib qw(t/lib); +use make_dbictest_db2; + +my $DUMP_DIR = './t/_common_dump'; +rmtree $DUMP_DIR; + +sub run_loader { + my %loader_opts = @_; + + my $schema_class = 'DBIXCSL_Test::Schema'; + Class::Unload->unload($schema_class); + + 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, + }; +} + +# test dynamic schema in 0.04006 mode +{ + my $res = run_loader(); + + like $res->{warnings}[0], qr/dynamic schema/i, + 'dynamic schema in backcompat mode detected'; + like $res->{warnings}[0], qr/run in 0\.04006 mode/, + 'dynamic schema in 0.04006 mode warning'; + + is_deeply [ @{ $res->{monikers} }{qw/foos bar bazes quuxes/} ], + [qw/Foos Bar Bazes Quuxes/], + 'correct monikers in 0.04006 mode'; + + ok my $bar = eval { $res->{schema}->resultset('Bar')->find(1) }; + + isa_ok eval { $bar->fooref }, $res->{classes}{foos}, + 'correct rel name'; + + ok my $baz = eval { $res->{schema}->resultset('Bazes')->find(1) }; + + isa_ok eval { $baz->quuxes }, 'DBIx::Class::ResultSet', + 'correct rel type and name for UNIQUE FK'; +} + +done_testing; + +END { rmtree $DUMP_DIR } diff --git a/t/lib/make_dbictest_db2.pm b/t/lib/make_dbictest_db2.pm new file mode 100644 index 0000000..b16761b --- /dev/null +++ b/t/lib/make_dbictest_db2.pm @@ -0,0 +1,50 @@ +package make_dbictest_db2; + +use strict; +use warnings; +use DBI; + +eval { require DBD::SQLite }; +my $class = $@ ? 'SQLite2' : 'SQLite'; + +my $fn = './t/dbictest.db'; + +unlink($fn); +our $dsn = "dbi:$class:dbname=$fn"; +my $dbh = DBI->connect($dsn); + +$dbh->do($_) for ( + q|CREATE TABLE foos ( + fooid INTEGER PRIMARY KEY, + footext TEXT + )|, + q|CREATE TABLE bar ( + barid INTEGER PRIMARY KEY, + fooref INTEGER REFERENCES foos (fooid) + )|, + q|CREATE TABLE bazes ( + bazid INTEGER PRIMARY KEY, + baz_num INTEGER NOT NULL UNIQUE + )|, + q|CREATE TABLE quuxes ( + quuxid INTEGER PRIMARY KEY, + bazref INTEGER NOT NULL, + FOREIGN KEY (bazref) REFERENCES bazes (baz_num) + )|, + q|INSERT INTO foos VALUES (1,'Foo text for number 1')|, + q|INSERT INTO foos VALUES (2,'Foo record associated with the Bar with barid 3')|, + q|INSERT INTO foos VALUES (3,'Foo text for number 3')|, + q|INSERT INTO foos VALUES (4,'Foo text for number 4')|, + q|INSERT INTO bar VALUES (1,4)|, + q|INSERT INTO bar VALUES (2,3)|, + q|INSERT INTO bar VALUES (3,2)|, + q|INSERT INTO bar VALUES (4,1)|, + q|INSERT INTO bazes VALUES (1,20)|, + q|INSERT INTO bazes VALUES (2,19)|, + q|INSERT INTO quuxes VALUES (1,20)|, + q|INSERT INTO quuxes VALUES (2,19)|, +); + +END { unlink($fn); } + +1;