riscv
/
OpenFPGA
mirror of https://github.com/lnis-uofu/OpenFPGA.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
OpenFPGA/libs/EXTERNAL/tcl8.6.12/pkgs/tdbcsqlite3-1.1.3/library/tdbcsqlite3.tcl

716 lines
19 KiB
Tcl
Raw Blame History

# tdbcsqlite3.tcl --
#
# SQLite3 database driver for TDBC
#
# Copyright (c) 2008 by Kevin B. Kenny.
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: tdbcodbc.tcl,v 1.47 2008/02/27 02:08:27 kennykb Exp $
#
#------------------------------------------------------------------------------
package require tdbc
package require sqlite3
package provide tdbc::sqlite3 1.1.3
namespace eval tdbc::sqlite3 {
namespace export connection
}
#------------------------------------------------------------------------------
#
# tdbc::sqlite3::connection --
#
# Class representing a SQLite3 database connection
#
#------------------------------------------------------------------------------
::oo::class create ::tdbc::sqlite3::connection {
superclass ::tdbc::connection
variable timeout
# The constructor accepts a database name and opens the database.
constructor {databaseName args} {
set timeout 0
if {[llength $args] % 2 != 0} {
set cmd [lrange [info level 0] 0 end-[llength $args]]
return -code error \
-errorcode {TDBC GENERAL_ERROR HY000 SQLITE3 WRONGNUMARGS} \
"wrong # args, should be \"$cmd ?-option value?...\""
}
next
sqlite3 [namespace current]::db $databaseName
if {[llength $args] > 0} {
my configure {*}$args
}
db nullvalue \ufffd
}
# The 'statementCreate' method forwards to the constructor of the
# statement class
forward statementCreate ::tdbc::sqlite3::statement create
# The 'configure' method queries and sets options to the database
method configure args {
if {[llength $args] == 0} {
# Query all configuration options
set result {-encoding utf-8}
lappend result -isolation
if {[db onecolumn {PRAGMA read_uncommitted}]} {
lappend result readuncommitted
} else {
lappend result serializable
}
lappend result -readonly 0
lappend result -timeout $timeout
return $result
} elseif {[llength $args] == 1} {
# Query a single option
set option [lindex $args 0]
switch -exact -- $option {
-e - -en - -enc - -enco - -encod - -encodi - -encodin -
-encoding {
return utf-8
}
-i - -is - -iso - -isol - -isola - -isolat - -isolati -
-isolatio - -isolation {
if {[db onecolumn {PRAGMA read_uncommitted}]} {
return readuncommitted
} else {
return serializable
}
}
-r - -re - -rea - -read - -reado - -readon - -readonl -
-readonly {
return 0
}
-t - -ti - -tim - -time - -timeo - -timeou - -timeout {
return $timeout
}
default {
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
BADOPTION $option] \
"bad option \"$option\": must be\
-encoding, -isolation, -readonly or -timeout"
}
}
} elseif {[llength $args] % 2 != 0} {
# Syntax error
set cmd [lrange [info level 0] 0 end-[llength $args]]
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 \
SQLITE3 WRONGNUMARGS] \
"wrong # args, should be \" $cmd ?-option value?...\""
}
# Set one or more options
foreach {option value} $args {
switch -exact -- $option {
-e - -en - -enc - -enco - -encod - -encodi - -encodin -
-encoding {
if {$value ne {utf-8}} {
return -code error \
-errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
SQLITE3 ENCODING] \
"-encoding not supported. SQLite3 is always \
Unicode."
}
}
-i - -is - -iso - -isol - -isola - -isolat - -isolati -
-isolatio - -isolation {
switch -exact -- $value {
readu - readun - readunc - readunco - readuncom -
readuncomm - readuncommi - readuncommit -
readuncommitt - readuncommitte - readuncommitted {
db eval {PRAGMA read_uncommitted = 1}
}
readc - readco - readcom - readcomm - readcommi -
readcommit - readcommitt - readcommitte -
readcommitted -
rep - repe - repea - repeat - repeata - repeatab -
repeatabl - repeatable - repeatabler - repeatablere -
repeatablerea - repeatablread -
s - se - ser - seri - seria - serial - seriali -
serializ - serializa - serializab - serializabl -
serializable -
reado - readon - readonl - readonly {
db eval {PRAGMA read_uncommitted = 0}
}
default {
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 \
SQLITE3 BADISOLATION $value] \
"bad isolation level \"$value\":\
should be readuncommitted, readcommitted,\
repeatableread, serializable, or readonly"
}
}
}
-r - -re - -rea - -read - -reado - -readon - -readonl -
-readonly {
if {$value} {
return -code error \
-errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
SQLITE3 READONLY] \
"SQLite3's Tcl API does not support read-only\
access"
}
}
-t - -ti - -tim - -time - -timeo - -timeou - -timeout {
if {![string is integer $value]} {
return -code error \
-errorcode [list TDBC DATA_EXCEPTION 22018 \
SQLITE3 $value] \
"expected integer but got \"$value\""
}
db timeout $value
set timeout $value
}
default {
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 \
SQLITE3 BADOPTION $value] \
"bad option \"$option\": must be\
-encoding, -isolation, -readonly or -timeout"
}
}
}
return
}
# The 'tables' method introspects on the tables in the database.
method tables {{pattern %}} {
set retval {}
my foreach row {
SELECT * from sqlite_master
WHERE type IN ('table', 'view')
AND name LIKE :pattern
} {
dict set row name [string tolower [dict get $row name]]
dict set retval [dict get $row name] $row
}
return $retval
}
# The 'columns' method introspects on columns of a table.
method columns {table {pattern %}} {
regsub -all ' $table '' table
set retval {}
set pattern [string map [list \
* {[*]} \
? {[?]} \
\[ \\\[ \
\] \\\[ \
_ ? \
% *] [string tolower $pattern]]
my foreach origrow "PRAGMA table_info('$table')" {
set row {}
dict for {key value} $origrow {
dict set row [string tolower $key] $value
}
dict set row name [string tolower [dict get $row name]]
if {![string match $pattern [dict get $row name]]} {
continue
}
switch -regexp -matchvar info [dict get $row type] {
{^(.+)\(\s*([[:digit:]]+)\s*,\s*([[:digit:]]+)\s*\)\s*$} {
dict set row type [string tolower [lindex $info 1]]
dict set row precision [lindex $info 2]
dict set row scale [lindex $info 3]
}
{^(.+)\(\s*([[:digit:]]+)\s*\)\s*$} {
dict set row type [string tolower [lindex $info 1]]
dict set row precision [lindex $info 2]
dict set row scale 0
}
default {
dict set row type [string tolower [dict get $row type]]
dict set row precision 0
dict set row scale 0
}
}
dict set row nullable [expr {![dict get $row notnull]}]
dict set retval [dict get $row name] $row
}
return $retval
}
# The 'primarykeys' method enumerates the primary keys on a table.
method primarykeys {table} {
set result {}
my foreach row "PRAGMA table_info($table)" {
if {[dict get $row pk]} {
lappend result [dict create ordinalPosition \
[expr {[dict get $row cid]+1}] \
columnName \
[dict get $row name]]
}
}
return $result
}
# The 'foreignkeys' method enumerates the foreign keys that are
# declared in a table or that refer to a given table.
method foreignkeys {args} {
variable ::tdbc::generalError
# Check arguments
set argdict {}
if {[llength $args] % 2 != 0} {
set errorcode $generalError
lappend errorcode wrongNumArgs
return -code error -errorcode $errorcode \
"wrong # args: should be [lrange [info level 0] 0 1]\
?-option value?..."
}
foreach {key value} $args {
if {$key ni {-primary -foreign}} {
set errorcode $generalError
lappend errorcode badOption
return -code error -errorcode $errorcode \
"bad option \"$key\", must be -primary or -foreign"
}
set key [string range $key 1 end]
if {[dict exists $argdict $key]} {
set errorcode $generalError
lappend errorcode dupOption
return -code error -errorcode $errorcode \
"duplicate option \"$key\" supplied"
}
dict set argdict $key $value
}
# If we know the table with the foreign key, search just its
# foreign keys. Otherwise, iterate over all the tables in the
# database.
if {[dict exists $argdict foreign]} {
return [my ForeignKeysForTable [dict get $argdict foreign] \
$argdict]
} else {
set result {}
foreach foreignTable [dict keys [my tables]] {
lappend result {*}[my ForeignKeysForTable \
$foreignTable $argdict]
}
return $result
}
}
# The private ForeignKeysForTable method enumerates the foreign keys
# in a specific table.
#
# Parameters:
#
# foreignTable - Name of the table containing foreign keys.
# argdict - Dictionary that may or may not contain a key,
# 'primary', whose value is the name of a table that
# must hold the primary key corresponding to the foreign
# key. If the 'primary' key is absent, all tables are
# candidates.
# Results:
#
# Returns the list of foreign keys that meed the specified
# conditions, as a list of dictionaries, each containing the
# keys, foreignConstraintName, foreignTable, foreignColumn,
# primaryTable, primaryColumn, and ordinalPosition. Note that the
# foreign constraint name is constructed arbitrarily, since SQLite3
# does not report this information.
method ForeignKeysForTable {foreignTable argdict} {
set result {}
set n 0
# Go through the foreign keys in the given table, looking for
# ones that refer to the primary table (if one is given), or
# for any primary keys if none is given.
my foreach row "PRAGMA foreign_key_list($foreignTable)" {
if {(![dict exists $argdict primary])
|| ([string tolower [dict get $row table]]
eq [dict get $argdict primary])} {
# Construct a dictionary for each key, translating
# SQLite names to TDBC ones and converting sequence
# numbers to 1-based indexing.
set rrow [dict create foreignTable $foreignTable \
foreignConstraintName \
?$foreignTable?[dict get $row id]]
if {[dict exists $row seq]} {
dict set rrow ordinalPosition \
[expr {1 + [dict get $row seq]}]
}
foreach {to from} {
foreignColumn from
primaryTable table
primaryColumn to
deleteAction on_delete
updateAction on_update
} {
if {[dict exists $row $from]} {
dict set rrow $to [dict get $row $from]
}
}
# Add the newly-constucted dictionary to the result list
lappend result $rrow
}
}
return $result
}
# The 'preparecall' method prepares a call to a stored procedure.
# SQLite3 does not have stored procedures, since it's an in-process
# server.
method preparecall {call} {
return -code error \
-errorcode [list TDBC FEATURE_NOT_SUPPORTED 0A000 \
SQLITE3 PREPARECALL] \
{SQLite3 does not support stored procedures}
}
# The 'begintransaction' method launches a database transaction
method begintransaction {} {
db eval {BEGIN TRANSACTION}
}
# The 'commit' method commits a database transaction
method commit {} {
db eval {COMMIT}
}
# The 'rollback' method abandons a database transaction
method rollback {} {
db eval {ROLLBACK}
}
# The 'transaction' method executes a script as a single transaction.
# We override the 'transaction' method of the base class, since SQLite3
# has a faster implementation of the same thing. (The base class's generic
# method should also work.)
# (Don't overload the base class method, because 'break', 'continue'
# and 'return' in the transaction body don't work!)
#method transaction {script} {
# uplevel 1 [list {*}[namespace code db] transaction $script]
#}
method prepare {sqlCode} {
set result [next $sqlCode]
return $result
}
method getDBhandle {} {
return [namespace which db]
}
}
#------------------------------------------------------------------------------
#
# tdbc::sqlite3::statement --
#
# Class representing a statement to execute against a SQLite3 database
#
#------------------------------------------------------------------------------
::oo::class create ::tdbc::sqlite3::statement {
superclass ::tdbc::statement
variable Params db sql
# The constructor accepts the handle to the connection and the SQL
# code for the statement to prepare. All that it does is to parse the
# statement and store it. The parse is used to support the
# 'params' and 'paramtype' methods.
constructor {connection sqlcode} {
next
set Params {}
set db [$connection getDBhandle]
set sql $sqlcode
foreach token [::tdbc::tokenize $sqlcode] {
if {[string index $token 0] in {$ : @}} {
dict set Params [string range $token 1 end] \
{type Tcl_Obj precision 0 scale 0 nullable 1 direction in}
}
}
}
# The 'resultSetCreate' method relays to the result set constructor
forward resultSetCreate ::tdbc::sqlite3::resultset create
# The 'params' method returns descriptions of the parameters accepted
# by the statement
method params {} {
return $Params
}
# The 'paramtype' method need do nothing; Sqlite3 uses manifest typing.
method paramtype args {;}
method getDBhandle {} {
return $db
}
method getSql {} {
return $sql
}
}
#-------------------------------------------------------------------------------
#
# tdbc::sqlite3::resultset --
#
# Class that represents a SQLlite result set in Tcl
#
#-------------------------------------------------------------------------------
::oo::class create ::tdbc::sqlite3::resultset {
superclass ::tdbc::resultset
# The variables of this class all have peculiar names. The reason is
# that the RunQuery method needs to execute with an activation record
# that has no local variables whose names could conflict with names
# in the SQL query. We start the variable names with hyphens because
# they can't be bind variables.
variable -set {*}{
-columns -db -needcolumns -resultArray
-results -sql -Cursor -RowCount -END
}
constructor {statement args} {
next
set -db [$statement getDBhandle]
set -sql [$statement getSql]
set -columns {}
set -results {}
${-db} trace [namespace code {my RecordStatement}]
if {[llength $args] == 0} {
# Variable substitutions are evaluated in caller's context
uplevel 1 [list ${-db} eval ${-sql} \
[namespace which -variable -resultArray] \
[namespace code {my RecordResult}]]
} elseif {[llength $args] == 1} {
# Variable substitutions are in the dictionary at [lindex $args 0].
set -paramDict [lindex $args 0]
# At this point, the activation record must contain no variables
# that might be bound within the query. All variables at this point
# begin with hyphens so that they are syntactically incorrect
# as bound variables in SQL.
unset args
unset statement
dict with -paramDict {
${-db} eval ${-sql} -resultArray {
my RecordResult
}
}
} else {
${-db} trace {}
# Too many args
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 \
SQLITE3 WRONGNUMARGS] \
"wrong # args: should be\
[lrange [info level 0] 0 1] statement ?dictionary?"
}
${-db} trace {}
set -Cursor 0
if {${-Cursor} < [llength ${-results}]
&& [lindex ${-results} ${-Cursor}] eq {statement}} {
incr -Cursor 2
}
if {${-Cursor} < [llength ${-results}]
&& [lindex ${-results} ${-Cursor}] eq {columns}} {
incr -Cursor
set -columns [lindex ${-results} ${-Cursor}]
incr -Cursor
}
set -RowCount [${-db} changes]
}
# Record the start of a SQL statement
method RecordStatement {stmt} {
set -needcolumns 1
lappend -results statement {}
}
# Record one row of results from a query by appending it as a dictionary
# to the 'results' list. As a side effect, set 'columns' to a list
# comprising the names of the columns of the result.
method RecordResult {} {
set columns ${-resultArray(*)}
if {[info exists -needcolumns]} {
lappend -results columns $columns
unset -needcolumns
}
set dict {}
foreach key $columns {
if {[set -resultArray($key)] ne "\ufffd"} {
dict set dict $key [set -resultArray($key)]
}
}
lappend -results row $dict
}
# Advance to the next result set
method nextresults {} {
set have 0
while {${-Cursor} < [llength ${-results}]} {
if {[lindex ${-results} ${-Cursor}] eq {statement}} {
set have 1
incr -Cursor 2
break
}
incr -Cursor 2
}
if {!$have} {
set -END {}
}
if {${-Cursor} >= [llength ${-results}]} {
set -columns {}
} elseif {[lindex ${-results} ${-Cursor}] eq {columns}} {
incr -Cursor
set -columns [lindex ${-results} ${-Cursor}]
incr -Cursor
} else {
set -columns {}
}
return $have
}
method getDBhandle {} {
return ${-db}
}
# Return a list of the columns
method columns {} {
if {[info exists -END]} {
return -code error \
-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
"Function sequence error: result set is exhausted."
}
return ${-columns}
}
# Return the next row of the result set as a list
method nextlist var {
upvar 1 $var row
if {[info exists -END]} {
return -code error \
-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
"Function sequence error: result set is exhausted."
}
if {${-Cursor} >= [llength ${-results}]
|| [lindex ${-results} ${-Cursor}] ne {row}} {
return 0
} else {
set row {}
incr -Cursor
set d [lindex ${-results} ${-Cursor}]
incr -Cursor
foreach key ${-columns} {
if {[dict exists $d $key]} {
lappend row [dict get $d $key]
} else {
lappend row {}
}
}
}
return 1
}
# Return the next row of the result set as a dict
method nextdict var {
upvar 1 $var row
if {[info exists -END]} {
return -code error \
-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
"Function sequence error: result set is exhausted."
}
if {${-Cursor} >= [llength ${-results}]
|| [lindex ${-results} ${-Cursor}] ne {row}} {
return 0
} else {
incr -Cursor
set row [lindex ${-results} ${-Cursor}]
incr -Cursor
}
return 1
}
# Return the number of rows affected by a statement
method rowcount {} {
if {[info exists -END]} {
return -code error \
-errorcode {TDBC GENERAL_ERROR HY010 SQLITE3 FUNCTIONSEQ} \
"Function sequence error: result set is exhausted."
}
return ${-RowCount}
}
}
Reference in New Issue View Git Blame Copy Permalink