Mercurial > repos > rliterman > csp2

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