Posted to tcl by aspect at Mon Jan 06 18:33:05 GMT 2014view raw
- # options is on the wiki, [log] is trivial
- package provide modified 0.1
- package require options
- namespace eval modified {
- proc array_eq {array1 array2} {
- upvar 1 $array1 foo $array2 bar
- if {![array exists foo]} {
- return -code error "$array1 is not an array"
- }
- if {![array exists bar]} {
- return -code error "$array2 is not an array"
- }
- if {[array size foo] != [array size bar]} {
- return 0
- }
- if {[array size foo] == 0} {
- return 1
- }
- set keys [lsort -unique [concat [array names foo] [array names bar]]]
- if {[llength $keys] != [array size foo]} {
- return 0
- }
- foreach key $keys {
- if {$foo($key) ne $bar($key)} {
- return 0
- }
- }
- return 1
- }
- proc init args {
- options {-backingvar {}} ;# doesn't really work
- arguments {_var}
- if {$backingvar eq ""} {
- set backingvar back__${_var}
- }
- set ns [uplevel 1 namespace current]
- if {$ns eq "::"} {set ns ""}
- upvar 1 $_var var
- log debug "using backing var: ${ns}::${backingvar}"
- upvar #0 ${ns}::${backingvar} var_back
- if {[array exists var]} {
- array set var_back [array get var]
- } else {
- set var_back $var
- }
- }
- proc test args {
- options {-backingvar {}} ;# doesn't really work
- arguments {_var}
- if {$backingvar eq ""} {
- set backingvar back__${_var}
- }
- set ns [uplevel 1 namespace current]
- if {$ns eq "::"} {set ns ""}
- upvar 1 $_var var
- upvar #0 ${ns}::${backingvar} var_back
- if {[array exists var]} {
- return [expr {![array_eq var var_back]}]
- } else {
- return [expr {$var ne $var_back}]
- }
- }
- namespace export init test
- namespace ensemble create
- }
- # array set foo {a 1 b 2}
- # modified init foo
- # incr foo(b)
- # modified test foo
- # modified test foo(a) ;# bonus