922 lines
26 KiB
Tcl
922 lines
26 KiB
Tcl
|
# 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.
|
|||
|
|
|
|||
|
|
}
|