diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2020-03-17 20:46:21 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2020-03-17 20:46:21 +0000 |
commit | 450bc12eba9ebc61c597b70a633eb1e37ab92180 (patch) | |
tree | 8985a7de63a8ae88e499d497d684da7f00c8c993 /Master/tlpkg/tltcl/lib/tdbc1.1.1 | |
parent | 412579d4e7fdcc86bf649615419fb560809bc8f3 (diff) |
New Tcl/Tk for Windows. No longer a single-file kit.
git-svn-id: svn://tug.org/texlive/trunk@54375 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tltcl/lib/tdbc1.1.1')
-rw-r--r-- | Master/tlpkg/tltcl/lib/tdbc1.1.1/libtdbcstub111.a | bin | 0 -> 1468 bytes | |||
-rw-r--r-- | Master/tlpkg/tltcl/lib/tdbc1.1.1/pkgIndex.tcl | 18 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc.tcl | 922 | ||||
-rw-r--r-- | Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc111.dll | bin | 0 -> 283475 bytes | |||
-rw-r--r-- | Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbcConfig.sh | 81 |
5 files changed, 1021 insertions, 0 deletions
diff --git a/Master/tlpkg/tltcl/lib/tdbc1.1.1/libtdbcstub111.a b/Master/tlpkg/tltcl/lib/tdbc1.1.1/libtdbcstub111.a Binary files differnew file mode 100644 index 00000000000..95b91c4feac --- /dev/null +++ b/Master/tlpkg/tltcl/lib/tdbc1.1.1/libtdbcstub111.a diff --git a/Master/tlpkg/tltcl/lib/tdbc1.1.1/pkgIndex.tcl b/Master/tlpkg/tltcl/lib/tdbc1.1.1/pkgIndex.tcl new file mode 100644 index 00000000000..ab541acb771 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/tdbc1.1.1/pkgIndex.tcl @@ -0,0 +1,18 @@ +# Index file to load the TDBC package. + +# Make sure that TDBC is running in a compatible version of Tcl, and +# that TclOO is available. + +if {[catch {package present Tcl 8.5-}]} { + return +} +apply {{dir} { + set libraryfile [file join $dir tdbc.tcl] + if {![file exists $libraryfile] && [info exists ::env(TDBC_LIBRARY)]} { + set libraryfile [file join $::env(TDBC_LIBRARY) tdbc.tcl] + } + package ifneeded tdbc 1.1.1 \ + "package require TclOO 1.0-;\ + [list load [file join $dir tdbc111.dll] tdbc]\;\ + [list source $libraryfile]" +}} $dir diff --git a/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc.tcl b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc.tcl new file mode 100644 index 00000000000..2a167cbefe4 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc.tcl @@ -0,0 +1,922 @@ +# tdbc.tcl -- +# +# Definitions of base classes from which TDBC drivers' connections, +# statements and result sets may inherit. +# +# 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$ +# +#------------------------------------------------------------------------------ + +package require TclOO + +namespace eval ::tdbc { + namespace export connection statement resultset + variable generalError [list TDBC GENERAL_ERROR HY000 {}] +} + +#------------------------------------------------------------------------------ +# +# tdbc::ParseConvenienceArgs -- +# +# Parse the convenience arguments to a TDBC 'execute', +# 'executewithdictionary', or 'foreach' call. +# +# Parameters: +# argv - Arguments to the call +# optsVar -- Name of a variable in caller's scope that will receive +# a dictionary of the supplied options +# +# Results: +# Returns any args remaining after parsing the options. +# +# Side effects: +# Sets the 'opts' dictionary to the options. +# +#------------------------------------------------------------------------------ + +proc tdbc::ParseConvenienceArgs {argv optsVar} { + + variable generalError + upvar 1 $optsVar opts + + set opts [dict create -as dicts] + set i 0 + + # Munch keyword options off the front of the command arguments + + foreach {key value} $argv { + if {[string index $key 0] eq {-}} { + switch -regexp -- $key { + -as? { + if {$value ne {dicts} && $value ne {lists}} { + set errorcode $generalError + lappend errorcode badVarType $value + return -code error \ + -errorcode $errorcode \ + "bad variable type \"$value\":\ + must be lists or dicts" + } + dict set opts -as $value + } + -c(?:o(?:l(?:u(?:m(?:n(?:s(?:v(?:a(?:r(?:i(?:a(?:b(?:le?)?)?)?)?)?)?)?)?)?)?)?)?) { + dict set opts -columnsvariable $value + } + -- { + incr i + break + } + default { + set errorcode $generalError + lappend errorcode badOption $key + return -code error \ + -errorcode $errorcode \ + "bad option \"$key\":\ + must be -as or -columnsvariable" + } + } + } else { + break + } + incr i 2 + } + + return [lrange $argv[set argv {}] $i end] + +} + + + +#------------------------------------------------------------------------------ +# +# tdbc::connection -- +# +# Class that represents a generic connection to a database. +# +#----------------------------------------------------------------------------- + +oo::class create ::tdbc::connection { + + # statementSeq is the sequence number of the last statement created. + # statementClass is the name of the class that implements the + # 'statement' API. + # primaryKeysStatement is the statement that queries primary keys + # foreignKeysStatement is the statement that queries foreign keys + + variable statementSeq primaryKeysStatement foreignKeysStatement + + # The base class constructor accepts no arguments. It sets up the + # machinery to do the bookkeeping to keep track of what statements + # are associated with the connection. The derived class constructor + # is expected to set the variable, 'statementClass' to the name + # of the class that represents statements, so that the 'prepare' + # method can invoke it. + + constructor {} { + set statementSeq 0 + namespace eval Stmt {} + } + + # The 'close' method is simply an alternative syntax for destroying + # the connection. + + method close {} { + my destroy + } + + # The 'prepare' method creates a new statement against the connection, + # giving its constructor the current statement and the SQL code to + # prepare. It uses the 'statementClass' variable set by the constructor + # to get the class to instantiate. + + method prepare {sqlcode} { + return [my statementCreate Stmt::[incr statementSeq] [self] $sqlcode] + } + + # The 'statementCreate' method delegates to the constructor + # of the class specified by the 'statementClass' variable. It's + # intended for drivers designed before tdbc 1.0b10. Current ones + # should forward this method to the constructor directly. + + method statementCreate {name instance sqlcode} { + my variable statementClass + return [$statementClass create $name $instance $sqlcode] + } + + # Derived classes are expected to implement the 'prepareCall' method, + # and have it call 'prepare' as needed (or do something else and + # install the resulting statement) + + # The 'statements' method lists the statements active against this + # connection. + + method statements {} { + info commands Stmt::* + } + + # The 'resultsets' method lists the result sets active against this + # connection. + + method resultsets {} { + set retval {} + foreach statement [my statements] { + foreach resultset [$statement resultsets] { + lappend retval $resultset + } + } + return $retval + } + + # The 'transaction' method executes a block of Tcl code as an + # ACID transaction against the database. + + method transaction {script} { + my begintransaction + set status [catch {uplevel 1 $script} result options] + if {$status in {0 2 3 4}} { + set status2 [catch {my commit} result2 options2] + if {$status2 == 1} { + set status 1 + set result $result2 + set options $options2 + } + } + switch -exact -- $status { + 0 { + # do nothing + } + 2 - 3 - 4 { + set options [dict merge {-level 1} $options[set options {}]] + dict incr options -level + } + default { + my rollback + } + } + return -options $options $result + } + + # The 'allrows' method prepares a statement, then executes it with + # a given set of substituents, returning a list of all the rows + # that the statement returns. Optionally, it stores the names of + # the columns in '-columnsvariable'. + # Usage: + # $db allrows ?-as lists|dicts? ?-columnsvariable varName? ?--? + # sql ?dictionary? + + method allrows args { + + variable ::tdbc::generalError + + # Grab keyword-value parameters + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + + # Check postitional parameters + + set cmd [list [self] prepare] + if {[llength $args] == 1} { + set sqlcode [lindex $args 0] + } elseif {[llength $args] == 2} { + lassign $args sqlcode dict + } else { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? sqlcode ?dictionary?" + } + lappend cmd $sqlcode + + # Prepare the statement + + set stmt [uplevel 1 $cmd] + + # Delegate to the statement to accumulate the results + + set cmd [list $stmt allrows {*}$opts --] + if {[info exists dict]} { + lappend cmd $dict + } + set status [catch { + uplevel 1 $cmd + } result options] + + # Destroy the statement + + catch { + $stmt close + } + + return -options $options $result + } + + # The 'foreach' method prepares a statement, then executes it with + # a supplied set of substituents. For each row of the result, + # it sets a variable to the row and invokes a script in the caller's + # scope. + # + # Usage: + # $db foreach ?-as lists|dicts? ?-columnsVariable varName? ?--? + # varName sql ?dictionary? script + + method foreach args { + + variable ::tdbc::generalError + + # Grab keyword-value parameters + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + + # Check postitional parameters + + set cmd [list [self] prepare] + if {[llength $args] == 3} { + lassign $args varname sqlcode script + } elseif {[llength $args] == 4} { + lassign $args varname sqlcode dict script + } else { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? varname sqlcode ?dictionary? script" + } + lappend cmd $sqlcode + + # Prepare the statement + + set stmt [uplevel 1 $cmd] + + # Delegate to the statement to iterate over the results + + set cmd [list $stmt foreach {*}$opts -- $varname] + if {[info exists dict]} { + lappend cmd $dict + } + lappend cmd $script + set status [catch { + uplevel 1 $cmd + } result options] + + # Destroy the statement + + catch { + $stmt close + } + + # Adjust return level in the case that the script [return]s + + if {$status == 2} { + set options [dict merge {-level 1} $options[set options {}]] + dict incr options -level + } + return -options $options $result + } + + # The 'BuildPrimaryKeysStatement' method builds a SQL statement to + # retrieve the primary keys from a database. (It executes once the + # first time the 'primaryKeys' method is executed, and retains the + # prepared statement for reuse.) + + method BuildPrimaryKeysStatement {} { + + # On some databases, CONSTRAINT_CATALOG is always NULL and + # JOINing to it fails. Check for this case and include that + # JOIN only if catalog names are supplied. + + set catalogClause {} + if {[lindex [set count [my allrows -as lists { + SELECT COUNT(*) + FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS + WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} { + set catalogClause \ + {AND xtable.CONSTRAINT_CATALOG = xcolumn.CONSTRAINT_CATALOG} + } + set primaryKeysStatement [my prepare " + SELECT xtable.TABLE_SCHEMA AS \"tableSchema\", + xtable.TABLE_NAME AS \"tableName\", + xtable.CONSTRAINT_CATALOG AS \"constraintCatalog\", + xtable.CONSTRAINT_SCHEMA AS \"constraintSchema\", + xtable.CONSTRAINT_NAME AS \"constraintName\", + xcolumn.COLUMN_NAME AS \"columnName\", + xcolumn.ORDINAL_POSITION AS \"ordinalPosition\" + FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS xtable + INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE xcolumn + ON xtable.CONSTRAINT_SCHEMA = xcolumn.CONSTRAINT_SCHEMA + AND xtable.TABLE_NAME = xcolumn.TABLE_NAME + AND xtable.CONSTRAINT_NAME = xcolumn.CONSTRAINT_NAME + $catalogClause + WHERE xtable.TABLE_NAME = :tableName + AND xtable.CONSTRAINT_TYPE = 'PRIMARY KEY' + "] + } + + # The default implementation of the 'primarykeys' method uses the + # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases + # that might not have INFORMATION_SCHEMA must overload this method. + + method primarykeys {tableName} { + if {![info exists primaryKeysStatement]} { + my BuildPrimaryKeysStatement + } + tailcall $primaryKeysStatement allrows [list tableName $tableName] + } + + # The 'BuildForeignKeysStatements' method builds a SQL statement to + # retrieve the foreign keys from a database. (It executes once the + # first time the 'foreignKeys' method is executed, and retains the + # prepared statements for reuse.) + + method BuildForeignKeysStatement {} { + + # On some databases, CONSTRAINT_CATALOG is always NULL and + # JOINing to it fails. Check for this case and include that + # JOIN only if catalog names are supplied. + + set catalogClause1 {} + set catalogClause2 {} + if {[lindex [set count [my allrows -as lists { + SELECT COUNT(*) + FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS + WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} { + set catalogClause1 \ + {AND fkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG} + set catalogClause2 \ + {AND pkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG} + } + + foreach {exists1 clause1} { + 0 {} + 1 { AND pkc.TABLE_NAME = :primary} + } { + foreach {exists2 clause2} { + 0 {} + 1 { AND fkc.TABLE_NAME = :foreign} + } { + set stmt [my prepare " + SELECT rc.CONSTRAINT_CATALOG AS \"foreignConstraintCatalog\", + rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\", + rc.CONSTRAINT_NAME AS \"foreignConstraintName\", + rc.UNIQUE_CONSTRAINT_CATALOG + AS \"primaryConstraintCatalog\", + rc.UNIQUE_CONSTRAINT_SCHEMA AS \"primaryConstraintSchema\", + rc.UNIQUE_CONSTRAINT_NAME AS \"primaryConstraintName\", + rc.UPDATE_RULE AS \"updateAction\", + rc.DELETE_RULE AS \"deleteAction\", + pkc.TABLE_CATALOG AS \"primaryCatalog\", + pkc.TABLE_SCHEMA AS \"primarySchema\", + pkc.TABLE_NAME AS \"primaryTable\", + pkc.COLUMN_NAME AS \"primaryColumn\", + fkc.TABLE_CATALOG AS \"foreignCatalog\", + fkc.TABLE_SCHEMA AS \"foreignSchema\", + fkc.TABLE_NAME AS \"foreignTable\", + fkc.COLUMN_NAME AS \"foreignColumn\", + pkc.ORDINAL_POSITION AS \"ordinalPosition\" + FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc + INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc + ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME + AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA + $catalogClause1 + INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE pkc + ON pkc.CONSTRAINT_NAME = rc.UNIQUE_CONSTRAINT_NAME + AND pkc.CONSTRAINT_SCHEMA = rc.UNIQUE_CONSTRAINT_SCHEMA + $catalogClause2 + AND pkc.ORDINAL_POSITION = fkc.ORDINAL_POSITION + WHERE 1=1 + $clause1 + $clause2 + ORDER BY \"foreignConstraintCatalog\", \"foreignConstraintSchema\", \"foreignConstraintName\", \"ordinalPosition\" +"] + dict set foreignKeysStatement $exists1 $exists2 $stmt + } + } + } + + # The default implementation of the 'foreignkeys' method uses the + # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases + # that might not have INFORMATION_SCHEMA must overload this method. + + 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 + } + + # Build the statements that query foreign keys. There are four + # of them, one for each combination of whether -primary + # and -foreign is specified. + + if {![info exists foreignKeysStatement]} { + my BuildForeignKeysStatement + } + set stmt [dict get $foreignKeysStatement \ + [dict exists $argdict primary] \ + [dict exists $argdict foreign]] + tailcall $stmt allrows $argdict + } + + # Derived classes are expected to implement the 'begintransaction', + # 'commit', and 'rollback' methods. + + # Derived classes are expected to implement 'tables' and 'columns' method. + +} + +#------------------------------------------------------------------------------ +# +# Class: tdbc::statement +# +# Class that represents a SQL statement in a generic database +# +#------------------------------------------------------------------------------ + +oo::class create tdbc::statement { + + # resultSetSeq is the sequence number of the last result set created. + # resultSetClass is the name of the class that implements the 'resultset' + # API. + + variable resultSetClass resultSetSeq + + # The base class constructor accepts no arguments. It initializes + # the machinery for tracking the ownership of result sets. The derived + # constructor is expected to invoke the base constructor, and to + # set a variable 'resultSetClass' to the fully-qualified name of the + # class that represents result sets. + + constructor {} { + set resultSetSeq 0 + namespace eval ResultSet {} + } + + # The 'execute' method on a statement runs the statement with + # a particular set of substituted variables. It actually works + # by creating the result set object and letting that objects + # constructor do the work of running the statement. The creation + # is wrapped in an [uplevel] call because the substitution proces + # may need to access variables in the caller's scope. + + # WORKAROUND: Take out the '0 &&' from the next line when + # Bug 2649975 is fixed + if {0 && [package vsatisfies [package provide Tcl] 8.6]} { + method execute args { + tailcall my resultSetCreate \ + [namespace current]::ResultSet::[incr resultSetSeq] \ + [self] {*}$args + } + } else { + method execute args { + return \ + [uplevel 1 \ + [list \ + [self] resultSetCreate \ + [namespace current]::ResultSet::[incr resultSetSeq] \ + [self] {*}$args]] + } + } + + # The 'ResultSetCreate' method is expected to be a forward to the + # appropriate result set constructor. If it's missing, the driver must + # have been designed for tdbc 1.0b9 and earlier, and the 'resultSetClass' + # variable holds the class name. + + method resultSetCreate {name instance args} { + return [uplevel 1 [list $resultSetClass create \ + $name $instance {*}$args]] + } + + # The 'resultsets' method returns a list of result sets produced by + # the current statement + + method resultsets {} { + info commands ResultSet::* + } + + # The 'allrows' method executes a statement with a given set of + # substituents, and returns a list of all the rows that the statement + # returns. Optionally, it stores the names of columns in + # '-columnsvariable'. + # + # Usage: + # $statement allrows ?-as lists|dicts? ?-columnsvariable varName? ?--? + # ?dictionary? + + + method allrows args { + + variable ::tdbc::generalError + + # Grab keyword-value parameters + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + + # Check postitional parameters + + set cmd [list [self] execute] + if {[llength $args] == 0} { + # do nothing + } elseif {[llength $args] == 1} { + lappend cmd [lindex $args 0] + } else { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? ?dictionary?" + } + + # Get the result set + + set resultSet [uplevel 1 $cmd] + + # Delegate to the result set's [allrows] method to accumulate + # the rows of the result. + + set cmd [list $resultSet allrows {*}$opts] + set status [catch { + uplevel 1 $cmd + } result options] + + # Destroy the result set + + catch { + rename $resultSet {} + } + + # Adjust return level in the case that the script [return]s + + if {$status == 2} { + set options [dict merge {-level 1} $options[set options {}]] + dict incr options -level + } + return -options $options $result + } + + # The 'foreach' method executes a statement with a given set of + # substituents. It runs the supplied script, substituting the supplied + # named variable. Optionally, it stores the names of columns in + # '-columnsvariable'. + # + # Usage: + # $statement foreach ?-as lists|dicts? ?-columnsvariable varName? ?--? + # variableName ?dictionary? script + + method foreach args { + + variable ::tdbc::generalError + + # Grab keyword-value parameters + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + + # Check positional parameters + + set cmd [list [self] execute] + if {[llength $args] == 2} { + lassign $args varname script + } elseif {[llength $args] == 3} { + lassign $args varname dict script + lappend cmd $dict + } else { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? varName ?dictionary? script" + } + + # Get the result set + + set resultSet [uplevel 1 $cmd] + + # Delegate to the result set's [foreach] method to evaluate + # the script for each row of the result. + + set cmd [list $resultSet foreach {*}$opts -- $varname $script] + set status [catch { + uplevel 1 $cmd + } result options] + + # Destroy the result set + + catch { + rename $resultSet {} + } + + # Adjust return level in the case that the script [return]s + + if {$status == 2} { + set options [dict merge {-level 1} $options[set options {}]] + dict incr options -level + } + return -options $options $result + } + + # The 'close' method is syntactic sugar for invoking the destructor + + method close {} { + my destroy + } + + # Derived classes are expected to implement their own constructors, + # plus the following methods: + + # paramtype paramName ?direction? type ?scale ?precision?? + # Declares the type of a parameter in the statement + +} + +#------------------------------------------------------------------------------ +# +# Class: tdbc::resultset +# +# Class that represents a result set in a generic database. +# +#------------------------------------------------------------------------------ + +oo::class create tdbc::resultset { + + constructor {} { } + + # The 'allrows' method returns a list of all rows that a given + # result set returns. + + method allrows args { + + variable ::tdbc::generalError + + # Parse args + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + if {[llength $args] != 0} { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? varName script" + } + + # Do -columnsvariable if requested + + if {[dict exists $opts -columnsvariable]} { + upvar 1 [dict get $opts -columnsvariable] columns + } + + # Assemble the results + + if {[dict get $opts -as] eq {lists}} { + set delegate nextlist + } else { + set delegate nextdict + } + set results [list] + while {1} { + set columns [my columns] + while {[my $delegate row]} { + lappend results $row + } + if {![my nextresults]} break + } + return $results + + } + + # The 'foreach' method runs a script on each row from a result set. + + method foreach args { + + variable ::tdbc::generalError + + # Grab keyword-value parameters + + set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts] + + # Check positional parameters + + if {[llength $args] != 2} { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? varName script" + } + + # Do -columnsvariable if requested + + if {[dict exists $opts -columnsvariable]} { + upvar 1 [dict get $opts -columnsvariable] columns + } + + # Iterate over the groups of results + while {1} { + + # Export column names to caller + + set columns [my columns] + + # Iterate over the rows of one group of results + + upvar 1 [lindex $args 0] row + if {[dict get $opts -as] eq {lists}} { + set delegate nextlist + } else { + set delegate nextdict + } + while {[my $delegate row]} { + set status [catch { + uplevel 1 [lindex $args 1] + } result options] + switch -exact -- $status { + 0 - 4 { # OK or CONTINUE + } + 2 { # RETURN + set options \ + [dict merge {-level 1} $options[set options {}]] + dict incr options -level + return -options $options $result + } + 3 { # BREAK + set broken 1 + break + } + default { # ERROR or unknown status + return -options $options $result + } + } + } + + # Advance to the next group of results if there is one + + if {[info exists broken] || ![my nextresults]} { + break + } + } + + return + } + + + # The 'nextrow' method retrieves a row in the form of either + # a list or a dictionary. + + method nextrow {args} { + + variable ::tdbc::generalError + + set opts [dict create -as dicts] + set i 0 + + # Munch keyword options off the front of the command arguments + + foreach {key value} $args { + if {[string index $key 0] eq {-}} { + switch -regexp -- $key { + -as? { + dict set opts -as $value + } + -- { + incr i + break + } + default { + set errorcode $generalError + lappend errorcode badOption $key + return -code error -errorcode $errorcode \ + "bad option \"$key\":\ + must be -as or -columnsvariable" + } + } + } else { + break + } + incr i 2 + } + + set args [lrange $args $i end] + if {[llength $args] != 1} { + set errorcode $generalError + lappend errorcode wrongNumArgs + return -code error -errorcode $errorcode \ + "wrong # args: should be [lrange [info level 0] 0 1]\ + ?-option value?... ?--? varName" + } + upvar 1 [lindex $args 0] row + if {[dict get $opts -as] eq {lists}} { + set delegate nextlist + } else { + set delegate nextdict + } + return [my $delegate row] + } + + # Derived classes must override 'nextresults' if a single + # statement execution can yield multiple sets of results + + method nextresults {} { + return 0 + } + + # Derived classes must override 'outputparams' if statements can + # have output parameters. + + method outputparams {} { + return {} + } + + # The 'close' method is syntactic sugar for destroying the result set. + + method close {} { + my destroy + } + + # Derived classes are expected to implement the following methods: + + # constructor and destructor. + # Constructor accepts a statement and an optional + # a dictionary of substituted parameters and + # executes the statement against the database. If + # the dictionary is not supplied, then the default + # is to get params from variables in the caller's scope). + # columns + # -- Returns a list of the names of the columns in the result. + # nextdict variableName + # -- Stores the next row of the result set in the given variable + # in caller's scope, in the form of a dictionary that maps + # column names to values. + # nextlist variableName + # -- Stores the next row of the result set in the given variable + # in caller's scope, in the form of a list of cells. + # rowcount + # -- Returns a count of rows affected by the statement, or -1 + # if the count of rows has not been determined. + +}
\ No newline at end of file diff --git a/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc111.dll b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc111.dll Binary files differnew file mode 100644 index 00000000000..b46a539996e --- /dev/null +++ b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbc111.dll diff --git a/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbcConfig.sh b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbcConfig.sh new file mode 100644 index 00000000000..fb79bb63e46 --- /dev/null +++ b/Master/tlpkg/tltcl/lib/tdbc1.1.1/tdbcConfig.sh @@ -0,0 +1,81 @@ +# tdbcConfig.sh -- +# +# This shell script (for sh) is generated automatically by TDBC'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 TDBC 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. +# +# RCS: @(#) $Id$ + +# TDBC's version number +tdbc_VERSION=1.1.1 +TDBC_VERSION=1.1.1 + +# Name of the TDBC library - may be either a static or shared library +tdbc_LIB_FILE=tdbc111.dll +TDBC_LIB_FILE=tdbc111.dll + +# String to pass to the linker to pick up the TDBC library from its build dir +tdbc_BUILD_LIB_SPEC="-L/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1 -ltdbc111" +TDBC_BUILD_LIB_SPEC="-L/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1 -ltdbc111" + +# String to pass to the linker to pick up the TDBC library from its installed +# dir. +tdbc_LIB_SPEC="-L/tmp/siepo/tcltk/lib/tdbc1.1.1 -ltdbc111" +TDBC_LIB_SPEC="-L/tmp/siepo/tcltk/lib/tdbc1.1.1 -ltdbc111" + +# Name of the TBDC stub library +tdbc_STUB_LIB_FILE="libtdbcstub111.a" +TDBC_STUB_LIB_FILE="libtdbcstub111.a" + +# String to pass to the linker to pick up the TDBC stub library from its +# build directory +tdbc_BUILD_STUB_LIB_SPEC="-L/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1 -ltdbcstub111" +TDBC_BUILD_STUB_LIB_SPEC="-L/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1 -ltdbcstub111" + +# String to pass to the linker to pick up the TDBC stub library from its +# installed directory +tdbc_STUB_LIB_SPEC="-L/tmp/siepo/tcltk/lib/tdbc1.1.1 -ltdbcstub111" +TDBC_STUB_LIB_SPEC="-L/tmp/siepo/tcltk/lib/tdbc1.1.1 -ltdbcstub111" + +# Path name of the TDBC stub library in its build directory +tdbc_BUILD_STUB_LIB_PATH="/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1/libtdbcstub111.a" +TDBC_BUILD_STUB_LIB_PATH="/tmp/siepo/tcl8.6.10/win/pkgs/tdbc1.1.1/libtdbcstub111.a" + +# Path name of the TDBC stub library in its installed directory +tdbc_STUB_LIB_PATH="/tmp/siepo/tcltk/lib/tdbc1.1.1/libtdbcstub111.a" +TDBC_STUB_LIB_PATH="/tmp/siepo/tcltk/lib/tdbc1.1.1/libtdbcstub111.a" + +# Location of the top-level source directories from which TDBC was built. +# This is the directory that contains doc/, generic/ and so on. If TDBC +# was compiled in a directory other than the source directory, this still +# points to the location of the sources, not the location where TDBC was +# compiled. +tdbc_SRC_DIR="/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1" +TDBC_SRC_DIR="/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1" + +# String to pass to the compiler so that an extension can find installed TDBC +# headers +tdbc_INCLUDE_SPEC="-I/tmp/siepo/tcltk/include" +TDBC_INCLUDE_SPEC="-I/tmp/siepo/tcltk/include" + +# String to pass to the compiler so that an extension can find TDBC headers +# in the source directory +tdbc_BUILD_INCLUDE_SPEC="-I/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1/generic" +TDBC_BUILD_INCLUDE_SPEC="-I/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1/generic" + +# Path name where .tcl files in the tdbc package appear at run time. +tdbc_LIBRARY_PATH="/tmp/siepo/tcltk/lib/tdbc1.1.1" +TDBC_LIBRARY_PATH="/tmp/siepo/tcltk/lib/tdbc1.1.1" + +# Path name where .tcl files in the tdbc package appear at build time. +tdbc_BUILD_LIBRARY_PATH="/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1/library" +TDBC_BUILD_LIBRARY_PATH="/tmp/siepo/tcl8.6.10/pkgs/tdbc1.1.1/library" + +# Additional flags that must be passed to the C compiler to use tdbc +tdbc_CFLAGS= +TDBC_CFLAGS= + |