Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tdbc1.1.5/tdbc.tcl @ 68:5028fdace37b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
planemo upload commit 2e9511a184a1ca667c7be0c6321a36dc4e3d116d
author jpayne
date Tue, 18 Mar 2025 16:23:26 -0400
parents
children
rev   line source
jpayne@68 1 # tdbc.tcl --
jpayne@68 2 #
jpayne@68 3 # Definitions of base classes from which TDBC drivers' connections,
jpayne@68 4 # statements and result sets may inherit.
jpayne@68 5 #
jpayne@68 6 # Copyright (c) 2008 by Kevin B. Kenny
jpayne@68 7 # See the file "license.terms" for information on usage and redistribution
jpayne@68 8 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
jpayne@68 9 #
jpayne@68 10 # RCS: @(#) $Id$
jpayne@68 11 #
jpayne@68 12 #------------------------------------------------------------------------------
jpayne@68 13
jpayne@68 14 package require TclOO
jpayne@68 15
jpayne@68 16 namespace eval ::tdbc {
jpayne@68 17 namespace export connection statement resultset
jpayne@68 18 variable generalError [list TDBC GENERAL_ERROR HY000 {}]
jpayne@68 19 }
jpayne@68 20
jpayne@68 21 #------------------------------------------------------------------------------
jpayne@68 22 #
jpayne@68 23 # tdbc::ParseConvenienceArgs --
jpayne@68 24 #
jpayne@68 25 # Parse the convenience arguments to a TDBC 'execute',
jpayne@68 26 # 'executewithdictionary', or 'foreach' call.
jpayne@68 27 #
jpayne@68 28 # Parameters:
jpayne@68 29 # argv - Arguments to the call
jpayne@68 30 # optsVar -- Name of a variable in caller's scope that will receive
jpayne@68 31 # a dictionary of the supplied options
jpayne@68 32 #
jpayne@68 33 # Results:
jpayne@68 34 # Returns any args remaining after parsing the options.
jpayne@68 35 #
jpayne@68 36 # Side effects:
jpayne@68 37 # Sets the 'opts' dictionary to the options.
jpayne@68 38 #
jpayne@68 39 #------------------------------------------------------------------------------
jpayne@68 40
jpayne@68 41 proc tdbc::ParseConvenienceArgs {argv optsVar} {
jpayne@68 42
jpayne@68 43 variable generalError
jpayne@68 44 upvar 1 $optsVar opts
jpayne@68 45
jpayne@68 46 set opts [dict create -as dicts]
jpayne@68 47 set i 0
jpayne@68 48
jpayne@68 49 # Munch keyword options off the front of the command arguments
jpayne@68 50
jpayne@68 51 foreach {key value} $argv {
jpayne@68 52 if {[string index $key 0] eq {-}} {
jpayne@68 53 switch -regexp -- $key {
jpayne@68 54 -as? {
jpayne@68 55 if {$value ne {dicts} && $value ne {lists}} {
jpayne@68 56 set errorcode $generalError
jpayne@68 57 lappend errorcode badVarType $value
jpayne@68 58 return -code error \
jpayne@68 59 -errorcode $errorcode \
jpayne@68 60 "bad variable type \"$value\":\
jpayne@68 61 must be lists or dicts"
jpayne@68 62 }
jpayne@68 63 dict set opts -as $value
jpayne@68 64 }
jpayne@68 65 -c(?:o(?:l(?:u(?:m(?:n(?:s(?:v(?:a(?:r(?:i(?:a(?:b(?:le?)?)?)?)?)?)?)?)?)?)?)?)?) {
jpayne@68 66 dict set opts -columnsvariable $value
jpayne@68 67 }
jpayne@68 68 -- {
jpayne@68 69 incr i
jpayne@68 70 break
jpayne@68 71 }
jpayne@68 72 default {
jpayne@68 73 set errorcode $generalError
jpayne@68 74 lappend errorcode badOption $key
jpayne@68 75 return -code error \
jpayne@68 76 -errorcode $errorcode \
jpayne@68 77 "bad option \"$key\":\
jpayne@68 78 must be -as or -columnsvariable"
jpayne@68 79 }
jpayne@68 80 }
jpayne@68 81 } else {
jpayne@68 82 break
jpayne@68 83 }
jpayne@68 84 incr i 2
jpayne@68 85 }
jpayne@68 86
jpayne@68 87 return [lrange $argv[set argv {}] $i end]
jpayne@68 88
jpayne@68 89 }
jpayne@68 90
jpayne@68 91
jpayne@68 92
jpayne@68 93 #------------------------------------------------------------------------------
jpayne@68 94 #
jpayne@68 95 # tdbc::connection --
jpayne@68 96 #
jpayne@68 97 # Class that represents a generic connection to a database.
jpayne@68 98 #
jpayne@68 99 #-----------------------------------------------------------------------------
jpayne@68 100
jpayne@68 101 oo::class create ::tdbc::connection {
jpayne@68 102
jpayne@68 103 # statementSeq is the sequence number of the last statement created.
jpayne@68 104 # statementClass is the name of the class that implements the
jpayne@68 105 # 'statement' API.
jpayne@68 106 # primaryKeysStatement is the statement that queries primary keys
jpayne@68 107 # foreignKeysStatement is the statement that queries foreign keys
jpayne@68 108
jpayne@68 109 variable statementSeq primaryKeysStatement foreignKeysStatement
jpayne@68 110
jpayne@68 111 # The base class constructor accepts no arguments. It sets up the
jpayne@68 112 # machinery to do the bookkeeping to keep track of what statements
jpayne@68 113 # are associated with the connection. The derived class constructor
jpayne@68 114 # is expected to set the variable, 'statementClass' to the name
jpayne@68 115 # of the class that represents statements, so that the 'prepare'
jpayne@68 116 # method can invoke it.
jpayne@68 117
jpayne@68 118 constructor {} {
jpayne@68 119 set statementSeq 0
jpayne@68 120 namespace eval Stmt {}
jpayne@68 121 }
jpayne@68 122
jpayne@68 123 # The 'close' method is simply an alternative syntax for destroying
jpayne@68 124 # the connection.
jpayne@68 125
jpayne@68 126 method close {} {
jpayne@68 127 my destroy
jpayne@68 128 }
jpayne@68 129
jpayne@68 130 # The 'prepare' method creates a new statement against the connection,
jpayne@68 131 # giving its constructor the current statement and the SQL code to
jpayne@68 132 # prepare. It uses the 'statementClass' variable set by the constructor
jpayne@68 133 # to get the class to instantiate.
jpayne@68 134
jpayne@68 135 method prepare {sqlcode} {
jpayne@68 136 return [my statementCreate Stmt::[incr statementSeq] [self] $sqlcode]
jpayne@68 137 }
jpayne@68 138
jpayne@68 139 # The 'statementCreate' method delegates to the constructor
jpayne@68 140 # of the class specified by the 'statementClass' variable. It's
jpayne@68 141 # intended for drivers designed before tdbc 1.0b10. Current ones
jpayne@68 142 # should forward this method to the constructor directly.
jpayne@68 143
jpayne@68 144 method statementCreate {name instance sqlcode} {
jpayne@68 145 my variable statementClass
jpayne@68 146 return [$statementClass create $name $instance $sqlcode]
jpayne@68 147 }
jpayne@68 148
jpayne@68 149 # Derived classes are expected to implement the 'prepareCall' method,
jpayne@68 150 # and have it call 'prepare' as needed (or do something else and
jpayne@68 151 # install the resulting statement)
jpayne@68 152
jpayne@68 153 # The 'statements' method lists the statements active against this
jpayne@68 154 # connection.
jpayne@68 155
jpayne@68 156 method statements {} {
jpayne@68 157 info commands Stmt::*
jpayne@68 158 }
jpayne@68 159
jpayne@68 160 # The 'resultsets' method lists the result sets active against this
jpayne@68 161 # connection.
jpayne@68 162
jpayne@68 163 method resultsets {} {
jpayne@68 164 set retval {}
jpayne@68 165 foreach statement [my statements] {
jpayne@68 166 foreach resultset [$statement resultsets] {
jpayne@68 167 lappend retval $resultset
jpayne@68 168 }
jpayne@68 169 }
jpayne@68 170 return $retval
jpayne@68 171 }
jpayne@68 172
jpayne@68 173 # The 'transaction' method executes a block of Tcl code as an
jpayne@68 174 # ACID transaction against the database.
jpayne@68 175
jpayne@68 176 method transaction {script} {
jpayne@68 177 my begintransaction
jpayne@68 178 set status [catch {uplevel 1 $script} result options]
jpayne@68 179 if {$status in {0 2 3 4}} {
jpayne@68 180 set status2 [catch {my commit} result2 options2]
jpayne@68 181 if {$status2 == 1} {
jpayne@68 182 set status 1
jpayne@68 183 set result $result2
jpayne@68 184 set options $options2
jpayne@68 185 }
jpayne@68 186 }
jpayne@68 187 switch -exact -- $status {
jpayne@68 188 0 {
jpayne@68 189 # do nothing
jpayne@68 190 }
jpayne@68 191 2 - 3 - 4 {
jpayne@68 192 set options [dict merge {-level 1} $options[set options {}]]
jpayne@68 193 dict incr options -level
jpayne@68 194 }
jpayne@68 195 default {
jpayne@68 196 my rollback
jpayne@68 197 }
jpayne@68 198 }
jpayne@68 199 return -options $options $result
jpayne@68 200 }
jpayne@68 201
jpayne@68 202 # The 'allrows' method prepares a statement, then executes it with
jpayne@68 203 # a given set of substituents, returning a list of all the rows
jpayne@68 204 # that the statement returns. Optionally, it stores the names of
jpayne@68 205 # the columns in '-columnsvariable'.
jpayne@68 206 # Usage:
jpayne@68 207 # $db allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
jpayne@68 208 # sql ?dictionary?
jpayne@68 209
jpayne@68 210 method allrows args {
jpayne@68 211
jpayne@68 212 variable ::tdbc::generalError
jpayne@68 213
jpayne@68 214 # Grab keyword-value parameters
jpayne@68 215
jpayne@68 216 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 217
jpayne@68 218 # Check postitional parameters
jpayne@68 219
jpayne@68 220 set cmd [list [self] prepare]
jpayne@68 221 if {[llength $args] == 1} {
jpayne@68 222 set sqlcode [lindex $args 0]
jpayne@68 223 } elseif {[llength $args] == 2} {
jpayne@68 224 lassign $args sqlcode dict
jpayne@68 225 } else {
jpayne@68 226 set errorcode $generalError
jpayne@68 227 lappend errorcode wrongNumArgs
jpayne@68 228 return -code error -errorcode $errorcode \
jpayne@68 229 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 230 ?-option value?... ?--? sqlcode ?dictionary?"
jpayne@68 231 }
jpayne@68 232 lappend cmd $sqlcode
jpayne@68 233
jpayne@68 234 # Prepare the statement
jpayne@68 235
jpayne@68 236 set stmt [uplevel 1 $cmd]
jpayne@68 237
jpayne@68 238 # Delegate to the statement to accumulate the results
jpayne@68 239
jpayne@68 240 set cmd [list $stmt allrows {*}$opts --]
jpayne@68 241 if {[info exists dict]} {
jpayne@68 242 lappend cmd $dict
jpayne@68 243 }
jpayne@68 244 set status [catch {
jpayne@68 245 uplevel 1 $cmd
jpayne@68 246 } result options]
jpayne@68 247
jpayne@68 248 # Destroy the statement
jpayne@68 249
jpayne@68 250 catch {
jpayne@68 251 $stmt close
jpayne@68 252 }
jpayne@68 253
jpayne@68 254 return -options $options $result
jpayne@68 255 }
jpayne@68 256
jpayne@68 257 # The 'foreach' method prepares a statement, then executes it with
jpayne@68 258 # a supplied set of substituents. For each row of the result,
jpayne@68 259 # it sets a variable to the row and invokes a script in the caller's
jpayne@68 260 # scope.
jpayne@68 261 #
jpayne@68 262 # Usage:
jpayne@68 263 # $db foreach ?-as lists|dicts? ?-columnsVariable varName? ?--?
jpayne@68 264 # varName sql ?dictionary? script
jpayne@68 265
jpayne@68 266 method foreach args {
jpayne@68 267
jpayne@68 268 variable ::tdbc::generalError
jpayne@68 269
jpayne@68 270 # Grab keyword-value parameters
jpayne@68 271
jpayne@68 272 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 273
jpayne@68 274 # Check postitional parameters
jpayne@68 275
jpayne@68 276 set cmd [list [self] prepare]
jpayne@68 277 if {[llength $args] == 3} {
jpayne@68 278 lassign $args varname sqlcode script
jpayne@68 279 } elseif {[llength $args] == 4} {
jpayne@68 280 lassign $args varname sqlcode dict script
jpayne@68 281 } else {
jpayne@68 282 set errorcode $generalError
jpayne@68 283 lappend errorcode wrongNumArgs
jpayne@68 284 return -code error -errorcode $errorcode \
jpayne@68 285 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 286 ?-option value?... ?--? varname sqlcode ?dictionary? script"
jpayne@68 287 }
jpayne@68 288 lappend cmd $sqlcode
jpayne@68 289
jpayne@68 290 # Prepare the statement
jpayne@68 291
jpayne@68 292 set stmt [uplevel 1 $cmd]
jpayne@68 293
jpayne@68 294 # Delegate to the statement to iterate over the results
jpayne@68 295
jpayne@68 296 set cmd [list $stmt foreach {*}$opts -- $varname]
jpayne@68 297 if {[info exists dict]} {
jpayne@68 298 lappend cmd $dict
jpayne@68 299 }
jpayne@68 300 lappend cmd $script
jpayne@68 301 set status [catch {
jpayne@68 302 uplevel 1 $cmd
jpayne@68 303 } result options]
jpayne@68 304
jpayne@68 305 # Destroy the statement
jpayne@68 306
jpayne@68 307 catch {
jpayne@68 308 $stmt close
jpayne@68 309 }
jpayne@68 310
jpayne@68 311 # Adjust return level in the case that the script [return]s
jpayne@68 312
jpayne@68 313 if {$status == 2} {
jpayne@68 314 set options [dict merge {-level 1} $options[set options {}]]
jpayne@68 315 dict incr options -level
jpayne@68 316 }
jpayne@68 317 return -options $options $result
jpayne@68 318 }
jpayne@68 319
jpayne@68 320 # The 'BuildPrimaryKeysStatement' method builds a SQL statement to
jpayne@68 321 # retrieve the primary keys from a database. (It executes once the
jpayne@68 322 # first time the 'primaryKeys' method is executed, and retains the
jpayne@68 323 # prepared statement for reuse.)
jpayne@68 324
jpayne@68 325 method BuildPrimaryKeysStatement {} {
jpayne@68 326
jpayne@68 327 # On some databases, CONSTRAINT_CATALOG is always NULL and
jpayne@68 328 # JOINing to it fails. Check for this case and include that
jpayne@68 329 # JOIN only if catalog names are supplied.
jpayne@68 330
jpayne@68 331 set catalogClause {}
jpayne@68 332 if {[lindex [set count [my allrows -as lists {
jpayne@68 333 SELECT COUNT(*)
jpayne@68 334 FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
jpayne@68 335 WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
jpayne@68 336 set catalogClause \
jpayne@68 337 {AND xtable.CONSTRAINT_CATALOG = xcolumn.CONSTRAINT_CATALOG}
jpayne@68 338 }
jpayne@68 339 set primaryKeysStatement [my prepare "
jpayne@68 340 SELECT xtable.TABLE_SCHEMA AS \"tableSchema\",
jpayne@68 341 xtable.TABLE_NAME AS \"tableName\",
jpayne@68 342 xtable.CONSTRAINT_CATALOG AS \"constraintCatalog\",
jpayne@68 343 xtable.CONSTRAINT_SCHEMA AS \"constraintSchema\",
jpayne@68 344 xtable.CONSTRAINT_NAME AS \"constraintName\",
jpayne@68 345 xcolumn.COLUMN_NAME AS \"columnName\",
jpayne@68 346 xcolumn.ORDINAL_POSITION AS \"ordinalPosition\"
jpayne@68 347 FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS xtable
jpayne@68 348 INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE xcolumn
jpayne@68 349 ON xtable.CONSTRAINT_SCHEMA = xcolumn.CONSTRAINT_SCHEMA
jpayne@68 350 AND xtable.TABLE_NAME = xcolumn.TABLE_NAME
jpayne@68 351 AND xtable.CONSTRAINT_NAME = xcolumn.CONSTRAINT_NAME
jpayne@68 352 $catalogClause
jpayne@68 353 WHERE xtable.TABLE_NAME = :tableName
jpayne@68 354 AND xtable.CONSTRAINT_TYPE = 'PRIMARY KEY'
jpayne@68 355 "]
jpayne@68 356 }
jpayne@68 357
jpayne@68 358 # The default implementation of the 'primarykeys' method uses the
jpayne@68 359 # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
jpayne@68 360 # that might not have INFORMATION_SCHEMA must overload this method.
jpayne@68 361
jpayne@68 362 method primarykeys {tableName} {
jpayne@68 363 if {![info exists primaryKeysStatement]} {
jpayne@68 364 my BuildPrimaryKeysStatement
jpayne@68 365 }
jpayne@68 366 tailcall $primaryKeysStatement allrows [list tableName $tableName]
jpayne@68 367 }
jpayne@68 368
jpayne@68 369 # The 'BuildForeignKeysStatements' method builds a SQL statement to
jpayne@68 370 # retrieve the foreign keys from a database. (It executes once the
jpayne@68 371 # first time the 'foreignKeys' method is executed, and retains the
jpayne@68 372 # prepared statements for reuse.)
jpayne@68 373
jpayne@68 374 method BuildForeignKeysStatement {} {
jpayne@68 375
jpayne@68 376 # On some databases, CONSTRAINT_CATALOG is always NULL and
jpayne@68 377 # JOINing to it fails. Check for this case and include that
jpayne@68 378 # JOIN only if catalog names are supplied.
jpayne@68 379
jpayne@68 380 set catalogClause1 {}
jpayne@68 381 set catalogClause2 {}
jpayne@68 382 if {[lindex [set count [my allrows -as lists {
jpayne@68 383 SELECT COUNT(*)
jpayne@68 384 FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
jpayne@68 385 WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
jpayne@68 386 set catalogClause1 \
jpayne@68 387 {AND fkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
jpayne@68 388 set catalogClause2 \
jpayne@68 389 {AND pkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
jpayne@68 390 }
jpayne@68 391
jpayne@68 392 foreach {exists1 clause1} {
jpayne@68 393 0 {}
jpayne@68 394 1 { AND pkc.TABLE_NAME = :primary}
jpayne@68 395 } {
jpayne@68 396 foreach {exists2 clause2} {
jpayne@68 397 0 {}
jpayne@68 398 1 { AND fkc.TABLE_NAME = :foreign}
jpayne@68 399 } {
jpayne@68 400 set stmt [my prepare "
jpayne@68 401 SELECT rc.CONSTRAINT_CATALOG AS \"foreignConstraintCatalog\",
jpayne@68 402 rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
jpayne@68 403 rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
jpayne@68 404 rc.UNIQUE_CONSTRAINT_CATALOG
jpayne@68 405 AS \"primaryConstraintCatalog\",
jpayne@68 406 rc.UNIQUE_CONSTRAINT_SCHEMA AS \"primaryConstraintSchema\",
jpayne@68 407 rc.UNIQUE_CONSTRAINT_NAME AS \"primaryConstraintName\",
jpayne@68 408 rc.UPDATE_RULE AS \"updateAction\",
jpayne@68 409 rc.DELETE_RULE AS \"deleteAction\",
jpayne@68 410 pkc.TABLE_CATALOG AS \"primaryCatalog\",
jpayne@68 411 pkc.TABLE_SCHEMA AS \"primarySchema\",
jpayne@68 412 pkc.TABLE_NAME AS \"primaryTable\",
jpayne@68 413 pkc.COLUMN_NAME AS \"primaryColumn\",
jpayne@68 414 fkc.TABLE_CATALOG AS \"foreignCatalog\",
jpayne@68 415 fkc.TABLE_SCHEMA AS \"foreignSchema\",
jpayne@68 416 fkc.TABLE_NAME AS \"foreignTable\",
jpayne@68 417 fkc.COLUMN_NAME AS \"foreignColumn\",
jpayne@68 418 pkc.ORDINAL_POSITION AS \"ordinalPosition\"
jpayne@68 419 FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
jpayne@68 420 INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
jpayne@68 421 ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
jpayne@68 422 AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
jpayne@68 423 $catalogClause1
jpayne@68 424 INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE pkc
jpayne@68 425 ON pkc.CONSTRAINT_NAME = rc.UNIQUE_CONSTRAINT_NAME
jpayne@68 426 AND pkc.CONSTRAINT_SCHEMA = rc.UNIQUE_CONSTRAINT_SCHEMA
jpayne@68 427 $catalogClause2
jpayne@68 428 AND pkc.ORDINAL_POSITION = fkc.ORDINAL_POSITION
jpayne@68 429 WHERE 1=1
jpayne@68 430 $clause1
jpayne@68 431 $clause2
jpayne@68 432 ORDER BY \"foreignConstraintCatalog\", \"foreignConstraintSchema\", \"foreignConstraintName\", \"ordinalPosition\"
jpayne@68 433 "]
jpayne@68 434 dict set foreignKeysStatement $exists1 $exists2 $stmt
jpayne@68 435 }
jpayne@68 436 }
jpayne@68 437 }
jpayne@68 438
jpayne@68 439 # The default implementation of the 'foreignkeys' method uses the
jpayne@68 440 # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
jpayne@68 441 # that might not have INFORMATION_SCHEMA must overload this method.
jpayne@68 442
jpayne@68 443 method foreignkeys {args} {
jpayne@68 444
jpayne@68 445 variable ::tdbc::generalError
jpayne@68 446
jpayne@68 447 # Check arguments
jpayne@68 448
jpayne@68 449 set argdict {}
jpayne@68 450 if {[llength $args] % 2 != 0} {
jpayne@68 451 set errorcode $generalError
jpayne@68 452 lappend errorcode wrongNumArgs
jpayne@68 453 return -code error -errorcode $errorcode \
jpayne@68 454 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 455 ?-option value?..."
jpayne@68 456 }
jpayne@68 457 foreach {key value} $args {
jpayne@68 458 if {$key ni {-primary -foreign}} {
jpayne@68 459 set errorcode $generalError
jpayne@68 460 lappend errorcode badOption
jpayne@68 461 return -code error -errorcode $errorcode \
jpayne@68 462 "bad option \"$key\", must be -primary or -foreign"
jpayne@68 463 }
jpayne@68 464 set key [string range $key 1 end]
jpayne@68 465 if {[dict exists $argdict $key]} {
jpayne@68 466 set errorcode $generalError
jpayne@68 467 lappend errorcode dupOption
jpayne@68 468 return -code error -errorcode $errorcode \
jpayne@68 469 "duplicate option \"$key\" supplied"
jpayne@68 470 }
jpayne@68 471 dict set argdict $key $value
jpayne@68 472 }
jpayne@68 473
jpayne@68 474 # Build the statements that query foreign keys. There are four
jpayne@68 475 # of them, one for each combination of whether -primary
jpayne@68 476 # and -foreign is specified.
jpayne@68 477
jpayne@68 478 if {![info exists foreignKeysStatement]} {
jpayne@68 479 my BuildForeignKeysStatement
jpayne@68 480 }
jpayne@68 481 set stmt [dict get $foreignKeysStatement \
jpayne@68 482 [dict exists $argdict primary] \
jpayne@68 483 [dict exists $argdict foreign]]
jpayne@68 484 tailcall $stmt allrows $argdict
jpayne@68 485 }
jpayne@68 486
jpayne@68 487 # Derived classes are expected to implement the 'begintransaction',
jpayne@68 488 # 'commit', and 'rollback' methods.
jpayne@68 489
jpayne@68 490 # Derived classes are expected to implement 'tables' and 'columns' method.
jpayne@68 491
jpayne@68 492 }
jpayne@68 493
jpayne@68 494 #------------------------------------------------------------------------------
jpayne@68 495 #
jpayne@68 496 # Class: tdbc::statement
jpayne@68 497 #
jpayne@68 498 # Class that represents a SQL statement in a generic database
jpayne@68 499 #
jpayne@68 500 #------------------------------------------------------------------------------
jpayne@68 501
jpayne@68 502 oo::class create tdbc::statement {
jpayne@68 503
jpayne@68 504 # resultSetSeq is the sequence number of the last result set created.
jpayne@68 505 # resultSetClass is the name of the class that implements the 'resultset'
jpayne@68 506 # API.
jpayne@68 507
jpayne@68 508 variable resultSetClass resultSetSeq
jpayne@68 509
jpayne@68 510 # The base class constructor accepts no arguments. It initializes
jpayne@68 511 # the machinery for tracking the ownership of result sets. The derived
jpayne@68 512 # constructor is expected to invoke the base constructor, and to
jpayne@68 513 # set a variable 'resultSetClass' to the fully-qualified name of the
jpayne@68 514 # class that represents result sets.
jpayne@68 515
jpayne@68 516 constructor {} {
jpayne@68 517 set resultSetSeq 0
jpayne@68 518 namespace eval ResultSet {}
jpayne@68 519 }
jpayne@68 520
jpayne@68 521 # The 'execute' method on a statement runs the statement with
jpayne@68 522 # a particular set of substituted variables. It actually works
jpayne@68 523 # by creating the result set object and letting that objects
jpayne@68 524 # constructor do the work of running the statement. The creation
jpayne@68 525 # is wrapped in an [uplevel] call because the substitution proces
jpayne@68 526 # may need to access variables in the caller's scope.
jpayne@68 527
jpayne@68 528 # WORKAROUND: Take out the '0 &&' from the next line when
jpayne@68 529 # Bug 2649975 is fixed
jpayne@68 530 if {0 && [package vsatisfies [package provide Tcl] 8.6]} {
jpayne@68 531 method execute args {
jpayne@68 532 tailcall my resultSetCreate \
jpayne@68 533 [namespace current]::ResultSet::[incr resultSetSeq] \
jpayne@68 534 [self] {*}$args
jpayne@68 535 }
jpayne@68 536 } else {
jpayne@68 537 method execute args {
jpayne@68 538 return \
jpayne@68 539 [uplevel 1 \
jpayne@68 540 [list \
jpayne@68 541 [self] resultSetCreate \
jpayne@68 542 [namespace current]::ResultSet::[incr resultSetSeq] \
jpayne@68 543 [self] {*}$args]]
jpayne@68 544 }
jpayne@68 545 }
jpayne@68 546
jpayne@68 547 # The 'ResultSetCreate' method is expected to be a forward to the
jpayne@68 548 # appropriate result set constructor. If it's missing, the driver must
jpayne@68 549 # have been designed for tdbc 1.0b9 and earlier, and the 'resultSetClass'
jpayne@68 550 # variable holds the class name.
jpayne@68 551
jpayne@68 552 method resultSetCreate {name instance args} {
jpayne@68 553 return [uplevel 1 [list $resultSetClass create \
jpayne@68 554 $name $instance {*}$args]]
jpayne@68 555 }
jpayne@68 556
jpayne@68 557 # The 'resultsets' method returns a list of result sets produced by
jpayne@68 558 # the current statement
jpayne@68 559
jpayne@68 560 method resultsets {} {
jpayne@68 561 info commands ResultSet::*
jpayne@68 562 }
jpayne@68 563
jpayne@68 564 # The 'allrows' method executes a statement with a given set of
jpayne@68 565 # substituents, and returns a list of all the rows that the statement
jpayne@68 566 # returns. Optionally, it stores the names of columns in
jpayne@68 567 # '-columnsvariable'.
jpayne@68 568 #
jpayne@68 569 # Usage:
jpayne@68 570 # $statement allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
jpayne@68 571 # ?dictionary?
jpayne@68 572
jpayne@68 573
jpayne@68 574 method allrows args {
jpayne@68 575
jpayne@68 576 variable ::tdbc::generalError
jpayne@68 577
jpayne@68 578 # Grab keyword-value parameters
jpayne@68 579
jpayne@68 580 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 581
jpayne@68 582 # Check postitional parameters
jpayne@68 583
jpayne@68 584 set cmd [list [self] execute]
jpayne@68 585 if {[llength $args] == 0} {
jpayne@68 586 # do nothing
jpayne@68 587 } elseif {[llength $args] == 1} {
jpayne@68 588 lappend cmd [lindex $args 0]
jpayne@68 589 } else {
jpayne@68 590 set errorcode $generalError
jpayne@68 591 lappend errorcode wrongNumArgs
jpayne@68 592 return -code error -errorcode $errorcode \
jpayne@68 593 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 594 ?-option value?... ?--? ?dictionary?"
jpayne@68 595 }
jpayne@68 596
jpayne@68 597 # Get the result set
jpayne@68 598
jpayne@68 599 set resultSet [uplevel 1 $cmd]
jpayne@68 600
jpayne@68 601 # Delegate to the result set's [allrows] method to accumulate
jpayne@68 602 # the rows of the result.
jpayne@68 603
jpayne@68 604 set cmd [list $resultSet allrows {*}$opts]
jpayne@68 605 set status [catch {
jpayne@68 606 uplevel 1 $cmd
jpayne@68 607 } result options]
jpayne@68 608
jpayne@68 609 # Destroy the result set
jpayne@68 610
jpayne@68 611 catch {
jpayne@68 612 rename $resultSet {}
jpayne@68 613 }
jpayne@68 614
jpayne@68 615 # Adjust return level in the case that the script [return]s
jpayne@68 616
jpayne@68 617 if {$status == 2} {
jpayne@68 618 set options [dict merge {-level 1} $options[set options {}]]
jpayne@68 619 dict incr options -level
jpayne@68 620 }
jpayne@68 621 return -options $options $result
jpayne@68 622 }
jpayne@68 623
jpayne@68 624 # The 'foreach' method executes a statement with a given set of
jpayne@68 625 # substituents. It runs the supplied script, substituting the supplied
jpayne@68 626 # named variable. Optionally, it stores the names of columns in
jpayne@68 627 # '-columnsvariable'.
jpayne@68 628 #
jpayne@68 629 # Usage:
jpayne@68 630 # $statement foreach ?-as lists|dicts? ?-columnsvariable varName? ?--?
jpayne@68 631 # variableName ?dictionary? script
jpayne@68 632
jpayne@68 633 method foreach args {
jpayne@68 634
jpayne@68 635 variable ::tdbc::generalError
jpayne@68 636
jpayne@68 637 # Grab keyword-value parameters
jpayne@68 638
jpayne@68 639 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 640
jpayne@68 641 # Check positional parameters
jpayne@68 642
jpayne@68 643 set cmd [list [self] execute]
jpayne@68 644 if {[llength $args] == 2} {
jpayne@68 645 lassign $args varname script
jpayne@68 646 } elseif {[llength $args] == 3} {
jpayne@68 647 lassign $args varname dict script
jpayne@68 648 lappend cmd $dict
jpayne@68 649 } else {
jpayne@68 650 set errorcode $generalError
jpayne@68 651 lappend errorcode wrongNumArgs
jpayne@68 652 return -code error -errorcode $errorcode \
jpayne@68 653 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 654 ?-option value?... ?--? varName ?dictionary? script"
jpayne@68 655 }
jpayne@68 656
jpayne@68 657 # Get the result set
jpayne@68 658
jpayne@68 659 set resultSet [uplevel 1 $cmd]
jpayne@68 660
jpayne@68 661 # Delegate to the result set's [foreach] method to evaluate
jpayne@68 662 # the script for each row of the result.
jpayne@68 663
jpayne@68 664 set cmd [list $resultSet foreach {*}$opts -- $varname $script]
jpayne@68 665 set status [catch {
jpayne@68 666 uplevel 1 $cmd
jpayne@68 667 } result options]
jpayne@68 668
jpayne@68 669 # Destroy the result set
jpayne@68 670
jpayne@68 671 catch {
jpayne@68 672 rename $resultSet {}
jpayne@68 673 }
jpayne@68 674
jpayne@68 675 # Adjust return level in the case that the script [return]s
jpayne@68 676
jpayne@68 677 if {$status == 2} {
jpayne@68 678 set options [dict merge {-level 1} $options[set options {}]]
jpayne@68 679 dict incr options -level
jpayne@68 680 }
jpayne@68 681 return -options $options $result
jpayne@68 682 }
jpayne@68 683
jpayne@68 684 # The 'close' method is syntactic sugar for invoking the destructor
jpayne@68 685
jpayne@68 686 method close {} {
jpayne@68 687 my destroy
jpayne@68 688 }
jpayne@68 689
jpayne@68 690 # Derived classes are expected to implement their own constructors,
jpayne@68 691 # plus the following methods:
jpayne@68 692
jpayne@68 693 # paramtype paramName ?direction? type ?scale ?precision??
jpayne@68 694 # Declares the type of a parameter in the statement
jpayne@68 695
jpayne@68 696 }
jpayne@68 697
jpayne@68 698 #------------------------------------------------------------------------------
jpayne@68 699 #
jpayne@68 700 # Class: tdbc::resultset
jpayne@68 701 #
jpayne@68 702 # Class that represents a result set in a generic database.
jpayne@68 703 #
jpayne@68 704 #------------------------------------------------------------------------------
jpayne@68 705
jpayne@68 706 oo::class create tdbc::resultset {
jpayne@68 707
jpayne@68 708 constructor {} { }
jpayne@68 709
jpayne@68 710 # The 'allrows' method returns a list of all rows that a given
jpayne@68 711 # result set returns.
jpayne@68 712
jpayne@68 713 method allrows args {
jpayne@68 714
jpayne@68 715 variable ::tdbc::generalError
jpayne@68 716
jpayne@68 717 # Parse args
jpayne@68 718
jpayne@68 719 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 720 if {[llength $args] != 0} {
jpayne@68 721 set errorcode $generalError
jpayne@68 722 lappend errorcode wrongNumArgs
jpayne@68 723 return -code error -errorcode $errorcode \
jpayne@68 724 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 725 ?-option value?... ?--? varName script"
jpayne@68 726 }
jpayne@68 727
jpayne@68 728 # Do -columnsvariable if requested
jpayne@68 729
jpayne@68 730 if {[dict exists $opts -columnsvariable]} {
jpayne@68 731 upvar 1 [dict get $opts -columnsvariable] columns
jpayne@68 732 }
jpayne@68 733
jpayne@68 734 # Assemble the results
jpayne@68 735
jpayne@68 736 if {[dict get $opts -as] eq {lists}} {
jpayne@68 737 set delegate nextlist
jpayne@68 738 } else {
jpayne@68 739 set delegate nextdict
jpayne@68 740 }
jpayne@68 741 set results [list]
jpayne@68 742 while {1} {
jpayne@68 743 set columns [my columns]
jpayne@68 744 while {[my $delegate row]} {
jpayne@68 745 lappend results $row
jpayne@68 746 }
jpayne@68 747 if {![my nextresults]} break
jpayne@68 748 }
jpayne@68 749 return $results
jpayne@68 750
jpayne@68 751 }
jpayne@68 752
jpayne@68 753 # The 'foreach' method runs a script on each row from a result set.
jpayne@68 754
jpayne@68 755 method foreach args {
jpayne@68 756
jpayne@68 757 variable ::tdbc::generalError
jpayne@68 758
jpayne@68 759 # Grab keyword-value parameters
jpayne@68 760
jpayne@68 761 set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
jpayne@68 762
jpayne@68 763 # Check positional parameters
jpayne@68 764
jpayne@68 765 if {[llength $args] != 2} {
jpayne@68 766 set errorcode $generalError
jpayne@68 767 lappend errorcode wrongNumArgs
jpayne@68 768 return -code error -errorcode $errorcode \
jpayne@68 769 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 770 ?-option value?... ?--? varName script"
jpayne@68 771 }
jpayne@68 772
jpayne@68 773 # Do -columnsvariable if requested
jpayne@68 774
jpayne@68 775 if {[dict exists $opts -columnsvariable]} {
jpayne@68 776 upvar 1 [dict get $opts -columnsvariable] columns
jpayne@68 777 }
jpayne@68 778
jpayne@68 779 # Iterate over the groups of results
jpayne@68 780 while {1} {
jpayne@68 781
jpayne@68 782 # Export column names to caller
jpayne@68 783
jpayne@68 784 set columns [my columns]
jpayne@68 785
jpayne@68 786 # Iterate over the rows of one group of results
jpayne@68 787
jpayne@68 788 upvar 1 [lindex $args 0] row
jpayne@68 789 if {[dict get $opts -as] eq {lists}} {
jpayne@68 790 set delegate nextlist
jpayne@68 791 } else {
jpayne@68 792 set delegate nextdict
jpayne@68 793 }
jpayne@68 794 while {[my $delegate row]} {
jpayne@68 795 set status [catch {
jpayne@68 796 uplevel 1 [lindex $args 1]
jpayne@68 797 } result options]
jpayne@68 798 switch -exact -- $status {
jpayne@68 799 0 - 4 { # OK or CONTINUE
jpayne@68 800 }
jpayne@68 801 2 { # RETURN
jpayne@68 802 set options \
jpayne@68 803 [dict merge {-level 1} $options[set options {}]]
jpayne@68 804 dict incr options -level
jpayne@68 805 return -options $options $result
jpayne@68 806 }
jpayne@68 807 3 { # BREAK
jpayne@68 808 set broken 1
jpayne@68 809 break
jpayne@68 810 }
jpayne@68 811 default { # ERROR or unknown status
jpayne@68 812 return -options $options $result
jpayne@68 813 }
jpayne@68 814 }
jpayne@68 815 }
jpayne@68 816
jpayne@68 817 # Advance to the next group of results if there is one
jpayne@68 818
jpayne@68 819 if {[info exists broken] || ![my nextresults]} {
jpayne@68 820 break
jpayne@68 821 }
jpayne@68 822 }
jpayne@68 823
jpayne@68 824 return
jpayne@68 825 }
jpayne@68 826
jpayne@68 827
jpayne@68 828 # The 'nextrow' method retrieves a row in the form of either
jpayne@68 829 # a list or a dictionary.
jpayne@68 830
jpayne@68 831 method nextrow {args} {
jpayne@68 832
jpayne@68 833 variable ::tdbc::generalError
jpayne@68 834
jpayne@68 835 set opts [dict create -as dicts]
jpayne@68 836 set i 0
jpayne@68 837
jpayne@68 838 # Munch keyword options off the front of the command arguments
jpayne@68 839
jpayne@68 840 foreach {key value} $args {
jpayne@68 841 if {[string index $key 0] eq {-}} {
jpayne@68 842 switch -regexp -- $key {
jpayne@68 843 -as? {
jpayne@68 844 dict set opts -as $value
jpayne@68 845 }
jpayne@68 846 -- {
jpayne@68 847 incr i
jpayne@68 848 break
jpayne@68 849 }
jpayne@68 850 default {
jpayne@68 851 set errorcode $generalError
jpayne@68 852 lappend errorcode badOption $key
jpayne@68 853 return -code error -errorcode $errorcode \
jpayne@68 854 "bad option \"$key\":\
jpayne@68 855 must be -as or -columnsvariable"
jpayne@68 856 }
jpayne@68 857 }
jpayne@68 858 } else {
jpayne@68 859 break
jpayne@68 860 }
jpayne@68 861 incr i 2
jpayne@68 862 }
jpayne@68 863
jpayne@68 864 set args [lrange $args $i end]
jpayne@68 865 if {[llength $args] != 1} {
jpayne@68 866 set errorcode $generalError
jpayne@68 867 lappend errorcode wrongNumArgs
jpayne@68 868 return -code error -errorcode $errorcode \
jpayne@68 869 "wrong # args: should be [lrange [info level 0] 0 1]\
jpayne@68 870 ?-option value?... ?--? varName"
jpayne@68 871 }
jpayne@68 872 upvar 1 [lindex $args 0] row
jpayne@68 873 if {[dict get $opts -as] eq {lists}} {
jpayne@68 874 set delegate nextlist
jpayne@68 875 } else {
jpayne@68 876 set delegate nextdict
jpayne@68 877 }
jpayne@68 878 return [my $delegate row]
jpayne@68 879 }
jpayne@68 880
jpayne@68 881 # Derived classes must override 'nextresults' if a single
jpayne@68 882 # statement execution can yield multiple sets of results
jpayne@68 883
jpayne@68 884 method nextresults {} {
jpayne@68 885 return 0
jpayne@68 886 }
jpayne@68 887
jpayne@68 888 # Derived classes must override 'outputparams' if statements can
jpayne@68 889 # have output parameters.
jpayne@68 890
jpayne@68 891 method outputparams {} {
jpayne@68 892 return {}
jpayne@68 893 }
jpayne@68 894
jpayne@68 895 # The 'close' method is syntactic sugar for destroying the result set.
jpayne@68 896
jpayne@68 897 method close {} {
jpayne@68 898 my destroy
jpayne@68 899 }
jpayne@68 900
jpayne@68 901 # Derived classes are expected to implement the following methods:
jpayne@68 902
jpayne@68 903 # constructor and destructor.
jpayne@68 904 # Constructor accepts a statement and an optional
jpayne@68 905 # a dictionary of substituted parameters and
jpayne@68 906 # executes the statement against the database. If
jpayne@68 907 # the dictionary is not supplied, then the default
jpayne@68 908 # is to get params from variables in the caller's scope).
jpayne@68 909 # columns
jpayne@68 910 # -- Returns a list of the names of the columns in the result.
jpayne@68 911 # nextdict variableName
jpayne@68 912 # -- Stores the next row of the result set in the given variable
jpayne@68 913 # in caller's scope, in the form of a dictionary that maps
jpayne@68 914 # column names to values.
jpayne@68 915 # nextlist variableName
jpayne@68 916 # -- Stores the next row of the result set in the given variable
jpayne@68 917 # in caller's scope, in the form of a list of cells.
jpayne@68 918 # rowcount
jpayne@68 919 # -- Returns a count of rows affected by the statement, or -1
jpayne@68 920 # if the count of rows has not been determined.
jpayne@68 921
jpayne@68 922 }