Attachment "tdbcsqlite3.tcl.diff" to
ticket [a1e76ad92f]
added by
chw
2020-05-26 23:27:32.
Index: library/tdbcsqlite3.tcl
==================================================================
--- library/tdbcsqlite3.tcl
+++ library/tdbcsqlite3.tcl
@@ -30,15 +30,17 @@
::oo::class create ::tdbc::sqlite3::connection {
superclass ::tdbc::connection
variable timeout
+ variable keepcase
# The constructor accepts a database name and opens the database.
constructor {databaseName args} {
set timeout 0
+ set keepcase 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?...\""
@@ -68,46 +70,46 @@
if {[db onecolumn {PRAGMA read_uncommitted}]} {
lappend result readuncommitted
} else {
lappend result serializable
}
+ lappend result -keepcase $keepcase
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 -
+ if {[catch {::tcl::prefix match -message "option" {
+ -encoding -isolation -keepcase -readonly -timeout
+ } $option} opt]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
+ BADOPTION $option] $opt
+ }
+ switch -exact -- $opt {
-encoding {
return utf-8
}
- -i - -is - -iso - -isol - -isola - -isolat - -isolati -
- -isolatio - -isolation {
+ -isolation {
if {[db onecolumn {PRAGMA read_uncommitted}]} {
return readuncommitted
} else {
return serializable
}
}
- -r - -re - -rea - -read - -reado - -readon - -readonl -
+ -keepcase {
+ return $keepcase
+ }
-readonly {
return 0
}
- -t - -ti - -tim - -time - -timeo - -timeou - -timeout {
+ -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} {
@@ -121,39 +123,47 @@
}
# Set one or more options
foreach {option value} $args {
- switch -exact -- $option {
- -e - -en - -enc - -enco - -encod - -encodi - -encodin -
+
+ if {[catch {::tcl::prefix match -message "option" {
+ -encoding -isolation -keepcase -readonly -timeout
+ } $option} opt]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 SQLITE3 \
+ BADOPTION $option] $opt
+ }
+
+ switch -exact -- $opt {
-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 {
+ -isolation {
+ if {[catch {::tcl::prefix match -message "option" {
+ readuncommitted readcommitted repeatableread
+ serializable readonly
+ } $value} val]} {
+ return -code error \
+ -errorcode [list TDBC GENERAL_ERROR HY000 \
+ SQLITE3 BADISOLATION $value] \
+ $opt
+ }
+ switch -exact -- $val {
+ 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 -
+ repeatableread -
serializable -
- reado - readon - readonl - readonly {
+ readonly {
db eval {PRAGMA read_uncommitted = 0}
}
default {
return -code error \
-errorcode [list TDBC GENERAL_ERROR HY000 \
@@ -162,37 +172,37 @@
should be readuncommitted, readcommitted,\
repeatableread, serializable, or readonly"
}
}
}
- -r - -re - -rea - -read - -reado - -readon - -readonl -
+ -keepcase {
+ if {![string is integer $value]} {
+ return -code error \
+ -errorcode [list TDBC DATA_EXCEPTION 22018 \
+ SQLITE3 $value] \
+ "expected integer but got \"$value\""
+ }
+ set keepcase $value
+ }
-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 {
+ -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
}
@@ -204,11 +214,13 @@
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]]
+ if {!$keepcase} {
+ dict set row name [string tolower [dict get $row name]]
+ }
dict set retval [dict get $row name] $row
}
return $retval
}
@@ -227,17 +239,21 @@
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]]} {
+ if {!$keepcase} {
+ dict set row name [string tolower [dict get $row name]]
+ }
+ if {![string match $pattern \
+ [string tolower [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 type \
+ [string trim [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]]
@@ -352,11 +368,11 @@
# 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])} {
+ eq [string tolower [dict get $argdict primary]])} {
# Construct a dictionary for each key, translating
# SQLite names to TDBC ones and converting sequence
# numbers to 1-based indexing.
