ton/ImageUtils
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

update

Browse Source
This commit is contained in:
ton
2024-10-07 10:13:40 +07:00
parent aa1631742f
commit 3a7d696db6
9729 changed files with 1832837 additions and 161742 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.CondaPkg/env/Library/lib/tcl8/8.4/platform-1.0.19.tm vendored
View File

@@ -265,7 +265,7 @@ proc ::platform::LibcVersion {base _->_ vv} {
set libc [lindex $libclist 0]
# Try executing the library first. This should suceed
# Try executing the library first. This should succeed
# for a glibc library, and return the version
# information.

8
.CondaPkg/env/Library/lib/tcl8/8.4/platform/shell-1.1.4.tm vendored
View File

@@ -27,7 +27,7 @@ proc ::platform::shell::generic {shell} {
LOCATE base out
set code {}
# Forget any pre-existing platform package, it might be in
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
@@ -52,7 +52,7 @@ proc ::platform::shell::identify {shell} {
LOCATE base out
set code {}
# Forget any pre-existing platform package, it might be in
# Forget any preexisting platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
@@ -99,14 +99,14 @@ proc ::platform::shell::LOCATE {bv ov} {
upvar 1 $bv base $ov out
# Locate the platform package for injection into the specified
# shell. We are using package management to find it, whereever it
# shell. We are using package management to find it, wherever it
# is, instead of using hardwired relative paths. This allows us to
# install the two packages as TMs without breaking the code
# here. If the found package is wrapped we copy the code somewhere
# where the spawned shell will be able to read it.
# This code is brittle, it needs has to adapt to whatever changes
# are made to the TM code, i.e. the provide statement generated by
# are made to the TM code, i.e. the "provide" statement generated by
# tm.tcl
set pl [package ifneeded platform [package require platform]]

12
.CondaPkg/env/Library/lib/tcl8/8.5/msgcat-1.6.1.tm vendored
View File

@@ -32,7 +32,7 @@ namespace eval msgcat {
# Configuration values per Package (e.g. client namespace).
# The dict key is of the form "<option> <namespace>" and the value is the
# configuration option. A nonexisting key is an unset option.
# configuration option. A non-existing key is an unset option.
variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\
unknowncmd {} loadedlocales {} loclist {}]
@@ -179,7 +179,7 @@ namespace eval msgcat {
# Find the translation for the given string based on the current
# locale setting. Check the local namespace first, then look in each
# parent namespace until the source is found. If additional args are
# specified, use the format command to work them into the traslated
# specified, use the format command to work them into the translated
# string.
# If no catalog item is found, mcunknown is called in the caller frame
# and its result is returned.
@@ -578,7 +578,7 @@ proc msgcat::mcforgetpackage {} {
# mcfolder
# The message catalog folder of the package.
# This is automatically set by mcload.
# If the value is changed using the set subcommand, an evntual
# If the value is changed using the set subcommand, an eventual
# loadcmd is invoked and all message files of the package locale are
# loaded.
#
@@ -1013,7 +1013,7 @@ proc msgcat::mcflmset {pairs} {
# by an application specific routine for error reporting
# purposes. The default behavior is to return the source string.
# If additional args are specified, the format command will be used
# to work them into the traslated string.
# to work them into the translated string.
#
# Arguments:
# locale The current locale.
@@ -1034,9 +1034,9 @@ proc msgcat::mcunknown {args} {
# - Default global handler, if mcunknown is not redefined.
# - Per package handler, if the package sets unknowncmd to the empty
# string.
# It returna the source string if the argument list is empty.
# It returns the source string if the argument list is empty.
# If additional args are specified, the format command will be used
# to work them into the traslated string.
# to work them into the translated string.
#
# Arguments:
# locale (unused) The current locale.

133
.CondaPkg/env/Library/lib/tcl8/8.5/tcltest-2.5.5.tm → .CondaPkg/env/Library/lib/tcl8/8.5/tcltest-2.5.7.tm vendored
View File

@@ -16,20 +16,22 @@
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.5
variable Version 2.5.7
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# Do not use these. Call [package require] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable version [package require Tcl 8.5-]
variable patchLevel [info patchlevel]
# Detect if we can use code points >= \U10000
variable fullutf [package vsatisfies $version 8.7-]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
@@ -41,7 +43,7 @@ namespace eval tcltest {
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
if {![package vsatisfies [package provide Tcl] 8.7-]} {
if {!$fullutf} {
namespace export bytestring ;# dups [encoding convertfrom identity]
}
namespace export debug ;# [configure -debug]
@@ -153,7 +155,7 @@ namespace eval tcltest {
}
##### Initialize internal arrays of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# has not already preinitialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
@@ -163,7 +165,7 @@ namespace eval tcltest {
return
}
if {[info exists $varName]} {
# Pre-initialized value is a scalar: destroy it!
# Preinitialized value is a scalar: Destroy it!
unset $varName
}
array set $varName $value
@@ -196,7 +198,7 @@ namespace eval tcltest {
ArrayDefault testConstraints {}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# has not already preinitialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
@@ -229,7 +231,7 @@ namespace eval tcltest {
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# pre-existing files.
# preexisting files.
#
# Note that $filesExisted lists only those files that exist in
# the original [temporaryDirectory].
@@ -298,7 +300,7 @@ namespace eval tcltest {
# keep track of test level for nested test commands
variable testLevel 0
# the variables and procs that existed when saveState was called are
# the variables and procedures that existed when saveState was called are
# stored in a variable of the same name
Default saveState {}
@@ -345,6 +347,7 @@ namespace eval tcltest {
proc outputChannel { {filename ""} } {
variable outputChannel
variable ChannelsWeOpened
variable fullutf
# This is very subtle and tricky, so let me try to explain.
# (Hopefully this longer comment will be clear when I come
@@ -354,12 +357,12 @@ namespace eval tcltest {
# be kept in sync with the [configure -outfile] configuration
# option ( and underlying variable Option(-outfile) ). This is
# accomplished with a write trace on Option(-outfile) that will
# update [outputChannel] whenver a new value is written. That
# update [outputChannel] whenever a new value is written. That
# much is easy.
#
# The trick is that in order to maintain compatibility with
# version 1 of tcltest, we must allow every configuration option
# to get its inital value from command line arguments. This is
# to get its initial value from command line arguments. This is
# accomplished by setting initial read traces on all the
# configuration options to parse the command line option the first
# time they are read. These traces are cancelled whenever the
@@ -399,8 +402,8 @@ namespace eval tcltest {
}
default {
set outputChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $outputChannel -encoding utf-8
if {$fullutf} {
fconfigure $outputChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($outputChannel) 1
@@ -427,6 +430,7 @@ namespace eval tcltest {
proc errorChannel { {filename ""} } {
variable errorChannel
variable ChannelsWeOpened
variable fullutf
# This is subtle and tricky. See the comment above in
# [outputChannel] for a detailed explanation.
@@ -446,8 +450,8 @@ namespace eval tcltest {
}
default {
set errorChannel [open $filename a]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $errorChannel -encoding utf-8
if {$fullutf} {
fconfigure $errorChannel -profile tcl8 -encoding utf-8
}
set ChannelsWeOpened($errorChannel) 1
@@ -482,7 +486,7 @@ namespace eval tcltest {
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
# is already set, support compatibility by accepting its pre-set value.
# is already set, support compatibility by accepting its preset value.
# Use [trace] to establish ongoing connection between the deprecated
# exported variable and the modern option kept as a true internal var.
# Also set up usage string and value testing for the option.
@@ -761,7 +765,7 @@ namespace eval tcltest {
# even if the directory is not writable
return $directory
}
return -code error "\"$directory\" is not writeable"
return -code error "\"$directory\" is not writable"
}
return $directory
}
@@ -789,10 +793,12 @@ namespace eval tcltest {
}
proc ReadLoadScript {args} {
variable Option
variable fullutf
if {$Option(-loadfile) eq {}} {return}
set tmp [open $Option(-loadfile) r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $tmp -encoding utf-8
if {$fullutf} {
fconfigure $tmp -profile tcl8 -encoding utf-8
}
loadScript [read $tmp]
close $tmp
@@ -852,7 +858,7 @@ namespace eval tcltest {
# tcltest::Debug* --
#
# Internal helper procedures to write out debug information
# dependent on the chosen level. A test shell may overide
# dependent on the chosen level. A test shell may override
# them, f.e. to redirect the output into a different
# channel, or even into a GUI.
@@ -1134,6 +1140,37 @@ proc tcltest::SafeFetch {n1 n2 op} {
}
}
# tcltest::Asciify --
#
# Transforms the passed string to contain only printable ascii characters.
# Useful for printing to terminals. Non-printables are mapped to
# \x, \u or \U sequences, except \n.
#
# Arguments:
# s - string to transform
#
# Results:
# The transformed strings
#
# Side effects:
# None.
proc tcltest::Asciify {s} {
set print ""
foreach c [split $s ""] {
if {(($c < "\x7F") && [string is print $c]) || ($c eq "\n")} {
append print $c
} elseif {$c < "\u0100"} {
append print \\x[format %02X [scan $c %c]]
} elseif {$c > "\uFFFF"} {
append print \\U[format %08X [scan $c %c]]
} else {
append print \\u[format %04X [scan $c %c]]
}
}
return $print
}
# tcltest::ConstraintInitializer --
#
# Get or set a script that when evaluated in the tcltest namespace
@@ -1337,10 +1374,12 @@ proc tcltest::DefineConstraintInitializers {} {
}
ConstraintInitializer stdio {
variable fullutf
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
if {$fullutf} {
fconfigure $f -profile tcl8 -encoding utf-8
}
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
@@ -1758,7 +1797,7 @@ proc tcltest::SubstArguments {argList} {
# We need to split the argList up into tokens but cannot use list
# operations as they throw away some significant quoting, and
# [split] ignores braces as it should. Therefore what we do is
# gradually build up a string out of whitespace seperated strings.
# gradually build up a string out of whitespace-separated strings.
# We cannot use [split] to split the argList into whitespace
# separated strings as it throws away the whitespace which maybe
# important so we have to do it all by hand.
@@ -1865,7 +1904,7 @@ proc tcltest::SubstArguments {argList} {
# match - specifies type of matching to do on result,
# output, errorOutput; this must be a string
# previously registered by a call to [customMatch].
# The strings exact, glob, and regexp are pre-registered
# The strings exact, glob, and regexp are preregistered
# by the tcltest package. Default value is exact.
#
# Arguments:
@@ -1884,6 +1923,8 @@ proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
variable fullutf
DebugPuts 3 "test $name $args"
DebugDo 1 {
variable TestNames
@@ -1896,7 +1937,7 @@ proc tcltest::test {name description args} {
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# Predefine everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
lassign {} constraints setup cleanup body result returnCodes errorCode match
@@ -2189,8 +2230,8 @@ proc tcltest::test {name description args} {
set testFile [file normalize [uplevel 1 {info script}]]
if {[file readable $testFile]} {
set testFd [open $testFile r]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $testFd -encoding utf-8
if {$fullutf} {
fconfigure $testFd -profile tcl8 -encoding utf-8
}
set testLine [expr {[lsearch -regexp \
[split [read $testFd] "\n"] \
@@ -2221,9 +2262,13 @@ proc tcltest::test {name description args} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
if {[catch {
puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]"
} errMsg]} {
puts [outputChannel] "\n---- Result was:\n<error printing result: $errMsg>"
}
puts [outputChannel] "---- Result should have been\
($match matching):\n$result"
($match matching):\n[Asciify $result]"
}
}
if {$errorCodeFailure} {
@@ -2365,6 +2410,7 @@ proc tcltest::Skipped {name constraints} {
# make sure that the constraints are satisfied.
set doTest 0
set constraints [string trim $constraints]
if {[string match {*[$\[]*} $constraints] != 0} {
# full expression, e.g. {$foo > [info tclversion]}
catch {set doTest [uplevel #0 [list expr $constraints]]}
@@ -2491,7 +2537,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# workingDirectory that were not preexisting, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
@@ -2582,7 +2628,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
# loop is running, which is the real issue.
# Actually, this doesn't belong here at all. A package
# really has no business [exit]-ing an application.
if {![catch {package present Tk}] && ![testConstraint interactive]} {
if {[info exists ::tk_version] && ![testConstraint interactive]} {
exit
}
} else {
@@ -2815,6 +2861,7 @@ proc tcltest::runAllTests { {shell ""} } {
variable numTests
variable failFiles
variable DefaultValue
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 1} {
@@ -2900,8 +2947,8 @@ proc tcltest::runAllTests { {shell ""} } {
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $pipeFd -encoding utf-8
if {$fullutf} {
fconfigure $pipeFd -profile tcl8 -encoding utf-8
}
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
@@ -3087,6 +3134,8 @@ proc tcltest::normalizeMsg {msg} {
proc tcltest::makeFile {contents name {directory ""}} {
variable filesMade
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 3} {
@@ -3100,8 +3149,8 @@ proc tcltest::makeFile {contents name {directory ""}} {
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $fd -encoding utf-8
if {$fullutf} {
fconfigure $fd -profile tcl8 -encoding utf-8
}
if {[string index $contents end] eq "\n"} {
puts -nonewline $fd $contents
@@ -3245,14 +3294,16 @@ proc tcltest::removeDirectory {name {directory ""}} {
# None.
proc tcltest::viewFile {name {directory ""}} {
variable fullutf
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
if {[package vsatisfies [package provide Tcl] 8.7-]} {
fconfigure $f -encoding utf-8
if {$fullutf} {
fconfigure $f -profile tcl8 -encoding utf-8
}
set data [read -nonewline $f]
close $f
@@ -3287,7 +3338,7 @@ proc tcltest::viewFile {name {directory ""}} {
# Side effects:
# None
if {![package vsatisfies [package provide Tcl] 8.7-]} {
if {!$::tcltest::fullutf} {
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
@@ -3449,7 +3500,7 @@ proc tcltest::threadReap {} {
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
# Define initializers for all the built-in contraint definitions
# Define initializers for all the built-in constraint definitions
DefineConstraintInitializers
# Set up the constraints in the testConstraints array to be lazily
@@ -3458,7 +3509,7 @@ namespace eval tcltest {
trace add variable testConstraints read [namespace code SafeFetch]
# Only initialize constraints at package load time if an
# [initConstraintsHook] has been pre-defined. This is only
# [initConstraintsHook] has been predefined. This is only
# for compatibility support. The modern way to add a custom
# test constraint is to just call the [testConstraint] command
# straight away, without all this "hook" nonsense.

8
.CondaPkg/env/Library/lib/tcl8/8.6/http-2.9.8.tm vendored
View File

@@ -2356,7 +2356,7 @@ proc http::error {token} {
# token The token returned from http::geturl
#
# Side Effects
# unsets the state array
# Unsets the state array.
proc http::cleanup {token} {
variable $token
@@ -2375,7 +2375,7 @@ proc http::cleanup {token} {
# http::Connect
#
# This callback is made when an asyncronous connection completes.
# This callback is made when an asynchronous connection completes.
#
# Arguments
# token The token returned from http::geturl
@@ -3250,7 +3250,7 @@ proc http::CopyChunk {token chunk} {
#
# Arguments
# token The token returned from http::geturl
# count The amount transfered
# count The amount transferred
#
# Side Effects
# Invokes callbacks
@@ -3293,7 +3293,7 @@ proc http::CopyDone {token count {error {}}} {
# reason - "eof" means premature EOF (not EOF as the natural end of
# the response)
# - "" means completion of response, with or without EOF
# - anything else describes an error confition other than
# - anything else describes an error condition other than
# premature EOF.
#
# Side Effects

715
.CondaPkg/env/Library/lib/tcl8/8.6/tdbc/sqlite3-1.1.5.tm vendored
View File

@@ -1,715 +0,0 @@
# 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.5
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}
}
}