tdbc.tcl 26 KB

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