summaryrefslogtreecommitdiffstats
path: root/tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl')
-rw-r--r--tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl922
1 files changed, 0 insertions, 922 deletions
diff --git a/tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl b/tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl
deleted file mode 100644
index 2a167cb..0000000
--- a/tcl8.6/pkgs/tdbc1.1.0/library/tdbc.tcl
+++ /dev/null
@@ -1,922 +0,0 @@
-# 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