# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::SQL::Driver
#   CVS Info : 087,071,086,086,085      
#   $Id: Driver.pm,v 2.6 2005/11/03 01:38:30 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Overview: This implements a driver class.
#

package GT::SQL::Driver;
# ===============================================================
use strict;
use GT::SQL::Table;
use GT::AutoLoader;
use GT::SQL::Driver::Types;
use GT::SQL::Driver::debug;
use Exporter();
require GT::SQL::Driver::sth;
use vars qw/%CONN @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS %QUERY_MAP/;

use constant PROTOCOL => 2;

$ATTRIBS = {
    name    => '',
    schema  => '',
    dbh     => '',
    connect => {}
};
$ERROR_MESSAGE = 'GT::SQL';
$VERSION       = sprintf "%d.%03d", q$Revision: 2.6 $ =~ /(\d+)\.(\d+)/;
$DEBUG         = 0;
@ISA           = qw/GT::SQL::Driver::debug/;

%QUERY_MAP = (
#   QUERY    => METHOD (will be prefixed with '_prepare_' or '_execute_')
    CREATE   => 'create',
    INSERT   => 'insert',
    ALTER    => 'alter',
    SELECT   => 'select',
    UPDATE   => 'update',
    DROP     => 'drop',
    DELETE   => 'delete',
    DESCRIBE => 'describe',
    'SHOW TABLES' => 'show_tables',
    'SHOW INDEX' => 'show_index'
);

$DBI::errstr if 0;

sub load_driver {
# -----------------------------------------------------------------------------
# Loads a sub-driver (i.e. GT::SQL::Driver::MYSQL, GT::SQL::Driver::PG, etc.),
# and creates and returns a new driver object.  The first argument should be
# the name of the driver (e.g. 'PG'), and the remaining arguments are passed to
# new() - which could well be handled by the driver.
#
    my ($class, $driver, @opts) = @_;

# Old GT::SQL versions had an 'ODBC' driver that wasn't an ODBC driver, but an
# MSSQL driver that used ODBC.
    $driver = 'MSSQL' if $driver eq 'ODBC';

    my $pkg = "GT::SQL::Driver::$driver";
    my $lib_path = $INC{'GT/SQL/Driver.pm'};
    $lib_path =~ s|GT/SQL/Driver\.pm$||;
    {
        # Ensure that the driver is loaded from the same location as GT/SQL/Driver.pm
        local @INC = ($lib_path, @INC);
        require "GT/SQL/Driver/$driver.pm";
    }

    my $protocol = $pkg->protocol_version;
    return $class->fatal(DRIVERPROTOCOL => PROTOCOL, $protocol) if $protocol != PROTOCOL;

    return $pkg->new(@opts);
}

sub new {
# -----------------------------------------------------------------------------
# Generic new() method for drivers to inherit; load_driver() should be used
# instead to get a driver object.
#
    my $this    = shift;
    my $class   = ref $this || $this;
    my $self    = bless {}, $class;
    my $opts    = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); invalid parameter: '@_'");

# Otherwise we need to make sure we have a schema.
    $opts->{schema} and ref $opts->{schema} or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); must specify schema and name");

    $self->{name}     = $opts->{name};
    $self->{schema}   = $opts->{schema};
    $self->{connect}  = $opts->{connect};
    $self->{_debug}   = $opts->{debug}    || $DEBUG;
    $self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
    $self->{dbh}      = undef;
    $self->{hints}    = { $self->hints };
    $self->debug("New driver object loaded from table: $self->{name}.") if ($self->{_debug} > 2);

    return $self;
}

# This method is designed to be subclassed to provide "hints" for simple, small
# differences between drivers, which simplifies the code over using a subclass.
# It returns a hash of hints, with values of "1" unless otherwise indicated.
# Currently supported hints are:
#   case_map            # Corrects ->fetchrow_hashref column case when the database doesn't
#   prefix_indexes      # Indexes will be prefixed with the table name (including the table's prefix)
#   fix_index_dbprefix  # Look for erroneous (db_prefix)(index) when dropping indexes
#   now                 # Specifies an SQL value to use instead of NOW() (for 'time_check' columns, among other things)
#   bind                # An array ref of: [\%BIND_HASH, ('COLUMNTYPE' => $bind_type, 'TYPE2' => $bind_type2, ...)] for drivers that need special placeholder binding for certain column types
#   ai                  # Contains a string to use for an AI column; or a code reference that is passed ($table, $column) and returns the string, or an array reference of queries to run to create the ai sequence after the column/table has been created
#   drop_pk_constraint  # use ALTER TABLE ... DROP CONSTRAINT pkeyname to drop a primary key
sub hints { () }
# Removing the () breaks under 5.00404, as it will return @_ in list context

$COMPILE{protocol_version} = __LINE__ . <<'END_OF_SUB';
sub protocol_version {
# -----------------------------------------------------------------------------
# This checks the GT::SQL::Driver protocol, and dies if the versions aren't
# equal.  The protocol version only changes for major driver changes such as
# the v2.000 version of this module, which had the drivers do their own queries
# (as opposed to the previous hack of having drivers trying to return alternate
# versions of MySQL's queries).  All protocol v2 and above drivers are required
# to override this - any driver that does not is, by definition, a protocol v1
# driver.
#
# The current protocol version is defined by the PROTOCOL constant - but
# drivers that haven't overridden protocol_version() are, by definition, v1.
#
    1;
}
END_OF_SUB

sub available_drivers {
# -----------------------------------------------------------------------------
# Returns a list of available GT::SQL::Driver::* drivers
#
    my $driver_path = $INC{'GT/SQL/Driver.pm'};
    $driver_path =~ s/\.pm$//;
    my $dh = \do { local *DH; *DH };
    my @drivers;
    opendir $dh, $driver_path or return ();
    while (defined(my $driver = readdir $dh)) {
        # By convention, only all-uppercase modules are accepted as GT::SQL drivers
        next unless $driver =~ /^([A-Z_][A-Z0-9_]*)\.pm$/;
        push @drivers, $1;
    }
    @drivers;
}

sub connect {
# -------------------------------------------------------------------
# Returns the current database handle.
#
    my $self    = shift;
    $self->{dbh} and return $self->{dbh};

    eval { require DBI };
    if ($@) {
        return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
    }

# Make sure we have a database, otherwise probably an error.
    exists $self->{connect}->{database} or return $self->fatal(CANTCONNECT => "No connection string passed to tbl->connect, make sure your table object got a connection hash.");
    keys %{$self->{schema}}             or return $self->fatal(CANTCONNECT => "Unable to connect to database without a valid schema.");

    my $dsn = $self->dsn($self->{connect});
    my $conn_key = "$dsn\0$self->{connect}->{login}\0$self->{connect}->{password}";
    if (defined $CONN{$conn_key}) {
        $self->{dbh} = $CONN{$conn_key};
        $self->debug("Using stored connection: $dsn") if ($self->{_debug} > 1);
        return $CONN{$conn_key};
    }

# Connect to the database.
    $self->debug("Connecting to database with: '$dsn', '$self->{connect}->{login}', '******'") if ($self->{_debug} > 1);
    my $res = eval {
        $CONN{$conn_key} = DBI->connect($dsn, $self->{connect}->{login}, $self->{connect}->{password}, { RaiseError => $self->{connect}->{RaiseError}, PrintError => $self->{connect}->{PrintError}, AutoCommit => 1 })
            or die "$DBI::errstr\n";
        1;
    };
    $res or return $self->warn(CANTCONNECT => "$@");

    $self->{dbh} = $CONN{$conn_key};
    $self->debug("Connected successfully to database.") if $self->{_debug} > 1;

    return $self->{dbh};
}

$COMPILE{dsn} = __LINE__ . <<'END_OF_SUB';
sub dsn {
# -------------------------------------------------------------------
# Creates the data source name used by DBI to connect to the database.
# Since this is database-dependant, this is just a stub.
#
    require Carp;
    Carp::croak("Driver has no dsn()");
}
END_OF_SUB

$COMPILE{prepare_raw} = __LINE__ . <<'END_OF_SUB';
sub prepare_raw {
# ---------------------------------------------------------------
# Returns a raw sth object.
# WARNING: MAKE SURE YOUR SQL IS PORTABLE AS NO ALTERATIONS WILL
# BE MADE! ALSO YOU MUST MANUALLY CALL ->finish ON THESE!
#
    my ($self, $query) = @_;
    $self->debug("Preparing RAW query: $query") if $self->{_debug} > 1;
    my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
    $self->debug("RAW STH is prepared: $query") if $self->{_debug} > 1;
    return $sth;
}
END_OF_SUB

$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
sub prepare {
# ---------------------------------------------------------------
# We can override whatever type of queries we need to alter by replacing
# the _prepare_* functions.
#
    my ($self, $query) = @_;
    if (! defined $query) {
        return $self->warn(CANTPREPARE => "", "Empty Query");
    }

    # For any drivers that need hacked-in limit support (currently MS SQL and Oracle):
    delete @$self{qw/_limit _lim_offset _lim_rows/};

    if (my $now = $self->{hints}->{now}) {
        $query =~ s/\bNOW\(\)/$now/g;
    }

    if ($query =~ /^\s*SHOW\s+TABLES\s*(?:;\s*)?$/i) {
        $self->{do} = 'SHOW TABLES';
    }
    elsif ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+\w+\s*(?:;\s*)?$/i) {
        # See 'Driver-specific notes' below
        $self->{do} = 'SHOW INDEX';
    }
    else {
        $self->{do} = uc +($query =~ /(\w+)/)[0];
    }
    if (my $meth = $QUERY_MAP{$self->{do}}) {
        $meth = "_prepare_$meth";
        $query = $self->$meth($query) or return;
    }

    $self->{query} = $query;
    $self->debug("Preparing query: $query") if $self->{_debug} > 1;

    $self->{sth} = $self->{dbh}->prepare($query)
        or return $self->warn(CANTPREPARE => $query, $DBI::errstr);

    my $pkg = ref($self) . '::sth';
    $self->debug("CREATING $pkg OBJECT") if $self->{_debug} > 2;
    return $pkg->new($self);
}
END_OF_SUB

# Define one generic prepare, and alias all the specific _prepare_* functions to it
sub _generic_prepare { $_[1] }
for (*_prepare_create, *_prepare_insert, *_prepare_alter, *_prepare_select, *_prepare_update, *_prepare_drop, *_prepare_delete, *_prepare_describe) {
    $_ = \&_generic_prepare;
}
# Driver-specific notes:
# 'SHOW TABLES'
# The driver should return single-column rows of non-system tables in the
# database.  The name of the column is not important, and users of SHOW TABLE
# should not depend on it (i.e. do not use ->fetchrow_hashref)
*_prepare_show_tables = \&_generic_prepare;
# 'SHOW INDEX FROM table'
# Drivers should return one row per column per index, having at least the keys:
#   - index_name: the name of the index
#   - index_column: the name of the column
#   - index_unique: 1 if the index is unique, 0 otherwise
#   - index_primary: 1 if the column is a primary key, 0 otherwise
#
# The rows must be grouped by index, and ordered by the position of the column
# within said groupings.
#
# So, for a unique index named 'unique1' on columns 'col1', 'col2', 'col3', and
# a normal index named 'index1' on 'col3', 'col4', and a primary key on
# 'colpk', you should get (at a minimum; extra columns are permitted):
# +------------+--------------+--------------+---------------+
# | index_name | index_column | index_unique | index_primary |
# +------------+--------------+--------------+---------------+
# | unique1    | col1         |            1 |             0 |
# | unique1    | col2         |            1 |             0 |
# | unique1    | col3         |            1 |             0 |
# | index1     | col3         |            0 |             0 |
# | index1     | col4         |            0 |             0 |
# | PRIMARY    | colpk        |            1 |             1 |
# +------------+--------------+--------------+---------------+
# 'PRIMARY' above should be changed by drivers whose databases have named
# primary keys, otherwise using 'PRIMARY' for the primary key is recommended.
#
# Any other information may be returned; users of this query mapping should
# always use ->fetchrow_hashref, and access the above four keys for
# portability.
#
# Note that index_primary results may overlap other indexes for some databases
# - Oracle, in particular, will bind a primary key onto an existing index if
# possible.  In such a case, you'll get the index indicated normally, but some
# of the columns may make up the primary key.  For example, the following
# result would indicate that there is one index on col1, col2, col3, and that
# there is a primary key made up of (col1, col2):
#
# +------------+--------------+--------------+---------------+
# | index_name | index_column | index_unique | index_primary |
# +------------+--------------+--------------+---------------+
# | index1     | col1         |            0 |             1 |
# | index1     | col2         |            0 |             1 |
# | index1     | col3         |            0 |             0 |
# +------------+--------------+--------------+---------------+
#
# Currently, results such as the above are known to occur in Oracle databases
# where a primary key was added to an already-indexed column after creating the
# table - other databases give primary keys an independant index.
#
# Although _prepare_show_index is defined here, no drivers actually satisfy the
# above without some query result remapping, and as such all currently override
# either this or _execute_show_index.
*_prepare_show_index = \&_generic_prepare;

$COMPILE{extract_index_name} = __LINE__ . <<'END_OF_SUB';
sub extract_index_name {
# -----------------------------------------------------------------------------
# Takes an table name and database index name (which could be prefixed, if the
# database uses prefixes) and returns the GT::SQL index name (i.e. without
# prefix).
    my ($self, $table, $index) = @_;
    if ($self->{hints}->{prefix_indexes}) {
        $index =~ s/^\Q$table\E(?=.)//i;
    }
    $index;
}
END_OF_SUB

sub disconnect {
# -------------------------------------------------------------------
# Disconnect from the database.
#
    my $self = shift;
    $self->{dbh} and $self->{dbh}->disconnect;
}

sub reset_env {
# -------------------------------------------------------------------
# Remove all database connections that aren't still alive
#
    @GT::SQL::Driver::debug::QUERY_STACK = ();
    for my $dsn (keys %CONN) {
        next if ($CONN{$dsn} and $CONN{$dsn}->ping);
        $CONN{$dsn}->disconnect if ($CONN{$dsn});
        delete $CONN{$dsn};
    }
}

sub do {
# -------------------------------------------------------------------
# Do a query.
#
    my $self = shift;
    ($self->prepare(@_) or return)->execute;
}

$COMPILE{do_raw_transaction} = __LINE__ . <<'END_OF_SUB';
sub do_raw_transaction {
# -----------------------------------------------------------------------------
# Do a series of queries as a single transaction - note that this is only
# supported under DBI >= 1.20; older versions of DBI result in the queries
# being performed without a transaction.
# This subroutine should be passed a list of queries; the queries will be run
# in order.  Each query may optionally be an array reference where the first
# element is the query, and remaining elements are placeholders to use when
# executing the query.  Furthermore, you may pass a reference to the string
# or array reference to specify a non-critical query.
#
# For example:
# $self->do_raw_transaction(
#     "QUERY1",
#     \["QUERY2 ?", $value],
#     \"QUERY3",
#     ["QUERY4 ?, ?", $value1, $value2]
# );
#
# This will attempt to run the 4 queries, and will abort if query 1 or 4 do not
# succeed.
#
# Also note that this is ONLY meant to be used by individual drivers as it
# assumes the queries passed in are ready to run without any rewriting.  As
# such, any use outside of individual drivers should be considered an error.
#
# Returns '1' on success, undef on failure of any query (excepting non-critical
# queries, see above).
#
    my ($self, @queries) = @_;

    my $transaction = $DBI::VERSION >= 1.20;
    $self->{dbh}->begin_work if $transaction;

    $self->debug("Begin query transaction") if $self->{_debug};
    $self->debug("Transaction not possible; DBI version < 1.20") if $self->{_debug} and not $transaction;

    my $time;
    $time = Time::HiRes::time() if $self->{_debug} and exists $INC{"Time/HiRes.pm"};
    for (@queries) {
        my $critical = not(ref eq 'SCALAR' or ref eq 'REF');
        my $q = $critical ? $_ : $$_;
        my ($query, @ph) = ref $q ? @$q : $q;
        if ($self->{_debug}) {
            my $debugquery = GT::SQL::Driver::debug->replace_placeholders($query, @ph);
            $self->debug("Executing query $debugquery");
        }
        my $did = $self->{dbh}->do($query, undef, @ph);
        if (!$did and $critical) {
            $self->warn(CANTEXECUTE => $query => $DBI::errstr);
            $self->debug("Critical query failed, transaction aborted; performing transaction rollback")
                if $self->{_debug} and $transaction;
            $self->{dbh}->rollback if $transaction;
            return undef;
        }
    }

    $self->debug("Transaction complete; committing") if $self->{_debug};
    $self->{dbh}->commit if $transaction;

    if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
        my $elapsed = Time::HiRes::time() - $time;
        $self->debug(sprintf("Transaction execution took: %.6fs", $elapsed));
    }

    1;
}
END_OF_SUB

sub quote {
# -----------------------------------------------------------
# This subroutines quotes (or not) a value.
#
    my $val = pop;
    return 'NULL' if not defined $val;
    return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
    (values %CONN)[0]->quote($val);
}

$COMPILE{create_table} = __LINE__ . <<'END_OF_SUB';
sub create_table {
# -------------------------------------------------------------------
# Creates a table.
#
    my $self = shift;
    $self->connect or return;

    my $table = $self->{name};

# Figure out the order of the create, and then build the create statement.
    my %pos = map { $_ => $self->{schema}->{cols}->{$_}->{pos} } keys %{$self->{schema}->{cols}};
    my (@field_defs, $ai_queries);
    for my $field (sort { $pos{$a} <=> $pos{$b} } keys %{$self->{schema}->{cols}}) {
        my %field_def = map { defined $self->{schema}->{cols}->{$field}->{$_} ? ($_ => $self->{schema}->{cols}->{$field}->{$_}) : () } keys %{$self->{schema}->{cols}->{$field}};
        my $is_ai = $self->{schema}->{ai} && $field eq $self->{schema}->{ai};
        delete $field_def{default} if $is_ai;
        my $def = $field . ' ' . ($self->column_sql(\%field_def) or return);
        if ($is_ai) {
            my $ai = $self->{hints}->{ai} || 'AUTO_INCREMENT';
            $ai = $ai->($table, $field) if ref $ai eq 'CODE';
            if (ref $ai eq 'ARRAY') {
                $ai_queries = $ai;
            }
            else {
                $def .= " $ai";
            }
        }
        push @field_defs, $def;
    }

# Add the primary key.
    if (@{$self->{schema}->{pk}}) {
        push @field_defs, "PRIMARY KEY (" .  join(",", @{$self->{schema}->{pk}}) . ")";
    }

# Create the table
    my $create_query = "\n\tCREATE TABLE $table (\n\t\t";
    $create_query .= join ",\n\t\t", @field_defs;
    $create_query .= "\n\t)";

    $self->do($create_query) or return;

# If the database needs separate queries to set up the auto-increment, run them
    if ($ai_queries) {
        for (@$ai_queries) {
            $self->do($_);
        }
    }

# Create the table's indexes
    for my $type (qw/index unique/) {
        my $create_index = "create_$type";
        while (my ($index_name, $index) = each %{$self->{schema}->{$type}}) {
            $self->$create_index($table => $index_name => @$index) if @$index;
        }
    }

    1;
}
END_OF_SUB

$COMPILE{column_sql} = __LINE__ . <<'END_OF_SUB';
sub column_sql {
# -----------------------------------------------------------------------------
# Converts a column definition into an SQL string used in the create table
# statement, and (for some drivers) when adding a new column to a table.
#
    my ($self, $opts) = @_;

    ref $opts eq 'HASH' or return $self->fatal(BADARGS => '$obj->column_sql (HASH_REF)');
    $opts->{type}       or return $self->fatal(BADARGS => 'Column definition does not have a SQL type defined');

    my $pkg = ref($self) . '::Types';
    my $type = uc $opts->{type};

    if ($pkg->can($type)) {
        $self->debug("Using driver specific SQL for type $opts->{type}") if $self->{_debug} > 1;
    }
    elsif (GT::SQL::Driver::Types->can($type)) {
        $pkg = 'GT::SQL::Driver::Types';
    }
    else {
        return $self->fatal(BADTYPE => $opts->{type});
    }
    $pkg->$type({%$opts});
}
END_OF_SUB

$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
sub insert {
# -----------------------------------------------------------------------------
# This subroutine, using a couple driver hints, handles insertions for every
# driver currently supported.
#
    my ($self, $input) = @_;

    my (@names, @values, @placeholders, @binds);
    my %got;
    my $ai = $self->{schema}->{ai};
    my $bind = $self->{hints}->{bind};
    my $cols = $self->{schema}->{cols};
    while (my ($col, $val) = each %$input) {
        ++$got{$col};
        next if $ai and $col eq $ai and !$val;
        push @names, $col;
        my $def = $cols->{$col};
        if ($def->{time_check} and (not defined $val or $val eq '' or $val eq 'NOW()')) {
            push @values, $self->{hints}->{now} || 'NOW()';
        }
        elsif ($def->{type} =~ /DATE/ and (not defined $val or $val eq '')) {
            push @values, 'NULL';
        }
        elsif (ref $val eq 'SCALAR' or ref $val eq 'LVALUE') {
            push @values, $$val;
        }
        else {
            push @placeholders, $val;
            push @values, '?';
            if ($bind and defined $val) {
                for (my $i = 1; $i < @$bind; $i += 2) {
                    if ($def->{type} =~ /$bind->[$i]/) {
                        push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
                        last;
                    }
                }
            }
        }
    }

# Update any timestamp columns to current time.
    for my $col (keys %$cols) {
        next unless not $got{$col} and $cols->{$col}->{time_check};
        push @names, $col;
        push @values, $self->{hints}->{now} || 'NOW()';
        $got{$col} = 1;
    }

# Add an auto increment field if required
    if ($ai and not $input->{$ai}) {
        my @ai_insert = $self->ai_insert($ai);
        if (@ai_insert) {
            push @names,  $ai_insert[0];
            push @values, $ai_insert[1];
        }
    }

# Fill in any missing defaults 
    for my $col (keys %$cols) {
        next if $ai and $col eq $ai
             or $got{$col}
             or not exists $cols->{$col}->{default};
        my $val = $cols->{$col}->{default};
        push @names, $col;
        push @values, '?';

        # If the column is numeric, make sure a '' becomes a null, due to
        # problems where old libraries or the table editor could have set the
        # default to '':
        if (defined $val and $val eq '' and $cols->{$col}->{type} =~ /^(?:INTEGER|REAL|FLOAT|DOUBLE|DECIMAL)$|INT$/) {
            $val = undef;
        }
        push @placeholders, $val;
        $got{$col} = 1;
        if ($bind and defined $val) {
            my $def = $cols->{$col};
            for (my $i = 1; $i < @$bind; $i += 2) {
                if ($def->{type} =~ /$bind->[$i]/) {
                    push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
                    last;
                }
            }
        }
    }

# Create the SQL and statement handle.
    my $query = "INSERT INTO $self->{name} (";
    $query .= join ',', @names;
    $query .= ") VALUES (";
    $query .= join ',', @values;
    $query .= ")";

    $bind->[0]->{$query} = \@binds if $bind;

    my $sth = $self->prepare($query) or return;
    $sth->execute(@placeholders) or return;
    $sth;
}
END_OF_SUB

sub ai_insert {
# -----------------------------------------------------------------------------
# Returns a column name and value to use for the AI column when inserting a
# row.  If this returns an empty list, no value will be inserted.  This will
# only be called when the table has an auto-increment column, so checking is
# not necessary.  The sole argument passed in is the name of the column.
#
    my ($self, $ai) = @_;
    return $ai, 'NULL';
}

$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs a multiple-insertion.  By default, this is simply done as multiple
# executes on a single insertion, and as a single transaction if under
# DBI >= 1.20.
#
    my ($self, $cols, $args) = @_;
    $self->{dbh}->begin_work if $DBI::VERSION >= 1.20;
    my $count;
    for my $val (@$args) {
        my %set;
        for my $i (0 .. $#$cols) {
            $set{$cols->[$i]} = $val->[$i];
        }
        ++$count if $self->insert(\%set);
    }
    $self->{dbh}->commit if $DBI::VERSION >= 1.20;
    $count;
}
END_OF_SUB

sub update {
# -------------------------------------------------------------------
    my ($self, $set, $where) = @_;

    my $c = $self->{schema}->{cols};
    my %set;

    for my $cond (@{$set->{cond}}) {
        if (ref $cond eq 'ARRAY') {
            $set{$cond->[0]}++ if exists $c->{$cond->[0]} and $c->{$cond->[0]}->{time_check};
        }
    }
    for my $col (keys %$c) {
        next unless not $set{$col} and $c->{$col}->{time_check};
        $set->add($col, '=', \($self->{hints}->{now} || 'NOW()'));
    }

    my ($sql_set, $set_vals, $set_cols) = $set->sql(1);
    my ($sql_where, $where_vals, $where_cols) = $where->sql(1);
    my $i = 1;

    # Set up binds, if necessary
    my @binds;
    my $bind = $self->{hints}->{bind};
    if ($bind) {
        for my $col (@$set_cols) {
            next unless exists $c->{$col};
            for (my $j = 1; $j < @$bind; $j += 2) {
                if ($c->{$col}->{type} =~ /$bind->[$j]/) {
                    push @binds, [scalar $i, $col, $bind->[$j+1]];
                    last;
                }
            }
            $i++;
        }
    }

    my $query = "UPDATE $self->{name} SET $sql_set";
    $query .= " WHERE $sql_where" if $sql_where;

    $bind->[0]->{$query} = \@binds if $bind;

    my $sth = $self->prepare($query) or return;
    $sth->execute(@$set_vals, @$where_vals) or return;
    $sth;
}

sub delete {
# -------------------------------------------------------------------
    my ($self, $where) = @_;
    my ($sql_where, $where_vals) = $where ? $where->sql(1) : ();
    my $sql = "DELETE FROM $self->{name}";
    $sql .= " WHERE $sql_where" if $sql_where;

    my $sth = $self->prepare($sql) or return;
    $sth->execute(@$where_vals) or return;
    $sth;
}

sub select {
# -------------------------------------------------------------------
    my ($self, $field_arr, $where, $opts) = @_;

    my ($fields, $opt_clause) = ('', '');
    if (ref $field_arr and @$field_arr) {
        $fields = join ",", @$field_arr;
    }
    else {
        $fields = '*';
    }
    my ($sql_where, $where_vals) = $where->sql(1);
    $sql_where and ($sql_where = " WHERE $sql_where");
    if ($opts) {
        for my $opt (@$opts) {
            next if (! defined $opt);
            $opt_clause .= " $opt";
        }
    }
    my $sql = "SELECT $fields FROM " . $self->{name};
    $sql .= $sql_where if $sql_where;
    $sql .= $opt_clause if $opt_clause;
    my $sth = $self->prepare($sql) or return;
    $sth->execute(@$where_vals) or return;
    $sth;
}

$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
sub drop_table {
# -------------------------------------------------------------------
# Drops the table passed in.
#
    my ($self, $table) = @_;
    $self->do("DROP TABLE $table");
}
END_OF_SUB

$COMPILE{column_exists} = __LINE__ . <<'END_OF_SUB';
sub column_exists {
# -----------------------------------------------------------------------------
# Returns true or false value depending on whether the column exists in the
# table.  This defaults to a DESCRIBE of the table, then looks for the column
# in the DESCRIBE results - but many databases probably have a much more
# efficient alternative.
#
    my ($self, $table, $column) = @_;
    my $sth = $self->prepare("DESCRIBE $table") or return;
    $sth->execute or return;
    my $found;
    while (my ($col) = $sth->fetchrow) {
        $found = 1, last if $col eq $column;
    }
    $found;
}
END_OF_SUB

$COMPILE{add_column} = __LINE__ . <<'END_OF_SUB';
sub add_column {
# -------------------------------------------------------------------
# Adds a column to a table.
#
    my ($self, $table, $column, $def) = @_;
    $self->do("ALTER TABLE $table ADD $column $def");
}
END_OF_SUB

$COMPILE{drop_column} = __LINE__ . <<'END_OF_SUB';
sub drop_column {
# -------------------------------------------------------------------
# Drops a column from a table.
#
    my ($self, $table, $column) = @_;
    $self->do("ALTER TABLE $table DROP $column");
}
END_OF_SUB

$COMPILE{alter_column} = __LINE__ . <<'END_OF_SUB';
sub alter_column {
# -----------------------------------------------------------------------------
# Changes a column.  Takes table name, column name, definition for the new
# column (string), and the old column definition (hash ref).  The new column
# definition should already be set in the table object
# ($self->{table}->{schema}->{cols}->{$column_name}).
#
    my ($self, $table, $column, $new_def, $old_col) = @_;
    $self->do("ALTER TABLE $table CHANGE $column $column $new_def");
}
END_OF_SUB

$COMPILE{create_index} = __LINE__ . <<'END_OF_SUB';
sub create_index {
# -----------------------------------------------------------------------------
# Adds an index - checks driver hints for whether or not to prefix the index
# with the prefixed table name.
#
    my ($self, $table, $index_name, @index_cols) = @_;
    $index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
    $self->do("CREATE INDEX $index_name ON $table (" . join(",", @index_cols) . ")");
}
END_OF_SUB

$COMPILE{create_unique} = __LINE__ . <<'END_OF_SUB';
sub create_unique {
# -----------------------------------------------------------------------------
# Adds a unique index to a table, using the prefixed table name as a prefix.
#
    my ($self, $table, $unique_name, @unique_cols) = @_;
    $unique_name = $table . $unique_name if $self->{hints}->{prefix_indexes};
    $self->do("CREATE UNIQUE INDEX $unique_name ON $table (" . join(",", @unique_cols) . ")");
}
END_OF_SUB

$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
sub drop_index {
# -----------------------------------------------------------------------------
# Drops an index.
#
    my ($self, $table, $index_name) = @_;
    $index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
    my $dropped = $self->do("DROP INDEX $index_name");
    $dropped ||= $self->do("DROP INDEX $self->{connect}->{PREFIX}$index_name") if $self->{hints}->{fix_index_dbprefix};
    $dropped;
}
END_OF_SUB

$COMPILE{create_pk} = __LINE__ . <<'END_OF_SUB';
sub create_pk {
# -------------------------------------------------------------------
# Adds a primary key to a table.
#
    my ($self, $table, @cols) = @_;
    $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(",", @cols) . ")");
}
END_OF_SUB

$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
sub drop_pk {
# -------------------------------------------------------------------
# Drop a primary key.
#
    my ($self, $table) = @_;
    my $do;
    if ($self->{hints}->{drop_pk_constraint}) {
        # To drop a primary key in ODBC or Pg, you drop the primary key
        # constraint, which implicitly drops the index implicitly created by a
        # primary key.
        my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
        $sth->execute or return;

        my $pk_constraint;
        while (my $index = $sth->fetchrow_hashref) {
            if ($index->{index_primary}) {
                $pk_constraint = $index->{index_name};
                last;
            }
        }

        $pk_constraint or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");

        $do = "ALTER TABLE $table DROP CONSTRAINT $pk_constraint";
    }
    else {
        $do = "ALTER TABLE $table DROP PRIMARY KEY";
    }
    $self->do($do);
}
END_OF_SUB

1;