deref

# deref.tcl
 #
 # Copyright 2001 by Larry Smith
 # Wild Open Source, Inc
 # License: BSD
 #
 # deref will return the value of the given variable name.
 # If followed by an integer count, it will continue to
 # dereference the name until it reaches the specified
 # depth.  If no depth is specified, it will continue to
 # dereference until a value is found not starting with
 # a $.

 proc name { varname { depth 0 } } {
  set prevname ""
  if { $depth == 0 } {
    set varname \$$varname
    while { [ string index $varname 0] == "\$" } {
      set varname [ string range $varname 1 end ]
      set prevname $varname
      set varname [ uplevel set $varname ]
    }
  }
  for { set i 0 } { $i < $depth } { incr i } {
    set prevname $varname
    set varname [ uplevel set $varname ]
  }
  return $prevname
 }

 proc value { varname { depth 0 } } {
  if { $depth == 0 } {
    set varname \$$varname
    while { [ string index $varname 0] == "\$" } {
      set varname [ string range $varname 1 end ]
      set varname [ uplevel set $varname ]
    }
  }
  for { set i 0 } { $i < $depth } { incr i } {
    set varname [ uplevel set $varname ]
  }
  return $varname
 }




#----------------------------------

# test and demo

 source deref.tcl

 set a b
 set b c
 set c d

 if { "d" == "[value a 3 ]" } {
  puts "test 1: pass" } else { puts "test 1: fail" }
 set [ name a 3 ] "x"

 if { "x" == "[value a 3 ]" } {
  puts "test 2: pass" } else { puts "test 2: fail" }

 set a \$b
 set b \$c
 set c d

 if { "d" == "[ value a ]" } {
  puts "test 3: pass" } else { puts "test 3: fail" }

 set [ name a ] "x"
 if { "x" == "[value a ]" } {
  puts "test 4: pass" } else { puts "test 4: fail" }

 set a x
 if { "x" == "[ value a ]" } {
  puts "test 5: pass" } else { puts "test 5: fail" }

 set [name a] "y"
 if { "y" == "[ value a ]" } {
  puts "test 6: pass" } else { puts "test 6: fail" }

 set [name a 1 ] "x"
 if { "x" == "[ value a 1 ]" } {
  puts "test 7: pass" } else { puts "test 7: fail" }
Category Uncategorized