# @(#$Id$ (C) 1994 CDKIT
# MSQL-specific code for the tcsq module
package provide MSQLtcsq 0.1
proc MSQLquotequote {in} {
regsub -all "'" "$in" "\\'" out
return $out
}
# We want to hide the fact that each connection can only handle
# one open query. So we actually manage a pool of open connection
# that we reuse when needed. connection and query handles are currently
# exactly the same thing
# For the time being, we don't support connections to multiple
# databases so that there is only one pool. If we want to change
# this, we'll just have to manage several pools, this will need no interface
# change, but a number of internal array manipulations
# For now, idle connections are cached in the MSQLidlecons global
# array. This array will turn to multiple ones when we go to multiple db
# Also note that the hdl that MSQLconnect returns is wasted: it's a
# real db connection, but is never used for actual operations. We
# should return some bogus handle instead.
proc MSQLconnect {{host ""} {user ""} {passwd ""}} {
global MSQLidlecons MSQLdatabase MSQLhost MSQLuser MSQLpasswd
# puts "MSQLconnect: host $host, user $user, passwd $passwd"
set hdl [msqlconnect $host $user $passwd]
set MSQLhost $host
set MSQLuser $user
set MSQLpasswd $passwd
return $hdl
}
proc MSQLuse {hdl database} {
global MSQLidlecons MSQLdatabase MSQLhost
# we should and could handle the database change case by clearing
# the idle connection cache
msqluse $hdl $database
set MSQLidlecons($hdl) ""
set MSQLdatabase $database
return $hdl
}
# the input hdl is actually not used currently. Might be used to
# select the right pool (for host/db) in the future
# Also 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 MSQLidlecon {hdl} {
global MSQLidlecons MSQLdatabase MSQLhost MSQLuser MSQLpasswd
set idle [lsort [array names MSQLidlecons]]
if {[llength $idle] == 0} {
set hdl [msqlconnect $MSQLhost $MSQLuser $MSQLpasswd]
msqluse $hdl $MSQLdatabase
} else {
set hdl [lindex $idle 0]
unset MSQLidlecons($hdl)
}
# puts "MSQLidlecon: returning $hdl"
return $hdl
}
proc MSQLopensel {hdl stmt} {
set hdl [MSQLidlecon $hdl]
msqlsel $hdl $stmt
return $hdl
}
proc MSQLnext {qry} {
msqlnext $qry
}
proc MSQLrew {qry} {
msqlseek $qry 0
}
proc MSQLclosel {qry} {
global MSQLidlecons MSQLdatabase MSQLhost
set MSQLidlecons($qry) ""
}
# Note that consecutive exec/insertid are guaranteed to use the same
# db connection, so that the result will be correct
proc MSQLexec {hdl stmt} {
global MSQLidlecons MSQLdatabase MSQLhost
set hdl [MSQLidlecon $hdl]
set res [msqlexec $hdl $stmt]
set MSQLidlecons($hdl) ""
return $res
}
proc MSQLinsertid {hdl} {
global MSQLidlecons
set hdl [MSQLidlecon $hdl]
set res [msqlinsertid $hdl]
set MSQLidlecons($hdl) ""
return $res
}
proc MSQLdiscon {hdl} {
global MSQLidlecons
msqlclose $hdl
catch "unset MSQLidlecons($hdl)"
# set idle [array names idlemsqlcons]
# foreach hdl $idle {
# msqlclose $hdl
# unset MSQLidlecons($hdl)
# }
}
proc MSQLtabinfo {hdl} {
return [msqlinfo $hdl tables]
}
proc MSQLcolinfo {hdl tbl arnm} {
upvar $arnm ar
global sqlsc_def_maxlen
# puts "getcolinfo: arnm: $arnm, table: $tbl"
# Fetch info from msql
set tabdesc [msqlcol $hdl $tbl name type length prim_key]
set names [lindex $tabdesc 0]
set typs [lindex $tabdesc 1]
set lens [lindex $tabdesc 2]
set prim_keys [lindex $tabdesc 3]
# For some unknown reason, msql capitalizes the column names
foreach nm $names {
lappend tnm [string tolower $nm]
}
set names $tnm
unset tnm
if {![info exists ar(columns)]} {
set ar(columns) $names
set autocols 1
} else {
set autocols 0
}
# Look for primary index, possibly build updateindex
set pos 0
foreach flag $prim_keys {
if {$flag == 0} {
continue
}
set nm [lindex $names $pos]
# If this is an integer, we make the assumption it's a serial
# There seems to be no way to retrieve the AUTO_INCREMENT
# attribute from the API
set typ [lindex $typs $pos]
# puts "Type of primary index: $typ"
if {[string match {*int} $typ] || $typ == "long"} {
set ar(tabcolserial) $nm
# puts "tabcolserial for $tbl: $nm"
}
if {$autocols} {
lappend ar(updateindex) $nm
}
incr pos
}
foreach col $ar(columns) {
set scol [_tcsqsimplecolname $tbl $col]
if {$scol == ""} {
continue
}
set pos [lsearch $names $scol]
# There may be names from different tables in the columns list
# so it is not an error if the name is not found in the
# table's column list
if {$pos < 0} {
continue
}
set typ [lindex $typs $pos]
set length [lindex $lens $pos]
# puts "$col: Dbtyp: $typ, Dblen: $length"
# In all cases, remember type and length as from db
set ar(sqlsc_${col}_dbtype) $typ
set ar(sqlsc_${col}_dblen) $length
set typind "sqlsc_${col}_type"
set lenind "sqlsc_${col}_len"
if {![info exists ar($lenind)]} {
set ar($lenind) $length
# 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
}
}
switch $typ {
char -
varchar -
var_string -
string {
set ar($typind) "char"
# We don't do upshift automatically with msql
# except in CDKIT where we need to stay compatible
# with informix
global env
if {$autocols && [info exists env(CDKITDB)]} {
lappend ar(upshiftcols) $col
}
}
date {
set ar($typind) "date"
}
datetime {
set ar($typind) "datetime"
}
default {
set ar($typind) "bin"
}
}
# puts "name: $col, pos $pos, typ $ar($typind) len $ar($lenind)"
}
}
proc MSQLuniqueid {hdl tbl} {
global MSQLdatabase MSQLhost
return [cdkuniqueid $MSQLhost $MSQLdatabase $tbl]
}
# 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 MSQLquoteblob {blb} {
# puts "quoteblob: in: --$blb--"
regsub -all "\\\\" $blb "\\\\\\\\" blb
regsub -all "'" $blb "\\'" blb
regsub -all "\"" $blb "\\\"" blb
regsub -all "\n" $blb "\\n" blb
# puts "quoteblob: out: --$blb--"
return $blb
}