523 lines
18 KiB
Perl
523 lines
18 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::SQL::Driver::MSSQL
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: MSSQL.pm,v 2.7 2005/12/03 00:54:11 jagerman Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description: MSSQL driver for GT::SQL
|
|
#
|
|
|
|
package GT::SQL::Driver::MSSQL;
|
|
# ====================================================================
|
|
use strict;
|
|
use vars qw/@ISA $ERROR_MESSAGE %BINDS/;
|
|
use DBI qw/:sql_types/;
|
|
use GT::SQL::Driver;
|
|
use GT::AutoLoader;
|
|
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
@ISA = qw/GT::SQL::Driver/;
|
|
|
|
sub protocol_version { 2 }
|
|
|
|
sub connect {
|
|
# ------------------------------------------------------------------
|
|
# Need to set some session preferences.
|
|
#
|
|
my $self = shift;
|
|
my $dbh = $self->SUPER::connect(@_) or return;
|
|
|
|
# Set max read properties for DBI
|
|
$dbh->{LongReadLen} = 1_048_576;
|
|
|
|
# Newer DBD::ODBC sets this to 0 which can cause cast errors
|
|
$dbh->{odbc_default_bind_type} = SQL_VARCHAR;
|
|
|
|
$dbh->do("SET QUOTED_IDENTIFIER ON");
|
|
$dbh->do("SET ANSI_NULLS ON");
|
|
$dbh->do("SET ANSI_PADDING OFF");
|
|
$dbh->do("SET ANSI_WARNINGS OFF");
|
|
|
|
return $dbh;
|
|
}
|
|
|
|
sub dsn {
|
|
# -------------------------------------------------------------------
|
|
# Override the default create dsn, with our own. Creates DSN like:
|
|
# DBI:ODBC:DSN
|
|
#
|
|
my ($self, $connect) = @_;
|
|
|
|
$self->{driver} = $connect->{driver} = 'ODBC';
|
|
|
|
return "DBI:$connect->{driver}:$connect->{database}";
|
|
}
|
|
|
|
sub hints {
|
|
fix_index_dbprefix => 1,
|
|
case_map => 1,
|
|
bind => [
|
|
\%BINDS,
|
|
'TEXT' => DBI::SQL_LONGVARCHAR,
|
|
'DATE|TIME' => DBI::SQL_VARCHAR
|
|
],
|
|
now => 'GETDATE()',
|
|
ai => 'IDENTITY(1,1)',
|
|
drop_pk_constraint => 1
|
|
}
|
|
|
|
sub _prepare_select {
|
|
# -----------------------------------------------------------------------------
|
|
# Track limits as ODBC has no built-in limit support; this driver hacks it in.
|
|
#
|
|
my ($self, $query) = @_;
|
|
|
|
my ($limit, $offset);
|
|
|
|
# Look for either PG or MySQL limits
|
|
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
|
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
|
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
|
|
|
if ($limit) {
|
|
$self->{_limit} = 1;
|
|
$self->{_lim_offset} = $offset;
|
|
my $top = $limit + $offset;
|
|
$query =~ s/(SELECT(?:\s+DISTINCT)?)/$1 TOP $top/i;
|
|
if (!$offset) {
|
|
delete @$self{qw/_limit _lim_offset/};
|
|
}
|
|
}
|
|
return $query;
|
|
}
|
|
|
|
sub _prepare_describe {
|
|
# -----------------------------------------------------------------------------
|
|
# For compatibility with old code, 'DESCRIBE TABLE' is mapped to something that
|
|
# looks something like a MySQL 'DESCRIBE TABLE' result.
|
|
#
|
|
my ($self, $query) = @_;
|
|
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
|
return <<QUERY;
|
|
SELECT
|
|
c.name AS "Field",
|
|
CASE
|
|
WHEN t.name LIKE '%int' THEN t.name + '(' + CAST(t.prec AS VARCHAR) + ')'
|
|
WHEN t.name LIKE '%char' THEN t.name + '(' + CAST(c.length AS VARCHAR) + ')'
|
|
WHEN t.name = 'decimal' THEN t.name + '(' + CAST(c.prec AS VARCHAR) + ',' + CAST(c.scale AS VARCHAR) + ')'
|
|
WHEN t.name = 'float' THEN 'double'
|
|
ELSE t.name
|
|
END AS "Type",
|
|
ISNULL(c.collation, 'binary') AS "Collation",
|
|
CASE WHEN c.isnullable = 1 THEN 'YES' ELSE '' END AS "Null",
|
|
(
|
|
SELECT TOP 1
|
|
CASE
|
|
WHEN m.text LIKE '(''%' THEN SUBSTRING(m.text, 3, LEN(m.text) - (CASE WHEN m.text LIKE '%'')' THEN 4 ELSE 2 END))
|
|
WHEN m.text LIKE '(%' THEN SUBSTRING(m.text, 2, LEN(m.text) - (CASE WHEN m.text LIKE '%)' THEN 2 ELSE 1 END))
|
|
ELSE m.text
|
|
END
|
|
FROM syscomments m, sysobjects d
|
|
WHERE m.id = d.id AND d.xtype = 'D' AND d.info = c.colid AND d.parent_obj = o.id
|
|
) AS "Default",
|
|
|
|
CASE WHEN c.status & 0x80 = 0x80 THEN 'auto_increment' ELSE '' END AS "Extra"
|
|
FROM
|
|
syscolumns c, systypes t, sysobjects o
|
|
WHERE
|
|
c.id = o.id AND
|
|
o.name = '$1' AND
|
|
o.type = 'U' AND
|
|
c.xtype = t.xtype
|
|
ORDER BY
|
|
c.colid
|
|
QUERY
|
|
}
|
|
else {
|
|
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported DESCRIBE query");
|
|
}
|
|
# The following could be used above for "Key" - but it really isn't that useful
|
|
# considering there's a working SHOW INDEX:
|
|
# (
|
|
# SELECT
|
|
# CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
|
# FROM sysindexes i, sysindexkeys k
|
|
# WHERE
|
|
# i.indid = 1 AND i.id = o.id AND k.id = i.id AND k.indid = i.indid AND
|
|
# k.colid = c.colid
|
|
# ) AS "Key",
|
|
}
|
|
|
|
sub column_exists {
|
|
my ($self, $table, $column) = @_;
|
|
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
|
SELECT
|
|
COUNT(*)
|
|
FROM syscolumns c, sysobjects o
|
|
WHERE
|
|
c.id = o.id AND
|
|
o.type = 'U' AND
|
|
o.name = ? AND
|
|
c.name = ?
|
|
EXISTS
|
|
$sth->execute($table, $column);
|
|
|
|
return scalar $sth->fetchrow;
|
|
}
|
|
|
|
sub _prepare_show_tables {
|
|
# -----------------------------------------------------------------------------
|
|
# MS SQL's version of MySQL's 'SHOW TABLES'; there is also 'sp_tables', but
|
|
# that returns more information (and more tables - it includes system tables)
|
|
# than we want.
|
|
#
|
|
my $self = shift;
|
|
$self->{do} = 'SELECT';
|
|
"SELECT name as table_name FROM sysobjects WHERE xtype = 'U'";
|
|
}
|
|
|
|
sub _prepare_show_index {
|
|
# -----------------------------------------------------------------------------
|
|
# See the 'Driver-specific notes' comment in GT::SQL::Driver
|
|
#
|
|
my ($self, $query) = @_;
|
|
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
|
$self->{do} = 'SELECT';
|
|
return <<QUERY;
|
|
SELECT
|
|
sysindexes.name AS index_name,
|
|
syscolumns.name AS index_column,
|
|
INDEXPROPERTY(sysindexes.id, sysindexes.name, 'IsUnique') AS index_unique,
|
|
CASE
|
|
WHEN sysindexes.indid = 1 AND (
|
|
SELECT COUNT(*) FROM sysconstraints
|
|
WHERE sysconstraints.id = sysobjects.id AND sysconstraints.status & 7 = 1
|
|
) > 0 THEN 1
|
|
ELSE 0
|
|
END AS index_primary
|
|
FROM
|
|
sysindexes, sysobjects, sysindexkeys, syscolumns
|
|
WHERE
|
|
sysindexes.indid >= 1 AND sysindexes.indid < 255 AND
|
|
sysindexes.id = sysobjects.id AND sysindexes.id = sysindexkeys.id AND sysindexes.id = syscolumns.id AND
|
|
sysindexkeys.colid = syscolumns.colid AND
|
|
sysindexes.status = 0 AND
|
|
sysindexes.indid = sysindexkeys.indid AND
|
|
sysobjects.xtype = 'U' AND sysobjects.name = '$1'
|
|
ORDER BY
|
|
sysindexkeys.indid, sysindexkeys.keyno
|
|
QUERY
|
|
}
|
|
else {
|
|
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query");
|
|
}
|
|
}
|
|
|
|
# MS SQL shouldn't have the AI column in the insert list
|
|
sub ai_insert { () }
|
|
|
|
# Returns a list of default constraints given a table and column
|
|
sub _defaults {
|
|
my ($self, $table_name, $column_name) = @_;
|
|
my $query = <<" QUERY";
|
|
SELECT o.name
|
|
FROM sysconstraints d, sysobjects t, syscolumns c, sysobjects o
|
|
WHERE d.status & 5 = 5 -- status with '5' bit set indicates a default constraint
|
|
AND d.id = t.id -- constraint table to table
|
|
AND c.id = t.id -- column's table to table
|
|
AND d.colid = c.colid -- constraint column to column
|
|
AND d.constid = o.id -- constraint id to object
|
|
AND t.name = '$table_name' -- the table we're looking for
|
|
AND c.name = '$column_name' -- the column we're looking for
|
|
QUERY
|
|
my $sth = $self->{dbh}->prepare($query)
|
|
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
|
$sth->execute()
|
|
or return $self->warn(CANTEXECUTE => $query, $DBI::errstr);
|
|
|
|
my @defaults;
|
|
while (my $default = $sth->fetchrow) {
|
|
push @defaults, $default;
|
|
}
|
|
return @defaults;
|
|
}
|
|
|
|
sub drop_column {
|
|
# -------------------------------------------------------------------
|
|
# Generates the SQL to drop a column.
|
|
#
|
|
my ($self, $table, $column, $old_col) = @_;
|
|
|
|
my @queries;
|
|
|
|
# Delete any indexes on the column, as MSSQL does not do this automatically
|
|
my $sth = $self->prepare("SHOW INDEX FROM $table");
|
|
$sth->execute;
|
|
my %drop_index;
|
|
while (my $index = $sth->fetchrow_hashref) {
|
|
if ($index->{index_column} eq $column) {
|
|
$drop_index{$index->{index_name}}++;
|
|
}
|
|
}
|
|
push @queries, map "DROP INDEX $table.$_", keys %drop_index;
|
|
|
|
for ($self->_defaults($table, $column)) {
|
|
# Drop any default constraints
|
|
push @queries, "ALTER TABLE $table DROP CONSTRAINT $_";
|
|
}
|
|
|
|
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
|
|
|
$self->do_raw_transaction(@queries);
|
|
}
|
|
|
|
sub alter_column {
|
|
# -------------------------------------------------------------------
|
|
# Changes a column in a table.
|
|
#
|
|
my ($self, $table, $column, $new_def, $old_col) = @_;
|
|
|
|
# make a copy so as not to clobber the original reference
|
|
my %col = %{$self->{schema}->{cols}->{$column}};
|
|
|
|
if ($col{type} =~ /TEXT$/i) {
|
|
# You can't alter a TEXT column in MSSQL, so we have to create an
|
|
# entirely new column, copy the data, drop the old one, then rename the
|
|
# new one using sp_rename.
|
|
my $tmpcol = "tempcol__" . time . "__" . ('a' .. 'z', 'A' .. 'Z')[rand 52];
|
|
|
|
# We don't have to worry about dropping indexes because TEXT's can't be indexed.
|
|
my @constraints = $self->_defaults($table, $column);
|
|
|
|
# Added columns must have a default, which unfortunately cannot be a column, so
|
|
# if the definition doesn't already have a default, add a fake one. We use ''
|
|
# for the default - though not allowed by GT::SQL, it _is_ allowed by MSSQL.
|
|
my $no_default;
|
|
if (not defined $col{default}) {
|
|
$col{default} = '';
|
|
$new_def = $self->column_sql(\%col);
|
|
$no_default = 1;
|
|
}
|
|
|
|
# This cannot be done in one single transaction as the columns won't
|
|
# completely exist yet, as far as MSSQL is concerned.
|
|
$self->do("ALTER TABLE $table ADD $tmpcol $new_def") or return;
|
|
|
|
push @constraints, $self->_defaults($table, $tmpcol) if $no_default;
|
|
|
|
my @q = "UPDATE $table SET $tmpcol = $column";
|
|
push @q, map "ALTER TABLE $table DROP CONSTRAINT $_", @constraints;
|
|
push @q, "ALTER TABLE $table DROP COLUMN $column";
|
|
|
|
$self->do_raw_transaction(@q) or return;
|
|
|
|
$self->do("sp_rename '$table.$tmpcol', '$column'") or return;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# An ALTER COLUMN in MS SQL cannot contain a default, so if a default is
|
|
# specified that isn't the same as the old one, we drop the default
|
|
# constraint and add a new one.
|
|
my $new_default = delete $col{default};
|
|
my $old_default = $old_col->{default};
|
|
|
|
my $default_changed = (
|
|
defined $new_default and defined $old_default and $new_default ne $old_default
|
|
or
|
|
defined $new_default ne defined $old_default
|
|
);
|
|
|
|
my @queries;
|
|
|
|
if ($default_changed) {
|
|
if (defined $old_default) {
|
|
push @queries, map "ALTER TABLE $table DROP CONSTRAINT $_", $self->_defaults($table, $column);
|
|
}
|
|
if (defined $new_default) {
|
|
push @queries, "ALTER TABLE $table ADD CONSTRAINT default_${table}_$column DEFAULT " . $self->quote($new_default) . " FOR $column";
|
|
}
|
|
}
|
|
|
|
if (defined $new_default) {
|
|
# Rewrite the column def without the DEFAULT (an ALTER COLUMN cannot contain a default in MSSQL)
|
|
$new_def = $self->column_sql(\%col);
|
|
}
|
|
|
|
push @queries, "ALTER TABLE $table ALTER COLUMN $column $new_def";
|
|
|
|
return @queries > 1
|
|
? $self->do_raw_transaction(@queries)
|
|
: $self->do($queries[0]);
|
|
}
|
|
|
|
sub drop_index {
|
|
# -------------------------------------------------------------------
|
|
# Drops an index. Versions of this module prior to 2.0 were quite broken -
|
|
# first, the index naming was (database prefix)(index name) in some places, and
|
|
# (prefixed table name)(index name) in others. Furthermore, no prefixing of
|
|
# indexes is needed at all as, like MySQL, indexes are per-table. As such,
|
|
# this driver now looks for all three types of index when attempting to remove
|
|
# existing indexes.
|
|
#
|
|
my ($self, $table, $index_name) = @_;
|
|
|
|
return $self->do("DROP INDEX $table.$index_name")
|
|
or $self->do("DROP INDEX $table.$table$index_name")
|
|
or $self->do("DROP INDEX $table.$self->{connect}->{PREFIX}$index_name");
|
|
}
|
|
|
|
sub extract_index_name {
|
|
# -----------------------------------------------------------------------------
|
|
my ($self, $table, $index) = @_;
|
|
$index =~ s/^\Q$table\E(?=.)//i # broken (tablename)(index name) format
|
|
or $index =~ s/^\Q$self->{connect}->{PREFIX}\E(?=.)//i; # broken (prefix)(index name) format;
|
|
$index;
|
|
}
|
|
|
|
|
|
package GT::SQL::Driver::MSSQL::sth;
|
|
# ====================================================================
|
|
use strict;
|
|
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
|
use GT::SQL::Driver::sth;
|
|
use GT::AutoLoader;
|
|
|
|
$ERROR_MESSAGE = 'GT::SQL';
|
|
$DEBUG = 0;
|
|
@ISA = qw/GT::SQL::Driver::sth/;
|
|
|
|
sub insert_id {
|
|
# -------------------------------------------------------------------
|
|
# Retrieves the current sequence.
|
|
#
|
|
my $self = shift;
|
|
return $self->{_insert_id} if $self->{_insert_id};
|
|
|
|
my $sth = $self->{dbh}->prepare('SELECT @@IDENTITY') or return $self->fatal(CANTPREPARE => 'SELECT @@IDENTITY', $DBI::errstr);
|
|
$sth->execute or return $self->fatal(CANTEXECUTE => 'SELECT @@IDENTITY', $DBI::errstr);
|
|
$self->{_insert_id} = $sth->fetchrow;
|
|
}
|
|
|
|
sub execute {
|
|
# -------------------------------------------------------------------
|
|
# Fetch off only rows we are interested in.
|
|
#
|
|
my $self = shift;
|
|
if ($self->{_need_preparing}) {
|
|
$self->{sth} = $self->{dbh}->prepare($self->{query}) or return $self->warn(CANTPREPARE => $self->{query}, $DBI::errstr);
|
|
}
|
|
if (my $binds = $GT::SQL::Driver::MSSQL::BINDS{$self->{query}}) {
|
|
for my $bind (@$binds) {
|
|
my ($index, $col, $type) = @$bind;
|
|
$self->{sth}->bind_param($index, $_[$index-1], $type);
|
|
}
|
|
}
|
|
else {
|
|
# We need to look for any values longer than 8000 characters and bind_param them
|
|
# to SQL_LONGVARCHAR's to avoid an implicit rebinding that results in a
|
|
# "Can't rebind placeholder x" error. Actually, we look for 4000 because that's
|
|
# the worst-case scenario for escaping being able to increase to 8000 characters.
|
|
for (my $i = 0; $i < @_; $i++) {
|
|
if (defined $_[$i] and length $_[$i] > 4000) {
|
|
$self->{sth}->bind_param($i+1, $_[$i], DBI::SQL_LONGVARCHAR);
|
|
}
|
|
}
|
|
}
|
|
my $time;
|
|
if ($self->{_debug}) {
|
|
$self->last_query($self->{query}, @_);
|
|
my $stack = '';
|
|
if ($self->{_debug} > 1) {
|
|
$stack = GT::Base->stack_trace(1,1);
|
|
$stack =~ s/<br>/\n /g;
|
|
$stack =~ s/ / /g;
|
|
$stack = "\n $stack\n"
|
|
}
|
|
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
|
$self->debug("Executing query: $query$stack");
|
|
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
|
}
|
|
|
|
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
|
$self->{_names} = $self->{_results} = $self->{_insert_id} = undef;
|
|
|
|
# Attempting to access ->{NAME} is not allowed for queries that don't actually
|
|
# returning anything (such as 'ALTER TABLE foo ADD COLUMN a INT'); as such, try
|
|
# to avoid them here. The eval is there just in case a query runs that isn't
|
|
# caught.
|
|
unless ($self->{do} =~ /^(?:ALTER|CREATE|INSERT|UPDATE|DROP|DELETE|SP_RENAME)$/) {
|
|
eval {
|
|
$self->{_names} = $self->{sth}->{NAME};
|
|
};
|
|
}
|
|
|
|
# Limit the results if needed.
|
|
if ($self->{do} eq 'SELECT' or $self->{do} eq 'DESCRIBE') {
|
|
my $none;
|
|
if ($self->{_limit}) {
|
|
my $begin = $self->{_lim_offset} || 0;
|
|
for (1 .. $begin) {
|
|
# Discard any leading rows that we don't care about
|
|
$self->{sth}->fetchrow_arrayref or $none = 1, last;
|
|
}
|
|
}
|
|
$self->{_results} = $none ? [] : $self->{sth}->fetchall_arrayref;
|
|
$self->{rows} = @{$self->{_results}};
|
|
}
|
|
elsif ($self->{query} =~ /^\s*sp_/) {
|
|
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
|
$self->{rows} = @{$self->{_results}};
|
|
}
|
|
else {
|
|
$self->{rows} = $self->{sth}->rows;
|
|
}
|
|
$self->{sth}->finish;
|
|
$self->{_need_preparing} = 1;
|
|
|
|
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
|
my $elapsed = Time::HiRes::time() - $time;
|
|
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
|
}
|
|
|
|
return $rc;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------------------------ #
|
|
# DATA TYPE MAPPINGS
|
|
# ------------------------------------------------------------------------------------------------ #
|
|
package GT::SQL::Driver::MSSQL::Types;
|
|
use strict;
|
|
use GT::SQL::Driver::Types;
|
|
use Carp qw/croak/;
|
|
use vars qw/@ISA/;
|
|
@ISA = 'GT::SQL::Driver::Types';
|
|
|
|
# MSSQL has a TINYINT type, however it is always unsigned, so only use it if
|
|
# the column is _meant_ to be unsigned - otherwise use SMALLINT, which is
|
|
# always signed.
|
|
sub TINYINT {
|
|
my ($class, $args) = @_;
|
|
my $type = $args->{unsigned} ? 'TINYINT' : 'SMALLINT';
|
|
$class->base($args, $type);
|
|
}
|
|
|
|
# Though MSSQL supports a CHAR type, it can't be used because it doesn't trim
|
|
# trailing spaces, and that would most likely break things designed to work
|
|
# with the way 'CHAR's currently work.
|
|
|
|
sub DATE { $_[0]->base($_[1], 'DATETIME') }
|
|
sub TIMESTAMP { $_[0]->base($_[1], 'DATETIME') }
|
|
sub TIME { croak "MSSQL does not support 'TIME' columns" }
|
|
sub YEAR { $_[0]->base($_[1], 'DATETIME') }
|
|
|
|
# MSSQL doesn't support BLOB's, but has binary 'IMAGE' and 'VARBINARY' types -
|
|
# the one (rather large) caveat to these being that they require escaping and
|
|
# unescaping of input and output.
|
|
|
|
1;
|