--- a
+++ b/sqlite3tcsq.tcl
@@ -0,0 +1,294 @@
+# @(#$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 ############################################