1: # dio.tcl -- implements a database abstraction layer. 2: 3: # Copyright 2002-2004 The Apache Software Foundation 4: 5: # Licensed under the Apache License, Version 2.0 (the "License"); 6: # you may not use this file except in compliance with the License. 7: # You may obtain a copy of the License at 8: 9: # http://www.apache.org/licenses/LICENSE-2.0 10: 11: # Unless required by applicable law or agreed to in writing, software 12: # distributed under the License is distributed on an "AS IS" BASIS, 13: # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14: # See the License for the specific language governing permissions and 15: # limitations under the License. 16: 17: 18: 19: catch {package require Tclx} 20: package require Itcl 21: set auto_path [linsert $auto_path 0 [file dirname [info script]]] 22: 23: namespace eval ::DIO { 24: 25: proc handle {interface args} { 26: set obj \#auto 27: set first [lindex $args 0] 28: if {![lempty $first] && [string index $first 0] != "-"} { 29: set obj [lindex $args 0] 30: set args [lreplace $args 0 0] 31: } 32: uplevel \#0 package require dio_$interface 33: return [uplevel \#0 ::DIO::$interface $obj $args] 34: } 35: 36: ## 37: # DATABASE CLASS 38: ## 39: ::itcl::class Database { 40: constructor {args} { 41: eval configure $args 42: } 43: 44: destructor { 45: close 46: } 47: 48: # 49: # result - generate a new DIO result object for the specified database 50: # interface, with key-value pairs that get configured into the new 51: # result object. 52: # 53: protected method result {interface args} { 54: return [eval uplevel \#0 ::DIO::${interface}Result \#auto $args] 55: } 56: 57: # 58: # quote - given a string, return the same string with any single 59: # quote characters preceded by a backslash 60: # 61: method quote {string} { 62: regsub -all {'} $string {\'} string 63: return $string 64: } 65: 66: # 67: # build_select_query - build a select query based on given arguments, 68: # which can include a table name, a select statement, switches to 69: # turn on boolean AND or OR processing, and possibly 70: # some key-value pairs that cause the where clause to be 71: # generated accordingly 72: # 73: protected method build_select_query {args} { 74: 75: set bool AND 76: set first 1 77: set req "" 78: set myTable $table 79: set what "*" 80: 81: # for each argument passed us... 82: # (we go by integers because we mess with the index based on 83: # what we find) 84: for {set i 0} {$i < [llength $args]} {incr i} { 85: # fetch the argument we're currently processing 86: set elem [lindex $args $i] 87: 88: switch -- [::string tolower $elem] { 89: "-and" { 90: # -and -- switch to AND-style processing 91: set bool AND 92: } 93: 94: "-or" { 95: # -or -- switch to OR-style processing 96: set bool OR 97: } 98: 99: "-table" { 100: # -table -- identify which table the query is about 101: set myTable [lindex $args [incr i]] 102: } 103: 104: "-select" { 105: # -select - 106: set what [lindex $args [incr i]] 107: } 108: 109: default { 110: # it wasn't -and, -or, -table, or -select... 111: 112: # if the first character of the element is a dash, 113: # it's a field name and a value 114: 115: if {[::string index $elem 0] == "-"} { 116: set field [::string range $elem 1 end] 117: set elem [lindex $args [incr i]] 118: 119: # if it's the first field being processed, append 120: # WHERE to the SQL request we're generating 121: if {$first} { 122: append req " WHERE" 123: set first 0 124: } else { 125: # it's not the first variable in the comparison 126: # expression, so append the boolean state, either 127: # AND or OR 128: append req " $bool" 129: } 130: 131: # convert any asterisks to percent signs in the 132: # value field 133: regsub -all {\*} $elem {%} elem 134: 135: # if there is a percent sign in the value 136: # field now (having been there originally or 137: # mapped in there a moment ago), the SQL aspect 138: # is appended with a "field LIKE value" 139: 140: if {[::string first {%} $elem] != -1} { 141: append req " $field LIKE '[quote $elem]'" 142: } elseif {[regexp {^([<>]) *([0-9.]*)$} $elem _ fn val]} { 143: # value starts with <, or >, then space, 144: # and a something 145: append req " $field$fn$val" 146: } elseif {[regexp {^([<>]=) *([0-9.]*)$} $elem _ fn val]} { 147: # value starts with <= or >=, space, and something. 148: append req " $field$fn$val" 149: } else { 150: # otherwise it's a straight key=value comparison 151: append req " $field='[quote $elem]'" 152: } 153: 154: continue 155: } 156: append req " $elem" 157: } 158: } 159: } 160: return "select $what from $myTable $req" 161: } 162: 163: # 164: # build_insert_query -- given an array name, a list of fields, and 165: # possibly a table name, return a SQL insert statement inserting 166: # into the named table (or the object's table variable, if none 167: # is specified) for all of the fields specified, with their values 168: # coming from the array 169: # 170: protected method build_insert_query {arrayName fields {myTable ""}} { 171: upvar 1 $arrayName array 172: 173: if {[lempty $myTable]} { set myTable $table } 174: foreach field $fields { 175: if {![info exists array($field)]} { continue } 176: append vars "$field," 177: append vals "'[quote $array($field)]'," 178: } 179: set vals [::string range $vals 0 end-1] 180: set vars [::string range $vars 0 end-1] 181: return "insert into $myTable ($vars) VALUES ($vals)" 182: } 183: 184: # 185: # build_update_query -- given an array name, a list of fields, and 186: # possibly a table name, return a SQL update statement updating 187: # the named table (or using object's table variable, if none 188: # is named) for all of the fields specified, with their values 189: # coming from the array 190: # 191: # note that after use a where clause still neds to be added or 192: # you might update a lot more than you bargained for 193: # 194: protected method build_update_query {arrayName fields {myTable ""}} { 195: upvar 1 $arrayName array 196: if {[lempty $myTable]} { set myTable $table } 197: foreach field $fields { 198: if {![info exists array($field)]} { continue } 199: append string "$field='[quote $array($field)]'," 200: } 201: set string [::string range $string 0 end-1] 202: return "update $myTable SET $string" 203: } 204: 205: # 206: # lassign_array - given a list, an array name, and a variable number 207: # of arguments consisting of variable names, assign each element in 208: # the list, in turn, to elements corresponding to the variable 209: # arguments, into the named array. From TclX. 210: # 211: protected method lassign_array {list arrayName args} { 212: upvar 1 $arrayName array 213: foreach elem $list field $args { 214: set array($field) $elem 215: } 216: } 217: 218: # 219: # configure_variable - given a variable name and a string, if the 220: # string is empty return the variable name, otherwise set the 221: # variable to the string. 222: # 223: protected method configure_variable {varName string} { 224: if {[lempty $string]} { return [cget -$varName] } 225: configure -$varName $string 226: } 227: 228: # 229: # build_where_key_clause - given a list of one or more key fields and 230: # a corresponding list of one or more key values, construct a 231: # SQL where clause that boolean ANDs all of the key-value pairs 232: # together. 233: # 234: protected method build_key_where_clause {myKeyfield myKey} { 235: ## If we're not using multiple keyfields, just return a simple 236: ## where clause. 237: if {[llength $myKeyfield] < 2} { 238: return " WHERE $myKeyfield = '[quote $myKey]'" 239: } 240: 241: # multiple fields, construct it as a where-and 242: set first 1 243: set req "" 244: foreach field $myKeyfield key $myKey { 245: if {$first} { 246: append req " WHERE $field='[quote $key]'" 247: set first 0 248: } else { 249: append req " AND $field='[quote $key]'" 250: } 251: } 252: return $req 253: } 254: 255: ## 256: ## makekey -- Given an array containing a key-value pairs and 257: # an optional list of key fields (we use the object's keyfield 258: # if none is specified)... 259: # 260: # if we're doing auto keys, create and return a new key, 261: # otherwise if it's a single key, just return its value 262: # from the array, else if it's multiple keys, return all their 263: # values as a list 264: ## 265: method makekey {arrayName {myKeyfield ""}} { 266: if {[lempty $myKeyfield]} { set myKeyfield $keyfield } 267: if {[lempty $myKeyfield]} { 268: return -code error "No -keyfield specified in object" 269: } 270: upvar 1 $arrayName array 271: 272: ## If we're not using multiple keyfields, we want to check and see 273: ## if we're using auto keys. If we are, create a new key and 274: ## return it. If not, just return the value of the single keyfield 275: ## in the array. 276: if {[llength $myKeyfield] < 2} { 277: if {$autokey} { 278: set array($myKeyfield) [$this nextkey] 279: } else { 280: if {![info exists array($myKeyfield)]} { 281: return -code error \ 282: "${arrayName}($myKeyfield) does not exist" 283: } 284: } 285: return $array($myKeyfield) 286: } 287: 288: ## We're using multiple keys. Return a list of all the keyfield 289: ## values. 290: foreach field $myKeyfield { 291: if {![info exists array($field)]} { 292: return -code error "$field does not exist in $arrayName" 293: } 294: lappend key $array($field) 295: } 296: return $key 297: } 298: 299: method destroy {} { 300: ::itcl::delete object $this 301: } 302: 303: # 304: # string - execute a SQL request and only return a string of one row. 305: # 306: method string {req} { 307: set res [exec $req] 308: set val [$res next -list] 309: $res destroy 310: return $val 311: } 312: 313: # 314: # list - execute a request and return a list of the first element of each 315: # row returned. 316: # 317: method list {req} { 318: set res [exec $req] 319: set list "" 320: $res forall -list line { 321: lappend list [lindex $line 0] 322: } 323: $res destroy 324: return $list 325: } 326: 327: # 328: # array - execute a request and setup an array containing elements 329: # with the field names as the keys and the first row results as 330: # the values 331: # 332: method array {req arrayName} { 333: upvar 1 $arrayName $arrayName 334: set res [exec $req] 335: set ret [$res next -array $arrayName] 336: $res destroy 337: return $ret 338: } 339: 340: # 341: # forall - execute a SQL select and iteratively fill the named array 342: # with elements named with the matching field names, containing the 343: # matching values, executing the specified code body for each, in turn. 344: # 345: method forall {req arrayName body} { 346: upvar 1 $arrayName $arrayName 347: 348: set res [exec $req] 349: 350: if {[$res error]} { 351: set errinf [$res errorinfo] 352: $res destroy 353: return -code error "Got '$errinf' executing '$req'" 354: } 355: 356: set ret [$res numrows] 357: $res forall -array $arrayName { 358: uplevel 1 $body 359: } 360: $res destroy 361: return $ret 362: } 363: 364: # 365: # table_check - internal method to populate the data array with 366: # a -table element containing the table name, a -keyfield element 367: # containing the key field or list of key fields, and a list of 368: # key-value pairs to get set into the data table. 369: # 370: # afterwards, it's an error if -table or -keyfield hasn't somehow been 371: # determined. 372: # 373: protected method table_check {list {tableVar myTable} {keyVar myKeyfield}} { 374: upvar 1 $tableVar $tableVar $keyVar $keyVar 375: set data(-table) $table 376: set data(-keyfield) $keyfield 377: ::array set data $list 378: 379: if {[lempty $data(-table)]} { 380: return -code error "-table not specified in DIO object" 381: } 382: if {[lempty $data(-keyfield)]} { 383: return -code error "-keyfield not specified in DIO object" 384: } 385: 386: set $tableVar $data(-table) 387: set $keyVar $data(-keyfield) 388: } 389: 390: # 391: # key_check - given a list of key fields and a list of keys, it's 392: # an error if there aren't the same number of each, and if it's 393: # autokey, there can't be more than one key. 394: # 395: protected method key_check {myKeyfield myKey} { 396: if {[llength $myKeyfield] < 2} { return } 397: if {$autokey} { 398: return -code error "Cannot have autokey and multiple keyfields" 399: } 400: if {[llength $myKeyfield] != [llength $myKey]} { 401: return -code error "Bad key length." 402: } 403: } 404: 405: # 406: # fetch - given a key (or list of keys) an array name, and some 407: # extra key-value arguments like -table and -keyfield, fetch 408: # the key into the array 409: # 410: method fetch {key arrayName args} { 411: table_check $args 412: key_check $myKeyfield $key 413: upvar 1 $arrayName $arrayName 414: set req "select * from $myTable" 415: append req [build_key_where_clause $myKeyfield $key] 416: 417: set res [$this exec $req] 418: if {[$res error]} { 419: set errinf [$res errorinfo] 420: $res destroy 421: return -code error "Got '$errinf' executing '$req'" 422: } 423: set return [expr [$res numrows] > 0] 424: $res next -array $arrayName 425: $res destroy 426: return $return 427: } 428: 429: # 430: # store - given an array containing key-value pairs and optional 431: # arguments like -table and -keyfield, insert or update the 432: # corresponding table entry. 433: # 434: method store {arrayName args} { 435: table_check $args 436: upvar 1 $arrayName $arrayName $arrayName array 437: if {[llength $myKeyfield] > 1 && $autokey} { 438: return -code error "Cannot have autokey and multiple keyfields" 439: } 440: 441: set key [makekey $arrayName $myKeyfield] 442: set req "select * from $myTable" 443: append req [build_key_where_clause $myKeyfield $key] 444: set res [exec $req] 445: if {[$res error]} { 446: set errinf [$res errorinfo] 447: $res destroy 448: return -code error "Got '$errinf' executing '$req'" 449: } 450: set numrows [$res numrows] 451: set fields [$res fields] 452: $res destroy 453: 454: if {$numrows} { 455: set req [build_update_query array $fields $myTable] 456: append req [build_key_where_clause $myKeyfield $key] 457: } else { 458: set req [build_insert_query array $fields $myTable] 459: } 460: 461: set res [exec $req] 462: if {[$res error]} { 463: set errinf [$res errorinfo] 464: $res destroy 465: return -code error "Got '$errinf' executing '$req'" 466: } 467: $res destroy 468: return 1 469: } 470: 471: # 472: # insert - a pure insert, without store's somewhat clumsy 473: # efforts to see if it needs to be an update rather than 474: # an insert -- this shouldn't require fields, it's broken 475: # 476: method insert {arrayName fields args} { 477: table_check $args 478: upvar 1 $arrayName $arrayName $arrayName array 479: set req [build_insert_query array $fields $myTable] 480: 481: set res [exec $req] 482: if {[$res error]} { 483: set errinf [$res errorinfo] 484: $res destroy 485: return -code error "Got '$errinf' executing '$req'" 486: } 487: $res destroy 488: return 1 489: } 490: 491: # 492: # delete - delete matching record from the specified table 493: # 494: method delete {key args} { 495: table_check $args 496: set req "delete from $myTable" 497: append req [build_key_where_clause $myKeyfield $key] 498: 499: set res [exec $req] 500: if {[$res error]} { 501: set errinf [$res errorinfo] 502: $res destroy 503: return -code error "Got '$errinf' executing '$req'" 504: } 505: 506: set return [$res numrows] 507: $res destroy 508: return $return 509: } 510: 511: # 512: # keys - return all keys in a tbale 513: # 514: method keys {args} { 515: table_check $args 516: set req "select * from $myTable" 517: set obj [$this exec $req] 518: 519: set keys "" 520: $obj forall -array a { 521: lappend keys [makekey a $myKeyfield] 522: } 523: $obj destroy 524: 525: return $keys 526: } 527: 528: # 529: # search - construct and execute a SQL select statement using 530: # build_select_query style and return the result handle. 531: # 532: method search {args} { 533: set req [eval build_select_query $args] 534: return [exec $req] 535: } 536: 537: # 538: # count - return a count of the specified (or current) table. 539: # 540: method count {args} { 541: table_check $args 542: return [string "select count(*) from $myTable"] 543: } 544: 545: ## 546: ## These are methods which should be defined by each individual database 547: ## interface class. 548: ## 549: method open {args} {} 550: method close {args} {} 551: method exec {args} {} 552: method nextkey {args} {} 553: method lastkey {args} {} 554: 555: ## 556: ## Functions to get and set public variables. 557: ## 558: method interface {{string ""}} { configure_variable interface $string } 559: method errorinfo {{string ""}} { configure_variable errorinfo $string } 560: method db {{string ""}} { configure_variable db $string } 561: method table {{string ""}} { configure_variable table $string } 562: method keyfield {{string ""}} { configure_variable keyfield $string } 563: method autokey {{string ""}} { configure_variable autokey $string } 564: method sequence {{string ""}} { configure_variable sequence $string } 565: method user {{string ""}} { configure_variable user $string } 566: method pass {{string ""}} { configure_variable pass $string } 567: method host {{string ""}} { configure_variable host $string } 568: method port {{string ""}} { configure_variable port $string } 569: 570: public variable interface "" 571: public variable errorinfo "" 572: 573: public variable db "" 574: public variable table "" 575: public variable sequence "" 576: 577: public variable user "" 578: public variable pass "" 579: public variable host "" 580: public variable port "" 581: 582: public variable keyfield "" { 583: if {[llength $keyfield] > 1 && $autokey} { 584: return -code error "Cannot have autokey and multiple keyfields" 585: } 586: } 587: 588: public variable autokey 0 { 589: if {[llength $keyfield] > 1 && $autokey} { 590: return -code error "Cannot have autokey and multiple keyfields" 591: } 592: } 593: 594: } ; ## ::itcl::class Database 595: 596: # 597: # DIO Result object 598: # 599: ::itcl::class Result { 600: constructor {args} { 601: eval configure $args 602: } 603: 604: destructor { } 605: 606: method destroy {} { 607: ::itcl::delete object $this 608: } 609: 610: # 611: # configure_variable - given a variable name and a string, if the 612: # string is empty return the variable name, otherwise set the 613: # variable to the string. 614: # 615: protected method configure_variable {varName string} { 616: if {[lempty $string]} { return [cget -$varName] } 617: configure -$varName $string 618: } 619: 620: # 621: # lassign_array - given a list, an array name, and a variable number 622: # of arguments consisting of variable names, assign each element in 623: # the list, in turn, to elements corresponding to the variable 624: # arguments, into the named array. From TclX. 625: # 626: protected method lassign_array {list arrayName args} { 627: upvar 1 $arrayName array 628: foreach elem $list field $args { 629: set array($field) $elem 630: } 631: } 632: 633: # 634: # seek - set the current row ID (our internal row cursor, if you will) 635: # to the specified row ID 636: # 637: method seek {newrowid} { 638: set rowid $newrowid 639: } 640: 641: method cache {{size "all"}} { 642: set cacheSize $size 643: if {$size == "all"} { set cacheSize $numrows } 644: 645: ## Delete the previous cache array. 646: catch {unset cacheArray} 647: 648: set autostatus $autocache 649: set currrow $rowid 650: set autocache 1 651: seek 0 652: set i 0 653: while {[next -list list]} { 654: if {[incr i] >= $cacheSize} { break } 655: } 656: set autocache $autostatus 657: seek $currrow 658: set cached 1 659: } 660: 661: # 662: # forall -- walk the result object, executing the code body over it 663: # 664: method forall {type varName body} { 665: upvar 1 $varName $varName 666: set currrow $rowid 667: seek 0 668: while {[next $type $varName]} { 669: uplevel 1 $body 670: } 671: set rowid $currrow 672: return 673: } 674: 675: method next {type {varName ""}} { 676: set return 1 677: if {![lempty $varName]} { 678: upvar 1 $varName var 679: set return 0 680: } 681: 682: catch {unset var} 683: 684: set list "" 685: ## If we have a cached result for this row, use it. 686: if {[info exists cacheArray($rowid)]} { 687: set list $cacheArray($rowid) 688: } else { 689: set list [$this nextrow] 690: if {[lempty $list]} { 691: if {$return} { return } 692: set var "" 693: return 0 694: } 695: if {$autocache} { set cacheArray($rowid) $list } 696: } 697: 698: incr rowid 699: 700: switch -- $type { 701: "-list" { 702: if {$return} { 703: return $list 704: } else { 705: set var $list 706: } 707: } 708: "-array" { 709: if {$return} { 710: foreach field $fields elem $list { 711: lappend var $field $elem 712: } 713: return $var 714: } else { 715: eval lassign_array [list $list] var $fields 716: } 717: } 718: "-keyvalue" { 719: foreach field $fields elem $list { 720: lappend var -$field $elem 721: } 722: if {$return} { return $var } 723: } 724: 725: default { 726: incr rowid -1 727: return -code error \ 728: "In-valid type: must be -list, -array or -keyvalue" 729: } 730: } 731: return [expr [lempty $list] == 0] 732: } 733: 734: method resultid {{string ""}} { configure_variable resultid $string } 735: method fields {{string ""}} { configure_variable fields $string } 736: method rowid {{string ""}} { configure_variable rowid $string } 737: method numrows {{string ""}} { configure_variable numrows $string } 738: method error {{string ""}} { configure_variable error $string } 739: method errorcode {{string ""}} { configure_variable errorcode $string } 740: method errorinfo {{string ""}} { configure_variable errorinfo $string } 741: method autocache {{string ""}} { configure_variable autocache $string } 742: 743: public variable resultid "" 744: public variable fields "" 745: public variable rowid 0 746: public variable numrows 0 747: public variable error 0 748: public variable errorcode 0 749: public variable errorinfo "" 750: public variable autocache 1 751: 752: protected variable cached 0 753: protected variable cacheSize 0 754: protected variable cacheArray 755: 756: } ; ## ::itcl::class Result 757: 758: } ; ## namespace eval DIO 759: 760: package provide DIO 1.0 |