[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.07039';

=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, $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;

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