Posted to tcl by aspect at Mon Jan 06 18:33:05 GMT 2014view raw

  1. # options is on the wiki, [log] is trivial
  2. package provide modified 0.1
  3. package require options
  4.  
  5.  
  6. namespace eval modified {
  7. proc array_eq {array1 array2} {
  8. upvar 1 $array1 foo $array2 bar
  9. if {![array exists foo]} {
  10. return -code error "$array1 is not an array"
  11. }
  12. if {![array exists bar]} {
  13. return -code error "$array2 is not an array"
  14. }
  15. if {[array size foo] != [array size bar]} {
  16. return 0
  17. }
  18. if {[array size foo] == 0} {
  19. return 1
  20. }
  21.  
  22. set keys [lsort -unique [concat [array names foo] [array names bar]]]
  23. if {[llength $keys] != [array size foo]} {
  24. return 0
  25. }
  26.  
  27. foreach key $keys {
  28. if {$foo($key) ne $bar($key)} {
  29. return 0
  30. }
  31. }
  32. return 1
  33. }
  34. proc init args {
  35. options {-backingvar {}} ;# doesn't really work
  36. arguments {_var}
  37.  
  38. if {$backingvar eq ""} {
  39. set backingvar back__${_var}
  40. }
  41. set ns [uplevel 1 namespace current]
  42. if {$ns eq "::"} {set ns ""}
  43.  
  44. upvar 1 $_var var
  45. log debug "using backing var: ${ns}::${backingvar}"
  46. upvar #0 ${ns}::${backingvar} var_back
  47.  
  48. if {[array exists var]} {
  49. array set var_back [array get var]
  50. } else {
  51. set var_back $var
  52. }
  53. }
  54. proc test args {
  55. options {-backingvar {}} ;# doesn't really work
  56. arguments {_var}
  57.  
  58. if {$backingvar eq ""} {
  59. set backingvar back__${_var}
  60. }
  61. set ns [uplevel 1 namespace current]
  62. if {$ns eq "::"} {set ns ""}
  63.  
  64. upvar 1 $_var var
  65. upvar #0 ${ns}::${backingvar} var_back
  66.  
  67. if {[array exists var]} {
  68. return [expr {![array_eq var var_back]}]
  69. } else {
  70. return [expr {$var ne $var_back}]
  71. }
  72. }
  73. namespace export init test
  74. namespace ensemble create
  75. }
  76.  
  77. # array set foo {a 1 b 2}
  78. # modified init foo
  79. # incr foo(b)
  80. # modified test foo
  81. # modified test foo(a) ;# bonus