[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 Carp::Clan qw/^DBIx::Class/;
use Class::C3;

__PACKAGE__->mk_group_accessors('simple', qw/
    case_sensitive_collation
/);

our $VERSION = '0.06001';

=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, 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:

    case_sensitive_collation => 1|0

in your Loader options.

=cut

sub _is_case_sensitive {
    my $self = shift;

    return $self->case_sensitive_collation ? 1 : 0;
}

sub _setup {
    my $self = shift;

    $self->next::method;

    return if defined $self->case_sensitive_collation;

    my $dbh = $self->schema->storage->dbh;

    # 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 { $dbh->selectrow_array('SELECT collation_name FROM sys.databases WHERE name = DB_NAME()') }
        || eval { $dbh->selectrow_array("SELECT CAST(databasepropertyex(DB_NAME(), 'Collation') AS VARCHAR)") };

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

WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode.
Override the 'case_sensitive_collation' attribute in your Loader options if
needed.
EOF
        $self->case_sensitive_collation(0);
        return;
    }

    my $case_sensitive = $collation_name =~ /_(?:CS|BIN2?)(?:_|\z)/;

    $self->case_sensitive_collation($case_sensitive ? 1 : 0);
}

sub _lc {
    my ($self, $name) = @_;

    return $self->case_sensitive_collation ? $name : lc($name);
}

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

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
SELECT t.table_name
FROM INFORMATION_SCHEMA.TABLES t
WHERE lower(t.table_schema) = ?
EOF
    $sth->execute(lc $self->db_schema);

    my @tables = map @$_, @{ $sth->fetchall_arrayref };

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

sub _table_pk_info {
    my ($self, $table) = @_;
    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
    $sth->execute;

    my @keydata;

    while (my $row = $sth->fetchrow_hashref) {
        push @keydata, $self->_lc($row->{COLUMN_NAME});
    }

    return \@keydata;
}

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

    my ($local_cols, $remote_cols, $remote_table, @rels, $sth);
    my $dbh = $self->schema->storage->dbh;
    eval {
        $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
        $sth->execute;
    };

    while (my $row = eval { $sth->fetchrow_hashref }) {
        my $fk = $row->{FK_NAME};
        push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME});
        push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME});
        $remote_table->{$fk} = $row->{PKTABLE_NAME};
    }

    foreach my $fk (keys %$remote_table) {
        push @rels, {
                      local_columns => \@{$local_cols->{$fk}},
                      remote_columns => \@{$remote_cols->{$fk}},
                      remote_table => $remote_table->{$fk},
                    };

    }
    return \@rels;
}

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

    my $dbh = $self->schema->storage->dbh;
    local $dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $dbh->prepare(qq{
SELECT ccu.constraint_name, ccu.column_name
FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE ccu
JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc on (ccu.constraint_name = tc.constraint_name)
JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name)
wHERE lower(ccu.table_name) = @{[ $dbh->quote(lc $table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
    });
    $sth->execute;
    my $constraints;
    while (my $row = $sth->fetchrow_hashref) {
        my $name = $row->{constraint_name};
        my $col  = $self->_lc($row->{column_name});
        push @{$constraints->{$name}}, $col;
    }

    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
    return \@uniqs;
}

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

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

    while (my ($col, $info) = each %$result) {
        my $dbh = $self->schema->storage->dbh;

# find identities
        my $sth = $dbh->prepare(qq{
SELECT column_name 
FROM INFORMATION_SCHEMA.COLUMNS
WHERE columnproperty(object_id(@{[ $dbh->quote(lc $table) ]}, 'U'), @{[ $dbh->quote(lc $col) ]}, 'IsIdentity') = 1
AND lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
        });
        if (eval { $sth->execute; $sth->fetchrow_array }) {
            $info->{is_auto_increment} = 1;
            $info->{data_type} =~ s/\s*identity//i;
            delete $info->{size};
        }

# fix types
        if ($info->{data_type} eq 'int') {
            $info->{data_type} = 'integer';
        }
        elsif ($info->{data_type} eq 'timestamp') {
            $info->{inflate_datetime} = 0;
        }
        elsif ($info->{data_type} =~ /^(?:numeric|decimal)\z/) {
            if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
                delete $info->{size};
            }
        }
        elsif ($info->{data_type} eq 'real') {
            $info->{data_type} = 'float';
            $info->{size}      = 24;
        }
        elsif ($info->{data_type} eq 'float') {
            $info->{data_type} = 'double precision';
        }
        elsif ($info->{data_type} =~ /^(?:small)?datetime\z/) {
            # fixup for DBD::Sybase
            if ($info->{default_value} && $info->{default_value} eq '3') {
                delete $info->{default_value};
            }
        }
        elsif ($info->{data_type} eq 'datetimeoffset') {
            $info->{size} = {
                26 => 0,
                28 => 1,
                29 => 2,
                30 => 3,
                31 => 4,
                32 => 5,
                33 => 6,
                34 => 7,
            }->{$info->{size}};

            delete $info->{size} if $info->{size} == 7;
        }
        elsif ($info->{data_type} eq 'datetime2') {
            $info->{size} = {
                19 => 0,
                21 => 1,
                22 => 2,
                23 => 3,
                24 => 4,
                25 => 5,
                26 => 6,
                27 => 7,
            }->{$info->{size}};

            delete $info->{size} if $info->{size} == 7;
        }
        elsif ($info->{data_type} eq 'time') {
            $info->{size} = {
                 8 => 0,
                10 => 1,
                11 => 2,
                12 => 3,
                13 => 4,
                14 => 5,
                15 => 6,
                16 => 7,
            }->{$info->{size}};

            delete $info->{size} if $info->{size} == 7;
        }

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

# get default
        $sth = $dbh->prepare(qq{
SELECT column_default
FROM INFORMATION_SCHEMA.COLUMNS
wHERE lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
        });
        my ($default) = eval { $sth->execute; $sth->fetchrow_array };

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

    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';
fe67d343	6	use Carp::Clan qw/^DBIx::Class/;
	7	use Class::C3;
	8
3559ae79	9	__PACKAGE__->mk_group_accessors('simple', qw/
	10	case_sensitive_collation
	11	/);
	12
5afd3e72	13	our $VERSION = '0.06001';
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
	36	We attempt to detect the database collation at startup, and set the column
	37	lowercasing behavior accordingly, as lower-cased column names do not work on
	38	case-sensitive databases.
	39
81ade4d9	40	To manually control case-sensitive mode, put:
b065e3df	41
81ade4d9	42	case_sensitive_collation => 1\|0
b065e3df	43
103e90da	44	in your Loader options.
b065e3df	45
acfcc1fb	46	=cut
fe67d343	47
3559ae79	48	sub _is_case_sensitive {
	49	my $self = shift;
	50
	51	return $self->case_sensitive_collation ? 1 : 0;
	52	}
	53
	54	sub _setup {
	55	my $self = shift;
	56
	57	$self->next::method;
	58
b065e3df	59	return if defined $self->case_sensitive_collation;
b065e3df	60
3559ae79	61	my $dbh = $self->schema->storage->dbh;
3559ae79	62
b7a0a040	63	# We use the sys.databases query for the general case, and fallback to
	64	# databasepropertyex() if for some reason sys.databases is not available,
	65	# which does not work over DBD::ODBC with unixODBC+FreeTDS.
	66	#
	67	# XXX why does databasepropertyex() not work over DBD::ODBC ?
40914006	68	#
40914006	69	# more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
b7a0a040	70	my ($collation_name) =
b7a0a040	71	eval { $dbh->selectrow_array('SELECT collation_name FROM sys.databases WHERE name = DB_NAME()') }
103e90da	72	\|\| eval { $dbh->selectrow_array("SELECT CAST(databasepropertyex(DB_NAME(), 'Collation') AS VARCHAR)") };
b7a0a040	73
b7a0a040	74	if (not $collation_name) {
b065e3df	75	warn <<'EOF';
	76
	77	WARNING: MSSQL Collation detection failed. Defaulting to case-insensitive mode.
	78	Override the 'case_sensitive_collation' attribute in your Loader options if
	79	needed.
	80	EOF
	81	$self->case_sensitive_collation(0);
b7a0a040	82	return;
b7a0a040	83	}
3559ae79	84
5ac72caa	85	my $case_sensitive = $collation_name =~ /_(?:CS\|BIN2?)(?:_\|\z)/;
3559ae79	86
5ac72caa	87	$self->case_sensitive_collation($case_sensitive ? 1 : 0);
3559ae79	88	}
	89
	90	sub _lc {
	91	my ($self, $name) = @_;
	92
	93	return $self->case_sensitive_collation ? $name : lc($name);
	94	}
	95
acfcc1fb	96	sub _tables_list {
bfb43060	97	my ($self, $opts) = @_;
fe67d343	98
acfcc1fb	99	my $dbh = $self->schema->storage->dbh;
acfcc1fb	100	my $sth = $dbh->prepare(<<'EOF');
020f3c3a	101	SELECT t.table_name
060f5ecd	102	FROM INFORMATION_SCHEMA.TABLES t
43170884	103	WHERE lower(t.table_schema) = ?
acfcc1fb	104	EOF
43170884	105	$sth->execute(lc $self->db_schema);
fe67d343	106
bfb43060	107	my @tables = map @$_, @{ $sth->fetchall_arrayref };
acfcc1fb	108
bfb43060	109	return $self->_filter_tables(\@tables, $opts);
acfcc1fb	110	}
fe67d343	111
fe67d343	112	sub _table_pk_info {
	113	my ($self, $table) = @_;
	114	my $dbh = $self->schema->storage->dbh;
	115	my $sth = $dbh->prepare(qq{sp_pkeys '$table'});
	116	$sth->execute;
	117
	118	my @keydata;
	119
	120	while (my $row = $sth->fetchrow_hashref) {
3559ae79	121	push @keydata, $self->_lc($row->{COLUMN_NAME});
fe67d343	122	}
	123
	124	return \@keydata;
	125	}
	126
	127	sub _table_fk_info {
	128	my ($self, $table) = @_;
	129
a3e05a4b	130	my ($local_cols, $remote_cols, $remote_table, @rels, $sth);
fe67d343	131	my $dbh = $self->schema->storage->dbh;
a3e05a4b	132	eval {
ea8d5d7c	133	$sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
a3e05a4b	134	$sth->execute;
a3e05a4b	135	};
fe67d343	136
a3e05a4b	137	while (my $row = eval { $sth->fetchrow_hashref }) {
65f74457	138	my $fk = $row->{FK_NAME};
3559ae79	139	push @{$local_cols->{$fk}}, $self->_lc($row->{FKCOLUMN_NAME});
3559ae79	140	push @{$remote_cols->{$fk}}, $self->_lc($row->{PKCOLUMN_NAME});
bfb43060	141	$remote_table->{$fk} = $row->{PKTABLE_NAME};
fe67d343	142	}
	143
	144	foreach my $fk (keys %$remote_table) {
65f74457	145	push @rels, {
	146	local_columns => \@{$local_cols->{$fk}},
	147	remote_columns => \@{$remote_cols->{$fk}},
	148	remote_table => $remote_table->{$fk},
	149	};
fe67d343	150
	151	}
	152	return \@rels;
	153	}
	154
	155	sub _table_uniq_info {
	156	my ($self, $table) = @_;
	157
	158	my $dbh = $self->schema->storage->dbh;
020f3c3a	159	local $dbh->{FetchHashKeyName} = 'NAME_lc';
	160
	161	my $sth = $dbh->prepare(qq{
	162	SELECT ccu.constraint_name, ccu.column_name
060f5ecd	163	FROM INFORMATION_SCHEMA.CONSTRAINT_COLUMN_USAGE ccu
	164	JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc on (ccu.constraint_name = tc.constraint_name)
	165	JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu on (ccu.constraint_name = kcu.constraint_name and ccu.column_name = kcu.column_name)
bfb43060	166	wHERE lower(ccu.table_name) = @{[ $dbh->quote(lc $table) ]} AND constraint_type = 'UNIQUE' ORDER BY kcu.ordinal_position
020f3c3a	167	});
fe67d343	168	$sth->execute;
	169	my $constraints;
	170	while (my $row = $sth->fetchrow_hashref) {
020f3c3a	171	my $name = $row->{constraint_name};
3559ae79	172	my $col = $self->_lc($row->{column_name});
fe67d343	173	push @{$constraints->{$name}}, $col;
	174	}
	175
	176	my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
	177	return \@uniqs;
	178	}
	179
9c9197d6	180	sub _columns_info_for {
	181	my $self = shift;
	182	my ($table) = @_;
	183
	184	my $result = $self->next::method(@_);
	185
	186	while (my ($col, $info) = each %$result) {
	187	my $dbh = $self->schema->storage->dbh;
020f3c3a	188
81ade4d9	189	# find identities
9c9197d6	190	my $sth = $dbh->prepare(qq{
020f3c3a	191	SELECT column_name
060f5ecd	192	FROM INFORMATION_SCHEMA.COLUMNS
bfb43060	193	WHERE columnproperty(object_id(@{[ $dbh->quote(lc $table) ]}, 'U'), @{[ $dbh->quote(lc $col) ]}, 'IsIdentity') = 1
bfb43060	194	AND lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
9c9197d6	195	});
020f3c3a	196	if (eval { $sth->execute; $sth->fetchrow_array }) {
9c9197d6	197	$info->{is_auto_increment} = 1;
	198	$info->{data_type} =~ s/\s*identity//i;
	199	delete $info->{size};
	200	}
fe67d343	201
81ade4d9	202	# fix types
	203	if ($info->{data_type} eq 'int') {
	204	$info->{data_type} = 'integer';
	205	}
	206	elsif ($info->{data_type} eq 'timestamp') {
	207	$info->{inflate_datetime} = 0;
	208	}
	209	elsif ($info->{data_type} =~ /^(?:numeric\|decimal)\z/) {
	210	if (ref($info->{size}) && $info->{size}[0] == 18 && $info->{size}[1] == 0) {
	211	delete $info->{size};
	212	}
	213	}
	214	elsif ($info->{data_type} eq 'real') {
	215	$info->{data_type} = 'float';
	216	$info->{size} = 24;
	217	}
	218	elsif ($info->{data_type} eq 'float') {
	219	$info->{data_type} = 'double precision';
	220	}
	221	elsif ($info->{data_type} =~ /^(?:small)?datetime\z/) {
	222	# fixup for DBD::Sybase
	223	if ($info->{default_value} && $info->{default_value} eq '3') {
	224	delete $info->{default_value};
	225	}
	226	}
	227	elsif ($info->{data_type} eq 'datetimeoffset') {
	228	$info->{size} = {
	229	26 => 0,
	230	28 => 1,
	231	29 => 2,
	232	30 => 3,
	233	31 => 4,
	234	32 => 5,
	235	33 => 6,
	236	34 => 7,
	237	}->{$info->{size}};
	238
	239	delete $info->{size} if $info->{size} == 7;
	240	}
	241	elsif ($info->{data_type} eq 'datetime2') {
	242	$info->{size} = {
	243	19 => 0,
	244	21 => 1,
	245	22 => 2,
	246	23 => 3,
	247	24 => 4,
	248	25 => 5,
	249	26 => 6,
	250	27 => 7,
	251	}->{$info->{size}};
	252
	253	delete $info->{size} if $info->{size} == 7;
	254	}
	255	elsif ($info->{data_type} eq 'time') {
	256	$info->{size} = {
	257	8 => 0,
	258	10 => 1,
	259	11 => 2,
	260	12 => 3,
	261	13 => 4,
	262	14 => 5,
	263	15 => 6,
	264	16 => 7,
	265	}->{$info->{size}};
266
267	delete $info->{size} if $info->{size} == 7;
268	}
269
270	if ($info->{data_type} !~ /^(?:n?char\|n?varchar\|binary\|varbinary\|numeric\|decimal\|float\|datetime(?:2\|offset)\|time)\z/) {
271	delete $info->{size};
272	}
273
5c6fb0a1	274	# get default
9c9197d6	275	$sth = $dbh->prepare(qq{
020f3c3a	276	SELECT column_default
060f5ecd	277	FROM INFORMATION_SCHEMA.COLUMNS
bfb43060	278	wHERE lower(table_name) = @{[ $dbh->quote(lc $table) ]} AND lower(column_name) = @{[ $dbh->quote(lc $col) ]}
9c9197d6	279	});
020f3c3a	280	my ($default) = eval { $sth->execute; $sth->fetchrow_array };
9c9197d6	281
	282	if (defined $default) {
	283	# strip parens
	284	$default =~ s/^\( (.*) \)\z/$1/x;
	285
	286	# Literal strings are in ''s, numbers are in ()s (in some versions of
	287	# MSSQL, in others they are unquoted) everything else is a function.
	288	$info->{default_value} =
	289	$default =~ /^['(] (.*) [)']\z/x ? $1 :
	290	$default =~ /^\d/ ? $default : \$default;
	291	}
5c6fb0a1	292	}
5c6fb0a1	293
9c9197d6	294	return $result;
fe67d343	295	}
fe67d343	296
fe67d343	297	=head1 SEE ALSO
fe67d343	298
acfcc1fb	299	L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server>,
acfcc1fb	300	L<DBIx::Class::Schema::Loader::DBI::ODBC::Microsoft_SQL_Server>,
fe67d343	301	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	302	L<DBIx::Class::Schema::Loader::DBI>
	303
	304	=head1 AUTHOR
	305
9cc8e7e1	306	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
fe67d343	307
be80bba7	308	=head1 LICENSE
0852b7b8	309
be80bba7	310	This library is free software; you can redistribute it and/or modify it under
be80bba7	311	the same terms as Perl itself.
0852b7b8	312
fe67d343	313	=cut
	314
	315	1;
bfb43060	316	# vim:et sts=4 sw=4 tw=0: