Mercurial > repos > rliterman > csp2

annotate CSP2/CSP2_env/env-d9b9114564458d9d-741b3de822f2aaca6c6caa4325c4afce/lib/tdbc1.1.5/tdbc.tcl @ 69:33d812a61356

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