1# tie.tcl -- 2# 3# Tie arrays to persistence engines. 4# 5# Copyright (c) 2004 Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# 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: tie.tcl,v 1.7 2006/09/19 23:36:18 andreas_kupries Exp $ 11 12# ### ### ### ######### ######### ######### 13## Requisites 14 15package require snit 16package require cmdline 17 18# ### ### ### ######### ######### ######### 19## Implementation 20 21# ### ### ### ######### ######### ######### 22## Public API 23 24namespace eval ::tie {} 25 26proc ::tie::tie {avar args} { 27 # Syntax : avar ?-open? ?-save? ?-merge? dstype dsargs...? 28 29 variable registry 30 31 upvar 1 $avar thearray 32 33 if {![array exists thearray]} { 34 return -code error "can't tie to \"$avar\": no such array variable" 35 } 36 37 # Create shortcuts for the options, and initialize them. 38 foreach k {open save merge} {upvar 0 opts($k) $k} 39 set open 0 40 set save 0 41 set merge 0 42 43 # Option processing ... 44 45 array set opts [GetOptions args] 46 47 # Basic validation ... 48 49 if {$open && $save} { 50 return -code error "-open and -save exclude each other" 51 } elseif {!$open && !$save} { 52 set open 1 53 } 54 55 if {![llength $args]} { 56 return -code error "dstype and type arguments missing" 57 } 58 set type [lindex $args 0] 59 set args [lrange $args 1 end] 60 61 # Create DS object from type (DS class) and args. 62 if {[::info exists registry($type)]} { 63 set type $registry($type) 64 } 65 set dso [eval [concat $type %AUTO% $args]] 66 67 Connect thearray $open $merge $dso 68 return [NewToken thearray $dso] 69} 70 71proc ::tie::untie {avar args} { 72 # Syntax : arrayvarname ?token? 73 74 variable mgr 75 variable tie 76 77 upvar 1 $avar thearray 78 79 switch -exact -- [llength $args] { 80 0 { 81 # Remove all ties for the variable. Do nothing if there 82 # are no ties in place. 83 84 set mid [TraceManager thearray] 85 if {$mid eq ""} return 86 } 87 1 { 88 # Remove a specific tie. 89 90 set tid [lindex $args 0] 91 if {![::info exists tie($tid)]} { 92 return -code error "Unknown tie \"$tid\"" 93 } 94 95 foreach {mid dso} $tie($tid) break 96 set midvar [TraceManager thearray] 97 98 if {$mid ne $midvar} { 99 return -code error "Tie \"$tid\" not associated with variable \"$avar\"" 100 } 101 102 set pos [lsearch -exact $mgr($mid) $tid] 103 set mgr($mid) [lreplace $mgr($mid) $pos $pos] 104 105 unset tie($tid) 106 $dso destroy 107 108 # Leave the manager in place if there still ties 109 # associated with the variable. 110 if {[llength $mgr($mid)]} return 111 } 112 default { 113 return -code error "wrong#args: array ?token?" 114 } 115 } 116 117 # Delegate full removal to common code. 118 Untie $mid thearray 119 return 120} 121 122proc ::tie::info {cmd args} { 123 variable mgr 124 if {$cmd eq "ties"} { 125 if {[llength $args] != 1} { 126 return -code error "wrong#args: should be \"tie::info ties avar\"" 127 } 128 upvar 1 [lindex $args 0] thearray 129 set mid [TraceManager thearray] 130 if {$mid eq ""} {return {}} 131 132 return $mgr($mid) 133 } elseif {$cmd eq "types"} { 134 if {[llength $args] != 0} { 135 return -code error "wrong#args: should be \"tie::info types\"" 136 } 137 variable registry 138 return [array get registry] 139 } elseif {$cmd eq "type"} { 140 if {[llength $args] != 1} { 141 return -code error "wrong#args: should be \"tie::info type dstype\"" 142 } 143 variable registry 144 set type [lindex $args 0] 145 if {![::info exists registry($type)]} { 146 return -code error "Unknown type \"$type\"" 147 } 148 return $registry($type) 149 } else { 150 return -code error "Unknown command \"$cmd\", should be ties, type, or types" 151 } 152} 153 154proc ::tie::register {dsclasscmd _as_ dstype} { 155 variable registry 156 if {$_as_ ne "as"} { 157 return -code error "wrong#args: should be \"tie::register command 'as' type\"" 158 } 159 160 # Resolve a chain of type definitions right now. 161 while {[::info exists registry($dsclasscmd)]} { 162 set dsclasscmd $registry($dsclasscmd) 163 } 164 165 set registry($dstype) $dsclasscmd 166 return 167} 168 169# ### ### ### ######### ######### ######### 170## Internal : Framework state 171 172namespace eval ::tie { 173 # Registry of short names and their associated class commands 174 175 variable registry 176 array set registry {} 177 178 # Management databases for the ties. 179 # 180 # mgr : mgr id -> list (tie id) 181 # tie : tie id -> (mgr id, dso cmd) 182 # 183 # array ==> mgr -1---n-> tie 184 # ^ | 185 # +-1-------n-+ 186 # 187 # lock : mgr id x key -> 1/exists 0/!exists 188 189 # Database of managers for arrays. 190 # Also counter for the generation of mgr ids. 191 192 variable mgrcount 0 193 variable mgr ; array set mgr {} 194 195 196 # Database of ties (and their tokens). 197 # Also counter for the generation of tie ids. 198 199 variable tiecount 0 200 variable tie ; array set tie {} 201 202 # Database of locked arrays, keys, and data sources. 203 204 variable lock ; array set lock {} 205 206 # Key | Meaning 207 # --- + ------- 208 # $mid,$idx | Propagation for index $idx is in progress. 209} 210 211# ### ### ### ######### ######### ######### 212## Internal : Option processor 213 214proc ::tie::GetOptions {arglistVar} { 215 upvar 1 $arglistVar argv 216 217 set opts [lrange [::cmdline::GetOptionDefaults { 218 {open {}} 219 {save {}} 220 {merge {}} 221 } result] 2 end] ;# Remove ? and help. 222 223 set argc [llength $argv] 224 while {[set err [::cmdline::getopt argv $opts opt arg]]} { 225 if {$err < 0} { 226 set olist "" 227 foreach o [lsort $opts] { 228 if {[string match *.arg $o]} { 229 set o [string range $o 0 end-4] 230 } 231 lappend olist -$o 232 } 233 return -code error "bad option \"$opt\",\ 234 should be one of\ 235 [linsert [join $olist ", "] end-1 or]" 236 } 237 set result($opt) $arg 238 } 239 return [array get result] 240} 241 242# ### ### ### ######### ######### ######### 243## Internal : Token generator 244 245proc ::tie::NewToken {avar dso} { 246 variable tiecount 247 variable tie 248 variable mgr 249 250 upvar 1 $avar thearray 251 252 set mid [NewTraceManager thearray] 253 set tid tie[incr tiecount] 254 set tie($tid) [list $mid $dso] 255 lappend mgr($mid) $tid 256 return $tid 257} 258 259# ### ### ### ######### ######### ######### 260## Internal : Trace Management 261 262proc ::tie::TraceManager {avar} { 263 upvar 1 $avar thearray 264 265 set traces [trace info variable thearray] 266 267 foreach t $traces { 268 foreach {op cmd} $t break 269 if { 270 ([llength $cmd] == 2) && 271 ([lindex $cmd 0] eq "::tie::Trace") 272 } { 273 # Our internal manager id is the first argument of the 274 # trace command we attached to the array. 275 return [lindex $cmd 1] 276 } 277 } 278 # No framework trace was found, there is no manager. 279 return {} 280} 281 282proc ::tie::NewTraceManager {avar} { 283 variable mgrcount 284 variable mgr 285 286 upvar 1 $avar thearray 287 288 set mid [TraceManager thearray] 289 if {$mid ne ""} {return $mid} 290 291 # No manager was found, we have to create a new one for the 292 # variable. 293 294 set mid [incr mgrcount] 295 set mgr($mid) [list] 296 297 trace add variable thearray \ 298 {write unset} \ 299 [list ::tie::Trace $mid] 300 301 return $mid 302} 303 304proc ::tie::Trace {mid avar idx op} { 305 #puts "[pid] Trace $mid $avar ($idx) $op" 306 307 variable mgr 308 variable tie 309 variable lock 310 311 upvar $avar thearray 312 313 if {($op eq "unset") && ($idx eq "")} { 314 # The variable as a whole is unset. This 315 # destroys all the ties placed on it. 316 # Note: The traces are already gone! 317 318 Untie $mid thearray 319 return 320 } 321 322 if {[::info exists lock($mid,$idx)]} { 323 #puts "%% locked $mid,$idx" 324 return 325 } 326 set lock($mid,$idx) . 327 #puts "%% lock $mid,$idx" 328 329 if {$op eq "unset"} { 330 foreach tid $mgr($mid) { 331 set dso [lindex $tie($tid) 1] 332 $dso unsetv $idx 333 } 334 } elseif {$op eq "write"} { 335 set value $thearray($idx) 336 foreach tid $mgr($mid) { 337 set dso [lindex $tie($tid) 1] 338 $dso setv $idx $value 339 } 340 } else { 341 #puts "%% unlock/1 $mid,$idx" 342 unset -nocomplain lock($mid,$idx) 343 return -code error "Bad trace call, unexpected operation \"$op\"" 344 } 345 346 #puts "%% unlock/2 $mid,$idx" 347 unset -nocomplain lock($mid,$idx) 348 return 349} 350 351proc ::tie::Connect {avar open merge dso} { 352 upvar 1 $avar thearray 353 354 # Doing this as first operation is a convenient check that the ds 355 # object command exists. 356 set dsdata [$dso get] 357 358 if {$open} { 359 # Open DS and load data from it. 360 361 # Save current contents of array, for restoration in case of 362 # trouble. 363 set save [array get thearray] 364 365 if {$merge} { 366 # merge -> Remember the existing keys, so that we 367 # save their contents after loading the DS as well. 368 set wback [array names thearray] 369 } else { 370 # not merge -> Replace existing content. 371 array unset thearray * 372 } 373 374 if {[set code [catch { 375 array set thearray $dsdata 376 # ! Propagation through other ties. 377 } msg]]} { 378 # Errors found. Reset bogus contents, then reinsert the 379 # saved information to restore the previous state. 380 array unset thearray * 381 array set thearray $save 382 383 return -code $code \ 384 -errorcode $::errorCode \ 385 -errorinfo $::errorInfo $msg 386 } 387 388 if {$merge} { 389 # Now save everything we had before the tie was added into 390 # the DS. This may save data which came from the DS. 391 foreach idx $wback { 392 $dso setv $idx $thearray($idx) 393 } 394 } 395 } else { 396 # Save array data to DS. 397 398 # Save current contents of DS, for restoration in case of 399 # trouble. 400 # set save $dsdata 401 402 set source [array get thearray] 403 404 if {$merge} { 405 # merge -> Remember the existing keys, so that we 406 # read their contents after saving the array as well. 407 set rback [$dso names] 408 } else { 409 # not merge -> Replace existing content. 410 $dso unset 411 } 412 413 if {[set code [catch { 414 $dso set $source 415 } msg]]} { 416 $dso unset 417 $dso set $dsdata 418 419 return -code $code \ 420 -errorcode $::errorCode \ 421 -errorinfo $::errorInfo $msg 422 } 423 424 if {$merge} { 425 # Now read everything we had before the tie was added from 426 # the DS. This may read data which came from the array. 427 foreach idx $rback { 428 set thearray($idx) [$dso getv $idx] 429 # ! Propagation through other ties. 430 } 431 } 432 } 433 return 434} 435 436proc ::tie::Untie {mid avar} { 437 variable mgr 438 variable tie 439 variable lock 440 441 upvar 1 $avar thearray 442 443 trace remove variable thearray \ 444 {write unset} \ 445 [list ::tie::Trace $mid] 446 447 foreach tid $mgr($mid) { 448 foreach {mid dso} $tie($tid) break 449 # ASSERT: mid == mid 450 451 unset tie($tid) 452 $dso destroy 453 } 454 455 unset mgr($mid) 456 array unset lock ${mid},* 457 return 458} 459 460# ### ### ### ######### ######### ######### 461## Test helper, peek into internals 462## Returns a serialized representation. 463 464proc ::tie::Peek {} { 465 variable mgr 466 variable tie 467 468 variable mgrcount 469 variable tiecount 470 471 list \ 472 $mgrcount $tiecount \ 473 mgr [Dictsort [array get mgr]] \ 474 tie [Dictsort [array get tie]] 475} 476 477proc ::tie::Reset {} { 478 variable mgrcount 0 479 variable tiecount 0 480 return 481} 482 483proc ::tie::Dictsort {dict} { 484 array set a $dict 485 set out [list] 486 foreach key [lsort [array names a]] { 487 lappend out $key $a($key) 488 } 489 return $out 490} 491 492# ### ### ### ######### ######### ######### 493## Standard DS classes 494# @mdgen NODEP: tie::std::log 495# @mdgen NODEP: tie::std::dsource 496# @mdgen NODEP: tie::std::array 497# @mdgen NODEP: tie::std::rarray 498# @mdgen NODEP: tie::std::file 499# @mdgen NODEP: tie::std::growfile 500 501::tie::register {package require tie::std::log ; ::tie::std::log} as log 502::tie::register {package require tie::std::dsource ; ::tie::std::dsource} as dsource 503::tie::register {package require tie::std::array ; ::tie::std::array} as array 504::tie::register {package require tie::std::rarray ; ::tie::std::rarray} as remotearray 505::tie::register {package require tie::std::file ; ::tie::std::file} as file 506::tie::register {package require tie::std::growfile ; ::tie::std::growfile} as growfile 507 508# ### ### ### ######### ######### ######### 509## Ready to go 510 511package provide tie 1.1 512