From: Justin Hunter <justin.d.hunter@gmail.com>
Date: Mon, 20 Apr 2009 22:53:43 +0000 (+0000)
Subject: initial import of Sybase/MSSQL support
X-Git-Tag: 0.04999_08~22
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fe67d3434ad62ea06e1a483429cb07c744d6c70d;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

initial import of Sybase/MSSQL support
---

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
new file mode 100644
index 0000000..3409bf7
--- /dev/null
+++ b/lib/DBIx/Class/Schema/Loader/DBI/MSSQL.pm
@@ -0,0 +1,130 @@
+package DBIx::Class::Schema::Loader::DBI::MSSQL;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema::Loader::DBI';
+use Carp::Clan qw/^DBIx::Class/;
+use Class::C3;
+
+our $VERSION = '0.04999_06';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
+
+=head1 SYNOPSIS
+
+  package My::Schema;
+  use base qw/DBIx::Class::Schema::Loader/;
+
+  __PACKAGE__->loader_options( debug => 1 );
+
+  1;
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base>.
+
+=cut
+
+sub _setup {
+    my $self = shift;
+
+    $self->next::method(@_);
+    $self->{db_schema} ||= 'dbo';
+}
+
+sub _table_pk_info {
+    my ($self, $table) = @_;
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
+    $sth->execute;
+
+    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(qq{sp_fkeys \@FKTABLE_NAME = '$table'});
+    $sth->execute;
+
+    while (my $row = $sth->fetchrow_hashref) {
+      my $fk = $row->{FK_NAME};
+      push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME};
+      push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME};
+      $remote_table->{$fk} = $row->{PKTABLE_NAME};
+    }
+
+    foreach my $fk (keys %$remote_table) {
+      push @rels, {
+                    local_columns => \@{$local_cols->{$fk}},
+                    remote_columns => \@{$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(qq{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 CCU.TABLE_NAME = '$table' AND CONSTRAINT_TYPE = 'UNIQUE' ORDER BY KCU.ORDINAL_POSITION});
+    $sth->execute;
+    my $constraints;
+    while (my $row = $sth->fetchrow_hashref) {
+        my $name = lc $row->{CONSTRAINT_NAME};
+        my $col  = lc $row->{COLUMN_NAME};
+        push @{$constraints->{$name}}, $col;
+    }
+
+    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
+    return \@uniqs;
+}
+
+sub _extra_column_info {
+    my ($self, $info) = @_;
+    my %extra_info;
+
+    my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
+
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(qq{SELECT COLUMN_NAME 
+                               FROM INFORMATION_SCHEMA.COLUMNS
+                               WHERE COLUMNPROPERTY(object_id('$table', 'U'), '$column', 'IsIdentity') = 1 AND TABLE_NAME = '$table' AND COLUMN_NAME = '$column'
+                              });
+    $sth->execute();
+
+    if ($sth->fetchrow_array) {
+        $extra_info{is_auto_increment} = 1;
+    }
+
+    return \%extra_info;
+}
+
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+Justin Hunter C<justin.d.hunter@gmail.com>
+
+=cut
+
+1;
diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
new file mode 100644
index 0000000..4c7b7f3
--- /dev/null
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm
@@ -0,0 +1,157 @@
+package DBIx::Class::Schema::Loader::DBI::Sybase;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema::Loader::DBI';
+use Carp::Clan qw/^DBIx::Class/;
+use Class::C3;
+
+our $VERSION = '0.04999_06';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI Sybase Implementation.
+
+=head1 SYNOPSIS
+
+  package My::Schema;
+  use base qw/DBIx::Class::Schema::Loader/;
+
+  __PACKAGE__->loader_options( debug => 1 );
+
+  1;
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base>.
+
+=cut
+
+sub _setup {
+    my $self = shift;
+
+    $self->next::method(@_);
+    $self->{db_schema} ||= 'dbo';
+}
+
+sub _rebless {
+    my $self = shift;
+
+    my $dbh = $self->schema->storage->dbh;
+    my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
+    if ($DBMS_VERSION =~ /^Microsoft /i) {
+      my $subclass = 'DBIx::Class::Schema::Loader::DBI::MSSQL';
+      if ($self->load_optional_class($subclass)) {
+        bless $self, $subclass unless $self->isa($subclass);
+        $self->_rebless;
+      }
+    }
+}
+
+sub _table_columns {
+    my ($self, $table) = @_;
+
+    my $dbh = $self->schema->storage->dbh;
+    my $columns = $dbh->selectcol_arrayref(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = '$table' AND type = 'U')});
+
+    return $columns;
+}
+
+sub _table_pk_info {
+    my ($self, $table) = @_;
+
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
+    $sth->execute;
+
+    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;
+    # hide "Object does not exist in this database." when trying to fetch fkeys
+    $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; }; 
+    my $sth = $dbh->prepare(qq{sp_fkeys \@FKTABLE_NAME = '$table'});
+    $sth->execute;
+
+    while (my $row = $sth->fetchrow_hashref) {
+      next unless $row->{FK_NAME};
+      my $fk = $row->{FK_NAME};
+      push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME};
+      push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME};
+      $remote_table->{$fk} = $row->{PKTABLE_NAME};
+    }
+
+    foreach my $fk (keys %$remote_table) {
+      push @rels, {
+                    local_columns => \@{$local_cols->{$fk}},
+                    remote_columns => \@{$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(qq{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 CCU.TABLE_NAME = '$table' AND CONSTRAINT_TYPE = 'UNIQUE' ORDER BY KCU.ORDINAL_POSITION});
+    my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname='$table', \@nomsg='nomsg'});
+    $sth->execute;
+
+    my $constraints;
+    while (my $row = $sth->fetchrow_hashref) {
+        my $type = $row->{constraint_type} || '';
+        if ($type =~ /^unique/i) {
+          my $name = lc $row->{constraint_name};
+          push @{$constraints->{$name}}, ( split /,/, lc $row->{constraint_keys} );
+        }
+    }
+
+    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
+    return \@uniqs;
+}
+
+sub _extra_column_info {
+    my ($self, $info) = @_;
+    my %extra_info;
+
+    my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
+
+    my $dbh = $self->schema->storage->dbh;
+    my $sth = $dbh->prepare(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = '$table') AND (status & 0x80) = 0x80 AND name = '$column'});
+    $sth->execute();
+
+    if ($sth->fetchrow_array) {
+        $extra_info{is_auto_increment} = 1;
+    }
+
+    return \%extra_info;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+Justin Hunter C<justin.d.hunter@gmail.com>
+
+=cut
+
+1;
diff --git a/t/15sybase_common.t b/t/15sybase_common.t
new file mode 100644
index 0000000..4995752
--- /dev/null
+++ b/t/15sybase_common.t
@@ -0,0 +1,23 @@
+use strict;
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+my $dsn      = $ENV{DBICTEST_SYBASE_DSN} || '';
+my $user     = $ENV{DBICTEST_SYBASE_USER} || '';
+my $password = $ENV{DBICTEST_SYBASE_PASS} || '';
+
+my $tester = dbixcsl_common_tests->new(
+    vendor      => 'Sybase',
+    quote_char  => [qw/[ ]/],
+    auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
+    dsn         => $dsn,
+    user        => $user,
+    password    => $password,
+);
+
+if( !$dsn || !$user ) {
+    $tester->skip_tests('You need to set the DBICTEST_SYBASE_DSN, _USER, and _PASS environment variables');
+}
+else {
+    $tester->run_tests();
+}