dict.tcl (22238B)
1 # dict.tcl 2 # http://wiki.tcl.tk/10609 3 # 4 # Tcl 8.4-compatible implementation of the [dict] command. 5 # 6 # Known deficiencies: 7 # - In error messages, the variable name doesn't always appear correctly. This 8 # is due to use of [upvar] which renames the variable. 9 # - Tcl 8.4 offers no way for [return], [break], etc. inside the script to 10 # affect the caller. [uplevel] doesn't quite do everything that's needed. 11 # - Some usage error messages show different names for formal arguments. 12 # - Performance is reduced. 13 # 14 # Test failures (prefix each name with "dict-"): 15 # 3.12 4.5 5.7 9.7 9.8 11.15 12.7 12.8 12.10 16 # 13.7 13.8 13.9 14.1 14.2 14.3 14.4 14.12 14.13 17 # 14.22 15.9 15.10 15.11 16.8 16.9 16.17 16.18 17.13 18 # 17.16 17.18 21.1 21.2 21.3 21.4 21.13 21.14 21.15 19 # 22.1 22.2 22.3 22.10 22.14 22.15 23.1 23.2 24.1 20 # 24.2 24.3 24.4 24.12 24.13 24.20.1 24.21 24.24 24.25 21 22 # Only create [dict] command if it doesn't already exist. 23 if {[catch {dict get {}}]} { 24 # Tcl 8.4-style implementation of namespace ensembles. 25 namespace eval ::dict {} 26 proc ::dict {subcommand args} { 27 # Confirm $subcommand is a [dict] command or unambiguous prefix thereof. 28 if {[regexp {[][*?\\]} $subcommand] 29 || [llength [set command [info commands ::dict::$subcommand*]]] != 1} { 30 set commands [string map {::dict:: {}}\ 31 [lsort [info commands ::dict::*]]] 32 if {[llength $commands] > 1} { 33 lset commands end "or [lindex $commands end]" 34 } 35 if {[llength $commands] > 2} { 36 set commands [join $commands ", "] 37 } else { 38 set commands [join $commands " "] 39 } 40 error "unknown or ambiguous subcommand \"$subcommand\":\ 41 must be $commands" 42 } 43 44 # Invoke the command. 45 if {[catch {uplevel 1 [concat [list $command] $args]} msg]} { 46 # Rewrite the command name on error. 47 regsub {^(wrong # args: should be \")::(dict)::} $msg {\1\2 } msg 48 error $msg 49 } else { 50 return $msg 51 } 52 } 53 54 # [dict append] 55 proc ::dict::append {varName key args} { 56 upvar 1 $varName var 57 58 # Locate the matching key. On match, append to the key's value. 59 if {[::info exists var]} { 60 ::set var [get $var] 61 ::for {::set i 0} {$i < [llength $var]} {::incr i 2} { 62 if {[lindex $var $i] eq $key} { 63 ::incr i 64 return [lset var $i [lindex $var $i][join $args {}]] 65 } 66 } 67 } 68 69 # On search failure, add the key to the dict. This code also will 70 # create the dict if it doesn't already exist. 71 ::lappend var $key [join $args {}] 72 } 73 74 # [dict create] 75 proc ::dict::create {args} { 76 if {[llength $args] & 1} { 77 error "wrong # args: should be \"dict create ?key value ...?\"" 78 } 79 get $args 80 } 81 82 # [dict exists] 83 proc ::dict::exists {dictionary key args} { 84 # Traverse through nested dicts searching for matches. 85 ::set sub $dictionary 86 foreach key [concat [list $key] $args] { 87 if {[llength $sub] & 1} { 88 return 0 89 } 90 ::set match 0 91 foreach {subkey sub} $sub { 92 if {$subkey eq $key} { 93 ::set match 1 94 break 95 } 96 } 97 if {!$match} { 98 return 0 99 } 100 } 101 return $match 102 } 103 104 # [dict filter] 105 proc ::dict::filter {dictionary filterType args} { 106 # Invoke the correct filter handler. 107 ::set result {} 108 switch $filterType { 109 k - ke - key { 110 # Filter on keys. 111 foreach {key val} [get $dictionary] { 112 foreach pattern $args { 113 if {[string match $pattern $key]} { 114 ::lappend result $key $val 115 break 116 } 117 } 118 } 119 } v - va - val - valu - value { 120 # Filter on values. 121 foreach {key val} [get $dictionary] { 122 foreach pattern $args { 123 if {[string match $pattern $val]} { 124 ::lappend result $key $val 125 break 126 } 127 } 128 } 129 } s - sc - scr - scri - scrip - script { 130 # Filter on script returning true. 131 if {[llength $args] != 2} { 132 error "wrong # args: should be \"dict filter dictionary script\ 133 {keyVarName valueVarName} filterScript\"" 134 } elseif {[llength [lindex $args 0]] != 2} { 135 error "must have exactly two variable names" 136 } 137 upvar 1 [lindex $args 0 0] key [lindex $args 0 1] val 138 foreach {key val} [get $dictionary] { 139 if {[uplevel 1 [lindex $args 1]]} { 140 ::lappend result $key $val 141 } 142 } 143 } default { 144 error "bad filterType \"$filterType\":\ 145 must be key, script, or value" 146 }} 147 return $result 148 } 149 150 # [dict for] 151 proc ::dict::for {keyVarValueVar dictionary script} { 152 if {[llength $keyVarValueVar] != 2} { 153 error "must have exactly two variable names" 154 } 155 156 # [foreach] does what's needed, mostly. Tcl 8.4 offers no way for 157 # [return], etc. inside the script to make the caller return. 158 uplevel 1 [list foreach $keyVarValueVar [get $dictionary] $script] 159 } 160 161 # [dict get] 162 proc ::dict::get {dictionary args} { 163 if {[llength $args]} { 164 # When given multiple arguments, traverse nested dicts to find the 165 # requested key. Fail if the key is not found. 166 ::set sub $dictionary 167 foreach key $args { 168 if {[llength $sub] & 1} { 169 error "missing value to go with key" 170 } 171 ::for {::set i [expr {[llength $sub] - 2}]} {1} {::incr i -2} { 172 if {$i < 0} { 173 error "key \"$key\" not known in dictionary" 174 } elseif {[lindex $sub $i] eq $key} { 175 break 176 } 177 } 178 ::set sub [lindex $sub [expr {$i + 1}]] 179 } 180 return $sub 181 } else { 182 # With only one argument, convert that argument to a canonical dict. 183 if {[llength $dictionary] & 1} { 184 error "missing value to go with key" 185 } 186 ::for {::set i 0} {$i < [llength $dictionary]} {::incr i 2} { 187 if {[::info exists indexes([lindex $dictionary $i])]} { 188 lset dictionary $indexes([lindex $dictionary $i])\ 189 [lindex $dictionary [expr {$i + 1}]] 190 ::set dictionary [lreplace $dictionary $i [expr {$i + 1}]] 191 ::incr i -2 192 } else { 193 ::set indexes([lindex $dictionary $i]) [expr {$i + 1}] 194 } 195 } 196 return $dictionary 197 } 198 } 199 200 # [dict incr] 201 proc ::dict::incr {varName key {increment 1}} { 202 upvar 1 $varName var 203 204 # Disallow non-integer increments. 205 if {![string is integer -strict $increment]} { 206 error "expected integer but got \"$increment\"" 207 } 208 209 # Locate the matching key and increment its value. 210 if {[::info exists var]} { 211 ::set var [get $var] 212 ::for {::set i 0} {$i < [llength $var]} {::incr i 2} { 213 if {$key eq [lindex $var $i]} { 214 ::incr i 215 216 # Disallow non-integer values. 217 if {![string is integer -strict [lindex $var $i]]} { 218 error "expected integer but got \"[lindex $var $i]\"" 219 } 220 221 # Increment the value in place. 222 return [lset var $i [expr {[lindex $var $i] + $increment}]] 223 } 224 } 225 } 226 227 # On search failure, add the key to the dict. This code also will 228 # create the dict if it doesn't already exist. 229 ::lappend var $key $increment 230 } 231 232 # [dict info] 233 proc ::dict::info {dictionary} { 234 # Make sure the dictionary is valid. 235 if {[llength $dictionary] & 1} { 236 error "missing value to go with key" 237 } 238 239 # No hash table. 240 return "dict is represented as plain list" 241 } 242 243 # [dict keys] 244 proc ::dict::keys {dictionary {pattern *}} { 245 # Build and return a list of matching keys. 246 ::set result {} 247 foreach {key val} [get $dictionary] { 248 if {[string match $pattern $key]} { 249 ::lappend result $key 250 } 251 } 252 return $result 253 } 254 255 # [dict lappend] 256 proc ::dict::lappend {varName key args} { 257 upvar 1 $varName var 258 259 # Locate the matching key and append a list element to its value. 260 if {[::info exists var]} { 261 ::set var [get $var] 262 ::for {::set i 0} {$i < [llength $var]} {::incr i 2} { 263 if {$key eq [lindex $var $i]} { 264 ::incr i 265 266 # Disallow non-list values. 267 llength [lindex $var $i] 268 269 # Increment the value in place. 270 return [lset var $i [concat [lindex $var $i] $args]] 271 } 272 } 273 } 274 275 # On search failure, add the key to the dict. This code also will 276 # create the dict if it doesn't already exist. 277 ::lappend var $key $args 278 } 279 280 # [dict map] 281 proc ::dict::map {keyVarValueVar dictionary script} { 282 # Confirm argument syntax. 283 if {[llength $keyVarValueVar] != 2} { 284 error "must have exactly two variable names" 285 } 286 287 # Link to local variables which will be used as iterators. 288 upvar 1 [lindex $keyVarValueVar 0] key [lindex $keyVarValueVar 1] val 289 290 # Accumulate and return the result. 291 ::set result {} 292 foreach {key val} [get $dictionary] { 293 ::lappend result $key [uplevel 1 $script] 294 } 295 return $result 296 } 297 298 # [dict merge] 299 proc ::dict::merge {args} { 300 # Confirm each argument is a dict. 301 foreach dict $args { 302 if {[llength $dict] & 1} { 303 error "missing value to go with key" 304 } 305 } 306 307 # Merge the dicts, then normalize. 308 get [eval [list concat] $args] 309 } 310 311 # [dict remove] 312 proc ::dict::remove {dictionary args} { 313 # Remove all dictionary keys matching any of the key arguments. 314 ::set dictionary [get $dictionary] 315 ::set args [lsort -unique $args] 316 ::for {::set i 0} {$i < [llength $dictionary]} {::incr i 2} { 317 ::set index [lsearch -exact -sorted $args [lindex $dictionary $i]] 318 if {$index >= 0} { 319 ::set dictionary [lreplace $dictionary $i [expr {$i + 1}]] 320 ::set args [lreplace $args $index $index] 321 if {![llength $args]} { 322 break 323 } 324 ::incr i -2 325 } 326 } 327 return $dictionary 328 } 329 330 # [dict replace] 331 proc ::dict::replace {dictionary args} { 332 # Confirm correct argument parity. 333 if {[llength $args] & 1} { 334 error "wrong # args:\ 335 should be \"dict replace dictionary ?key value ...?\"" 336 } 337 338 # Concatenate the dicts then use [get] to canonicalize the result. 339 get [eval [list concat $dictionary] $args] 340 } 341 342 # [dict set] 343 proc ::dict::set {varName key args} { 344 upvar 1 $varName var 345 346 # Confirm that a value argument was given. 347 if {![llength $args]} { 348 error "wrong # args:\ 349 should be \"dict set varName key ?key ...? value\"" 350 } 351 352 # Default the dictionary to empty. 353 if {![::info exists var]} { 354 ::set var {} 355 } 356 357 # Shuffle the arguments into the right variables. 358 ::set keys [concat [list $key] [lrange $args 0 end-1]] 359 ::set val [lindex $args end] 360 361 # Traverse through nested dicts to find the key to insert or replace. 362 ::set path {} 363 ::set sub $var 364 ::for {::set i 0} {$i < [llength $keys]} {::incr i} { 365 # Canonicalize each level of nested dicts. 366 lset var $path [::set sub [get $sub]] 367 368 # Search the current level to see if any keys match. 369 ::for {::set j 0} {1} {::incr j 2} { 370 if {$j >= [llength $sub]} { 371 # On match failure, move the remaining keys into the value, 372 # transforming it into a nested dict, then set that value. 373 ::set j [expr {[llength $keys] - 1}] 374 ::for {} {$j > $i} {::incr j -1} { 375 ::set val [list [lindex $keys $j] $val] 376 } 377 lset var $path [concat $sub [list [lindex $keys $i] $val]] 378 return $var 379 } elseif {[lindex $sub $j] eq [lindex $keys $i]} { 380 # On match success, advance to the next level of nesting. 381 break 382 } 383 } 384 385 # Descend into the value associated with the matching key. 386 ::incr j 387 ::lappend path $j 388 ::set sub [lindex $sub $j] 389 } 390 391 # Replace the value of the matched key. 392 lset var $path $val 393 } 394 395 # [dict size] 396 proc ::dict::size {dictionary} { 397 # Canonicalize the dict and return half its length. 398 expr {[llength [get $dictionary]] / 2} 399 } 400 401 # [dict unset] 402 proc ::dict::unset {varName key args} { 403 upvar 1 $varName var 404 405 # Handle the case of the dict not existing. 406 if {![::info exists var]} { 407 if {[llength $args]} { 408 # Fail when unsetting a nested key. 409 error "key \"$key\" not known in dictionary" 410 } else { 411 # Create the dict when unsetting a non-nested key. 412 ::set var {} 413 return 414 } 415 } 416 417 # Traverse through nested dicts to find the key to remove. 418 ::set keys [concat [list $key] $args] 419 ::set path {} 420 ::set sub $var 421 ::for {::set i 0} {1} {::incr i} { 422 # Canonicalize each level of nested dicts. 423 lset var $path [::set sub [get $sub]] 424 425 # Search the current level to see if any keys match. 426 ::for {::set j 0} {$j < [llength $sub]} {::incr j 2} { 427 if {[lindex $sub $j] eq [lindex $keys $i]} { 428 break 429 } 430 } 431 432 # Handle outer and innermost nesting levels differently. 433 if {$i < [llength $keys] - 1} { 434 # In parent levels, search failure is an error. 435 if {$j >= [llength $sub]} { 436 error "key \"[lindex $keys $i]\" not known in dictionary" 437 } 438 439 # Descend into the value associated with the matching key. 440 ::incr j 441 ::lappend path $j 442 ::set sub [lindex $sub $j] 443 } else { 444 # In the innermost level, search failure is acceptable. On 445 # search success, remove the key, otherwise just ignore. 446 if {$j < [llength $sub]} { 447 lset var $path [lreplace $sub $j [expr {$j + 1}]] 448 } 449 450 # Return the updated dictionary. 451 return $var 452 } 453 } 454 } 455 456 # [dict update] 457 proc ::dict::update {varName key valVarName args} { 458 # Confirm argument parity. 459 if {!([llength $args] & 1)} { 460 error "wrong # args: should be \"dict update varName key valVarName\ 461 ?key valVarName ...? script\"" 462 } 463 ::set script [lindex $args end] 464 465 # Convert the list of keys and variable names to an array. 466 array set names [concat [list $key $valVarName] [lrange $args 0 end-1]] 467 468 # Copy the dict values into the caller's variables. 469 upvar 1 $varName dict 470 foreach {key val} [get $dict] { 471 if {[::info exists names($key)]} { 472 upvar 1 $names($key) valVar 473 ::set valVar $val 474 } 475 } 476 477 # Invoke the caller-supplied script. 478 ::set result [uplevel 1 $script] 479 480 # If the dict is gone, let it stay gone. Otherwise update it. 481 if {[::info exists dict]} { 482 # Update the dict values from the caller's variables, and remove 483 # keys corresponding to unset variables. 484 ::for {::set i 0} {$i < [llength $dict]} {::incr i 2} { 485 if {[::info exists names([lindex $dict $i])]} { 486 upvar 1 $names([lindex $dict $i]) valVar 487 ::unset names([lindex $dict $i]) 488 if {[::info exists valVar]} { 489 lset dict [expr {$i + 1}] $valVar 490 } else { 491 ::set dict [lreplace $dict $i [expr {$i + 1}]] 492 ::incr i -2 493 } 494 } 495 } 496 497 # Add keys back to the dict from the caller's variables, in case the 498 # caller removed some keys directly from the dict. 499 foreach {key valVarName} [array get names] { 500 upvar 1 $valVarName valVar 501 if {[::info exists valVar]} { 502 ::lappend dict $key $valVar 503 } 504 } 505 } 506 507 # Return the result of the script. 508 return $result 509 } 510 511 # [dict values] 512 proc ::dict::values {dictionary {pattern *}} { 513 # Build and return a list of matching values. 514 ::set result {} 515 foreach {key val} [get $dictionary] { 516 if {[string match $pattern $val]} { 517 ::lappend result $val 518 } 519 } 520 return $result 521 } 522 523 # [dict with] 524 proc ::dict::with {varName args} { 525 upvar 1 $varName dict 526 527 # Confirm a script argument was supplied. 528 if {![llength $args]} { 529 error "wrong # args:\ 530 should be \"dict with varName ?key ...? script\"" 531 } 532 ::set script [lindex $args end] 533 ::set args [lrange $args 0 end-1] 534 535 # Traverse through nested dicts to find the dict on which to operate. 536 ::set path {} 537 ::set sub [get $dict] 538 foreach key $args { 539 # Canonicalize each level of nested dicts. 540 lset dict $path $sub 541 542 # Search the current level to see if any keys match. 543 ::for {::set i 0} {$i < [llength $sub]} {::incr i 2} { 544 if {[lindex $sub $i] eq $key} { 545 break 546 } 547 } 548 549 # Terminate on match failure. 550 if {$i >= [llength $sub]} { 551 error "key \"$key\" not known in dictionary" 552 } 553 554 # Descend into the value associated with the matching key. 555 ::incr i 556 ::set sub [get [lindex $sub $i]] 557 ::lappend path $i 558 } 559 560 # Copy the dict values into the caller's variables. Make an array to 561 # keep track of all the keys in the dict. 562 foreach {key val} $sub { 563 upvar 1 $key valVar 564 ::set valVar $val 565 ::set keys($key) {} 566 } 567 568 # Invoke the caller-supplied script. 569 ::set result [uplevel 1 $script] 570 571 # If the dict is gone, let it stay gone. Otherwise update it. 572 if {[::info exists dict]} { 573 # Traverse through nested dicts again in case the caller-supplied 574 # script reorganized the dict. 575 ::set path {} 576 ::set sub [get $dict] 577 foreach key $args { 578 # Canonicalize each level of nested dicts. 579 lset dict $path $sub 580 581 # Search the current level to see if any keys match. 582 ::for {::set i 0} {$i < [llength $sub]} {::incr i 2} { 583 if {[lindex $sub $i] eq $key} { 584 break 585 } 586 } 587 588 # Terminate on match failure. 589 if {$i >= [llength $sub]} { 590 error "key \"$key\" not known in dictionary" 591 } 592 593 # Descend into the value associated with the matching key. 594 ::incr i 595 ::set sub [get [lindex $sub $i]] 596 ::lappend path $i 597 } 598 599 # Update the dict values from the caller's variables, and remove 600 # keys corresponding to unset variables. 601 ::for {::set i 0} {$i < [llength $sub]} {::incr i 2} { 602 if {[::info exists keys([lindex $sub $i])]} { 603 upvar 1 [lindex $sub $i] valVar 604 ::unset keys([lindex $sub $i]) 605 if {[::info exists valVar]} { 606 lset sub [expr {$i + 1}] $valVar 607 } else { 608 ::set sub [lreplace $sub $i [expr {$i + 1}]] 609 ::incr i -2 610 } 611 } 612 } 613 614 # Add keys back to the dict from the caller's variables, in case the 615 # caller removed some keys directly from the dict. 616 foreach key [array names keys] { 617 upvar 1 $key valVar 618 if {[::info exists valVar]} { 619 ::lappend sub $key $valVar 620 } 621 } 622 623 # Save the updated nested dict back into the dict variable. 624 lset dict $path $sub 625 } 626 627 # Return the result of the script. 628 return $result 629 } 630 }