[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::Util 'any';
use DBIx::Class::Schema::Loader::Table::Sybase ();
use namespace::clean;

our $VERSION = '0.07047';

=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

# SQL Server 2000: Ancient as time itself, but still out in the wild
sub _is_2k {
    return shift->schema->storage->_server_info->{normalized_dbms_version} < 9;
}

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 _schemas {
    my ($self, $db) = @_;

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

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

sub _current_schema {
    my $self = shift;

    if ($self->_is_2k) {
        return ($self->dbh->selectrow_array('SELECT user_name()'))[0];
    }

    return ($self->dbh->selectrow_array('SELECT schema_name()'))[0];
}

sub _current_db {
    my $self = shift;
    return ($self->dbh->selectrow_array('SELECT db_name()'))[0];
}

sub _switch_db {
    my ($self, $db) = @_;
    $self->dbh->do("use [$db]");
}

sub _setup {
    my $self = shift;

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

    my $current_db = $self->_current_db;

    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->_switch_db($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->_current_schema ];

        $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->_schemas($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 $current_db = $self->_current_db;

            $self->_switch_db($db);

            my $collation_name =
                   (eval { $self->dbh->selectrow_array("SELECT collation_name FROM [$db].sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") })[0]
                || (eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") })[0];

            $self->_switch_db($current_db);

            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) = @_;

    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);
}

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

    my $db = $table->database;

    my $pk = $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

    $pk = [ map $self->_lc($_), @$pk ];

    return $pk;
}

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, rc.delete_rule, rc.update_rule
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,
               $delete_rule, $update_rule) = $sth->fetchrow_array) {
        push @{ $rels{$fk}{local_columns}  }, $self->_lc($col);
        push @{ $rels{$fk}{remote_columns} }, $self->_lc($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};

        $rels{$fk}{attrs} ||= {
            on_delete     => uc $delete_rule,
            on_update     => uc $update_rule,
            is_deferrable => 1 # constraints can be temporarily disabled, but DEFERRABLE is not supported
        };
    }

    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{$_} ], sort keys %uniq ];
}

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

    my $db = $table->database;

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

    # get type info (and identity)
    my $rows = $self->dbh->selectall_arrayref($self->_is_2k ? <<"EOF2K" : <<"EOF");
SELECT c.column_name, c.character_maximum_length, c.data_type, c.datetime_precision, c.column_default, (sc.status & 0x80) is_identity
FROM [$db].INFORMATION_SCHEMA.COLUMNS c
JOIN [$db].dbo.sysusers ss ON
    c.table_schema = ss.name
JOIN [$db].dbo.sysobjects so ON
    c.table_name = so.name
    AND so.uid = ss.uid
JOIN [$db].dbo.syscolumns sc ON
    c.column_name = sc.name
    AND sc.id = so.Id
WHERE c.table_schema = @{[ $self->dbh->quote($table->schema) ]}
    AND c.table_name = @{[ $self->dbh->quote($table->name) ]}
EOF2K
SELECT c.column_name, c.character_maximum_length, c.data_type, c.datetime_precision, c.column_default, sc.is_identity
FROM [$db].INFORMATION_SCHEMA.COLUMNS c
JOIN [$db].sys.schemas ss ON
    c.table_schema = ss.name
JOIN [$db].sys.objects so ON
      c.table_name   = so.name
    AND so.schema_id = ss.schema_id
JOIN [$db].sys.columns sc ON
    c.column_name = sc.name
    AND sc.object_id = so.object_id
WHERE c.table_schema = @{[ $self->dbh->quote($table->schema) ]}
    AND c.table_name = @{[ $self->dbh->quote($table->name) ]}
EOF

    foreach my $row (@$rows) {
        my ($col, $char_max_length, $data_type, $datetime_precision, $default, $is_identity) = @$row;
        $col = lc $col unless $self->preserve_case;
        my $info = $result->{$col} || next;

        $info->{data_type} = $data_type;

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

        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 AUTHORS

See L<DBIx::Class::Schema::Loader/AUTHORS>.

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