saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

522
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm Normal file
View File

@ -0,0 +1,522 @@
# ==================================================================
# 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;

226
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm Normal file
View File

@ -0,0 +1,226 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::MYSQL
# CVS Info : 087,071,086,086,085
# $Id: MYSQL.pm,v 2.1 2005/04/14 00:56:30 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: MySQL driver for GT::SQL
#
package GT::SQL::Driver::MYSQL;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use DBD::mysql 1.19_03;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub dsn {
# -----------------------------------------------------------------------------
# Creates the data source name used by DBI to connect to the database.
#
my ($self, $connect) = @_;
my $dsn;
$connect->{driver} ||= 'mysql';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
$dsn = "DBI:$connect->{driver}:";
$dsn .= join ';', map { $connect->{$_} ? "$_=$connect->{$_}" : () } qw/database host port/;
return $dsn;
}
sub _prepare_select {
# -----------------------------------------------------------------------------
# Prepares a query; rewrites PG-style LIMIT x OFFSET y into MySQL's confusing
# LIMIT y, n
#
my ($self, $query) = @_;
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/LIMIT $2, $1/i
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/LIMIT $1, $2/i;
$query;
}
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs a multiple-insertion. We have to watch the maximum query length,
# performing multiple queries if necessary.
#
my ($self, $cols, $args) = @_;
my $has_ai;
$has_ai = grep $_ eq $self->{schema}->{ai}, @$cols if $self->{schema}->{ai};
my $names = join ",", @$cols;
$names .= ",$self->{schema}->{ai}" if $self->{schema}->{ai} and not $has_ai;
my $ret;
my $values = '';
for (@$args) {
my $new_val;
$new_val = "(" . join(",", map GT::SQL::Driver::quote($_), @$_);
$new_val .= ",NULL" if $self->{schema}->{ai} and not $has_ai;
$new_val .= ")";
if ($values and length($values) + length($new_val) > 1_000_000) {
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
$values = '';
}
$values .= "," if $values;
$values .= $new_val;
}
if ($values) {
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
}
$ret;
}
# If making a nullable TEXT column not null, make sure we update existing NULL
# columns to get the default value.
sub alter_column {
my ($self, $table, $column, $new_def, $old_col) = @_;
my %col = %{$self->{schema}->{cols}->{$column}};
if ($col{type} =~ /TEXT$/i
and $col{not_null}
and not $old_col->{not_null}
and defined $col{default}
and not defined $old_col->{default}) {
$self->{dbh}->do("UPDATE $table SET $column = ? WHERE $column IS NULL", undef, $col{default});
}
return $self->SUPER::alter_column(@_[1 .. $#_])
}
sub create_index {
my ($self, $table, $index_name, @index_cols) = @_;
$self->do("ALTER TABLE $table ADD INDEX $index_name (" . join(',', @index_cols) . ")");
}
sub create_unique {
my ($self, $table, $index_name, @index_cols) = @_;
$self->do("ALTER TABLE $table ADD UNIQUE $index_name (" . join(',', @index_cols) . ")");
}
sub drop_index {
my ($self, $table, $index_name) = @_;
$self->do("ALTER TABLE $table DROP INDEX $index_name");
}
package GT::SQL::Driver::MYSQL::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver::sth;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Catch mysql's auto increment field.
#
my $self = shift;
return $self->{sth}->{mysql_insertid} || $self->{sth}->{insertid};
}
sub rows { shift->{sth}->rows }
sub _execute_show_index {
my $self = shift;
$self->{sth}->execute or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
my @results;
# Mysql columns are: Table Non_unique Key_name Seq_in_index Column_name Collation Cardinality Sub_part Packed Null Index_type Comment
my @names = @{$self->row_names};
# We need to add index_name, index_column, index_unique, index_primary (see GT::SQL::Driver)
push @names, qw/index_name index_column index_unique index_primary/ unless $self->{_names};
while (my $row = $self->{sth}->fetchrow_arrayref) {
my %h = map { $names[$_] => $row->[$_] } 0 .. $#$row;
push @results, [@$row, $h{Key_name}, $h{Column_name}, $h{Non_unique} ? 0 : 1, $h{Key_name} eq 'PRIMARY' ? 1 : 0];
}
$self->{rows} = @results;
$self->{_names} = \@names;
$self->{_results} = \@results;
}
package GT::SQL::Driver::MYSQL::Types;
use strict;
use GT::SQL::Driver::Types;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
# Integers. MySQL supports non-standard unsigned and zerofill properties;
# unsigned, though unportable, is supported here, however zerofill - whose
# usefulness is dubious at best - is not.
sub TINYINT { $_[0]->base($_[1], 'TINYINT', ['unsigned']) }
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT', ['unsigned']) }
sub MEDIUMINT { $_[0]->base($_[1], 'MEDIUMINT', ['unsigned']) }
sub INT { $_[0]->base($_[1], 'INT', ['unsigned']) }
sub BIGINT { $_[0]->base($_[1], 'BIGINT', ['unsigned']) }
# Floats - MySQL's 'REAL' is really a 64-bit floating point number, while for
# everything else 'REAL' is a 32-bit floating point number, so we override the
# defaults here to FLOAT.
sub FLOAT { $_[0]->base($_[1], 'FLOAT') }
sub REAL { $_[0]->base($_[1], 'FLOAT') }
sub CHAR {
my ($class, $args, $out) = @_;
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
$out ||= 'CHAR';
$out .= "($args->{size})";
$out .= ' BINARY' if $args->{binary}; # MySQL-only
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
return $out;
}
sub TEXT {
my ($class, $args) = @_;
my $type = 'LONGTEXT';
delete $args->{default}; # MySQL is the only driver that doesn't support defaults on TEXT's
if ($args->{size}) {
if ($args->{size} < 256) {
$type = 'TINYTEXT';
}
elsif ($args->{size} < 65536) {
$type = 'TEXT';
}
elsif ($args->{size} < 16777216) {
$type = 'MEDIUMTEXT';
}
}
$class->base($args, $type);
}
# MySQL supports ENUM; the generic ENUM is mapped to a VARCHAR
sub ENUM {
my ($class, $args) = @_;
@{$args->{'values'}} or return;
my $out = 'ENUM(' . join(",", map GT::SQL::Driver->quote($_), @{$args->{values}}) . ')';
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
$out;
}
sub BLOB {
my ($class, $attrib, $blob) = @_;
delete $attrib->{default};
$class->base($attrib, $blob || 'BLOB');
}
1;

590
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm Normal file
View File

@ -0,0 +1,590 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::ORACLE
# CVS Info : 087,071,086,086,085
# $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Oracle 8+ driver for GT::SQL
#
package GT::SQL::Driver::ORACLE;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;
use DBD::Oracle qw/:ora_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;
# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};
my $dbh = $self->SUPER::connect(@_) or return;
# Set the date format to same format as other drivers use.
$dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
or return $self->fatal(NONLSDATE => $DBI::errstr);
# Set max read properties for DBI.
$dbh->{LongReadLen} = 1_048_576;
return $dbh;
}
sub dsn {
# -------------------------------------------------------------------
# Oracle DSN looks like:
# DBI:Oracle:host=HOST;port=POST;sid=SID
#
my ($self, $connect) = @_;
$connect->{driver} ||= 'Oracle';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
my $dsn = "DBI:$connect->{driver}:";
$dsn .= "host=$connect->{host}";
$dsn .= ";port=$connect->{port}" if $connect->{port};
$dsn .= ";sid=$connect->{database}";
return $dsn;
}
sub hints {
case_map => 1,
prefix_indexes => 1,
bind => [
\%BINDS,
'TEXT' => ORA_CLOB,
'BLOB' => ORA_BLOB
],
now => 'SYSDATE',
ai => sub {
my ($table, $column) = @_;
my $seq = "${table}_seq";
my @q;
push @q, \"DROP SEQUENCE $seq";
push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
\@q;
}
}
sub prepare {
# -----------------------------------------------------------------------------
# Clear our limit counters. Oracle does not have built-in limit support, so it
# is handled here by fetching all the results that were asked for into _results
# and our own fetchrow methods work off that.
#
my ($self, $query) = @_;
# Oracle uses "SUBSTR" instead of "SUBSTRING"
$query =~ s/\bSUBSTRING\(/SUBSTR(/gi;
$self->SUPER::prepare($query);
}
sub _prepare_select {
# -----------------------------------------------------------------------------
# Need to store what the requested result set; no built in LIMIT support like
# mysql.
#
my ($self, $query) = @_;
my ($limit, $offset);
# Handle 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;
# using ROWNUM to limit rows instead.
my $max_rows = $offset + $limit;
$query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $offset";
}
# LEFT OUTER JOIN is not supported, instead:
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
$query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
my $from_where = "FROM $table1, $table2 WHERE ";
$from_where .= index($col1, "$table1.") == 0
? "$col1 = $col2(+)"
: "$col2 = $col1(+)";
$from_where .= " AND " if $where;
$from_where;
}ie;
$query;
}
sub _prepare_describe {
# ------------------------------------------------------------------
# Oracle supports USER_TAB_COLUMNS to get information
# about a table.
#
my ($self, $query) = @_;
if ($query =~ /DESCRIBE\s+(\w+)/i) {
return <<" QUERY";
SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
FROM USER_TAB_COLUMNS
WHERE TABLE_NAME = '\U$1\E'
ORDER BY COLUMN_ID
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
}
}
sub column_exists {
my ($self, $table, $column) = @_;
my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT COUNT(*)
FROM USER_TAB_COLUMNS
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
EXISTS
$sth->execute(uc $table, uc $column);
return scalar $sth->fetchrow;
}
sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# Oracle's equivelant to SHOW TABLES
#
my $self = shift;
$self->{do} = 'SELECT';
'SELECT table_name FROM USER_TABLES ORDER BY table_name';
}
sub _prepare_show_index {
# -----------------------------------------------------------------------------
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
my ($self, $query) = @_;
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
# the 'index_unique' still has to be mapped to a 1/0 value in execute(). Also
# worth noting is that primary keys in Oracle don't always get their own index
# - in particular, when adding a primary key to a table using a column that is
# already indexed, the primary key will simply use the existing index instead
# of creating a new one.
return <<QUERY;
SELECT
ic.index_name AS "index_name",
ic.column_name AS "index_column",
(
SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
) "index_primary",
uniqueness AS "index_unique"
FROM
user_ind_columns ic,
user_indexes i
WHERE
ic.index_name = i.index_name AND
LOWER(ic.table_name) = '\L$1\E'
ORDER BY
ic.index_name,
ic.column_position
QUERY
}
else {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
}
}
sub drop_table {
# -------------------------------------------------------------------
# Drops a table, including a sequence if necessary
#
my ($self, $table) = @_;
my $seq = uc "${table}_seq";
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
$sth->execute();
if (my $seq_name = $sth->fetchrow) {
my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
$sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
}
return $self->SUPER::drop_table($table);
}
sub ai_insert {
my ($self, $ai) = @_;
return $ai, "$self->{name}_seq.NEXTVAL";
}
sub alter_column {
# -------------------------------------------------------------------
# Changes a column. Takes table name, column name, and new column definition.
#
my ($self, $table, $column, $new_def, $old_col) = @_;
# make a copy so the original reference doesn't get clobbered
my %col = %{$self->{schema}->{cols}->{$column}};
# If the default value was removed, then make sure that the default constraint
# from the previous instance is deactivated.
if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
$col{default} = \'NULL';
}
# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
if ($col{not_null} and $old_col->{not_null}) {
delete $col{not_null};
}
$new_def = $self->column_sql(\%col);
# But it needs an explicit NULL to drop the field's NOT NULL
if (not $col{not_null} and $old_col->{not_null}) {
$new_def .= ' NULL';
}
# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
$new_def =~ s/^[BC]LOB ?//;
$new_def or return 1; # If the def is empty now, there really isn't anything to be done.
$self->do("ALTER TABLE $table MODIFY $column $new_def");
}
sub drop_column {
# -------------------------------------------------------------------
# Drops a column
#
my ($self, $table, $column) = @_;
$self->do("ALTER TABLE $table DROP COLUMN $column");
}
sub create_pk {
# -------------------------------------------------------------------
# Adds a primary key to a table.
#
my ($self, $table, @cols) = @_;
$self->create_index($table, "${table}_pkey", @cols);
$self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
}
package GT::SQL::Driver::ORACLE::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 ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
$table ||= $self->{name};
my $seq = $table . "_seq.CURRVAL";
my $query = "SELECT $seq FROM $table";
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
$sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
my ($id) = $sth->fetchrow_array;
$self->{_insert_id} = $id;
return $id;
}
sub execute {
# -------------------------------------------------------------------
# Fetch off only desired rows.
#
my $self = shift;
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"};
}
if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
my ($index, $col, $type) = @$bind;
$self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
}
}
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
$self->{_results} = [];
$self->{_insert_id} = '';
$self->{_names} = $self->{sth}->{NAME};
if ($self->{do} eq 'SELECT') {
$self->{_lim_cnt} = 0;
if ($self->{_limit}) {
while (my $rec = $self->{sth}->fetchrow_arrayref) {
my @tmp = @$rec;
pop @tmp; # get rid of the RNUM extra column
push @{$self->{_results}}, [@tmp]; # Must copy as ref is reused in DBI.
}
}
else {
$self->{_results} = $self->{sth}->fetchall_arrayref;
}
$self->{rows} = @{$self->{_results}};
}
elsif ($self->{do} eq 'SHOW INDEX') {
$self->{_names} = $self->{sth}->{NAME_lc};
$self->{_results} = $self->{sth}->fetchall_arrayref;
my $i = 0;
for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
for (@{$self->{_results}}) {
$_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
}
$self->{rows} = @{$self->{_results}};
}
elsif ($self->{do} eq 'DESCRIBE') {
$rc = $self->_fixup_describe();
}
else {
$self->{rows} = $self->{sth}->rows;
}
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;
}
sub _fixup_describe {
# ---------------------------------------------------------------
# Converts output of 'sp_columns tablename' into similiar results
# of mysql's describe tablename.
#
my $self = shift;
my @results;
# Mysql Cols are: Field, Type, Null, Key, Default, Extra
my $table = uc $self->{name};
while (my $col = $self->{sth}->fetchrow_hashref) {
my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
my $null = $col->{NULLABLE} eq 'Y';
my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};
$size = length $default if length $default > $size;
if ($type =~ /VARCHAR2|CHAR/) {
$type = "varchar($size)";
}
elsif ($type =~ /NUMBER/ and !$scale) {
if ($prec) {
$type =
$prec >= 11 ? 'bigint' :
$prec >= 9 ? 'int' :
$prec >= 6 ? 'mediumint' :
$prec >= 4 ? 'smallint' :
'tinyint';
}
else {
$type = 'bigint';
}
}
elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
$type = "decimal($prec, $scale)";
}
elsif ($type =~ /FLOAT/) {
$type = (!$prec or $prec > 23) ? 'double' : 'real';
}
elsif ($type =~ /LONG|CLOB|NCLOB/) {
$type = 'text';
}
elsif ($type =~ /DATE/) {
$type = 'datetime';
}
$type = lc $type;
$default =~ s,^NULL\s*,,;
$default =~ s,^\(?'(.*)'\)?\s*$,$1,;
$null = $null ? 'YES' : '';
push @results, [$field, $type, $null, '', $default, ''];
}
( $#results < 0 ) and return;
# Fetch the Primary key
my $que_pk = <<" QUERY";
SELECT COL.COLUMN_NAME
FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON
WHERE COL.TABLE_NAME = '\U$table\E'
AND COL.TABLE_NAME = CON.TABLE_NAME
AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME
AND CON.CONSTRAINT_TYPE='P'
QUERY
my $sth_pk = $self->{dbh}->prepare($que_pk);
$sth_pk->execute;
my $indexes = {};
while ( my $col = $sth_pk->fetchrow_array ) {
$indexes->{$col} = "PRI";
}
$sth_pk->finish;
# Fetch the index information.
my $que_idx = <<" QUERY";
SELECT *
FROM USER_INDEXES IND, USER_IND_COLUMNS COL
WHERE IND.TABLE_NAME = '\U$table\E'
AND IND.TABLE_NAME = COL.TABLE_NAME
AND IND.INDEX_NAME = COL.INDEX_NAME
QUERY
my $sth_idx = $self->{dbh}->prepare($que_idx);
$sth_idx->execute;
while ( my $col = $sth_idx->fetchrow_hashref ) {
my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
}
for my $result (@results) {
if (defined $indexes->{$result->[0]}) {
$result->[3] = $indexes->{$result->[0]};
if ($result->[1] =~ /int/) { # Set extra
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
$sth->execute;
$result->[5] = 'auto_increment' if $sth->fetchrow;
$sth->finish;
}
}
}
$sth_idx->finish;
$self->{_results} = \@results;
$self->{_names} = [qw/Field Type Null Key Default Extra/];
$self->{rows} = @{$self->{_results}};
return 1;
}
sub finish {
# -----------------------------------------------------------------------------
my $self = shift;
delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
$self->SUPER::finish;
}
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
sub _fetchrow_hashref {
# -----------------------------------------------------------------------------
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
# handling).
#
my $self = shift;
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
if ($self->{hints}->{case_map}) {
if (exists $self->{schema}->{cols}) {
my $cols = $self->{schema}->{cols};
%case_map = map { lc $_ => $_ } keys %$cols;
}
else {
for my $table (keys %{$self->{schema}}) {
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
$case_map{lc $col} = $col;
}
}
}
}
if ($self->{_results}) {
my $arr = shift @{$self->{_results}} or return;
my $i;
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
my %hash;
for my $lc_col (keys %selected) {
next if $lc_col eq 'rnum';
if (exists $case_map{$lc_col}) {
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
}
else {
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
}
}
return \%hash;
}
else {
my $h = $self->{sth}->fetchrow_hashref or return;
for (keys %$h) {
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
}
return $h;
}
}
END_OF_SUB
# -----------------------------------------------------------------------------
# DATA TYPE MAPPINGS
# -----------------------------------------------------------------------------
package GT::SQL::Driver::ORACLE::Types;
use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
# Quoting table and/or column names gives case-sensitivity to the table and
# column names in Oracle - however, because this needs to be compatible with
# older versions of this driver that didn't properly handle table/column case,
# we can't use that to our advantage, as all the old unquoted tables/columns
# would be upper-case - TABLE or COLUMN will be the name in the database, and
# "Table" or "column" would not exist. It would, however, still be nice to
# support this at some point:
# sub base {
# my ($class, $args, $name, $attribs) = @_;
# $class->SUPER::base($args, qq{"$name"}, $attribs);
# }
sub TINYINT { $_[0]->base($_[1], 'NUMBER(3)') }
sub SMALLINT { $_[0]->base($_[1], 'NUMBER(5)') }
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
sub INT { $_[0]->base($_[1], 'NUMBER(10)') }
sub BIGINT { $_[0]->base($_[1], 'NUMBER(19)') }
sub REAL { $_[0]->base($_[1], 'FLOAT(23)') }
sub DOUBLE { $_[0]->base($_[1], 'FLOAT(52)') }
sub DATETIME { $_[0]->base($_[1], 'DATE') }
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
sub TIME { croak "Oracle does not support 'TIME' columns\n" }
sub YEAR { croak "Oracle does not support 'YEAR' columns\n" }
sub CHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
sub TEXT { $_[0]->base($_[1], 'CLOB') }
sub BLOB { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }
1;

661
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm Normal file
View File

@ -0,0 +1,661 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::PG
# CVS Info : 087,071,086,086,085
# $Id: PG.pm,v 2.3 2005/10/06 00:05:51 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: PostgreSQL driver for GT::SQL
#
package GT::SQL::Driver::PG;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use GT::AutoLoader;
use DBI();
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver/;
sub protocol_version { 2 }
sub connect {
my $self = shift;
my $dbh = $self->SUPER::connect(@_) or return;
# This is really a hack to get things working somewhat accurately - ideally
# all data should be in UTF8, but GT::SQL and our products do not yet have
# any provision for such, and inserting iso8859-1 data into a unicode table
# causes fatal errors about invalid utf8 sequences. So, we set it to
# latin1 here in the hopes that it won't break too much, and let the
# application deal with it. There are still inherent problems here,
# however - if the database is latin5, for example, setting this to latin1
# would make postgresql attempt to convert from latin1 -> latin5 on input
# and convert back on output, which is a potentially lossy conversion.
$dbh->do("SET NAMES 'LATIN1'");
return $dbh;
}
sub dsn {
# -----------------------------------------------------------------------------
# Creates a postgres-specific DSN, such as:
# DBI:Pg:dbname=database;host=some_hostname
# host is omitted if set to 'localhost', so that 'localhost' can be used for a
# non-network connection. If you really want to connect to localhost, use
# 127.0.0.1.
#
my ($self, $connect) = @_;
$connect->{driver} ||= 'Pg';
$connect->{host} ||= 'localhost';
$self->{driver} = $connect->{driver};
my $dsn = "DBI:$connect->{driver}:";
$dsn .= "dbname=$connect->{database}";
$dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost';
$dsn .= ";port=$connect->{port}" if $connect->{port};
return $dsn;
}
sub hints {
prefix_indexes => 1,
fix_index_dbprefix => 1,
case_map => 1,
ai => sub {
my ($table, $column) = @_;
my $seq = "${table}_seq";
my @q;
push @q, \"DROP SEQUENCE $seq";
push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1";
\@q;
},
drop_pk_constraint => 1
}
$COMPILE{_version} = __LINE__ . <<'END_OF_SUB';
sub _version {
my $self = shift;
return $self->{pg_version} if $self->{pg_version};
my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION
if ($ver) {
local $^W;
$ver = sprintf "%.2f", $ver;
}
return $self->{pg_version} = $ver;
}
END_OF_SUB
sub _prepare_select {
# -----------------------------------------------------------------------------
# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format
#
my ($self, $query) = @_;
$query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i;
$query;
}
sub _prepare_describe {
# ------------------------------------------------------------------
# Postgres-specific describe code
#
my ($self, $query) = @_;
$query =~ /DESCRIBE\s*(\w+)/i
or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query");
# atttypmod contains the scale and precision, but has to be extracted using bit operations:
my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000)
my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000)
<<QUERY
SELECT
a.attname as "Field",
CASE
WHEN t.typname = 'int4' THEN 'int(10)'
WHEN t.typname = 'int2' THEN 'smallint(5)'
WHEN t.typname = 'int8' THEN 'bigint(19)'
WHEN t.typname = 'float4' THEN 'real'
WHEN t.typname = 'float8' THEN 'double'
WHEN t.typname = 'bpchar' THEN 'char(' || (a.atttypmod - 4) || ')'
WHEN t.typname = 'varchar' THEN 'varchar(' || (a.atttypmod - 4) || ')'
WHEN t.typname = 'numeric' THEN 'decimal(' || ((atttypmod & $prec_bits)>>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')'
ELSE t.typname
END AS "Type",
CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null",
(
SELECT
CASE
WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#')
WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc
ELSE NULL
END
FROM pg_attrdef
WHERE adrelid = c.relfilenode AND adnum = a.attnum
) AS "Default",
(
SELECT
CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END
FROM pg_attrdef d
WHERE d.adrelid = c.relfilenode AND adnum = a.attnum
) AS "Extra"
FROM
pg_class c, pg_attribute a, pg_type t
WHERE
a.atttypid = t.oid AND a.attrelid = c.oid AND
relkind = 'r' AND
a.attnum > 0 AND
c.relname = '\L$1\E'
ORDER BY
a.attnum
QUERY
# The following could be used above for Key - but it's left off because SHOW
# INDEX is much more useful:
# (
# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
# FROM pg_index keyi, pg_class keyc, pg_attribute keya
# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid
# and indisprimary = 't' and keya.attname = a.attname
# ) AS "Key",
}
sub column_exists {
my ($self, $table, $column) = @_;
my $sth = $self->{dbh}->prepare(<<EXISTS);
SELECT
COUNT(*)
FROM
pg_class c, pg_attribute a
WHERE
a.attrelid = c.oid AND
c.relkind = 'r' AND a.attnum > 0 AND
c.relname = ? AND a.attname = ?
EXISTS
$sth->execute(lc $table, lc $column);
return scalar $sth->fetchrow;
}
sub _prepare_show_tables {
# -----------------------------------------------------------------------------
# pg-specific 'SHOW TABLES'-equivelant
#
<<' QUERY';
SELECT relname AS tables
FROM pg_class
WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%')
ORDER BY relname
QUERY
}
sub _prepare_show_index {
# -----------------------------------------------------------------------------
# Get index list
#
my ($self, $query) = @_;
unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
}
<<" QUERY";
SELECT
c.relname AS index_name,
attname AS index_column,
CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique,
CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary
FROM
pg_index i,
pg_class c,
pg_class t,
pg_attribute a
WHERE
i.indexrelid = c.oid AND
a.attrelid = c.oid AND
i.indrelid = t.oid AND
t.relname = '\L$1\E'
ORDER BY
i.indexrelid, a.attnum
QUERY
}
sub drop_table {
# -----------------------------------------------------------------------------
# Drops the table passed in - drops a sequence if needed. Takes a second
# argument that, if true, causes the sequence _not_ to be dropped - used when
# the table is being recreated.
#
my ($self, $table) = @_;
my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'");
$sth->execute();
if (my $seq_name = $sth->fetchrow) {
$self->do("DROP SEQUENCE $seq_name")
or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error);
}
return $self->SUPER::drop_table($table);
}
sub drop_column {
# -------------------------------------------------------------------
# Drops a column from a table.
#
my ($self, $table, $column) = @_;
my $ver = $self->_version();
# Postgresql 7.3 and above support ALTER TABLE $table DROP $column
return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03;
$self->_recreate_table();
}
$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB';
sub _recreate_table {
# -----------------------------------------------------------------------------
# Adds/removes/changes a column, but very expensively as it involves recreating
# and copying the entire table. Takes argument pairs, currently:
#
# with => 'adding_this_column' # optional
#
# Keep in mind that the various columns depend on the {cols} hash of the table
# having been updated to reflect the change.
#
# We absolutely require DBI 1.20 in this subroutine for transaction support.
# However, we won't get here if using PG >= 7.3, so you can have either an
# outdated PG, or an outdated DBI, but not both.
#
my ($self, %opts) = @_;
DBI->require_version(1.20);
my $ver = $self->_version;
my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified');
my $cols = $self->{schema}->{cols};
my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols;
my (@copy_cols, @select_cols);
for (keys %$cols) {
push @copy_cols, "$_ " . $self->column_sql($cols->{$_});
push @select_cols, $_;
}
if ($opts{with}) { # a column was added, so we can't select it from the old table
@select_cols = grep $_ ne $opts{with}, @select_cols;
}
$self->{dbh}->begin_work;
my $temptable = "GTTemp" . substr(time, -4) . int rand 10000;
my $select_cols = join ', ', @select_cols;
my $lock = "LOCK TABLE $table";
my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table";
my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable";
my $drop_temp = "DROP TABLE $temptable";
for my $precreate ($lock, $createtemp) {
unless ($self->{dbh}->do($precreate)) {
$self->warn(CANTEXECUTE => $precreate => $DBI::errstr);
$self->{dbh}->rollback;
return undef;
}
}
unless ($self->drop_table($table)) {
$self->{dbh}->rollback;
return undef;
}
unless ($self->create_table) {
$self->{dbh}->rollback;
return undef;
}
for my $postcreate ($insert, $drop_temp) {
unless ($self->{dbh}->do($postcreate)) {
$self->warn(CANTEXECUTE => $postcreate => $DBI::errstr);
$self->{dbh}->rollback;
return undef;
}
}
$self->{dbh}->commit;
return 1;
}
END_OF_SUB
sub alter_column {
# -----------------------------------------------------------------------------
# Changes a column in a table. The actual path done depends on multiple
# things, including your version of postgres. The following are supported
# _without_ recreating the table; anything more complicated requires the table
# be recreated via _recreate_table().
#
# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20,
# everything else does)
# - adding/dropping a not null contraint, with >= 7.3
# - any other changes, with >= 7.3, by adding a new column, copying data into
# it, dropping the old column
#
# Anything else calls _recreate_table(), which also requires DBI 1.20, but is
# much more involved as the table has to be dropped and recreated.
#
my ($self, $table, $column, $new_def, $old_col) = @_;
my $ver = $self->_version;
return $self->_recreate_table() if $ver < 7;
my $cols = $self->{schema}->{cols};
my $new_col = $cols->{$column};
my @onoff = qw/not_null/; # true/false attributes
my @changeable = qw/default size scale precision/; # changeable attributes
my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff;
my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff;
my %change = map { (
exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new
and (
defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't
or
defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but !=
)
) ? ($_ => 1) : () } @changeable;
{
my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable;
my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable;
%add = (%add, %add_changeable);
%rem = (%rem, %rem_changeable);
}
if ($ver < 7.03) {
# In 7.0 - 7.2, defaults can be added/dropped/changed, but anything
# more complicated needs a table recreation
if (
keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default
or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default
or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default
) {
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
my $ph;
if ($add{default} or $change{default}) {
$query .= "SET DEFAULT ?";
$ph = $new_col->{default};
}
else {
$query .= "DROP DEFAULT";
}
$self->{dbh}->do($query, defined $ph ? (undef, $ph) : ())
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
return 1;
}
return $self->_recreate_table();
}
# PG 7.3 or later
if (
keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL
or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL
) {
# All we're doing is changing a not_null constraint
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
$query .= $rem{not_null} ? 'DROP' : 'SET';
$query .= ' NOT NULL';
$self->{dbh}->do($query)
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
return 1;
}
if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8)
and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null
and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null
) {
my @query;
# Change type (PG 8+ only)
if ($ver >= 8 and $change{type}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}";
}
# Change default
if ($add{default} or $change{default}) {
push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}];
}
elsif ($rem{default}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT";
}
# Change not_null
if ($rem{not_null}) {
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL";
}
elsif ($add{not_null}) {
if ($add{default}) {
push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}];
}
push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL";
}
return $self->do_raw_transaction(@query);
}
# We've got more complex changes than PG's ALTER COLUMN can handle; we need
# to add a new column, copy the data, drop the old column, and rename the
# new one to the old name.
my (@queries, %index, %unique);
push @queries, "LOCK TABLE $table";
my %add_def = %$new_col;
my $not_null = delete $add_def{not_null};
my $default = delete $add_def{default};
my $add_def = $self->column_sql(\%add_def);
my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000);
push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def";
push @queries, "UPDATE $table SET $tmpcol = $column";
push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default;
push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default;
push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null;
push @queries, "ALTER TABLE $table DROP COLUMN $column";
push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column";
for my $type (qw/index unique/) {
while (my ($index, $columns) = each %{$new_col->{$type}}) {
my $recreate;
for (@$columns) {
if ($_ eq $column) {
$recreate = 1;
last;
}
}
next unless $recreate;
if ($type eq 'index') {
$index{$index} = $columns;
}
else {
$unique{$index} = $columns;
}
}
}
$self->do_raw_transaction(@queries);
while (my ($index, $columns) = each %index) {
$self->create_index($table, $index, @$columns);
}
while (my ($index, $columns) = each %unique) {
$self->create_unique($table, $index, @$columns);
}
1;
}
sub add_column {
# -----------------------------------------------------------------------------
# Adds a new column to the table.
#
my ($self, $table, $column, $def) = @_;
# make a copy so the original reference doesn't get clobbered
my %col = %{$self->{schema}->{cols}->{$column}};
# Defaults and not_null have to be set _after_ adding the column.
my $default = delete $col{default};
my $not_null = delete $col{not_null};
my $ver = $self->_version;
return $self->_recreate_table(with => $column)
if $ver < 7 and defined $default or $ver < 7.03 and $not_null;
my @queries;
if (defined $default or $not_null) {
$def = $self->column_sql(\%col);
}
push @queries, ["ALTER TABLE $table ADD $column $def"];
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default;
push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null;
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null;
$self->do_raw_transaction(@queries);
}
sub create_pk {
my ($self, $table, @cols) = @_;
my $ver = $self->_version;
if ($ver < 7.2) {
return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")");
}
else {
# ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior
# versions we have to recreate the entire table.
return $self->_recreate_table();
}
}
sub drop_pk {
# -----------------------------------------------------------------------------
# Drop a primary key. Look for the primary key, then call drop_index with it.
#
my ($self, $table) = @_;
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
$sth->execute or return;
my $pk_name;
while (my $index = $sth->fetchrow_hashref) {
if ($index->{index_primary}) {
$pk_name = $index->{index_name};
last;
}
}
$pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
$self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name");
}
sub ai_insert {
my ($self, $ai) = @_;
return $ai, "NEXTVAL('$self->{name}_seq')";
}
sub insert_multiple {
# -----------------------------------------------------------------------------
# Performs multiple insertions in a single transaction, for much better speed.
#
my $self = shift;
# ->begin_work and ->commit were not added until 1.20
return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20;
$self->{dbh}->begin_work;
my ($cols, $args) = @_;
my $names = join ",", @$cols, $self->{schema}->{ai} || ();
my $ret;
my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef;
my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')';
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
for (@$args) {
if ($sth->execute(@$_)) {
++$ret;
}
else {
$self->warn(CANTEXECUTE => $query);
}
}
$self->{dbh}->commit;
$ret;
}
sub quote {
# -----------------------------------------------------------------------------
# This subroutines quotes (or not) a value. Postgres can't handle any text
# fields containing null characters, so this has to go beyond the ordinary
# quote() in GT::SQL::Driver by stripping out null characters.
#
my $val = pop;
return 'NULL' if not defined $val;
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
$val =~ y/\x00//d;
(values %GT::SQL::Driver::CONN)[0]->quote($val);
}
package GT::SQL::Driver::PG::sth;
# ====================================================================
use strict;
use vars qw/@ISA $ERROR_MESSAGE/;
use GT::SQL::Driver;
use GT::AutoLoader;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = qw/GT::SQL::Driver::sth/;
sub insert_id {
# -------------------------------------------------------------------
# Retrieves the current sequence.
#
my $self = shift;
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
$table ||= $self->{name};
my $query = "SELECT CURRVAL('${table}_seq')";
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query => $DBI::errstr);
$sth->execute or return $self->fatal(CANTEXECUTE => $query => $DBI::errstr);
my $id = $sth->fetchrow;
return $id;
}
# ------------------------------------------------------------------------------------------------ #
# DATA TYPE MAPPINGS
# ------------------------------------------------------------------------------------------------ #
package GT::SQL::Driver::PG::Types;
# ===============================================================
use strict;
use GT::SQL::Driver::Types;
use Carp qw/croak/;
use vars qw/@ISA/;
@ISA = 'GT::SQL::Driver::Types';
sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') }
sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" }
# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big)
# caveat to this type, however, is that it requires escaping for any input, and
# unescaping for any output.
1;

191
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm Normal file
View File

@ -0,0 +1,191 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::Types
# CVS Info : 087,071,086,086,085
# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Implements subroutines for each type to convert into SQL string.
# See GT::SQL::Types for documentation
#
# Supported types are:
# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits
# REAL FLOAT DOUBLE - 32, 32, 64 bits
# DECIMAL - decimal precision
# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc.
# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space
# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type
# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively
# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes
# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons.
# FILE - GT::SQL pseudo-type
package GT::SQL::Driver::Types;
use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/;
use strict;
use Exporter();
use GT::Base();
*import = \&Exporter::import;
$ERROR_MESSAGE = 'GT::SQL';
@ISA = 'GT::Base';
$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/;
@EXPORT_OK = qw/base/;
sub base {
# ------------------------------------------------------------------
# Base function takes care of most of the types that don't require
# much special formatting.
#
my ($class, $args, $name, $attribs) = @_;
$attribs ||= [];
my $out = $name;
for my $attrib (@$attribs) {
$out .= ' ' . $attrib if $args->{$attrib};
}
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
$out;
}
# Integers. None of the following are supported by Oracle, which can only
# define integer types by the number of digits supported (see
# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by
# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned
# attribute is also passed in). All int types are signed - an 'unsigned'
# column attribute can be used to /suggest/ that the integer type be unsigned -
# but it is only for some databases and/or INT types, and so not guaranteed.
sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int
sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int
sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int
sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int
sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above
# Floating point numbers
sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision)
sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks
sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL
sub DECIMAL {
# ------------------------------------------------------------------
# Takes care of DECIMAL's precision.
#
my ($class, $args, $out, $attribs) = @_;
$out ||= 'DECIMAL';
$attribs ||= [];
# 'scale' and 'precision' are the proper names, but a prior version used
# the unfortunate 'display' and 'decimal' names, which have no relevant
# meaning in SQL.
my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef;
my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef;
$scale ||= 0;
$precision ||= 10;
$out .= "($precision, $scale)";
for my $attrib (@$attribs) {
$out .= ' ' . $attrib if $args->{$attrib};
}
defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default});
$args->{not_null} and $out .= ' NOT NULL';
return $out;
}
# Dates - just about every database seems to do things differently here.
sub DATE { $_[0]->base($_[1], 'DATE') }
sub DATETIME { $_[0]->base($_[1], 'DATETIME') }
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') }
sub TIME { $_[0]->base($_[1], 'TIME') }
sub YEAR { $_[0]->base($_[1], 'YEAR') }
# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255.
# Everything except Oracle handles VARCHAR's - Oracle, having deprecated
# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY'
# attribute to turn this into a "binary" char (meaning, really,
# case-insensitive, not binary) - for everything else, a "binary" argument is
# simply ignored.
sub CHAR {
my ($class, $args, $out) = @_;
# Important the set the size before calling BINARY, because BINARY's
# behaviour is different for sizes <= 255.
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR
$out ||= 'VARCHAR';
$out .= "($args->{size})";
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
$out .= ' NOT NULL' if $args->{not_null};
return $out;
}
sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') }
# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to
# provide different types based on the 'size' attribute.
sub TEXT {
my ($class, $attrib) = @_;
$class->base($attrib, 'TEXT')
}
# .+TEXT is for compatibility with old code, and should be considered
# deprecated. Takes the args hash and the size desired.
sub _OLD_TEXT {
my ($class, $args, $size) = @_;
$args = {$args ? %$args : ()};
$args->{size} = $size unless $args->{size} and $args->{size} < $size;
$class->TEXT($args);
}
sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) }
sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) }
sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) }
sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) }
# The BLOB* columns below are heavily deprecated - they're still here just in
# case someone is still using them. Storing binary data inside an SQL row is
# generally a poor idea; a much better approach is to store a pointer to the
# data (such as a filename) in the database, and the actual data in a file.
#
# As such, the default behaviour is to fatal if BLOB's are used - only drivers
# that supported BLOB's prior to protocol v2 should override this. Should a
# binary type be desired in the future, a 'BINARY' pseudo-type is recommended.
sub BLOB {
my ($driver) = $_[0] =~ /([^:]+)$/;
$driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver;
$_[0]->fatal(DRIVERTYPE => $driver => 'BLOB')
}
sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') }
sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') }
sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') }
# Enums - a non-standard SQL type implemented only by MySQL - the default
# implementation is to implement it as a CHAR (or TEXT if the longest value is
# more than 255 characters - but in that case, are you really sure you want to
# use this type?)
sub ENUM {
my ($class, $args) = @_;
my $max = 0;
@{$args->{'values'}} or return;
for my $val (@{$args->{'values'}}) {
my $len = length $val;
$max = $len if $len > $max;
}
my $meth = $max > 255 ? 'TEXT' : 'CHAR';
$class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} });
}
# File handling
sub FILE {
my ($class, $args) = @_;
$class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} });
}
1;

189
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm Normal file
View File

@ -0,0 +1,189 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::debug
# Author: Jason Rhinelander
# CVS Info : 087,071,086,086,085
# $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# GT::SQL::Driver debugging module
#
package GT::SQL::Driver::debug;
use strict;
use strict;
use GT::AutoLoader;
use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/;
@ISA = qw(GT::Base);
$QUERY_STACK_SIZE = 100;
$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB';
sub last_query {
# -------------------------------------------------------------------
# Get, or set the last query.
#
my $self = shift;
return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug});
@_ > 0 or return $LAST_QUERY || '';
$LAST_QUERY = shift;
$LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_);
# Display stack traces if requested via debug level.
my $stack = '';
if ($self->{_debug} > 2) {
($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY);
}
elsif ($self->{_debug} > 1) {
package DB;
my $i = 2;
my $ls = defined $ENV{REQUEST_METHOD} ? '<br>' : "\n";
my $spc = defined $ENV{REQUEST_METHOD} ? '&nbsp;' : ' ';
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
my @args;
for (@DB::args) {
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
my $print = $@ ? \$_ : $_;
push @args, defined $print ? $print : '[undef]';
}
if (@args) {
my $args = join ", ", @args;
$args =~ s/\n\s*\n/\n/g;
$args =~ s/\n/\n$spc$spc$spc$spc/g;
$stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
}
else {
$stack .= qq!$sub called at $file line $line with no arguments.$ls!;
}
}
}
push @QUERY_STACK, $LAST_QUERY;
push @STACK_TRACE, "<blockquote>\n" . $stack . "\n</blockquote>\n" if ($self->{_debug} and $stack);
# Pesistance such as Mod_Perl
@QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK;
@STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE;
return $LAST_QUERY || '';
}
END_OF_SUB
$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB';
sub js_stack {
# -------------------------------------------------------------------
# Create a nicely formatted javascript browser that (unfortunately)
# only works in ie, netscape sucks.
#
my ($sp, $title) = @_;
my $nb = @QUERY_STACK;
my ($stack, $dump_out);
{
package DB;
require GT::Dumper;
my $i = 0;
while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) {
if (@DB::args) {
$args = "with arguments<br>&nbsp;&nbsp; ";
my @args;
for (@DB::args) {
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
my $print = $@ ? \$_ : $_;
my $arg = defined $print ? $print : '[undef]';
$args .= "<a href='#a$nb$i'>$arg</a>, ";
my $dump = GT::Dumper::Dumper($arg);
$dump_out .= qq~
<a name="a$nb$i"></a>
<a href="#top">Top</a>
<pre>$dump</pre>
~;
$i++;
}
chop $args; chop $args;
}
else {
$args = "with no arguments";
}
$stack .= qq!<li>$sub called at $file line $line $args.<br></li>\n!;
}
}
$stack =~ s/\\/\\\\/g;
$stack =~ s/[\n\r]+/\\n/g;
$stack =~ s/'/\\'/g;
$stack =~ s,script,sc'+'ript,g;
$dump_out =~ s/\\/\\\\/g;
$dump_out =~ s/[\n\r]+/\\n/g;
$dump_out =~ s/'/\\'/g;
$dump_out =~ s,script,sc'+'ript,g;
my $var = <<HTML;
<script language="JavaScript">
function my$nb () {
msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes');
msg.document.write('<html><body><a name="top"></a>STACK TRACE<BR><OL>$stack</OL>$dump_out</BODY></HTML>');
msg.document.close();
}
HTML
my $link = qq!<a href="javascript:my$nb();">$title</a><br>!;
return $var, $link;
}
END_OF_SUB
$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB';
sub quick_quote {
# -------------------------------------------------------------------
# Quick quote to replace ' with \'.
#
my $str = shift;
defined $str and ($str eq "") and return "''";
$str =~ s/'/\\'/g;
return $str;
}
END_OF_SUB
$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB';
sub replace_placeholders {
# -------------------------------------------------------------------
# Replace question marks with the actual values
#
my ($self, $query, @args) = @_;
if (@args > 0) {
my @vals = split /('(?:[^']+|''|\\')')/, $query;
# Keep track of where we are in each of the @vals strings so that strings with
# '?'s in them that aren't placeholders don't incorrectly get replaced with
# values.
my @vals_idx;
VALUE: for my $val (@args) {
SUBSTRING: for my $i (0 .. $#vals) {
next SUBSTRING if $i % 2;
$vals_idx[$i] ||= 0;
$vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]);
if ($vals_idx[$i] >= 0) {
$val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL';
substr($vals[$i], $vals_idx[$i], 1, $val);
$vals_idx[$i] += length $val;
next VALUE;
}
else {
$vals_idx[$i] = 0;
}
}
}
$query = join '', @vals;
}
return $query;
}
END_OF_SUB
1;

296
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm Normal file
View File

@ -0,0 +1,296 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::SQL::Driver::sth
# Author: Jason Rhinelander
# CVS Info : 087,071,086,086,085
# $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
# Description:
# Generic statement handle wrapper
#
package GT::SQL::Driver::sth;
use strict;
use GT::Base;
use GT::AutoLoader(NEXT => '_AUTOLOAD');
require GT::SQL::Driver;
use GT::SQL::Driver::debug;
use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE);
$DEBUG = 0;
@ISA = qw/GT::SQL::Driver::debug/;
$ERROR_MESSAGE = 'GT::SQL';
# Get rid of a 'used only once' warnings
$DBI::errstr if 0;
sub new {
# --------------------------------------------------------
# Create a new driver sth.
#
my $this = shift;
my $class = ref $this || $this;
my $opts = {};
my $self = bless {}, $class;
if (@_ == 1 and ref $_[0]) { $opts = shift }
elsif (@_ and @_ % 2 == 0) { $opts = {@_} }
else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") }
$self->{_debug} = $opts->{_debug} || $DEBUG;
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
# Drivers can set this to handle name case changing for fetchrow_hashref
$self->{hints} = $opts->{hints} || {};
for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) {
$self->{$_} = $opts->{$_} if exists $opts->{$_};
}
$self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
return $self;
}
$COMPILE{execute} = __LINE__ . <<'END_OF_SUB';
sub execute {
# --------------------------------------------------------
# Execute the query.
#
my $self = shift;
my $do = $self->{do};
my $rc;
# Debugging, stack trace is printed if debug >= 2.
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"};
}
if (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) {
$meth = "_execute_$meth";
$rc = $self->$meth(@_) or return;
}
else {
$rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
}
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
my $elapsed = Time::HiRes::time() - $time;
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
}
$rc;
}
END_OF_SUB
# Define one generic execute, and alias all the specific _execute_* functions to it
sub _generic_execute {
my $self = shift;
$self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
}
for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) {
$_ = \&_generic_execute;
}
sub rows {
my $self = shift;
return $self->{_rows} if exists $self->{_rows};
return $self->{rows} if exists $self->{rows};
$self->{sth}->rows;
}
sub fetchrow_arrayref {
# -----------------------------------------------------------------------------
my $self = shift;
$self->{_results} or return $self->{sth}->fetchrow_arrayref;
return shift @{$self->{_results}};
}
sub fetchrow_array {
# -----------------------------------------------------------------------------
# When called in scalar context, returns either the first or last row, as per
# DBI, so avoid using in scalar context when fetching more than one row.
#
my $self = shift;
$self->{_results} or return $self->{sth}->fetchrow_array;
my $arr = shift @{$self->{_results}};
return $arr ? wantarray ? @$arr : $arr->[0] : ();
}
# -----------------------------------------------------------------------------
# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's
# documentation no longer mentions it at all).
*fetchrow = \&fetchrow_array; *fetchrow if 0;
sub fetchrow_hashref {
# -----------------------------------------------------------------------------
my $self = shift;
return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results};
$self->{sth}->fetchrow_hashref;
}
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
sub _fetchrow_hashref {
# -----------------------------------------------------------------------------
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
# handling).
#
my $self = shift;
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
if ($self->{hints}->{case_map}) {
if (exists $self->{schema}->{cols}) {
my $cols = $self->{schema}->{cols};
%case_map = map { lc $_ => $_ } keys %$cols;
}
else {
for my $table (keys %{$self->{schema}}) {
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
$case_map{lc $col} = $col;
}
}
}
}
if ($self->{_results}) {
my $arr = shift @{$self->{_results}} or return;
my $i;
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
my %hash;
for my $lc_col (keys %selected) {
if (exists $case_map{$lc_col}) {
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
}
else {
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
}
}
return \%hash;
}
else {
my $h = $self->{sth}->fetchrow_hashref or return;
for (keys %$h) {
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
}
return $h;
}
}
END_OF_SUB
sub fetchall_arrayref {
# ---------------------------------------------------------------
my $self = shift;
return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results};
my $opt = shift;
if ($opt and ref $opt eq 'HASH') {
my @ret;
while (my $row = $self->fetchrow_hashref) {
for (keys %$row) {
delete $row->{$_} unless exists $opt->{$_};
}
push @ret, $row;
}
return \@ret;
}
my $results = $self->{_results};
$self->{_results} = [];
return $results;
}
sub fetchall_list { map @$_, @{shift->fetchall_arrayref} }
sub fetchall_hashref {
# -----------------------------------------------------------------------------
# This is very different from DBI's fetchall_hashref - this is actually
# equivelant to DBI's ->fetchall_arrayref({})
#
my $self = shift;
my @results;
while (my $hash = $self->fetchrow_hashref) {
push @results, $hash;
}
return \@results;
}
sub row_names {
my $self = shift;
$self->{_names} || $self->{sth}->{NAME};
}
$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB';
sub insert_id {
# -------------------------------------------------------------------
# Returns the value of the last record inserted.
#
return $_[0]->{sth}->{insertid};
}
END_OF_SUB
sub DESTROY {
# -------------------------------------------------------------------
# Calls finish on the row when it is destroyed.
#
my $self = shift;
$self->debug("OBJECT DESTROYED") if $self->{_debug} > 2;
$self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish");
}
sub _AUTOLOAD {
# -------------------------------------------------------------------
# Autoloads any unknown methods to the DBI::st object.
#
my ($self, @param) = @_;
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
if (exists $DBI::st::{$attrib}) {
local *code = $DBI::st::{$attrib};
if (*code{CODE}) {
$self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1;
return code($self->{sth}, @param);
}
}
$GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD;
goto &GT::SQL::Driver::debug::AUTOLOAD;
}
sub debug {
# -------------------------------------------------------------------
# DBI::st has a debug that autoload is catching.
#
my $self = shift;
my $i = 1;
my ($package, $file, $line, $sub);
while (($package, $file, $line) = caller($i++)) {
last if index($package, 'GT::SQL') != 0;
}
while ($sub = (caller($i++))[3]) {
last if index($sub, 'GT::SQL') != 0;
}
my $msg = $_[0];
$msg .= " from $sub" if $sub;
$msg .= " at $file" if $file;
$msg .= " line $line" if $line;
$msg .= "\n";
return $self->SUPER::debug($msg);
}
1;