# @(#$Id$ (C) 2013 J.F. Dockes
#
# 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 THE AUTHOR 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 sqlite3.
# The SQLDBTYPE should be set to SQLITE3 for this to be used.
package provide SQLITE3tcsq 0.1
package require sqlite3
#set tcsqdebuglevel 2
### SQLITE3 CODE############################################
# Pseudo cursor management
array set _SQLITE3stmts {}
array set _SQLITE3cursors {}
# 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 SQLITE3
set _sql3hdlnum 0
proc SQLITE3connect {{host ""} {user ""} {passwd ""}} {
global _sql3hdlnum
set _sql3hdlnum [expr {$_sql3hdlnum + 1}]
return "sql3hdl$_sql3hdlnum"
}
# Connect to a database.
proc SQLITE3use {hdl database} {
tcsqdebug "SQLITE3use: '$hdl', '$database'"
set cmd [list sqlite3 $hdl $database]
tcsqdebug "SQLITE3use: '$cmd'" 2
eval $cmd
return $hdl
}
# Open a select statement and return a cursor. Sqlite really has no
# notion of this, it returns the whole result set in return from
# statement evaluation. So we have to store the result and the current pointer.
proc SQLITE3opensel {hdl stmt} {
global _SQLITE3stmts _SQLITE3cursors
tcsqdebug "SQLITE3opensel: hdl '$hdl', stmt '$stmt'"
set ok 0
for {set i 1} {$i < 100000} {incr i} {
set qry "qry$i"
if {![info exists _SQLITE3stmts($qry)]} {
set _SQLITE3stmts($qry) []
set _SQLITE3cursors($qry) -1
set ok 1
break
}
}
if {$ok == 0} {
return -code error "SQLITE3opensel: can't allocate statement handle"
}
$hdl eval $stmt resarray {
# resarray[*] has the column names in appropriate order
set row []
foreach col $resarray(*) {
lappend row $resarray($col)
}
lappend _SQLITE3stmts($qry) $row
}
return $qry
}
proc SQLITE3next {qry} {
global _SQLITE3stmts _SQLITE3cursors
incr _SQLITE3cursors($qry)
set res [lindex $_SQLITE3stmts($qry) $_SQLITE3cursors($qry)]
return $res
}
proc SQLITE3rew {qry} {
global _SQLITE3cursors
set _SQLITE3cursors($qry) -1
}
proc SQLITE3closel {qry} {
tcsqdebug "SQLITE3closel: qry '$qry'"
global _SQLITE3stmts _SQLITE3cursors
unset _SQLITE3stmts($qry)
unset _SQLITE3cursors($qry)
}
proc SQLITE3exec {hdl stmt} {
tcsqdebug "SQLITE3exec: hdl '$hdl', stmt '$stmt'"
$hdl eval $stmt
set res [$hdl changes]
tcsqdebug "SQLITE3exec: 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 SQLITE3insertid {hdl} {
return $hdl last_insert_rowid
}
# Retrieve unique id for the specified table. This should not ever be called
proc SQLITE3uniqueid {hdl tbl} {
return ""
}
proc SQLITE3discon {hdl} {
tcsqdebug "SQLITE3discon: hdl '$hdl'"
$hdl close
}
proc SQLITE3tabinfo {hdl} {
return [$hdl eval "select name from sqlite_master where type='table'"]
}
# Extract type and length information from sqlite3 pragma table_info "type"
# column
# typ[(len)]
proc SQLITE3gettyplen {typlen typnm lennm} {
upvar $typnm typ
upvar $lennm len
tcsqdebug "SQLITE3gettyplen: '$typlen'"
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 "SQLITE3gettyplen: typlen '$typlen', typ '$typ', ll '$ll'"
switch $typ {
date {set len 10}
time {set len 8}
datetime {set len 19}
timestamp {set len 10}
enum -
default {set len [lindex $ll 0]}
}
# Catch weird cases like blob, etc... and unexpected ones... Set
# arbitrary length.
if {$len == ""} {
set len 13
}
tcsqdebug "col typlen '$typlen', typ '$typ', len '$len'"
}
# One thing that we'd like to do, but don't know how is retrieve the
# "auto_increment attribute.
proc SQLITE3colinfo {hdl tbl arnm} {
tcsqdebug "SQLITE3colinfo hdl '$hdl' tbl '$tbl' arnm '$arnm'"
upvar $arnm ar
global sqlsc_def_maxlen env
set primkeycols {}
# Retrieve column info. List elements:
# 0 col# (cid) / 1 name / 2 type / 3 notnull / 4 dflt_value / 5 pk
$hdl eval "pragma table_info($tbl)" myar {
tcsqdebug "table_info row"
set nm [string tolower $myar(name)]
lappend allcols $nm
SQLITE3gettyplen $myar(type) typ($nm) len($nm)
if {$myar(pk)} {
lappend primkeycols $nm
if {$typ($nm) == "int"} {
set ar(tabcolserial) $nm
}
}
}
# 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
}
# 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
tcsqdebug "No type info for column '$scol'"
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
}
}
# SQLITE3 types ?
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
}
catch {tcsqdebug "$tbl: tabcolserial: $ar(tabcolserial)" 1}
}
proc SQLITE3quotequote {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 at all it is correct here.
proc SQLITE3quoteblob {blb} {
# puts "quoteblob: in: --$blb--"
regsub -all {\\} $blb {\\\\} blb
regsub -all {'} $blb {''} blb
regsub -all {"} $blb {\\"} blb
# puts "quoteblob: out: --$blb--"
return $blb
}
### END SQLITE3 CODE ############################################