1: # simpledb.tcl -- provides a simple tcl database. 2: 3: # Copyright 2003-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: # $Id: simpledb.tcl,v 1.3 2004/02/24 10:24:34 davidw Exp $ 18: 19: package provide simpledb 0.1 20: 21: namespace eval ::simpledb { 22: set oid 0 23: } 24: 25: # simpledb::createtable -- 26: # 27: # Creates a table and its associated columns. 28: # 29: # Arguments: 30: # table - name of the table. 31: # args - column names. 32: # 33: # Side Effects: 34: # Creates internal namespace and arrays. 35: # 36: # Results: 37: # None. 38: 39: proc simpledb::createtable { table args } { 40: namespace eval $table {} 41: array set ${table}::cols {} 42: # Currently active oids. 43: array set ${table}::goodoids {} 44: 45: foreach col $args { 46: # Each key gets its own namespace. 47: namespace eval ${table}::${col} {} 48: # In that namespace we have an array that maps oids->data. 49: array set ${table}::${col}::data {} 50: # And an array that maps data->oids. 51: array set ${table}::${col}::values {} 52: set ${table}::cols($col) 1 53: } 54: } 55: 56: 57: # simpledb::deltable -- 58: # 59: # Delete table. 60: # 61: # Arguments: 62: # table - table to delete. 63: # 64: # Side Effects: 65: # Deletes table namespace. 66: # 67: # Results: 68: # None. 69: 70: proc simpledb::deltable { table } { 71: namespace delete $table 72: } 73: 74: 75: # simpledb::tables -- 76: # 77: # Return a list of all tables. 78: # 79: # Arguments: 80: # None. 81: # 82: # Side Effects: 83: # None. 84: # 85: # Results: 86: # A list of all tables that exist in the database. 87: 88: proc simpledb::tables {} { 89: set res {} 90: foreach ns [namespace children [namespace current]] { 91: lappend res [namespace tail $ns] 92: } 93: return $res 94: } 95: 96: 97: # simpledb::createitem -- 98: # 99: # Create an item in the table. 100: # 101: # Arguments: 102: # table - table name. 103: # properties - a list of keys and their corresponding values. 104: # Keys must correspond to those listed in 'createtable'. 105: # 106: # Side Effects: 107: # Creates a new table item. 108: # 109: # Results: 110: # None. 111: 112: proc simpledb::createitem { table properties } { 113: variable oid 114: incr oid 115: set ${table}::goodoids($oid) 1 116: foreach {col data} $properties { 117: set ${table}::${col}::data($oid) $data 118: lappend ${table}::${col}::values($data) $oid 119: } 120: return $oid 121: } 122: 123: # simpledb::getitem -- 124: # 125: # Fetches an item from the database based on its oid. 126: # 127: # Arguments: 128: # table - table name. 129: # oid - identity of the item to fetch. 130: # 131: # Side Effects: 132: # None. 133: # 134: # Results: 135: # Returns information as a list suitable to pass to 'array set'. 136: 137: proc simpledb::getitem { table oid } { 138: foreach col [array names ${table}::cols] { 139: lappend res $col [set ${table}::${col}::data($oid)] 140: } 141: return $res 142: } 143: 144: 145: # simpledb::setitem -- 146: # 147: # Set the values of given keys. 148: # 149: # Arguments: 150: # table - table name. 151: # oid - item's unique id. 152: # properties - list of keys and values. 153: # 154: # Side Effects: 155: # The old value of the item is lost. 156: # 157: # Results: 158: # None. 159: 160: proc simpledb::setitem { table oid properties } { 161: upvar $properties props 162: foreach {col data} $properties { 163: if { [info exists ${table}::${col}::data($oid)] } { 164: set oldval [set ${table}::${col}::data($oid)] 165: set item [lsearch [set ${table}::${col}::values($oldval)] $oid] 166: if { $item >= 0 } { 167: set ${table}::${col}::values($oldval) \ 168: [lreplace ${table}::${col}::values($oldval) $item $item] 169: } 170: if { [llength [set ${table}::${col}::values($oldval)]] == 0 } { 171: unset ${table}::${col}::values($oldval) 172: } 173: } 174: 175: set ${table}::${col}::data($oid) $data 176: lappend ${table}::${col}::values($data) $oid 177: } 178: return $oid 179: } 180: 181: 182: # simpledb::delitem -- 183: # 184: # Delete an item from the database. This is slow because of the 185: # lsearch. 186: # 187: # Arguments: 188: # table - table name. 189: # oid - object's unique id. 190: # 191: # Side Effects: 192: # Deletes item from the database. 193: # 194: # Results: 195: # None. 196: 197: proc simpledb::delitem { table oid } { 198: foreach col [array names ${table}::cols] { 199: unset ${table}::${col}::data($oid) 200: set item [lsearch ${table}::${col}::values($props($col)) $oid] 201: set ${table}::${col}::values($props($col)) \ 202: [lreplace ${table}::${col}::values($props($col)) $item $item] 203: } 204: unset ${table}::goodoids($oid) 205: return $oid 206: } 207: 208: 209: # simpledb::finditems -- 210: # 211: # Find items that match the given "properties" - a list of keys 212: # and the sought values. Glob patterns are accepted as 213: # 'values'. 214: # 215: # Arguments: 216: # table - table name. 217: # propertymatch - list of keys and values to search on. 218: # 219: # Side Effects: 220: # None. 221: # 222: # Results: 223: # A list of the id's of matching item. 224: 225: proc simpledb::finditems { table propertymatch } { 226: array set res {} 227: foreach {col value} $propertymatch { 228: foreach {value oids} [array get ${table}::${col}::values $value] { 229: foreach oid $oids { 230: if { [info exists res($oid)] } { 231: incr res($oid) 232: } else { 233: set res($oid) 1 234: } 235: } 236: } 237: } 238: set retlist {} 239: foreach {oid num} [array get res] { 240: if { $res($oid) == [expr {[llength $propertymatch] / 2}] } { 241: lappend retlist $oid 242: } 243: } 244: return $retlist 245: } 246: 247: 248: # simpledb::items -- 249: # 250: # Fetch all the items from a particular table. 251: # 252: # Arguments: 253: # table. 254: # 255: # Side Effects: 256: # None. 257: # 258: # Results: 259: # A list of lists, with the sublists being key/value lists of 260: # column names and their value for the oid in question. 261: 262: proc simpledb::items {table} { 263: set reslist {} 264: set collist [array names ${table}::cols] 265: foreach oid [array names ${table}::goodoids] { 266: set oidlist {} 267: foreach col $collist { 268: if { [info exists ${table}::${col}::data($oid)] } { 269: lappend oidlist $col [set ${table}::${col}::data($oid)] 270: } 271: } 272: lappend reslist $oidlist 273: } 274: 275: return $reslist 276: } 277: 278: 279: # simpledb::synctostorage -- 280: # 281: # Writes the database to a file. The storage format, for the 282: # moment is Tcl code, which isn't space efficient, but is easy 283: # to reload. 284: # 285: # Arguments: 286: # savefile - file to save database in. 287: # 288: # Side Effects: 289: # None. 290: # 291: # Results: 292: # None. 293: 294: proc simpledb::synctostorage {savefile} { 295: set fl [open $savefile w] 296: foreach ns [namespace children] { 297: # Let's store the goodoids array. 298: set collist [array names ${ns}::cols] 299: puts $fl "namespace eval $ns \{" 300: puts $fl " array set cols \{ [array get ${ns}::cols] \}" 301: puts $fl " array set goodoids \{ [array get ${ns}::goodoids] \}". 302: foreach col $collist { 303: puts $fl " namespace eval ${col} \{" 304: puts $fl " array set data [list [array get ${ns}::${col}::data]]" 305: puts $fl " array set values [list [array get ${ns}::${col}::values]]" 306: puts $fl " \}" 307: } 308: puts $fl "\}" 309: } 310: close $fl 311: } 312: 313: 314: # simpledb::syncfromstorage -- 315: # 316: # Reloads database from file. 317: # 318: # Arguments: 319: # savefile - file to read. 320: # 321: # Side Effects: 322: # Creates database. 323: # 324: # Results: 325: # None. 326: 327: proc simpledb::syncfromstorage {savefile} { 328: source $savefile 329: } 330: |