[Bast-commits] r8176 - in branches/DBIx-Class-Schema-Loader/current:
lib/DBIx/Class/Schema/Loader t t/lib
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Fri Dec 25 00:56:55 GMT 2009
Author: caelum
Date: 2009-12-25 00:56:55 +0000 (Fri, 25 Dec 2009)
New Revision: 8176
Added:
branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t
branches/DBIx-Class-Schema-Loader/current/t/lib/make_dbictest_db2.pm
Modified:
branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
Log:
start of backcompat tests
Modified: branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-12-24 15:22:30 UTC (rev 8175)
+++ branches/DBIx-Class-Schema-Loader/current/lib/DBIx/Class/Schema/Loader/Base.pm 2009-12-25 00:56:55 UTC (rev 8176)
@@ -291,6 +291,8 @@
=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 @@
$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 @@
};
}
+ if ($self->naming) {
+ for (values %{ $self->naming }) {
+ $_ = CURRENT_V if $_ eq 'current';
+ }
+ }
+ $self->{naming} ||= {};
+
$self->_check_back_compat;
$self;
@@ -369,6 +378,16 @@
# 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 <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
+
+Dynamic schema detected, will run in 0.04006 mode.
+
+Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
+to disable this warning.
+EOF
+ }
+
$self->naming->{relationships} ||= 'v4';
$self->naming->{monikers} ||= 'v4';
@@ -516,6 +535,7 @@
}
sub _relbuilder {
+ no warnings 'uninitialized';
my ($self) = @_;
return if $self->{skip_relationships};
@@ -963,6 +983,7 @@
# Make a moniker from a table
sub _default_table2moniker {
+ no warnings 'uninitialized';
my ($self, $table) = @_;
if ($self->naming->{monikers} eq 'v4') {
Added: branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t (rev 0)
+++ branches/DBIx-Class-Schema-Loader/current/t/25backcompat_v4.t 2009-12-25 00:56:55 UTC (rev 8176)
@@ -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 }
Added: branches/DBIx-Class-Schema-Loader/current/t/lib/make_dbictest_db2.pm
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/t/lib/make_dbictest_db2.pm (rev 0)
+++ branches/DBIx-Class-Schema-Loader/current/t/lib/make_dbictest_db2.pm 2009-12-25 00:56:55 UTC (rev 8176)
@@ -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;
More information about the Bast-commits
mailing list