p147685/CardiacPhase
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial class construction

Browse Source
This commit is contained in:
João Narciso
2019-05-06 16:34:28 +02:00
parent 67f2d57e03
commit 431ff5f7d4
5813 changed files with 1622108 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

397
Git/mingw64/lib/tcl8/8.4/platform-1.0.14.tm Normal file
View File

@ -0,0 +1,397 @@
# -*- tcl -*-
# ### ### ### ######### ######### #########
## Overview
# Heuristics to assemble a platform identifier from publicly available
# information. The identifier describes the platform of the currently
# running tcl shell. This is a mixture of the runtime environment and
# of build-time properties of the executable itself.
#
# Examples:
# <1> A tcl shell executing on a x86_64 processor, but having a
# wordsize of 4 was compiled for the x86 environment, i.e. 32
# bit, and loaded packages have to match that, and not the
# actual cpu.
#
# <2> The hp/solaris 32/64 bit builds of the core cannot be
# distinguished by looking at tcl_platform. As packages have to
# match the 32/64 information we have to look in more places. In
# this case we inspect the executable itself (magic numbers,
# i.e. fileutil::magic::filetype).
#
# The basic information used comes out of the 'os' and 'machine'
# entries of the 'tcl_platform' array. A number of general and
# os/machine specific transformation are applied to get a canonical
# result.
#
# General
# Only the first element of 'os' is used - we don't care whether we
# are on "Windows NT" or "Windows XP" or whatever.
#
# Machine specific
# % arm* -> arm
# % sun4* -> sparc
# % intel -> ix86
# % i*86* -> ix86
# % Power* -> powerpc
# % x86_64 + wordSize 4 => x86 code
#
# OS specific
# % AIX are always powerpc machines
# % HP-UX 9000/800 etc means parisc
# % linux has to take glibc version into account
# % sunos -> solaris, and keep version number
#
# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
# has to provide all possible allowed platform identifiers when
# searching search. Ditto a solaris 2.8 platform can use solaris 2.6
# packages. Etc. This is handled by the other procedure, see below.
# ### ### ### ######### ######### #########
## Requirements
namespace eval ::platform {}
# ### ### ### ######### ######### #########
## Implementation
# -- platform::generic
#
# Assembles an identifier for the generic platform. It leaves out
# details like kernel version, libc version, etc.
proc ::platform::generic {} {
global tcl_platform
set plat [string tolower [lindex $tcl_platform(os) 0]]
set cpu $tcl_platform(machine)
switch -glob -- $cpu {
sun4* {
set cpu sparc
}
intel -
i*86* {
set cpu ix86
}
x86_64 {
if {$tcl_platform(wordSize) == 4} {
# See Example <1> at the top of this file.
set cpu ix86
}
}
"Power*" {
set cpu powerpc
}
"arm*" {
set cpu arm
}
ia64 {
if {$tcl_platform(wordSize) == 4} {
append cpu _32
}
}
}
switch -glob -- $plat {
cygwin* {
set plat cygwin
}
windows {
if {$tcl_platform(platform) == "unix"} {
set plat cygwin
} else {
set plat win32
}
if {$cpu eq "amd64"} {
# Do not check wordSize, win32-x64 is an IL32P64 platform.
set cpu x86_64
}
}
sunos {
set plat solaris
if {[string match "ix86" $cpu]} {
if {$tcl_platform(wordSize) == 8} {
set cpu x86_64
}
} elseif {![string match "ia64*" $cpu]} {
# sparc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
}
darwin {
set plat macosx
# Correctly identify the cpu when running as a 64bit
# process on a machine with a 32bit kernel
if {$cpu eq "ix86"} {
if {$tcl_platform(wordSize) == 8} {
set cpu x86_64
}
}
}
aix {
set cpu powerpc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
hp-ux {
set plat hpux
if {![string match "ia64*" $cpu]} {
set cpu parisc
if {$tcl_platform(wordSize) == 8} {
append cpu 64
}
}
}
osf1 {
set plat tru64
}
}
return "${plat}-${cpu}"
}
# -- platform::identify
#
# Assembles an identifier for the exact platform, by extending the
# generic identifier. I.e. it adds in details like kernel version,
# libc version, etc., if they are relevant for the loading of
# packages on the platform.
proc ::platform::identify {} {
global tcl_platform
set id [generic]
regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
switch -- $plat {
solaris {
regsub {^5} $tcl_platform(osVersion) 2 text
append plat $text
return "${plat}-${cpu}"
}
macosx {
set major [lindex [split $tcl_platform(osVersion) .] 0]
if {$major > 8} {
incr major -4
append plat 10.$major
return "${plat}-${cpu}"
}
}
linux {
# Look for the libc*.so and determine its version
# (libc5/6, libc6 further glibc 2.X)
set v unknown
# Determine in which directory to look. /lib, or /lib64.
# For that we use the tcl_platform(wordSize).
#
# We could use the 'cpu' info, per the equivalence below,
# that however would be restricted to intel. And this may
# be a arm, mips, etc. system. The wordsize is more
# fundamental.
#
# ix86 <=> (wordSize == 4) <=> 32 bit ==> /lib
# x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64
#
# Do not look into /lib64 even if present, if the cpu
# doesn't fit.
# TODO: Determine the prefixes (i386, x86_64, ...) for
# other cpus. The path after the generic one is utterly
# specific to intel right now. Ok, on Ubuntu, possibly
# other Debian systems we may apparently be able to query
# the necessary CPU code. If we can't we simply use the
# hardwired fallback.
switch -exact -- $tcl_platform(wordSize) {
4 {
lappend bases /lib
if {[catch {
exec dpkg-architecture -qDEB_HOST_MULTIARCH
} res]} {
lappend bases /lib/i386-linux-gnu
} else {
# dpkg-arch returns the full tripled, not just cpu.
lappend bases /lib/$res
}
}
8 {
lappend bases /lib64
if {[catch {
exec dpkg-architecture -qDEB_HOST_MULTIARCH
} res]} {
lappend bases /lib/x86_64-linux-gnu
} else {
# dpkg-arch returns the full tripled, not just cpu.
lappend bases /lib/$res
}
}
default {
return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
}
}
foreach base $bases {
if {[LibcVersion $base -> v]} break
}
append plat -$v
return "${plat}-${cpu}"
}
}
return $id
}
proc ::platform::LibcVersion {base _->_ vv} {
upvar 1 $vv v
set libclist [lsort [glob -nocomplain -directory $base libc*]]
if {![llength $libclist]} { return 0 }
set libc [lindex $libclist 0]
# Try executing the library first. This should suceed
# for a glibc library, and return the version
# information.
if {![catch {
set vdata [lindex [split [exec $libc] \n] 0]
}]} {
regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v
foreach {major minor} [split $v .] break
set v glibc${major}.${minor}
return 1
} else {
# We had trouble executing the library. We are now
# inspecting its name to determine the version
# number. This code by Larry McVoy.
if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
set v glibc${major}.${minor}
return 1
}
}
return 0
}
# -- platform::patterns
#
# Given an exact platform identifier, i.e. _not_ the generic
# identifier it assembles a list of exact platform identifier
# describing platform which should be compatible with the
# input.
#
# I.e. packages for all platforms in the result list should be
# loadable on the specified platform.
# << Should we add the generic identifier to the list as well ? In
# general it is not compatible I believe. So better not. In many
# cases the exact identifier is identical to the generic one
# anyway.
# >>
proc ::platform::patterns {id} {
set res [list $id]
if {$id eq "tcl"} {return $res}
switch -glob -- $id {
solaris*-* {
if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
if {$v eq ""} {return $id}
foreach {major minor} [split $v .] break
incr minor -1
for {set j $minor} {$j >= 6} {incr j -1} {
lappend res solaris${major}.${j}-${cpu}
}
}
}
linux*-* {
if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
foreach {major minor} [split $v .] break
incr minor -1
for {set j $minor} {$j >= 0} {incr j -1} {
lappend res linux-glibc${major}.${j}-${cpu}
}
}
}
macosx-powerpc {
lappend res macosx-universal
}
macosx-x86_64 {
lappend res macosx-i386-x86_64
}
macosx-ix86 {
lappend res macosx-universal macosx-i386-x86_64
}
macosx*-* {
# 10.5+
if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
switch -exact -- $cpu {
ix86 {
lappend alt i386-x86_64
lappend alt universal
}
x86_64 { lappend alt i386-x86_64 }
default { set alt {} }
}
if {$v ne ""} {
foreach {major minor} [split $v .] break
# Add 10.5 to 10.minor to patterns.
set res {}
for {set j $minor} {$j >= 5} {incr j -1} {
lappend res macosx${major}.${j}-${cpu}
foreach a $alt {
lappend res macosx${major}.${j}-$a
}
}
# Add unversioned patterns for 10.3/10.4 builds.
lappend res macosx-${cpu}
foreach a $alt {
lappend res macosx-$a
}
} else {
# No version, just do unversioned patterns.
foreach a $alt {
lappend res macosx-$a
}
}
} else {
# no v, no cpu ... nothing
}
}
}
lappend res tcl ; # Pure tcl packages are always compatible.
return $res
}
# ### ### ### ######### ######### #########
## Ready
package provide platform 1.0.14
# ### ### ### ######### ######### #########
## Demo application
if {[info exists argv0] && ($argv0 eq [info script])} {
puts ====================================
parray tcl_platform
puts ====================================
puts Generic\ identification:\ [::platform::generic]
puts Exact\ identification:\ \ \ [::platform::identify]
puts ====================================
puts Search\ patterns:
puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
puts ====================================
exit 0
}

241
Git/mingw64/lib/tcl8/8.4/platform/shell-1.1.4.tm Normal file
View File

@ -0,0 +1,241 @@
# -*- tcl -*-
# ### ### ### ######### ######### #########
## Overview
# Higher-level commands which invoke the functionality of this package
# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
# repository as while the tcl shell executing packages uses the same
# platform in general as a repository application there can be
# differences in detail (i.e. 32/64 bit builds).
# ### ### ### ######### ######### #########
## Requirements
package require platform
namespace eval ::platform::shell {}
# ### ### ### ######### ######### #########
## Implementation
# -- platform::shell::generic
proc ::platform::shell::generic {shell} {
# Argument is the path to a tcl shell.
CHECK $shell
LOCATE base out
set code {}
# Forget any pre-existing platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
lappend code [list source $base]
# Query and print the architecture
lappend code {puts [platform::generic]}
# And done
lappend code {exit 0}
set arch [RUN $shell [join $code \n]]
if {$out} {file delete -force $base}
return $arch
}
# -- platform::shell::identify
proc ::platform::shell::identify {shell} {
# Argument is the path to a tcl shell.
CHECK $shell
LOCATE base out
set code {}
# Forget any pre-existing platform package, it might be in
# conflict with this one.
lappend code {package forget platform}
# Inject our platform package
lappend code [list source $base]
# Query and print the architecture
lappend code {puts [platform::identify]}
# And done
lappend code {exit 0}
set arch [RUN $shell [join $code \n]]
if {$out} {file delete -force $base}
return $arch
}
# -- platform::shell::platform
proc ::platform::shell::platform {shell} {
# Argument is the path to a tcl shell.
CHECK $shell
set code {}
lappend code {puts $tcl_platform(platform)}
lappend code {exit 0}
return [RUN $shell [join $code \n]]
}
# ### ### ### ######### ######### #########
## Internal helper commands.
proc ::platform::shell::CHECK {shell} {
if {![file exists $shell]} {
return -code error "Shell \"$shell\" does not exist"
}
if {![file executable $shell]} {
return -code error "Shell \"$shell\" is not executable (permissions)"
}
return
}
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
# 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
# tm.tcl
set pl [package ifneeded platform [package require platform]]
set base [lindex $pl end]
set out 0
if {[lindex [file system $base]] ne "native"} {
set temp [TEMP]
file copy -force $base $temp
set base $temp
set out 1
}
return
}
proc ::platform::shell::RUN {shell code} {
set c [TEMP]
set cc [open $c w]
puts $cc $code
close $cc
set e [TEMP]
set code [catch {
exec $shell $c 2> $e
} res]
file delete $c
if {$code} {
append res \n[read [set chan [open $e r]]][close $chan]
file delete $e
return -code error "Shell \"$shell\" is not executable ($res)"
}
file delete $e
return $res
}
proc ::platform::shell::TEMP {} {
set prefix platform
# This code is copied out of Tcllib's fileutil package.
# (TempFile/tempfile)
set tmpdir [DIR]
set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
set nrand_chars 10
set maxtries 10
set access [list RDWR CREAT EXCL TRUNC]
set permission 0600
set channel ""
set checked_dir_writable 0
set mypid [pid]
for {set i 0} {$i < $maxtries} {incr i} {
set newname $prefix
for {set j 0} {$j < $nrand_chars} {incr j} {
append newname [string index $chars \
[expr {int(rand()*62)}]]
}
set newname [file join $tmpdir $newname]
if {[file exists $newname]} {
after 1
} else {
if {[catch {open $newname $access $permission} channel]} {
if {!$checked_dir_writable} {
set dirname [file dirname $newname]
if {![file writable $dirname]} {
return -code error "Directory $dirname is not writable"
}
set checked_dir_writable 1
}
} else {
# Success
close $channel
return [file normalize $newname]
}
}
}
if {$channel ne ""} {
return -code error "Failed to open a temporary file: $channel"
} else {
return -code error "Failed to find an unused temporary file name"
}
}
proc ::platform::shell::DIR {} {
# This code is copied out of Tcllib's fileutil package.
# (TempDir/tempdir)
global tcl_platform env
set attempdirs [list]
foreach tmp {TMPDIR TEMP TMP} {
if { [info exists env($tmp)] } {
lappend attempdirs $env($tmp)
}
}
switch $tcl_platform(platform) {
windows {
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
}
macintosh {
set tmpdir $env(TRASH_FOLDER) ;# a better place?
}
default {
lappend attempdirs \
[file join / tmp] \
[file join / var tmp] \
[file join / usr tmp]
}
}
lappend attempdirs [pwd]
foreach tmp $attempdirs {
if { [file isdirectory $tmp] && [file writable $tmp] } {
return [file normalize $tmp]
}
}
# Fail if nothing worked.
return -code error "Unable to determine a proper directory for temporary files"
}
# ### ### ### ######### ######### #########
## Ready
package provide platform::shell 1.1.4

1210
Git/mingw64/lib/tcl8/8.5/msgcat-1.6.1.tm Normal file
View File

File diff suppressed because it is too large Load Diff

3441
Git/mingw64/lib/tcl8/8.5/tcltest-2.5.0.tm Normal file
View File

File diff suppressed because it is too large Load Diff

3427
Git/mingw64/lib/tcl8/8.6/http-2.9.0.tm Normal file
View File

File diff suppressed because it is too large Load Diff

715
Git/mingw64/lib/tcl8/8.6/tdbc/sqlite3-1.1.0.tm Normal file
View File

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

181
Git/mingw64/lib/tcl8/tclConfig.sh Normal file
View File

@ -0,0 +1,181 @@
# tclConfig.sh --
#
# This shell script (for sh) is generated automatically by Tcl's
# configure script. It will create shell variables for most of
# the configuration options discovered by the configure script.
# This script is intended to be included by the configure scripts
# for Tcl extensions so that they don't have to figure this all
# out for themselves.
#
# The information in this file is specific to a single platform.
TCL_DLL_FILE="tcl86.dll"
# Tcl's version number.
TCL_VERSION='8.6'
TCL_MAJOR_VERSION='8'
TCL_MINOR_VERSION='6'
TCL_PATCH_LEVEL='.9'
# C compiler to use for compilation.
TCL_CC='x86_64-w64-mingw32-gcc'
# -D flags for use with the C compiler.
TCL_DEFS='-DPACKAGE_NAME=\"\" -DPACKAGE_TARNAME=\"\" -DPACKAGE_VERSION=\"\" -DPACKAGE_STRING=\"\" -DPACKAGE_BUGREPORT=\"\" -DPACKAGE_URL=\"\" -DSTDC_HEADERS=1 -DTCL_THREADS=1 -DUSE_THREAD_ALLOC=1 -DTCL_CFGVAL_ENCODING=\"cp1252\" -DHAVE_SYS_TYPES_H=1 -DHAVE_SYS_STAT_H=1 -DHAVE_STDLIB_H=1 -DHAVE_STRING_H=1 -DHAVE_MEMORY_H=1 -DHAVE_STRINGS_H=1 -DHAVE_INTTYPES_H=1 -DHAVE_STDINT_H=1 -DHAVE_UNISTD_H=1 -DMODULE_SCOPE=extern -DTCL_CFG_DO64BIT=1 -DHAVE_NO_SEH=1 -DHAVE_CAST_TO_UNION=1 -DHAVE_ZLIB=1 -DHAVE_INTPTR_T=1 -DHAVE_UINTPTR_T=1 -DHAVE_INTRIN_H=1 -DHAVE_WSPIAPI_H=1 -DNDEBUG=1 -DTCL_CFG_OPTIMIZED=1'
# If TCL was built with debugging symbols, generated libraries contain
# this string at the end of the library name (before the extension).
TCL_DBGX=
# Default flags used in an optimized and debuggable build, respectively.
TCL_CFLAGS_DEBUG='-g'
TCL_CFLAGS_OPTIMIZE='-O2 -fomit-frame-pointer'
# Default linker flags used in an optimized and debuggable build, respectively.
TCL_LDFLAGS_DEBUG=''
TCL_LDFLAGS_OPTIMIZE=''
# Flag, 1: we built a shared lib, 0 we didn't
TCL_SHARED_BUILD=1
# The name of the Tcl library (may be either a .a file or a shared library):
TCL_LIB_FILE='libtcl86.dll.a'
# Flag to indicate whether shared libraries need export files.
TCL_NEEDS_EXP_FILE=
# String that can be evaluated to generate the part of the export file
# name that comes after the "libxxx" (includes version number, if any,
# extension, and anything else needed). May depend on the variables
# VERSION. On most UNIX systems this is ${VERSION}.exp.
TCL_EXPORT_FILE_SUFFIX='${NODOT_VERSION}${DBGX}.a'
# Additional libraries to use when linking Tcl.
TCL_LIBS='-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32'
# Top-level directory in which Tcl's platform-independent files are
# installed.
TCL_PREFIX='/mingw64'
# Top-level directory in which Tcl's platform-specific files (e.g.
# executables) are installed.
TCL_EXEC_PREFIX='/mingw64'
# Flags to pass to cc when compiling the components of a shared library:
TCL_SHLIB_CFLAGS=''
# Flags to pass to cc to get warning messages
TCL_CFLAGS_WARNING='-Wall -Wdeclaration-after-statement'
# Extra flags to pass to cc:
TCL_EXTRA_CFLAGS='-pipe'
# Base command to use for combining object files into a shared library:
TCL_SHLIB_LD='${CC} -shared'
# Base command to use for combining object files into a static library:
TCL_STLIB_LD='${AR} cr'
# Either '$LIBS' (if dependent libraries should be included when linking
# shared libraries) or an empty string. See Tcl's configure.in for more
# explanation.
TCL_SHLIB_LD_LIBS='${LIBS}'
# Suffix to use for the name of a shared library.
TCL_SHLIB_SUFFIX='.dll'
# Library file(s) to include in tclsh and other base applications
# in order to provide facilities needed by DLOBJ above.
TCL_DL_LIBS=''
# Flags to pass to the compiler when linking object files into
# an executable tclsh or tcltest binary.
TCL_LD_FLAGS='-pipe'
# Flags to pass to cc/ld, such as "-R /usr/local/tcl/lib", that tell the
# run-time dynamic linker where to look for shared libraries such as
# libtcl.so. Used when linking applications. Only works if there
# is a variable "LIB_RUNTIME_DIR" defined in the Makefile.
TCL_CC_SEARCH_FLAGS=''
TCL_LD_SEARCH_FLAGS=''
# Additional object files linked with Tcl to provide compatibility
# with standard facilities from ANSI C or POSIX.
TCL_COMPAT_OBJS=''
# Name of the ranlib program to use.
TCL_RANLIB='ranlib'
# -l flag to pass to the linker to pick up the Tcl library
TCL_LIB_FLAG=''
# String to pass to linker to pick up the Tcl library from its
# build directory.
TCL_BUILD_LIB_SPEC='-Wl,/mingw64/lib/libtcl86.dll.a'
# String to pass to linker to pick up the Tcl library from its
# installed directory.
TCL_LIB_SPEC='-L/mingw64/lib -ltcl86'
# String to pass to the compiler so that an extension can
# find installed Tcl headers.
TCL_INCLUDE_SPEC='-I/mingw64/include/tcl8.6'
# Indicates whether a version numbers should be used in -l switches
# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means
# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for
# example.
TCL_LIB_VERSIONS_OK=''
# String that can be evaluated to generate the part of a shared library
# name that comes after the "libxxx" (includes version number, if any,
# extension, and anything else needed). May depend on the variables
# VERSION and SHLIB_SUFFIX. On most UNIX systems this is
# ${VERSION}${SHLIB_SUFFIX}.
TCL_SHARED_LIB_SUFFIX='${NODOT_VERSION}${DBGX}.dll'
# String that can be evaluated to generate the part of an unshared library
# name that comes after the "libxxx" (includes version number, if any,
# extension, and anything else needed). May depend on the variable
# VERSION. On most UNIX systems this is ${VERSION}.a.
TCL_UNSHARED_LIB_SUFFIX='${NODOT_VERSION}${DBGX}.a'
# Location of the top-level source directory from which Tcl was built.
# This is the directory that contains a README file as well as
# subdirectories such as generic, unix, etc. If Tcl was compiled in a
# different place than the directory containing the source files, this
# points to the location of the sources, not the location where Tcl was
# compiled.
TCL_SRC_DIR='/mingw64/include/tcl8.6/tcl-private'
# List of standard directories in which to look for packages during
# "package require" commands. Contains the "prefix" directory plus also
# the "exec_prefix" directory, if it is different.
TCL_PACKAGE_PATH='/mingw64/lib'
# Tcl supports stub.
TCL_SUPPORTS_STUBS=1
# The name of the Tcl stub library (.a):
TCL_STUB_LIB_FILE='libtclstub86.a'
# -l flag to pass to the linker to pick up the Tcl stub library
TCL_STUB_LIB_FLAG='-ltclstub86'
# String to pass to linker to pick up the Tcl stub library from its
# build directory.
TCL_BUILD_STUB_LIB_SPEC='-Wl,/mingw64/lib/libtclstub86.a'
# String to pass to linker to pick up the Tcl stub library from its
# installed directory.
TCL_STUB_LIB_SPEC='-L/mingw64/lib -ltclstub86'
# Path to the Tcl stub library in the build directory.
TCL_BUILD_STUB_LIB_PATH='/mingw64/lib'
# Path to the Tcl stub library in the install directory.
TCL_STUB_LIB_PATH='/mingw64/lib/libtclstub86.a'
# Flag, 1: we built Tcl with threads enabled, 0 we didn't
TCL_THREADS=1