From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 15 Feb 2010 10:13:42 +0000 (-0500)
Subject: support for SQL Anywhere
X-Git-Tag: 0.05002~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=8793567fbf7e508f772a464328f321caa243b45d

support for SQL Anywhere
---

diff --git a/Changes b/Changes
index 9b8934d..2c892eb 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - support for SQLAnywhere via DBD::SQLAnywhere and ODBC
         - fix picking up quoted tables for SQLite, patch from schwern
         - validate class/component loader_options to make sure classes
           are available before generating the schema
diff --git a/Makefile.PL b/Makefile.PL
index f4b33e9..d097dd9 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -27,6 +27,8 @@ requires 'Class::Inspector'            => 0;
 requires 'DBIx::Class'                 => '0.08114';
 requires 'Class::Unload'               => 0;
 requires 'File::Slurp'                 => '9999.13';
+requires 'List::MoreUtils'             => 0;
+requires 'namespace::autoclean'        => 0;
 
 install_script 'script/dbicdump';
 
@@ -94,7 +96,7 @@ my $_features = [
         ],
     },
     MSSQL => {
-        label => 'Microsoft SQL Server Support via DBD::Sybase (experimental)',
+        label => 'Microsoft SQL Server Support via DBD::Sybase',
         def   => $ENV{DBIC_FEATURE_MSSQL} || 0,
         deps  => [
             'DBI'         => '1.56',
@@ -102,7 +104,7 @@ my $_features = [
         ],
     },
     MSSQL_ODBC => {
-        label => 'Microsoft SQL Server Support via DBD::ODBC (experimental)',
+        label => 'Microsoft SQL Server Support via DBD::ODBC',
         def   => $ENV{DBIC_FEATURE_MSSQL} || 0,
         deps  => [
             'DBI'       => '1.56',
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
index 814ef1b..10415ce 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm
@@ -10,14 +10,11 @@ our $VERSION = '0.05001';
 
 =head1 NAME
 
-DBIx::Class::Schema::Loader::DBI::ODBC - L<DBD::ODBC> proxy, currently only for
-Microsoft SQL Server
+DBIx::Class::Schema::Loader::DBI::ODBC - L<DBD::ODBC> proxy
 
 =head1 DESCRIPTION
 
-Reblesses into L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
-which is a proxy for L<DBIx::Class::Schema::Loader::DBI::MSSQL> when using the
-L<DBD::ODBC> driver with Microsoft SQL Server.
+Reblesses into an C<::ODBC::> class when connecting via L<DBD::ODBC>.
 
 Code stolen from the L<DBIx::Class> ODBC storage.
 
@@ -27,9 +24,11 @@ See L<DBIx::Class::Schema::Loader::Base> for usage information.
 
 sub _rebless {
   my $self = shift;
-  my $dbh  = $self->schema->storage->dbh;
+
+  return if ref $self ne __PACKAGE__;
 
 # stolen from DBIC ODBC storage
+  my $dbh  = $self->schema->storage->dbh;
   my $dbtype = eval { $dbh->get_info(17) };
   unless ( $@ ) {
     # Translate the backend name into a perl identifier
@@ -42,6 +41,12 @@ sub _rebless {
   }
 }
 
+sub _tables_list { 
+    my $self = shift;
+
+    return $self->next::method(undef, undef);
+}
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm
index f94be10..a807701 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Microsoft_SQL_Server.pm
@@ -2,7 +2,10 @@ package DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server;
 
 use strict;
 use warnings;
-use base 'DBIx::Class::Schema::Loader::DBI::MSSQL';
+use base qw/
+    DBIx::Class::Schema::Loader::DBI::ODBC
+    DBIx::Class::Schema::Loader::DBI::MSSQL
+/;
 use Carp::Clan qw/^DBIx::Class/;
 use Class::C3;
 
@@ -19,14 +22,6 @@ Proxy for L<DBIx::Class::Schema::Loader::DBI::MSSQL> when using L<DBD::ODBC>.
 
 See L<DBIx::Class::Schema::Loader::Base> for usage information.
 
-=cut
-
-sub _tables_list { 
-    my $self = shift;
-
-    return $self->next::method(undef, undef);
-}
-
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader::DBI::MSSQL>,
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm
new file mode 100644
index 0000000..9c99b3e
--- /dev/null
+++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/SQL_Anywhere.pm
@@ -0,0 +1,42 @@
+package DBIx::Class::Schema::Loader::DBI::ODBC::SQL_Anywhere;
+
+use strict;
+use warnings;
+use base qw/
+    DBIx::Class::Schema::Loader::DBI::ODBC
+    DBIx::Class::Schema::Loader::DBI::SQLAnywhere
+/;
+use Carp::Clan qw/^DBIx::Class/;
+use Class::C3;
+
+our $VERSION = '0.05001';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::ODBC::SQL_Anywhere - ODBC wrapper for
+L<DBIx::Class::Schema::Loader::DBI::SQLAnywhere>
+
+=head1 DESCRIPTION
+
+Proxy for L<DBIx::Class::Schema::Loader::DBI::SQLAnywhere> when using L<DBD::ODBC>.
+
+See L<DBIx::Class::Schema::Loader::Base> for usage information.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBI::SQLAnywhere>,
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
new file mode 100644
index 0000000..71933bc
--- /dev/null
+++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm
@@ -0,0 +1,135 @@
+package DBIx::Class::Schema::Loader::DBI::SQLAnywhere;
+
+use strict;
+use warnings;
+use namespace::autoclean;
+use Class::C3;
+use base qw/
+    DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
+    DBIx::Class::Schema::Loader::DBI
+/;
+use Carp::Clan qw/^DBIx::Class/;
+use List::MoreUtils 'uniq';
+
+our $VERSION = '0.05001';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::SQLAnywhere - DBIx::Class::Schema::Loader::DBI
+SQL Anywhere Implementation.
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base>.
+
+=cut
+
+# check for IDENTITY columns
+sub _columns_info_for {
+    my $self   = shift;
+    my $result = $self->next::method(@_);
+
+    while (my ($col, $info) = each %$result) {
+        my $def = $info->{default_value};
+        if (ref $def eq 'SCALAR' && $$def eq 'autoincrement') {
+            delete $info->{default_value};
+            $info->{is_auto_increment} = 1;
+        }
+    }
+
+    return $result;
+}
+
+sub _table_pk_info {
+    my ($self, $table) = @_;
+    my $dbh = $self->schema->storage->dbh;
+    local $dbh->{FetchHashKeyName} = 'NAME_lc';
+    my $sth = $dbh->prepare(qq{sp_pkeys ?});
+    $sth->execute($table);
+
+    my @keydata;
+
+    while (my $row = $sth->fetchrow_hashref) {
+        push @keydata, lc $row->{column_name};
+    }
+
+    return \@keydata;
+}
+
+sub _table_fk_info {
+    my ($self, $table) = @_;
+
+    my ($local_cols, $remote_cols, $remote_table, @rels);
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(<<'EOF');
+select fki.index_name fk_name, fktc.column_name local_column, pkt.table_name remote_table, pktc.column_name remote_column
+from sysfkey fk
+join sysidx    pki  on fk.primary_table_id = pki.table_id  and fk.primary_index_id = pki.index_id
+join sysidx    fki  on fk.foreign_table_id = fki.table_id  and fk.foreign_index_id = fki.index_id
+join systab    pkt  on fk.primary_table_id = pkt.table_id
+join systab    fkt  on fk.foreign_table_id = fkt.table_id
+join sysidxcol pkic on pki.table_id        = pkic.table_id and pki.index_id        = pkic.index_id
+join sysidxcol fkic on fki.table_id        = fkic.table_id and fki.index_id        = fkic.index_id
+join systabcol pktc on pkic.table_id       = pktc.table_id and pkic.column_id      = pktc.column_id
+join systabcol fktc on fkic.table_id       = fktc.table_id and fkic.column_id      = fktc.column_id
+where fkt.table_name = ?
+EOF
+    $sth->execute($table);
+
+    while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
+        push @{$local_cols->{$fk}},  lc $local_col;
+        push @{$remote_cols->{$fk}}, lc $remote_col;
+        $remote_table->{$fk} = lc $remote_tab;
+    }
+
+    foreach my $fk (keys %$remote_table) {
+        push @rels, {
+            local_columns => [ uniq @{ $local_cols->{$fk} } ],
+            remote_columns => [ uniq @{ $remote_cols->{$fk} } ],
+            remote_table => $remote_table->{$fk},
+        };
+    }
+    return \@rels;
+}
+
+sub _table_uniq_info {
+    my ($self, $table) = @_;
+
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(<<'EOF');
+select c.constraint_name, tc.column_name
+from sysconstraint c
+join systab t on c.table_object_id = t.object_id
+join sysidx i on c.ref_object_id = i.object_id
+join sysidxcol ic on i.table_id = ic.table_id and i.index_id = ic.index_id
+join systabcol tc on ic.table_id = tc.table_id and ic.column_id = tc.column_id
+where c.constraint_type = 'U' and t.table_name = ?
+EOF
+    $sth->execute($table);
+
+    my $constraints;
+    while (my ($constraint_name, $column) = $sth->fetchrow_array) {
+        push @{$constraints->{$constraint_name}}, lc $column;
+    }
+
+    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
+    return \@uniqs;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm
index 2491c9b..d13932d 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase/Common.pm
@@ -69,7 +69,7 @@ sub _columns_info_for {
     my $self   = shift;
     my $result = $self->next::method(@_);
 
-    for my $col (keys %$result) {
+    foreach my $col (keys %$result) {
         $result->{$col}->{data_type} =~ s/\s* identity \s*//ix;
     }
 
diff --git a/t/17sybase_asa_common.t b/t/17sybase_asa_common.t
new file mode 100644
index 0000000..625c044
--- /dev/null
+++ b/t/17sybase_asa_common.t
@@ -0,0 +1,26 @@
+use strict;
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+# The default max_cursor_count and max_statement_count settings of 50 are too
+# low to run this test.
+
+my $dsn      = $ENV{DBICTEST_SYBASE_ASA_DSN} || '';
+my $user     = $ENV{DBICTEST_SYBASE_ASA_USER} || '';
+my $password = $ENV{DBICTEST_SYBASE_ASA_PASS} || '';
+
+my $tester = dbixcsl_common_tests->new(
+    vendor      => 'SQLAnywhere',
+    auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
+    default_function => 'current timestamp',
+    dsn         => $dsn,
+    user        => $user,
+    password    => $password,
+);
+
+if( !$dsn ) {
+    $tester->skip_tests('You need to set the DBICTEST_SYBASE_ASA_DSN, _USER, and _PASS environment variables');
+}
+else {
+    $tester->run_tests();
+}
diff --git a/t/17sybase_asa_odbc_common.t b/t/17sybase_asa_odbc_common.t
new file mode 100644
index 0000000..1b42199
--- /dev/null
+++ b/t/17sybase_asa_odbc_common.t
@@ -0,0 +1,26 @@
+use strict;
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+# The default max_cursor_count and max_statement_count settings of 50 are too
+# low to run this test.
+
+my $dsn      = $ENV{DBICTEST_SYBASE_ASA_ODBC_DSN} || '';
+my $user     = $ENV{DBICTEST_SYBASE_ASA_ODBC_USER} || '';
+my $password = $ENV{DBICTEST_SYBASE_ASA_ODBC_PASS} || '';
+
+my $tester = dbixcsl_common_tests->new(
+    vendor      => 'SQLAnywhere',
+    auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
+    default_function => 'current timestamp',
+    dsn         => $dsn,
+    user        => $user,
+    password    => $password,
+);
+
+if( !$dsn ) {
+    $tester->skip_tests('You need to set the DBICTEST_SYBASE_ASA_DSN, _USER, and _PASS environment variables');
+}
+else {
+    $tester->run_tests();
+}
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 57f64f7..6f21ba6 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -1120,7 +1120,7 @@ sub create {
         qq{
             CREATE TABLE loader_test11 (
                 id11 $self->{auto_inc_pk},
-                message VARCHAR(8) DEFAULT 'foo',
+                a_message VARCHAR(8) DEFAULT 'foo',
                 loader_test10 INTEGER $self->{null},
                 FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10)
             ) $self->{innodb}
@@ -1144,7 +1144,7 @@ sub create {
         qq{
             CREATE TABLE loader_test11 (
                 id11 $self->{auto_inc_pk},
-                message VARCHAR(8) DEFAULT 'foo',
+                a_message VARCHAR(8) DEFAULT 'foo',
                 loader_test10 INTEGER $self->{null},
                 FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10)
             ) $self->{innodb}