summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/tdbc.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/tdbc.tcl')
-rw-r--r--systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/tdbc.tcl922
1 files changed, 922 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/tdbc.tcl b/systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/tdbc.tcl
new file mode 100644
index 0000000000..f536131e80
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tltcl/lib/tdbc1.1.3/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