# ==================================================================
# 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/&nbsp;/  /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;