Posted to tcl by aspect at Sun May 15 10:47:53 GMT 2011view raw

  1. # Illustration for how [global] and [variable] (mostly) can be implemented
  2. # in terms of [upvar]
  3.  
  4. # http://www.tcl.tk/man/tcl8.6/TclCmd/global.htm
  5. proc global {args} {
  6. foreach name $args {
  7. uplevel 1 [list upvar #0 $name [namespace tail $name]]
  8. }
  9. }
  10.  
  11. # http://www.tcl.tk/man/tcl8.6/TclCmd/variable.htm
  12. proc variable {args} {
  13. # from outside a [proc] this should just do set
  14. if {"namespace" == [lindex [dict get [info frame 1] cmd] 0]} {
  15. if {[llength $args] == 1} {
  16. # we cannot create undefined variables, so we break the spec
  17. # but setting $var = {}
  18. uplevel 1 [list set $args {}]
  19. } else {
  20. foreach {name val} $args {
  21. uplevel 1 [list set $name $val]
  22. }
  23. }
  24. } else {
  25. set ns [uplevel 1 {namespace current}]
  26. if {[llength $args] == 1} {
  27. set localname [namespace tail $name]
  28. if [string match ::* $name] {
  29. set upname $name
  30. } else {
  31. set upname $ns::$name
  32. }
  33. uplevel 1 [list upvar #0 $upname $localname]
  34. }
  35. foreach {name val} $args {
  36. set localname [namespace tail $name]
  37. if [string match ::* $name] {
  38. set upname $name
  39. } else {
  40. set upname $ns::$name
  41. }
  42. uplevel 1 [list upvar #0 $upname $localname]
  43. uplevel 1 [list set $name $val]
  44. }
  45. }
  46. }
  47.