# @(#$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.
#
# A library of tcl routines to access different databases with a
# uniform interface. No match for odbc, but useful anyway.
#
# The SQLDBTYPE environment variable determines the database type:
# MYSQL -> MYSQL
# MSQL -> MSQL
# INFORMIX -> INFORMIX
# ODBC -> Unix odbc
# SQLITE3 -> SQLITE3
#
# Big and maybe temporary restriction: we only support the use of exactly
# one database type at a time (you can access several databases on
# several hosts simultaneously, but they must all be of the same kind).
#
# The generic and MYSQL parts of the code is in this file, the code
# for other kinds of accesses is in separate files
#
# The following procedures are defined:
#
# tcsqconnect [host [user [passwd]]]: returns sql server connection handle
# it may actually do nothing (Ex: informix)
#
# tcsquse hdl database : associates the connection with a database
#
# tcsqconuse database [host]: utility function: connect and use
#
# tcsqopensel hdl stmt : opens a query operation. Returns a select handle
#
# tcsqrew selhdl : rewinds the query associated with the select
# handle. This may actually rerun the query (informix) or be
# purely local (mysql)
#
# tcsqclosel selhdl : closes a query, and frees the associated resources.
#
# tcsqnext selhdl [1]: returns the next row for the query, as a list of values
#
# tcsqexec hdl stmt : executes a statement like insert or delete
#
# tcsqdiscon hdl : disconnects and frees resources associated with hdl
#
# tcsqtabinfo hdl : returns a list of user tables
#
# tcsqcolinfo hdl tbl arnm : returns information about table tbl into the
# array whose name is given in arnm
#
# tcsqinsertid hdl : returns the auto_increment value for the last
# inserted row
# tcsquniqueid hdl tbl : returns a unique id suitable for insertion in table
# with the special ckdit stuff about multiple sites. This is
# specific to our needs in CDKIT. Other people are more likely to
# use AUTO_INCREMENT or serial columns. sqlscreens will call this
# only if env(CDKITDB) exists
#
# tcsqquotequote s : returns a suitably escaped string, for use in sql stmts
# tcsqquoteblob s : same for blobs
#
# The hdl parameter is now mandatory for all tcsqopensel and tcsqexec
# calls (there used to be a compatibility hack).
#
# CAUTION: some peculiarities of the underlying databases can't be
# hidden:
# - informix supports only one connection to one database
# - mysql (depending on version) doesn't support the 'in' verb nor
# nested statements (like "where toto in(1,2)" or "select .. where
# toto in (select...")
#
# - Quoting quotes: informix wants '' to quote ', mysql accepts both ''
# and \', (?msql wants '' ?)
#
# - mysql always strips trailing blanks in select outputs. informix
# does not. Maybe we should actually include this in the INFORMIX-specific
# part because I can't see any good reason to leave the blanks on.
#
package provide tcsq 0.3
if {[info exists env(SQLDBTYPE)]} {
set dbbackend $env(SQLDBTYPE)
} else {
set dbbackend "MYSQL"
}
# A common mistake is to use informix or mysql instead of INFORMIX
set dbbackend [string toupper $dbbackend]
# We catch the following, because we could also be using the autoload
# facility, not being installed as a package
switch $dbbackend {
"MYSQL" {
catch {package require mysqltcl}
}
"INFORMIX" {
catch {package require INFORMIXtcsq}
}
"MSQL" {
catch {package require MSQLtcsq}
}
"ODBC" {
catch {package require ODBCtcsq}
}
"SQLITE3" {
catch {package require SQLITE3tcsq}
}
}
# if maxlen not set by sqlscreens, set it to a very high value
if {![info exists sqlsc_def_maxlen]} {
set sqlsc_def_maxlen 100000000
}
#puts "DBBACKEND $dbbackend"
set tcsqdebuglevel 0
set tcsqdebugfile ""
set tcsqdebugchan ""
proc tcsqdebug {m {l 1}} {
global tcsqdebuglevel tcsqdebugfile tcsqdebugchan
if {$l <= $tcsqdebuglevel} {
if {$tcsqdebugchan == ""} {
if {$tcsqdebugfile == ""} {
set tcsqdebugchan stdout
} else {
set tcsqdebugchan [open $tcsqdebugfile a]
}
}
puts $tcsqdebugchan $m;flush $tcsqdebugchan
}
}
# Maybe add names in the array, for compatibility with the old
# version, but with possible conflicts with column names. See
# sqlscreens.tcl for other comments
if {![info exists sqlsc_names_compat_old]} {
set sqlsc_names_compat_old 0
}
proc tcsqconnect {{host ""} {user ""} {passwd ""}} {
global dbbackend
return [${dbbackend}connect $host $user $passwd]
}
proc tcsquse {hdl database} {
global dbbackend
return [${dbbackend}use $hdl $database]
}
proc tcsqconuse {db {host ""}} {
set hdl [tcsqconnect $host]
tcsquse $hdl $db
return $hdl
}
proc tcsqopensel {hdl stmt} {
global dbbackend
set code [catch {${dbbackend}opensel $hdl $stmt} ret]
if {$code != 0} {
return -code $code "Failed statement: \"$stmt\"\n$ret"
} else {
return $ret
}
}
proc tcsqnext {qry {strip 0}} {
global dbbackend
if {$strip != 0} {
return [_tcsqstriplist [${dbbackend}next $qry]]
} else {
return [${dbbackend}next $qry]
}
}
proc tcsqrew {qry} {
global dbbackend
return [${dbbackend}rew $qry]
}
proc tcsqclosel {qry} {
global dbbackend
return [${dbbackend}closel $qry]
}
proc tcsqexec {hdl stmt} {
global dbbackend
set code [catch {${dbbackend}exec $hdl $stmt} ret]
if {$code != 0} {
return -code $code "Failed statement: \"$stmt\"\n$ret"
} else {
return $ret
}
}
proc tcsqdiscon {hdl} {
global dbbackend
return [${dbbackend}discon $hdl]
}
proc tcsqtabinfo {hdl} {
global dbbackend
return [${dbbackend}tabinfo $hdl]
}
proc tcsqcolinfo {hdl tbl arnm} {
global dbbackend sqlsc_names_compat_old
upvar $arnm ar
# puts "tcsqcolinfo: arnm: $arnm, compat: $sqlsc_names_compat_old"
if {$sqlsc_names_compat_old && [info exists ar(columns)]} {
foreach col $ar(columns) {
# puts "Checking len for $col"
if {[info exists ar(${col}_len)]} {
# puts "Setting col length to $ar(${col}_len) for $col"
set ar(sqlsc_${col}_len) $ar(${col}_len)
}
}
}
set ret [${dbbackend}colinfo $hdl $tbl ar]
if {$sqlsc_names_compat_old} {
foreach col $ar(columns) {
if {[info exists ar(sqlsc_${col}_type)]} {
set ar(${col}_type) $ar(sqlsc_${col}_type)
set ar(${col}_len) $ar(sqlsc_${col}_len)
}
}
}
return $ret
}
proc tcsqinsertid {hdl} {
global dbbackend
return [${dbbackend}insertid $hdl]
}
proc tcsquniqueid {hdl tbl} {
global dbbackend
return [${dbbackend}uniqueid $hdl $tbl]
}
# Quote a string, in a way appropriate for current database
proc tcsqquotequote {in} {
global dbbackend
return [${dbbackend}quotequote $in]
}
proc tcsqquoteblob {in} {
global dbbackend
return [${dbbackend}quoteblob $in]
}
# Common utility routines
proc _tcsqstriplist {lst} {
foreach elt $lst {
lappend lst1 [string trim $elt]
}
return $lst1
}
# Return unqualified column name if possibly fully qualified col
# could belong to table, else ""
proc _tcsqsimplecolname {table col} {
if {$col == "\n"} {
return ""
}
set cl [split $col .]
set l [llength $cl]
if {$l == 1} {
return $col
}
set tbl [lindex $cl [expr {$l - 2}]]
set scol [lindex $cl [expr {$l - 1}]]
if {$tbl == $table} {
return $scol
}
return ""
}
### CDKIT-specific stuff:
# Common form of unique id generation for all currently supported
# databases: call the unique id server
proc cdkgsbyname {service} {
set f [open "/etc/services" "r"]
while {[gets $f line] != -1} {
set s [lindex $line 0]
if {$s == $service} {
set port [lindex [split [lindex $line 1] /] 0]
close $f
return $port
}
}
close $f
return -code error "Can't get port number for service $service"
}
set uiport -1
proc cdkuniqueid {host db tbl} {
global uiport
# puts "host $host, db $db table $tbl";flush stdout
if {$uiport == -1} {
set uiport [cdkgsbyname cduniqueid]
}
set s [socket $host $uiport]
puts $s $db
puts $s $tbl
flush $s
gets $s result
# puts "cdkuniqueid: result $result";flush stdout
close $s
if {[string trim $result] == ""} {
return -code error "cdkuniqueid: got null string"
}
if {[string match {ERROR:*} $result]} {
return -code error $result
}
return $result
}
######### End CDKIT-specific
### MYSQL CODE############################################
# We want to hide the fact that each connection can only handle
# one open query. So we actually manage pools of open connections
# that we reuse when needed. connection and query handles are currently
# exactly the same thing.
# We take note of the host/user/passwd/database for each mysql handle
# in global arrays
# For each "primary" mysql handle (returned by a call to
# MYSQLconnect), we manage a pool of other handles connected to the
# same host/database, and we use them as needed to handle simultaneous
# queries.
# Open a connection to a mysql server
proc MYSQLconnect {{host ""} {user ""} {passwd ""}} {
tcsqdebug "MYSQLconnect: host $host, user $user, passwd $passwd"
set hdl [mysqlconnect $host $user $passwd]
set stmt [subst {
set MYSQLhosts($hdl) {$host}
set MYSQLusers($hdl) {$user}
set MYSQLpasswds($hdl) {$passwd}
}]
uplevel #0 $stmt
return $hdl
}
# Connect an open handle to a database. Enter the handle in the pool
# of idle handles for this host/db
proc MYSQLuse {hdl database} {
# we should and could handle the database change case by clearing
# the idle connection cache
tcsqdebug "MYSQLuse: '$hdl', '$database'"
mysqluse $hdl $database
set stmt [subst {
set MYSQLidleqry_${hdl}($hdl) {}
set MYSQLdatabases($hdl) {$database}
}]
uplevel #0 $stmt
return $hdl
}
# Get an idle handle to execute a query. We search the appropriate
# pool for one, and open a new connection if needed.
# The return value stores both the primary handle (pool name) and
# actual handle to use. This is transparent to external callers, but
# will be used internally.
# Note that we sort the array names list, so that we're sure that
# the same handle will be used if someone calls tcsqexec/tcsqinsertid
proc MYSQLgetQ {hdl} {
tcsqdebug "MYSQLgetQ: '$hdl'"
upvar #0 MYSQLidleqry_${hdl} idQ
set idle [lsort [array names idQ]]
if {[llength $idle] == 0} {
global MYSQLhosts MYSQLusers MYSQLpasswds MYSQLdatabases
set hdln [mysqlconnect $MYSQLhosts($hdl) $MYSQLusers($hdl) \
$MYSQLpasswds($hdl)]
mysqluse $hdln $MYSQLdatabases($hdl)
} else {
set hdln [lindex $idle 0]
unset idQ($hdln)
}
set ret [list ${hdl} ${hdln}]
tcsqdebug "MYSQLgetQ: returning '$ret'"
return $ret
}
# Release a handle to the appropriate pool
proc MYSQLrelQ {qry} {
tcsqdebug "MYSQLrelQ: $qry"
set mhdl [lindex $qry 0]
set qhdl [lindex $qry 1]
upvar #0 MYSQLidleqry_${mhdl} idQ
set idQ($qhdl) {}
}
# Open a select statement: get an idle handle first.
proc MYSQLopensel {hdl stmt} {
tcsqdebug "MYSQLopensel: hdl '$hdl', stmt '$stmt'"
set qry [MYSQLgetQ $hdl]
mysqlsel [lindex $qry 1] $stmt
return $qry
}
proc MYSQLnext {qry} {
mysqlnext [lindex $qry 1]
}
proc MYSQLrew {qry} {
mysqlseek [lindex $qry 1] 0
}
proc MYSQLclosel {qry} {
tcsqdebug "MYSQLclosel: qry '$qry'"
MYSQLrelQ $qry
}
# Note that consecutive exec/insertid are guaranteed to use the same
# db connection, so that the result will be correct
proc MYSQLexec {hdl stmt} {
tcsqdebug "MYSQLexec: hdl '$hdl', stmt '$stmt'"
set q [MYSQLgetQ $hdl]
set code [catch {mysqlexec [lindex $q 1] $stmt} res]
MYSQLrelQ $q
if {$code} {return -code $code $res}
return $res
}
# Retrieve auto_increment value for the last insert.
proc MYSQLinsertid {hdl} {
tcsqdebug "MYSQLinsertid: hdl '$hdl'"
set q [MYSQLgetQ $hdl]
set code [catch {mysqlinsertid [lindex $q 1]} res]
MYSQLrelQ $q
if {$code} {return -code $code $res}
return $res
}
# Retrieve unique id for the specified table
proc MYSQLuniqueid {hdl tbl} {
tcsqdebug "MYSQLuniqueid: hdl '$hdl', tbl '$tbl'"
global MYSQLdatabases MYSQLhosts
return [cdkuniqueid $MYSQLhosts($hdl) $MYSQLdatabases($hdl) $tbl]
}
proc MYSQLdiscon {hdl} {
tcsqdebug "MYSQLdiscon: hdl '$hdl'"
mysqlclose $hdl
set stmt [subst {
unset MYSQLhosts($hdl)
unset MYSQLusers($hdl)
unset MYSQLpasswds($hdl)
}]
uplevel #0 $stmt
upvar #0 MYSQLidleqry_$hdl idQ
# We try to close as many associated connections as possible, but
# we'll miss unclosed selects.
foreach h [array names idQ] {
if {$h != $hdl} {
mysqlclose $h
}
}
catch "unset idQ"
}
proc MYSQLtabinfo {hdl} {
return [mysqlinfo $hdl tables]
}
# Extract type and length information from MYSQL show columns
# data.
# The data is like:
# typ[(a,b,c)] [qual1 ...]
# The length is not easy because how to get it depends on the type.
# For a set or enum we also return the list of values
proc MYSQLgettyplen {typlen typnm lennm chnm} {
upvar $typnm typ
upvar $lennm len
upvar $chnm choices
catch {unset choices}
set parO [string first {(} $typlen]
if {$parO < 0} {
set typ [string tolower [lindex $typlen 0]]
set ll {}
} else {
set typ [string tolower [string range $typlen 0 [expr {$parO -1}]]]
set parC [string first {)} $typlen]
incr parO
incr parC -1
set ll [split [string range $typlen $parO $parC] ,]
}
#puts "MYSQLgettyplen: typlen '$typlen', typ '$typ', ll '$ll'"
switch $typ {
date {set len 10}
time {set len 8}
datetime {set len 19}
enum -
set {
# Note that for a set, we'd have to add all possible value
# lengths? or what ? Anyway, this poses other interface
# problems, so, for sets:
# - We compute length as for an enum.
# - We don't set 'choices'
set len -1
foreach s $ll {
set s [string range $s 1 [expr {[string length $s] - 2}]]
# Each 'choices' element is actually a list (2nd
# element in list is a translation if it exists)
lappend choices [list $s]
set l [string length $s]
if {$l > $len} {
set len $l
}
}
if {$typ == "set"} {unset choices}
}
default {set len [lindex $ll 0]}
}
# Catch weird cases like blob, etc... and unexpected ones... Set
# arbitrary length.
if {$len == ""} {
set len 13
}
# puts " typlen '$typlen', typ '$typ', len '$len'"
}
# We now use a 'show columns' SQL statement instead of the mysqltcl
# function to retrieve the column information. It seems that the data
# returned is more complete and up to date (For example, the C api's
# info didn't mention the auto_increment flag up to mysql v3.22
# because it was not returned by the server).
# Besides the TCL is easier to fix than the C code when something changes.
proc MYSQLcolinfo {hdl tbl arnm} {
upvar $arnm ar
global sqlsc_def_maxlen env
set primkeycols {}
# Retrieve all column info from the db
set qry [MYSQLopensel $hdl "show columns from $tbl"]
while {[set r [MYSQLnext $qry]] != ""} {
set nm [string tolower [string trim [lindex $r 0]]]
lappend allcols $nm
set typlen [string trim [lindex $r 1]]
MYSQLgettyplen $typlen typ($nm) len($nm) choices($nm)
# nullok: {YES {}}
set nullok($nm) [string trim [lindex $r 2]]
#Key type: {PRI UNI MUL {}}
set keytype($nm) [string trim [lindex $r 3]]
if {$keytype($nm) == "PRI"} {
lappend primkeycols $nm
}
set defval($nm) [string trim [lindex $r 4]]
# extra: auto_increment
set extra($nm) [string trim [lindex $r 5]]
if {[regexp -nocase {auto_increment} $extra($nm)] == 1} {
set ar(tabcolserial) $nm
}
}
MYSQLclosel $qry
# If the column list was not specified, we use all columns
if {![info exists ar(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.
foreach col $ar(columns) {
set scol [_tcsqsimplecolname $tbl $col]
if {$scol != ""} {
lappend scols [string tolower $scol]
}
}
set autocols 0
}
# Manage the 'updateindex' list.
if {![info exists ar(updateindex)]} {
# updateindex not specified by caller. Set it to the primary key.
if {[llength $primkeycols] != 0} {
set ar(updateindex) $primkeycols
}
if {$autocols == 0} {
# The column list was specified. Set the updateindex only
# if all the primary key components are included.
foreach col $primkeycols {
if {[lsearch -exact $scols $col] == -1} {
unset ar(updateindex)
break
}
}
}
} elseif {[llength $ar(updateindex)] == 0} {
# Special case: updateindex was specified empty. Set it to
# include all the screen's columns
if {$autocols == 0} {
set ar(updateindex) $scols
} else {
set ar(updateindex) $allcols
}
}
# 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
}
}
# Set choice list if it exists (enum)
catch {set ar(sqlsc_${col}_dbchoices) $choices($scol)}
switch $typ($scol) {
char -
varchar -
var_string -
string -
enum -
set {
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) $typ($scol)}
default {set ar($typind) "bin"}
}
# puts "name: $col, typ $ar($typind) len $ar($lenind)"
}
# 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 MYSQLquotequote {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 !
proc MYSQLquoteblob {blb} {
# puts "quoteblob: in: --$blb--"
regsub -all {\\} $blb {\\\\} blb
regsub -all {'} $blb {\\'} blb
regsub -all {"} $blb {\\"} blb
# puts "quoteblob: out: --$blb--"
return $blb
}
### END MYSQL CODE ############################################