# @(#$Id$ (C) 1996 CDKIT
#
# Copyright (c) 1996, 1997 - CDKIT - SAINT CLOUD - FRANCE
#
# Permission to use, copy, modify, distribute, and sell this software
# and its documentation for any purpose is hereby granted without fee,
# provided that the above copyright notice and this permission notice
# appear in all copies of the software and related documentation.
#
# THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
# EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
# WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
#
# IN NO EVENT SHALL CDKIT BE LIABLE FOR ANY SPECIAL, INCIDENTAL,
# INDIRECT OR CONSEQUENTIAL DAMAGES OF ANY KIND, OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER OR NOT
# ADVISED OF THE POSSIBILITY OF DAMAGE, AND ON ANY THEORY OF LIABILITY,
# ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
# SOFTWARE.
#
# The low level access layer for tcsq when using an odbc driver manager
# The SQLDBTYPE should be set to ODBC for this to be used.
# The ODBC comments in this file reflect the thinking of a very novice
# and naive ODBC user, and many maybe wrong. Please correct me:
# dockes@musicmaker.com
package provide ODBCtcsq 0.1
package require tclodbc
#set tcsqdebuglevel 2
### ODBC CODE############################################
# Places to store information about connections and statements
array set _ODBCconns {}
array set _ODBCstmts {}
# Open a connection. This is normally used to connect and identify to
# a database server, without mention of a specific database. This has
# no meaning for ODBC were a connection always refers to a specific
# datasource. We create a connection name and remember the parameters
# in a local array
proc ODBCconnect {{host ""} {user ""} {passwd ""}} {
global _ODBCconns
tcsqdebug "ODBCconnect: host $host, user $user, passwd $passwd"
set ok 0
for {set i 1} {$i < 100000} {incr i} {
set hdl "hdl$i"
if {![info exists _ODBCconns($hdl)]} {
set _ODBCconns($hdl) [list $host $user $passwd]
set ok 1
break
}
}
if {$ok} {
return $hdl
} else {
return -code error "ODBCconnect: can't allocate connection handle"
}
}
# Connect an open handle to a database. Enter the handle in the pool
# of idle handles for this host/db
proc ODBCuse {hdl database} {
global _ODBCconns
tcsqdebug "ODBCuse: '$hdl', '$database'"
if {![info exists _ODBCconns($hdl)]} {
return -code error "Unknown connection handle: '$hdl'"
}
set user [lindex $_ODBCconns($hdl) 1]
set passwd [lindex $_ODBCconns($hdl) 2]
set cmd [list database connect $hdl $database]
if {$user != ""} {
lappend cmd $user
if {$passwd != ""} {
lappend cmd $passwd
}
}
tcsqdebug "ODBCuse: '$cmd'" 2
eval $cmd
lappend _ODBCconns($hdl) $database
return $hdl
}
# Open a select statement: get an idle handle first.
proc ODBCopensel {hdl stmt} {
global _ODBCstmts
tcsqdebug "ODBCopensel: hdl '$hdl', stmt '$stmt'"
set ok 0
for {set i 1} {$i < 100000} {incr i} {
set qry "qry$i"
if {![info exists _ODBCstmts($qry)]} {
set _ODBCstmts($qry) ""
set ok 1
break
}
}
if {$ok == 0} {
return -code error "ODBCopensel: can't allocate statement handle"
}
$hdl statement $qry $stmt
$qry execute
return $qry
}
proc ODBCnext {qry} {
return [$qry fetch]
}
proc ODBCrew {qry} {
return [$qry execute]
}
proc ODBCclosel {qry} {
tcsqdebug "ODBCclosel: qry '$qry'"
$qry drop
global _ODBCstmts
unset _ODBCstmts($qry)
}
# We use an actual statement in order to retrieve the count of
# affected rows. Else, we could just do "$hdl $stmt"
proc ODBCexec {hdl stmt} {
tcsqdebug "ODBCexec: hdl '$hdl', stmt '$stmt'"
$hdl statement odbcexecstmt $stmt
odbcexecstmt execute
set res [odbcexecstmt rowcount]
odbcexecstmt drop
tcsqdebug "ODBCexec: returning: $res"
return $res
}
# Retrieve auto_increment value for the last insert.
# Don't know how portable this, probably not much. Works with MySQL
proc ODBCinsertid {hdl} {
set code [catch {set res [$hdl "SELECT LAST_INSERT_ID()"]}]
if {$code} {
return ""
} else {
tcsqdebug "Last insert id: '$res'" 1
return $res
}
}
# Retrieve unique id for the specified table
proc ODBCuniqueid {hdl tbl} {
tcsqdebug "ODBCuniqueid: hdl '$hdl', tbl '$tbl'"
global _ODBCconns
set host [lindex $_ODBCconns($hdl) 0]
set database [lindex $_ODBCconns($hdl) 3]
return [cdkuniqueid $host $database $tbl]
}
proc ODBCdiscon {hdl} {
tcsqdebug "ODBCdiscon: hdl '$hdl'"
$hdl disconnect
global _ODBCconns
unset _ODBCconns($hdl)
# We'd also need a way to clear stuff from _ODBCstmts, but this does
# not seem really important as only an empty array entry is lost
}
proc ODBCtabinfo {hdl} {
set ll [$hdl tables]
foreach tbl $ll {
lappend res [lindex $tbl 2]
}
return $res
}
# One thing that we'd like to do, but don't know how is retrieve the
# "auto_increment attribute. This is defined in odbc, but tclodbc
# doesn't seem to support it
proc ODBCcolinfo {hdl tbl arnm} {
upvar $arnm ar
global sqlsc_def_maxlen env
set primkeycols {}
# Retrieve column info. List elements:
# 0 TABLE_QUALIFIER #1 TABLE_OWNER #2 TABLE_NAME
# 3 COLUMN_NAME # 4 DATA_TYPE # 5 TYPE_NAME
# 6 PRECISION # 7 LENGTH # 8 SCALE # 9 RADIX # 10 NULLABLE # 11 REMARKS
set ll [$hdl columns $tbl]
foreach cll $ll {
tcsqdebug "$cll" 2
set nm [string tolower [lindex $cll 3]]
lappend allcols $nm
set typ($nm) [string trim [lindex $cll 5]]
set len($nm) [string trim [lindex $cll 6]]
}
# Retrieve index info. Each element in the list has:
#0 TABLE_QUALIFIER #1 TABLE_OWNER #2 TABLE_NAME
#3 NON_UNIQUE (0/1) #4 INDEX_QUALIFIER #5 INDEX_NAME (primkey->PRIMARY)
#6 TYPE # 7 SEQ_IN_INDEX # 8 COLUMN_NAME
#9 COLLATION #10 CARDINALITY #11 PAGES #12 FILTER_CONDITION
set ll [$hdl indexes $tbl]
foreach ill $ll {
tcsqdebug "Index: $ill" 2
set keyname [lindex $ill 5]
set colname [lindex $ill 8]
if {$keyname == "PRIMARY"} {
lappend primkeycols [string tolower $colname]
}
}
# Build the column list for the screen:
if {![info exists ar(columns)]} {
# If it was not specified, we use all columns
set ar(columns) $allcols
set autocols 1
} else {
# The user-specified list may include fully qualified
# names. Compute the list of simple column names.
# scol == "" may happen because of the "\n" in the column list
foreach col $ar(columns) {
set scol [_tcsqsimplecolname $tbl $col]
if {$scol != ""} {
lappend scols [string tolower $scol]
}
}
set autocols 0
}
# Try to retrieve the autoincrement attribute. It seems that we
# have to run a statement for this. Can't see why we can get it
# from the db object but...
$hdl statement colinfostmt "select * from $tbl where 1=0"
colinfostmt execute
set autoinclist {}
set namelist {}
set namelist [colinfostmt columns name]
# We catch this, because it doesn't work with some tclodbc versions
catch {set autoinclist [colinfostmt columns autoincrement]}
tcsqdebug "namelist: $namelist" 2
tcsqdebug "autoinclist: $autoinclist" 2
if {$autoinclist != {}} {
set i 0
foreach col $namelist {
set autoi [lindex $autoinclist $i]
if {$autoi} {
set ar(tabcolserial) $col
tcsqdebug "tabcolserial: $col" 2
break
}
incr i
}
}
# Possibly build updateindex from the primary key, if not
# specified by the caller.
# If the column list was specified, but not the updateindex list,
# we set the latter only if all its components are included in the
# column list.
if {![info exists ar(updateindex)]} {
set ar(updateindex) $primkeycols
if {$autocols == 0} {
foreach col $primkeycols {
if {[lsearch -exact $scols $col] == -1} {
unset ar(updateindex)
break
}
}
}
}
catch {tcsqdebug "$tbl: updateindex: $ar(updateindex)" 1}
# Set the column types and lengths in the array
foreach col $ar(columns) {
# Get the simple name and check that it is for this table
set scol [_tcsqsimplecolname $tbl $col]
if {$scol == "" || ![info exists typ($scol)]} {
# Column probably from another table
continue
}
# In all cases, remember type and length as from db
set ar(sqlsc_${col}_dbtype) $typ($scol)
set ar(sqlsc_${col}_dblen) $len($scol)
# puts "$col: Dbtyp: $typ($scol), Dblen: $len($scol)"
set typind "sqlsc_${col}_type"
set lenind "sqlsc_${col}_len"
if {![info exists ar($lenind)]} {
set ar($lenind) $len($scol)
# puts "$col: length not preset, set to $ar($lenind)"
if {$ar($lenind) > $sqlsc_def_maxlen} {
# puts "$col: limiting width to $sqlsc_def_maxlen"
set ar($lenind) $sqlsc_def_maxlen
}
}
# ODBC types ?
# CHAR VARCHAR LONGVARCHAR
# DATE TIME TIMESTAMP
# NUMERIC DECIMAL INTEGER SMALLINT BIGINT TINYINT BIT
# FLOAT REAL DOUBLE
# BINARY VARBINARY LONGVARBINARY
switch [set lowtyp [string tolower $typ($scol)]] {
char -
varchar -
longvarchar {
set ar($typind) "char"
# We don't do upshift automatically with mysql except
# in CDKIT where we need to stay compatible with
# informix
if {$autocols && [info exists env(CDKITDB)]} {
lappend ar(upshiftcols) $col
}
}
date -
datetime -
timestamp {
set ar($typind) $lowtyp
}
default {
set ar($typind) "bin"
}
}
tcsqdebug "name: $col, typ $ar($typind) len $ar($lenind)" 2
}
# Special stuff in CDKIT: because we're using cdkuniqueid, some of
# the primary key columns that should have an auto_increment
# flag, don't. We sure could change the databases, but, what
# happens if we have to restart from backups, etc... Waiting for a
# definitive solution: IF:
# - CDKITDB is defined
# - There is not already a tabcolserial
# - There is an updateindex, made of exactly one column
# - The said column is of integer kind (actually not char,date,...)
# - Then we define tabcolserial as being this column. This will
# ensure that we go on calling cdkuniqueid for those primary key
# integer columns that we have in all tables, even if they do
# not have the auto_increment attribute.
if {[info exists env(CDKITDB)] && \
![info exists ar(tabcolserial)] && \
[info exists ar(updateindex)] && \
[llength $ar(updateindex)] == 1} {
set col $ar(updateindex)
if {$ar(sqlsc_${col}_type) == "bin"} {
set ar(tabcolserial) $col
}
}
catch {tcsqdebug "$tbl: tabcolserial: $ar(tabcolserial)" 1}
}
proc ODBCquotequote {in} {
regsub -all "'" "$in" "\\'" out
return $out
}
# Quote bad chars in a text blob (which is a tcl string, no need to
# worry about zeros).
# note that we quote \ first, else we are going to requote those introduced
# by further operations !
# This is duplicated from the MYSQL module, not sure it is correct here.
proc ODBCquoteblob {blb} {
# puts "quoteblob: in: --$blb--"
regsub -all {\\} $blb {\\\\} blb
regsub -all {'} $blb {\\'} blb
regsub -all {"} $blb {\\"} blb
# puts "quoteblob: out: --$blb--"
return $blb
}
### END ODBC CODE ############################################