From: Rafael Kitover <rkitover@cpan.org>
Date: Thu, 25 Mar 2010 09:43:00 +0000 (-0400)
Subject: suppress 'bad table' warnings for filtered tables, preserve case of MSSQL table names
X-Git-Tag: 0.06000~30
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=bfb43060510498e0475461550af48f61bd99c981

suppress 'bad table' warnings for filtered tables, preserve case of MSSQL table names
---

diff --git a/Changes b/Changes
index 0119f2c..45e2605 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - suppress 'bad table or view' warnings for filtered tables/views
         - croak if several tables reduce to an identical moniker (ribasushi)
         - better type info for Sybase ASE
         - better type info for Pg: sets sequence for serials, handles numerics
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index e0a42fa..a2a7147 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -855,7 +855,9 @@ Does the actual schema-construction work.
 sub load {
     my $self = shift;
 
-    $self->_load_tables($self->_tables_list);
+    $self->_load_tables(
+        $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude })
+    );
 }
 
 =head2 rescan
@@ -880,8 +882,8 @@ sub rescan {
     $self->_relbuilder->{schema} = $schema;
 
     my @created;
-    my @current = $self->_tables_list;
-    foreach my $table ($self->_tables_list) {
+    my @current = $self->_tables_list({ constraint => $self->constraint, exclude => $self->exclude });
+    foreach my $table (@current) {
         if(!exists $self->{_tables}->{$table}) {
             push(@created, $table);
         }
@@ -917,15 +919,6 @@ sub _relbuilder {
 sub _load_tables {
     my ($self, @tables) = @_;
 
-    # First, use _tables_list with constraint and exclude
-    #  to get a list of tables to operate on
-
-    my $constraint   = $self->constraint;
-    my $exclude      = $self->exclude;
-
-    @tables = grep { /$constraint/ } @tables if $constraint;
-    @tables = grep { ! /$exclude/ } @tables if $exclude;
-
     # Save the new tables to the tables list
     foreach (@tables) {
         $self->{_tables}->{$_} = 1;
@@ -933,7 +926,6 @@ sub _load_tables {
 
     $self->_make_src_class($_) for @tables;
 
-
     # sanity-check for moniker clashes
     my $inverse_moniker_idx;
     for (keys %{$self->monikers}) {
@@ -1360,11 +1352,13 @@ sub _make_src_class {
             unless $table_class eq $old_class;
     }
 
-    my $table_normalized = lc $table;
+# this was a bad idea, should be ok now without it
+#    my $table_normalized = lc $table;
+#    $self->classes->{$table_normalized} = $table_class;
+#    $self->monikers->{$table_normalized} = $table_moniker;
+
     $self->classes->{$table} = $table_class;
-    $self->classes->{$table_normalized} = $table_class;
     $self->monikers->{$table} = $table_moniker;
-    $self->monikers->{$table_normalized} = $table_moniker;
 
     $self->_use   ($table_class, @{$self->additional_classes});
     $self->_inject($table_class, @{$self->left_base_classes});
@@ -1722,3 +1716,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0:
diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm
index 0eef7aa..fc07b22 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI.pm
@@ -84,7 +84,7 @@ sub _rebless { }
 
 # Returns an array of table names
 sub _tables_list { 
-    my $self = shift;
+    my ($self, $opts) = (shift, shift);
 
     my ($table, $type) = @_ ? @_ : ('%', '%');
 
@@ -102,15 +102,23 @@ sub _tables_list {
     }
     s/$qt//g for @tables;
 
-    return $self->_filter_tables(@tables);
+    return $self->_filter_tables(\@tables, $opts);
 }
 
-# ignore bad tables and views
+# apply constraint/exclude and ignore bad tables and views
 sub _filter_tables {
-    my ($self, @tables) = @_;
+    my ($self, $tables, $opts) = @_;
 
+    my @tables = @$tables;
     my @filtered_tables;
 
+    $opts ||= {};
+    my $constraint   = $opts->{constraint};
+    my $exclude      = $opts->{exclude};
+
+    @tables = grep { /$constraint/ } @$tables if defined $constraint;
+    @tables = grep { ! /$exclude/  } @$tables if defined $exclude;
+
     for my $table (@tables) {
         eval {
             my $sth = $self->_sth_for($table, undef, \'1 = 0');
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
index 0ceda3a..b3a1c23 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm
@@ -73,7 +73,7 @@ sub _table_uniq_info {
 
 # DBD::DB2 doesn't follow the DBI API for ->tables
 sub _tables_list { 
-    my $self = shift;
+    my ($self, $opts) = @_;
     
     my $dbh = $self->schema->storage->dbh;
     my @tables = map { lc } $dbh->tables(
@@ -82,7 +82,7 @@ sub _tables_list {
     s/\Q$self->{_quoter}\E//g for @tables;
     s/^.*\Q$self->{_namesep}\E// for @tables;
 
-    return @tables;
+    return $self->_filter_tables(\@tables, $opts);
 }
 
 sub _table_pk_info {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
index e69e4f2..10af9bd 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
@@ -26,7 +26,7 @@ usage information.
 =cut
 
 sub _tables_list {
-    my $self = shift;
+    my ($self, $opts) = @_;
 
     my $dbh = $self->schema->storage->dbh;
     my $sth = $dbh->prepare(<<'EOF');
@@ -36,9 +36,9 @@ WHERE t.table_schema = ?
 EOF
     $sth->execute($self->db_schema);
 
-    my @tables = map lc $_, map @$_, @{ $sth->fetchall_arrayref };
+    my @tables = map @$_, @{ $sth->fetchall_arrayref };
 
-    return $self->_filter_tables(@tables);
+    return $self->_filter_tables(\@tables, $opts);
 }
 
 sub _table_pk_info {
@@ -68,7 +68,7 @@ sub _table_fk_info {
         my $fk = $row->{FK_NAME};
         push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME};
         push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME};
-        $remote_table->{$fk} = lc $row->{PKTABLE_NAME};
+        $remote_table->{$fk} = $row->{PKTABLE_NAME};
     }
 
     foreach my $fk (keys %$remote_table) {
@@ -93,7 +93,7 @@ SELECT ccu.constraint_name, ccu.column_name
 FROM information_schema.constraint_column_usage ccu
 JOIN information_schema.table_constraints tc on (ccu.constraint_name = tc.constraint_name)
 JOIN information_schema.key_column_usage kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name)
-wHERE lower(ccu.table_name) = @{[ $dbh->quote($table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
+wHERE lower(ccu.table_name) = @{[ $dbh->quote(lc $table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
     });
     $sth->execute;
     my $constraints;
@@ -119,8 +119,8 @@ sub _columns_info_for {
         my $sth = $dbh->prepare(qq{
 SELECT column_name 
 FROM information_schema.columns
-WHERE columnproperty(object_id(@{[ $dbh->quote($table) ]}, 'U'), @{[ $dbh->quote($col) ]}, 'IsIdentity') = 1
-AND lower(table_name) = @{[ $dbh->quote($table) ]} AND lower(column_name) = @{[ $dbh->quote($col) ]}
+WHERE columnproperty(object_id(@{[ $dbh->quote(lc $table) ]}, 'U'), @{[ $dbh->quote(lc $col) ]}, 'IsIdentity') = 1
+AND lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
         });
         if (eval { $sth->execute; $sth->fetchrow_array }) {
             $info->{is_auto_increment} = 1;
@@ -132,7 +132,7 @@ AND lower(table_name) = @{[ $dbh->quote($table) ]} AND lower(column_name) = @{[
         $sth = $dbh->prepare(qq{
 SELECT column_default
 FROM information_schema.columns
-wHERE lower(table_name) = @{[ $dbh->quote($table) ]} AND lower(column_name) = @{[ $dbh->quote($col) ]}
+wHERE lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
         });
         my ($default) = eval { $sth->execute; $sth->fetchrow_array };
 
@@ -170,3 +170,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0:
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
index 052639f..efad039 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
@@ -42,9 +42,9 @@ sub _rebless {
 }
 
 sub _tables_list { 
-    my $self = shift;
+    my ($self, $opts) = @_;
 
-    return $self->next::method(undef, undef);
+    return $self->next::method($opts, undef, undef);
 }
 
 =head1 SEE ALSO
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
index c49e372..1a92b83 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
@@ -56,7 +56,7 @@ sub _table_as_sql {
 }
 
 sub _tables_list { 
-    my $self = shift;
+    my ($self, $opts) = @_;
 
     my $dbh = $self->schema->storage->dbh;
 
@@ -74,7 +74,7 @@ sub _tables_list {
           if $table =~ /\A(\w+)\z/;
     }
 
-    return $self->_filter_tables(@tables);
+    return $self->_filter_tables(\@tables, $opts);
 }
 
 sub _table_uniq_info {
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
index 0ff237f..6df0aac 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
@@ -30,7 +30,7 @@ sub _setup {
 }
 
 sub _tables_list {
-    my $self = shift;
+    my ($self, $opts) = @_;
 
     my $dbh = $self->schema->storage->dbh;
     my $sth = $dbh->prepare(<<'EOF');
@@ -42,7 +42,7 @@ EOF
 
     my @tables = map @$_, @{ $sth->fetchall_arrayref };
 
-    return $self->_filter_tables(@tables);
+    return $self->_filter_tables(\@tables, $opts);
 }
 
 # check for IDENTITY columns
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
index 24a2ba1..7ecda46 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm
@@ -132,7 +132,7 @@ sub _table_uniq_info {
 }
 
 sub _tables_list {
-    my $self = shift;
+    my ($self, $opts) = @_;
 
     my $dbh = $self->schema->storage->dbh;
     my $sth = $dbh->prepare("SELECT * FROM sqlite_master");
@@ -144,7 +144,7 @@ sub _tables_list {
         push @tables, $row->{tbl_name};
     }
     $sth->finish;
-    return $self->_filter_tables(@tables);
+    return $self->_filter_tables(\@tables, $opts);
 }
 
 =head1 SEE ALSO
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
index f102b3f..cb1fd37 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/mysql.pm
@@ -28,9 +28,9 @@ See L<DBIx::Class::Schema::Loader::Base>.
 =cut
 
 sub _tables_list { 
-    my $self = shift;
+    my ($self, $opts) = @_;
 
-    return $self->next::method(undef, undef);
+    return $self->next::method($opts, undef, undef);
 }
 
 sub _table_fk_info {
diff --git a/t/16mssql_common.t b/t/16mssql_common.t
index 114d991..7c2d37f 100644
--- a/t/16mssql_common.t
+++ b/t/16mssql_common.t
@@ -84,7 +84,7 @@ my $tester = dbixcsl_common_tests->new(
             'mssql_loader_test5',
             'mssql_loader_test6',
         ],
-        count  => 11,
+        count  => 10,
         run    => sub {
             my ($schema, $monikers, $classes) = @_;
 
@@ -105,8 +105,9 @@ my $tester = dbixcsl_common_tests->new(
             ok ((my $rsrc = $schema->resultset($monikers->{mssql_loader_test5})->result_source),
                 'got result_source');
 
-            is $rsrc->name, 'mssql_loader_test5',
-                'table name is lowercased';
+## not anymore
+#            is $rsrc->name, 'mssql_loader_test5',
+#                'table name is lowercased';
 
             is_deeply [ $rsrc->columns ], [qw/id foocol barcol/],
                 'column names are lowercased';
diff --git a/t/backcompat/0.04006/lib/dbixcsl_common_tests.pm b/t/backcompat/0.04006/lib/dbixcsl_common_tests.pm
index 5dd3ba2..7e046fc 100644
--- a/t/backcompat/0.04006/lib/dbixcsl_common_tests.pm
+++ b/t/backcompat/0.04006/lib/dbixcsl_common_tests.pm
@@ -665,7 +665,7 @@ sub create {
                 dat VARCHAR(8),
                 from_id INTEGER,
                 to_id INTEGER,
-                PRIMARY KEY (id1,id2)
+                PRIMARY KEY (id1,id2),
                 FOREIGN KEY (from_id) REFERENCES loader_test4 (id),
                 FOREIGN KEY (to_id) REFERENCES loader_test4 (id)
             ) $self->{innodb}
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 6b0a0d7..1074d35 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -1366,6 +1366,7 @@ sub create {
     );
 
     $self->drop_tables;
+    $self->drop_tables; # twice for good measure
 
     my $dbh = $self->dbconnect(1);