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 14package require TclOO 15 16namespace 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 41proc 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 101oo::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 502oo::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 706oo::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}