# @(#$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 ############################################