905 lines
32 KiB
Perl
905 lines
32 KiB
Perl
# ==================================================================
|
|
# 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;
|