[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / MSSQL.pm

package DBIx::Class::Schema::Loader::DBI::MSSQL;

use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
use mro 'c3';
use Try::Tiny;
use List::MoreUtils 'any';
use namespace::clean;

use DBIx::Class::Schema::Loader::Table::Sybase ();

our $VERSION = '0.07011';

=head1 NAME

DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.

=head1 DESCRIPTION

Base driver for Microsoft SQL Server, used by
L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> for support
via L<DBD::Sybase> and
L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server> for support via
L<DBD::ODBC>.

See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for
usage information.

=head1 CASE SENSITIVITY

Most MSSQL databases use C<CI> (case-insensitive) collation, for this reason
generated column names are lower-cased as this makes them easier to work with
in L<DBIx::Class>.

We attempt to detect the database collation at startup for any database
included in L<db_schema|DBIx::Class::Schema::Loader::Base/db_schema>, and set
the column lowercasing behavior accordingly, as lower-cased column names do not
work on case-sensitive databases.

To manually control case-sensitive mode, put:

    preserve_case => 1|0

in your Loader options.

See L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case>.

B<NOTE:> this option used to be called C<case_sensitive_collation>, but has
been renamed to a more generic option.

=cut

sub _system_databases {
    return (qw/
        master model tempdb msdb
    /);
}

sub _system_tables {
    return (qw/
        spt_fallback_db spt_fallback_dev spt_fallback_usg spt_monitor spt_values MSreplication_options
    /);
}

sub _owners {
    my ($self, $db) = @_;

    my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT name
FROM [$db].dbo.sysusers
WHERE uid <> gid
EOF

    return grep !/^(?:#|guest|INFORMATION_SCHEMA|sys)/, @$owners;
}

sub _setup {
    my $self = shift;

    $self->next::method(@_);

    my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');

    if (ref $self->db_schema eq 'HASH') {
        if (keys %{ $self->db_schema } < 2) {
            my ($db) = keys %{ $self->db_schema };

            $db ||= $current_db;

            if ($db eq '%') {
                my $owners = $self->db_schema->{$db};

                my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
SELECT name
FROM master.dbo.sysdatabases
EOF

                my @dbs;

                foreach my $db_name (@$db_names) {
                    push @dbs, $db_name
                        unless any { $_ eq $db_name } $self->_system_databases;
                }

                $self->db_schema({});

                DB: foreach my $db (@dbs) {
                    if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
                        my @owners;

                        foreach my $owner (@$owners) {
                            push @owners, $owner
                                if $self->dbh->selectrow_array(<<"EOF");
SELECT name
FROM [$db].dbo.sysusers
WHERE name = @{[ $self->dbh->quote($owner) ]}
EOF
                        }

                        next DB unless @owners;

                        $self->db_schema->{$db} = \@owners;
                    }
                    else {
                        # for post-processing below
                        $self->db_schema->{$db} = '%';
                    }
                }

                $self->qualify_objects(1);
            }
            else {
                if ($db ne $current_db) {
                    $self->dbh->do("USE [$db]");

                    $self->qualify_objects(1);
                }
            }
        }
        else {
            $self->qualify_objects(1);
        }
    }
    elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
        my $owners = $self->db_schema;
        $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ];

        $self->qualify_objects(1) if @$owners > 1;

        $self->db_schema({ $current_db => $owners });
    }

    foreach my $db (keys %{ $self->db_schema }) {
        if ($self->db_schema->{$db} eq '%') {
            $self->db_schema->{$db} = [ $self->_owners($db) ];

            $self->qualify_objects(1);
        }
    }

    if (not defined $self->preserve_case) {
        foreach my $db (keys %{ $self->db_schema }) {
            # We use the sys.databases query for the general case, and fallback to
            # databasepropertyex() if for some reason sys.databases is not available,
            # which does not work over DBD::ODBC with unixODBC+FreeTDS.
            #
            # XXX why does databasepropertyex() not work over DBD::ODBC ?
            #
            # more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
            my ($collation_name) =
                   eval { $self->dbh->selectrow_array("SELECT collation_name FROM sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") }
                || eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") };

            if (not $collation_name) {
                warn <<"EOF";

WARNING: MSSQL Collation detection failed for database '$db'. Defaulting to
case-insensitive mode. Override the 'preserve_case' attribute in your Loader
options if needed.

See 'preserve_case' in
perldoc DBIx::Class::Schema::Loader::Base
EOF
                $self->preserve_case(0) unless $self->preserve_case;
            }
            else {
                my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/;

                if ($case_sensitive && (not $self->preserve_case)) {
                    $self->preserve_case(1);
                }
                else {
                    $self->preserve_case(0);
                }
            }
        }
    }
}

sub _tables_list {
    my ($self, $opts) = @_;

    my @tables;

    while (my ($db, $owners) = each %{ $self->db_schema }) {
        foreach my $owner (@$owners) {
            my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT table_name
FROM [$db].INFORMATION_SCHEMA.TABLES
WHERE table_schema = @{[ $self->dbh->quote($owner) ]}
EOF

            TABLE: foreach my $table_name (@$table_names) {
                next TABLE if any { $_ eq $table_name } $self->_system_tables;

                push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
                    loader   => $self,
                    name     => $table_name,
                    database => $db,
                    schema   => $owner,
                );
            }
        }
    }

    return $self->_filter_tables(\@tables, $opts);
}

sub _table_pk_info {
    my ($self, $table) = @_;

    my $db = $table->database;

    return $self->dbh->selectcol_arrayref(<<"EOF")
SELECT kcu.column_name
FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
    ON kcu.table_name = tc.table_name
        AND kcu.table_schema = tc.table_schema
        AND kcu.constraint_name = tc.constraint_name
WHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
    AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
    AND tc.constraint_type = 'PRIMARY KEY'
ORDER BY kcu.ordinal_position
EOF
}

sub _table_fk_info {
    my ($self, $table) = @_;

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name
FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc
JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
    ON rc.constraint_name = fk_tc.constraint_name
        AND rc.constraint_schema = fk_tc.table_schema
JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu
    ON fk_kcu.constraint_name = fk_tc.constraint_name
        AND fk_kcu.table_name = fk_tc.table_name
        AND fk_kcu.table_schema = fk_tc.table_schema 
JOIN [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc
    ON uk_tc.constraint_name = rc.unique_constraint_name
        AND uk_tc.table_schema = rc.unique_constraint_schema
JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu
    ON uk_kcu.constraint_name = rc.unique_constraint_name
        AND uk_kcu.ordinal_position = fk_kcu.ordinal_position
        AND uk_kcu.table_name = uk_tc.table_name
        AND uk_kcu.table_schema = rc.unique_constraint_schema
WHERE fk_tc.table_name = @{[ $self->dbh->quote($table->name) ]}
    AND fk_tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
ORDER BY fk_kcu.ordinal_position
EOF

    $sth->execute;

    my %rels;

    while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) {
        push @{ $rels{$fk}{local_columns}  }, $col;
        push @{ $rels{$fk}{remote_columns} }, $remote_col;
        
        $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new(
            loader   => $self,
            name     => $remote_table,
            database => $db,
            schema   => $remote_schema,
        ) unless exists $rels{$fk}{remote_table};
    }

    return [ values %rels ];
}

sub _table_uniq_info {
    my ($self, $table) = @_;

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT tc.constraint_name, kcu.column_name
FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
    ON kcu.constraint_name = tc.constraint_name
        AND kcu.table_name = tc.table_name
        AND kcu.table_schema = tc.table_schema
wHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
    AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
    AND tc.constraint_type = 'UNIQUE'
ORDER BY kcu.ordinal_position
EOF

    $sth->execute;

    my %uniq;

    while (my ($constr, $col) = $sth->fetchrow_array) {
        push @{ $uniq{$constr} }, $self->_lc($col);
    }

    return [ map [ $_ => $uniq{$_} ], keys %uniq ];
}

sub _columns_info_for {
    my $self    = shift;
    my ($table) = @_;

    my $db = $table->database;

    my $result = $self->next::method(@_);

    while (my ($col, $info) = each %$result) {
# get type info
        my ($char_max_length, $data_type, $datetime_precision, $default) =
            $self->dbh->selectrow_array(<<"EOF");
SELECT character_maximum_length, data_type, datetime_precision, column_default
FROM [$db].INFORMATION_SCHEMA.COLUMNS
WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
    AND table_schema = @{[ $self->dbh->quote($table->schema) ]}
    AND column_name = @{[ $self->dbh->quote($col) ]}
EOF

        $info->{data_type} = $data_type;

        if (defined $char_max_length) {
            $info->{size} = $char_max_length;
            $info->{size} = 0 if $char_max_length < 0;
        }

# find identities
        my ($is_identity) = $self->dbh->selectrow_array(<<"EOF");
SELECT is_identity
FROM [$db].sys.columns
WHERE object_id = (
    SELECT object_id
    FROM [$db].sys.objects
    WHERE name = @{[ $self->dbh->quote($table->name) ]}
        AND schema_id = (
            SELECT schema_id
            FROM [$db].sys.schemas
            WHERE name = @{[ $self->dbh->quote($table->schema) ]}
        )
) AND name = @{[ $self->dbh->quote($col) ]}
EOF
        if ($is_identity) {
            $info->{is_auto_increment} = 1;
            $info->{data_type} =~ s/\s*identity//i;
            delete $info->{size};
        }

# fix types
        if ($data_type eq 'int') {
            $info->{data_type} = 'integer';
        }
        elsif ($data_type eq 'timestamp') {
            $info->{inflate_datetime} = 0;
        }
        elsif ($data_type =~ /^(?:numeric|decimal)\z/) {
            if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
                delete $info->{size};
            }
        }
        elsif ($data_type eq 'float') {
            $info->{data_type} = 'double precision';
            delete $info->{size};
        }
        elsif ($data_type =~ /^(?:small)?datetime\z/) {
            # fixup for DBD::Sybase
            if ($info->{default_value} && $info->{default_value} eq '3') {
                delete $info->{default_value};
            }
        }
        elsif ($data_type =~ /^(?:datetime(?:2|offset)|time)\z/) {
            $info->{size} = $datetime_precision;

            delete $info->{size} if $info->{size} == 7;
        }
        elsif ($data_type eq 'varchar'   && $info->{size} == 0) {
            $info->{data_type} = 'text';
            delete $info->{size};
        }
        elsif ($data_type eq 'nvarchar'  && $info->{size} == 0) {
            $info->{data_type} = 'ntext';
            delete $info->{size};
        }
        elsif ($data_type eq 'varbinary' && $info->{size} == 0) {
            $info->{data_type} = 'image';
            delete $info->{size};
        }

        if ($data_type !~ /^(?:n?char|n?varchar|binary|varbinary|numeric|decimal|float|datetime(?:2|offset)|time)\z/) {
            delete $info->{size};
        }

        if (defined $default) {
            # strip parens
            $default =~ s/^\( (.*) \)\z/$1/x;

            # Literal strings are in ''s, numbers are in ()s (in some versions of
            # MSSQL, in others they are unquoted) everything else is a function.
            $info->{default_value} =
                $default =~ /^['(] (.*) [)']\z/x ? $1 :
                    $default =~ /^\d/ ? $default : \$default;

            if ((eval { lc ${ $info->{default_value} } }||'') eq 'getdate()') {
                ${ $info->{default_value} } = 'current_timestamp';

                my $getdate = 'getdate()';
                $info->{original}{default_value} = \$getdate;
            }
        }
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
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;
# vim:et sts=4 sw=4 tw=0:
Commit	Line	Data
fe67d343	1	package DBIx::Class::Schema::Loader::DBI::MSSQL;
	2
	3	use strict;
	4	use warnings;
de82711a	5	use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
942bd5e0	6	use mro 'c3';
afcd3c32	7	use Try::Tiny;
c4a69b87	8	use List::MoreUtils 'any';
afcd3c32	9	use namespace::clean;
fe67d343	10
c4a69b87	11	use DBIx::Class::Schema::Loader::Table::Sybase ();
c4a69b87	12
8e6c80c9	13	our $VERSION = '0.07011';
fe67d343	14
	15	=head1 NAME
	16
	17	DBIx::Class::Schema::Loader::DBI::MSSQL - DBIx::Class::Schema::Loader::DBI MSSQL Implementation.
	18
acfcc1fb	19	=head1 DESCRIPTION
fe67d343	20
acfcc1fb	21	Base driver for Microsoft SQL Server, used by
	22	L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> for support
	23	via L<DBD::Sybase> and
	24	L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server> for support via
	25	L<DBD::ODBC>.
fe67d343	26
acfcc1fb	27	See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base> for
acfcc1fb	28	usage information.
fe67d343	29
b065e3df	30	=head1 CASE SENSITIVITY
	31
	32	Most MSSQL databases use C<CI> (case-insensitive) collation, for this reason
	33	generated column names are lower-cased as this makes them easier to work with
	34	in L<DBIx::Class>.
	35
c4a69b87	36	We attempt to detect the database collation at startup for any database
	37	included in L<db_schema\|DBIx::Class::Schema::Loader::Base/db_schema>, and set
	38	the column lowercasing behavior accordingly, as lower-cased column names do not
	39	work on case-sensitive databases.
b065e3df	40
81ade4d9	41	To manually control case-sensitive mode, put:
b065e3df	42
bc1cb85e	43	preserve_case => 1\|0
b065e3df	44
103e90da	45	in your Loader options.
b065e3df	46
bc1cb85e	47	See L<preserve_case\|DBIx::Class::Schema::Loader::Base/preserve_case>.
fe67d343	48
bc1cb85e	49	B<NOTE:> this option used to be called C<case_sensitive_collation>, but has
bc1cb85e	50	been renamed to a more generic option.
3559ae79	51
bc1cb85e	52	=cut
3559ae79	53
c4a69b87	54	sub _system_databases {
	55	return (qw/
	56	master model tempdb msdb
	57	/);
	58	}
	59
	60	sub _system_tables {
	61	return (qw/
	62	spt_fallback_db spt_fallback_dev spt_fallback_usg spt_monitor spt_values MSreplication_options
	63	/);
	64	}
	65
	66	sub _owners {
	67	my ($self, $db) = @_;
	68
	69	my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
	70	SELECT name
	71	FROM [$db].dbo.sysusers
	72	WHERE uid <> gid
	73	EOF
	74
	75	return grep !/^(?:#\|guest\|INFORMATION_SCHEMA\|sys)/, @$owners;
	76	}
	77
3559ae79	78	sub _setup {
	79	my $self = shift;
	80
bc1cb85e	81	$self->next::method(@_);
3559ae79	82
c4a69b87	83	my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
b065e3df	84
c4a69b87	85	if (ref $self->db_schema eq 'HASH') {
	86	if (keys %{ $self->db_schema } < 2) {
	87	my ($db) = keys %{ $self->db_schema };
3559ae79	88
c4a69b87	89	$db \|\|= $current_db;
b7a0a040	90
c4a69b87	91	if ($db eq '%') {
c4a69b87	92	my $owners = $self->db_schema->{$db};
b065e3df	93
c4a69b87	94	my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
	95	SELECT name
	96	FROM master.dbo.sysdatabases
	97	EOF
bc1cb85e	98
c4a69b87	99	my @dbs;
	100
	101	foreach my $db_name (@$db_names) {
	102	push @dbs, $db_name
	103	unless any { $_ eq $db_name } $self->_system_databases;
	104	}
	105
	106	$self->db_schema({});
	107
	108	DB: foreach my $db (@dbs) {
	109	if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') \|\| $owners eq '%')) {
	110	my @owners;
	111
	112	foreach my $owner (@$owners) {
	113	push @owners, $owner
	114	if $self->dbh->selectrow_array(<<"EOF");
	115	SELECT name
	116	FROM [$db].dbo.sysusers
	117	WHERE name = @{[ $self->dbh->quote($owner) ]}
b065e3df	118	EOF
c4a69b87	119	}
	120
	121	next DB unless @owners;
	122
	123	$self->db_schema->{$db} = \@owners;
	124	}
	125	else {
	126	# for post-processing below
	127	$self->db_schema->{$db} = '%';
	128	}
	129	}
	130
	131	$self->qualify_objects(1);
	132	}
	133	else {
	134	if ($db ne $current_db) {
	135	$self->dbh->do("USE [$db]");
	136
	137	$self->qualify_objects(1);
	138	}
	139	}
	140	}
	141	else {
	142	$self->qualify_objects(1);
	143	}
	144	}
	145	elsif (ref $self->db_schema eq 'ARRAY' \|\| (not defined $self->db_schema)) {
	146	my $owners = $self->db_schema;
	147	$owners \|\|= [ $self->dbh->selectrow_array('SELECT user_name()') ];
	148
	149	$self->qualify_objects(1) if @$owners > 1;
	150
	151	$self->db_schema({ $current_db => $owners });
b7a0a040	152	}
3559ae79	153
c4a69b87	154	foreach my $db (keys %{ $self->db_schema }) {
	155	if ($self->db_schema->{$db} eq '%') {
	156	$self->db_schema->{$db} = [ $self->_owners($db) ];
	157
	158	$self->qualify_objects(1);
	159	}
	160	}
3559ae79	161
c4a69b87	162	if (not defined $self->preserve_case) {
	163	foreach my $db (keys %{ $self->db_schema }) {
	164	# We use the sys.databases query for the general case, and fallback to
	165	# databasepropertyex() if for some reason sys.databases is not available,
	166	# which does not work over DBD::ODBC with unixODBC+FreeTDS.
	167	#
	168	# XXX why does databasepropertyex() not work over DBD::ODBC ?
	169	#
	170	# more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
	171	my ($collation_name) =
	172	eval { $self->dbh->selectrow_array("SELECT collation_name FROM sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") }
	173	\|\| eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") };
	174
	175	if (not $collation_name) {
	176	warn <<"EOF";
	177
	178	WARNING: MSSQL Collation detection failed for database '$db'. Defaulting to
	179	case-insensitive mode. Override the 'preserve_case' attribute in your Loader
	180	options if needed.
	181
	182	See 'preserve_case' in
	183	perldoc DBIx::Class::Schema::Loader::Base
	184	EOF
	185	$self->preserve_case(0) unless $self->preserve_case;
	186	}
	187	else {
	188	my $case_sensitive = $collation_name =~ /_(?:CS\|BIN2?)(?:_\|\z)/;
	189
	190	if ($case_sensitive && (not $self->preserve_case)) {
	191	$self->preserve_case(1);
	192	}
	193	else {
	194	$self->preserve_case(0);
	195	}
	196	}
	197	}
	198	}
3559ae79	199	}
3559ae79	200
acfcc1fb	201	sub _tables_list {
bfb43060	202	my ($self, $opts) = @_;
fe67d343	203
c4a69b87	204	my @tables;
	205
	206	while (my ($db, $owners) = each %{ $self->db_schema }) {
	207	foreach my $owner (@$owners) {
	208	my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
	209	SELECT table_name
	210	FROM [$db].INFORMATION_SCHEMA.TABLES
	211	WHERE table_schema = @{[ $self->dbh->quote($owner) ]}
acfcc1fb	212	EOF
fe67d343	213
c4a69b87	214	TABLE: foreach my $table_name (@$table_names) {
	215	next TABLE if any { $_ eq $table_name } $self->_system_tables;
	216
	217	push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
	218	loader => $self,
	219	name => $table_name,
	220	database => $db,
	221	schema => $owner,
	222	);
	223	}
	224	}
	225	}
acfcc1fb	226
bfb43060	227	return $self->_filter_tables(\@tables, $opts);
acfcc1fb	228	}
fe67d343	229
fe67d343	230	sub _table_pk_info {
fe67d343	231	my ($self, $table) = @_;
fe67d343	232
c4a69b87	233	my $db = $table->database;
	234
	235	return $self->dbh->selectcol_arrayref(<<"EOF")
	236	SELECT kcu.column_name
	237	FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
	238	JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
	239	ON kcu.table_name = tc.table_name
	240	AND kcu.table_schema = tc.table_schema
	241	AND kcu.constraint_name = tc.constraint_name
	242	WHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
	243	AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
	244	AND tc.constraint_type = 'PRIMARY KEY'
	245	ORDER BY kcu.ordinal_position
	246	EOF
fe67d343	247	}
	248
	249	sub _table_fk_info {
	250	my ($self, $table) = @_;
	251
c4a69b87	252	my $db = $table->database;
	253
	254	my $sth = $self->dbh->prepare(<<"EOF");
	255	SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name, fk_kcu.column_name, uk_kcu.column_name
	256	FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc
	257	JOIN [$db].INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
	258	ON rc.constraint_name = fk_tc.constraint_name
	259	AND rc.constraint_schema = fk_tc.table_schema
	260	JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu
	261	ON fk_kcu.constraint_name = fk_tc.constraint_name
	262	AND fk_kcu.table_name = fk_tc.table_name
	263	AND fk_kcu.table_schema = fk_tc.table_schema
	264	JOIN [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc
	265	ON uk_tc.constraint_name = rc.unique_constraint_name
	266	AND uk_tc.table_schema = rc.unique_constraint_schema
	267	JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu
	268	ON uk_kcu.constraint_name = rc.unique_constraint_name
	269	AND uk_kcu.ordinal_position = fk_kcu.ordinal_position
	270	AND uk_kcu.table_name = uk_tc.table_name
	271	AND uk_kcu.table_schema = rc.unique_constraint_schema
	272	WHERE fk_tc.table_name = @{[ $self->dbh->quote($table->name) ]}
	273	AND fk_tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
	274	ORDER BY fk_kcu.ordinal_position
	275	EOF
fe67d343	276
c4a69b87	277	$sth->execute;
fe67d343	278
c4a69b87	279	my %rels;
	280
	281	while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) {
	282	push @{ $rels{$fk}{local_columns} }, $col;
	283	push @{ $rels{$fk}{remote_columns} }, $remote_col;
	284
	285	$rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new(
	286	loader => $self,
	287	name => $remote_table,
	288	database => $db,
	289	schema => $remote_schema,
	290	) unless exists $rels{$fk}{remote_table};
fe67d343	291	}
c4a69b87	292
c4a69b87	293	return [ values %rels ];
fe67d343	294	}
	295
	296	sub _table_uniq_info {
	297	my ($self, $table) = @_;
	298
c4a69b87	299	my $db = $table->database;
	300
	301	my $sth = $self->dbh->prepare(<<"EOF");
	302	SELECT tc.constraint_name, kcu.column_name
	303	FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
	304	JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
	305	ON kcu.constraint_name = tc.constraint_name
	306	AND kcu.table_name = tc.table_name
	307	AND kcu.table_schema = tc.table_schema
	308	wHERE tc.table_name = @{[ $self->dbh->quote($table->name) ]}
	309	AND tc.table_schema = @{[ $self->dbh->quote($table->schema) ]}
	310	AND tc.constraint_type = 'UNIQUE'
	311	ORDER BY kcu.ordinal_position
	312	EOF
020f3c3a	313
fe67d343	314	$sth->execute;
c4a69b87	315
	316	my %uniq;
	317
	318	while (my ($constr, $col) = $sth->fetchrow_array) {
	319	push @{ $uniq{$constr} }, $self->_lc($col);
fe67d343	320	}
fe67d343	321
c4a69b87	322	return [ map [ $_ => $uniq{$_} ], keys %uniq ];
fe67d343	323	}
fe67d343	324
9c9197d6	325	sub _columns_info_for {
	326	my $self = shift;
	327	my ($table) = @_;
	328
c4a69b87	329	my $db = $table->database;
9c9197d6	330
c4a69b87	331	my $result = $self->next::method(@_);
afcd3c32	332
9c9197d6	333	while (my ($col, $info) = each %$result) {
afcd3c32	334	# get type info
c4a69b87	335	my ($char_max_length, $data_type, $datetime_precision, $default) =
	336	$self->dbh->selectrow_array(<<"EOF");
	337	SELECT character_maximum_length, data_type, datetime_precision, column_default
	338	FROM [$db].INFORMATION_SCHEMA.COLUMNS
	339	WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
	340	AND table_schema = @{[ $self->dbh->quote($table->schema) ]}
	341	AND column_name = @{[ $self->dbh->quote($col) ]}
	342	EOF
afcd3c32	343
	344	$info->{data_type} = $data_type;
	345
	346	if (defined $char_max_length) {
	347	$info->{size} = $char_max_length;
	348	$info->{size} = 0 if $char_max_length < 0;
	349	}
020f3c3a	350
81ade4d9	351	# find identities
c4a69b87	352	my ($is_identity) = $self->dbh->selectrow_array(<<"EOF");
	353	SELECT is_identity
	354	FROM [$db].sys.columns
	355	WHERE object_id = (
	356	SELECT object_id
	357	FROM [$db].sys.objects
	358	WHERE name = @{[ $self->dbh->quote($table->name) ]}
	359	AND schema_id = (
	360	SELECT schema_id
	361	FROM [$db].sys.schemas
	362	WHERE name = @{[ $self->dbh->quote($table->schema) ]}
	363	)
	364	) AND name = @{[ $self->dbh->quote($col) ]}
	365	EOF
	366	if ($is_identity) {
9c9197d6	367	$info->{is_auto_increment} = 1;
	368	$info->{data_type} =~ s/\s*identity//i;
	369	delete $info->{size};
	370	}
fe67d343	371
81ade4d9	372	# fix types
afcd3c32	373	if ($data_type eq 'int') {
81ade4d9	374	$info->{data_type} = 'integer';
81ade4d9	375	}
afcd3c32	376	elsif ($data_type eq 'timestamp') {
81ade4d9	377	$info->{inflate_datetime} = 0;
81ade4d9	378	}
afcd3c32	379	elsif ($data_type =~ /^(?:numeric\|decimal)\z/) {
81ade4d9	380	if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
	381	delete $info->{size};
	382	}
	383	}
afcd3c32	384	elsif ($data_type eq 'float') {
81ade4d9	385	$info->{data_type} = 'double precision';
afcd3c32	386	delete $info->{size};
81ade4d9	387	}
afcd3c32	388	elsif ($data_type =~ /^(?:small)?datetime\z/) {
81ade4d9	389	# fixup for DBD::Sybase
	390	if ($info->{default_value} && $info->{default_value} eq '3') {
	391	delete $info->{default_value};
	392	}
	393	}
afcd3c32	394	elsif ($data_type =~ /^(?:datetime(?:2\|offset)\|time)\z/) {
ae38ed69	395	$info->{size} = $datetime_precision;
81ade4d9	396
	397	delete $info->{size} if $info->{size} == 7;
	398	}
afcd3c32	399	elsif ($data_type eq 'varchar' && $info->{size} == 0) {
ae38ed69	400	$info->{data_type} = 'text';
ae38ed69	401	delete $info->{size};
81ade4d9	402	}
afcd3c32	403	elsif ($data_type eq 'nvarchar' && $info->{size} == 0) {
ae38ed69	404	$info->{data_type} = 'ntext';
	405	delete $info->{size};
	406	}
afcd3c32	407	elsif ($data_type eq 'varbinary' && $info->{size} == 0) {
ae38ed69	408	$info->{data_type} = 'image';
ae38ed69	409	delete $info->{size};
81ade4d9	410	}
81ade4d9	411
afcd3c32	412	if ($data_type !~ /^(?:n?char\|n?varchar\|binary\|varbinary\|numeric\|decimal\|float\|datetime(?:2\|offset)\|time)\z/) {
81ade4d9	413	delete $info->{size};
	414	}
	415
9c9197d6	416	if (defined $default) {
	417	# strip parens
	418	$default =~ s/^\( (.*) \)\z/$1/x;
	419
	420	# Literal strings are in ''s, numbers are in ()s (in some versions of
	421	# MSSQL, in others they are unquoted) everything else is a function.
	422	$info->{default_value} =
	423	$default =~ /^['(] (.*) [)']\z/x ? $1 :
	424	$default =~ /^\d/ ? $default : \$default;
8a64178e	425
268cc246	426	if ((eval { lc ${ $info->{default_value} } }\|\|'') eq 'getdate()') {
6e566cc4	427	${ $info->{default_value} } = 'current_timestamp';
701cd3e3	428
	429	my $getdate = 'getdate()';
	430	$info->{original}{default_value} = \$getdate;
8a64178e	431	}
9c9197d6	432	}
5c6fb0a1	433	}
5c6fb0a1	434
9c9197d6	435	return $result;
fe67d343	436	}
fe67d343	437
fe67d343	438	=head1 SEE ALSO
fe67d343	439
acfcc1fb	440	L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
acfcc1fb	441	L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
fe67d343	442	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	443	L<DBIx::Class::Schema::Loader::DBI>
	444
	445	=head1 AUTHOR
	446
9cc8e7e1	447	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
fe67d343	448
be80bba7	449	=head1 LICENSE
0852b7b8	450
be80bba7	451	This library is free software; you can redistribute it and/or modify it under
be80bba7	452	the same terms as Perl itself.
0852b7b8	453
fe67d343	454	=cut
	455
	456	1;
bfb43060	457	# vim:et sts=4 sw=4 tw=0: