# NOTE: If the name of this file is "vars.tcl", don't edit it!!!
# vars.tcl is made from either of vars1_tcl or vars2_tcl (which one
# depends on ../Makefile
#----------------------------------------------------------------------
# This file contains one implementation of the obTcl storage
# classes `instvar', `classvar' and `iclassvar', procedures to
# obtain information on existing variables, and procedures to
# free information used by objects/classes.
#
# No knowledge about the internals of this implementation should be
# used outside of this file!
#----------------------------------------------------------------------
# This implementation uses one global variable for each
# instvar/classvar/iclassvar.  The variable names are prefixed with
# class and, for instvars, object name.
#----------------------------------------------------------------------
proc initVars {} {}

proc instvar2global name {
	upvar 1 class class self self
	return _oIV_$class:$self:$name
}

proc iclassvar2global name {
	upvar 1 iclass iclass self self
	return _oICV_$iclass:$name
}

proc classvar2global name {
	upvar 1 class class self self
	return _oDCV_$class:$name
}

# Class variables of definition class

proc classvar args {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oDCV_\$class:\$_obTcl_i \$_obTcl_i
	}"
}

# Class variables of specified class
proc classvar_of_class { class args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oDCV_$class:\$_obTcl_i \$_obTcl_i
	}"
}

# Class variables of instance class
proc iclassvar args {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oICV_\$iclass:\$_obTcl_i \$_obTcl_i
	}"
}

# Iclass variables of specified class
proc iclassvar_of_class { iclass args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oICV_$iclass:\$_obTcl_i \$_obTcl_i
	}"
}

# Instance variables. Specific to instances.
# instvar: Has twin in obtcl.c!
# 
proc instvar args {
	uplevel 1 [list foreach _obTcl_i $args {
		upvar #0 _oIV_$class:$self:$_obTcl_i $_obTcl_i
	}]
}

# Make instvar from `class' available
# Use with caution!  I might put these variables in a separate category
# which must be "exported" variables (as opposed to "instvars").
#
proc instvar_of_class { class args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oIV_$class:\$self:\$_obTcl_i \$_obTcl_i
	}"
}

if {"[info commands instvarInspect]" == "" } {
    proc instvarTrace args {
	uplevel 1 "foreach _obTcl_i [list $args] {
upvar #0 _oIV_\$class:\$self:\$_obTcl_i \$_obTcl_i}
uplevel #0 \"set _obTcl_IV_trace \$self\""
    }
}

# Instance variables of specified class and object
proc specified_instvar { class obj args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oIV_${class}:${obj}:\$_obTcl_i \$_obTcl_i
	}"
}

# Renamed Instance variable. Specific to instances.
proc renamed_instvar { normal_name new_name } {
	uplevel 1 "upvar #0 _oIV_\${class}:\${self}:$normal_name $new_name"
}

#----------------------------------------------------------------------
# Get info on vars:
#
proc otInfoIV { class self {match ""} } {
	if ![string compare "" $match] { set match * }
	set l [info globals [concat _oIV_$class:$self]$match]
	set all {}
	foreach i $l {
		regsub "_oIV_$class:$self:(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc otInfoICV { class {match ""} } {
	if ![string compare "" $match] { set match * }
	set l [info globals [concat _oICV_$class]$match]
	set all {}
	foreach i $l {
		regsub "_oICV_$class:(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc otInfoDCV { class {match ""} } {
	if ![string compare "" $match] { set match * }
	set l [info globals [concat _oDCV_$class]$match]
	set all {}
	foreach i $l {
		regsub "_oDCV_$class:(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}

# OLD:
proc otObjInfoVars { glob base { match "" } } {
	if ![string compare "" $match] { set match * }
	set l [info globals ${glob}$match]
	set all {}
	foreach i $l {
		regsub "${base}(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}

# For debugging obTcl only:
#
proc otObjInfoLostVars {} {

	foreach i [uplevel #0 info vars _oIV_*] {
		set IV($i) 1
	}
	foreach i [uplevel #0 array names _obTcl_Objects] {
		foreach j [uplevel #0 info vars _oIV_*:$i:*] {
			unset IV($j)
		}
	}
	foreach i [uplevel #0 array names _obTcl_Classes] {
		foreach j [uplevel #0 info vars _oIV_*:$i:*] {
			unset IV($j)
		}
	}
	if { [array size IV] > 0 } {
		puts "Orphaned instvars:"
		puts stdout [array names IV]
	}
	foreach i [uplevel #0 info vars _oICV_*] {
		set ICV($i) 1
	}
	foreach i [uplevel #0 array names _obTcl_Classes] {
		foreach j [uplevel #0 info vars _oICV_$i:*] {
			unset ICV($j)
		}
	}
	if { [array size ICV] > 0 } {
		puts "Orphaned iclassvars:"
		puts stdout [array names ICV]
	}
	foreach i [uplevel #0 info vars _oDCV_*] {
		set DCV($i) 1
	}
	foreach i [uplevel #0 array names _obTcl_Classes] {
		foreach j [uplevel #0 info vars _oDCV_$i:*] {
			unset DCV($j)
		}
	}
	if { [array size DCV] > 0 } {
		puts "Orphaned classvars:"
		puts stdout [array names DCV]
	}
}

#----------------------------------------------------------------------
# otFreeObj
#	Unset all instance variables.
#
proc otFreeObj obj {
	uplevel #0 "eval {unset _obTcl_Owner($obj) _obTcl_Objects($obj)} \
			\[info vars _oIV_*:$obj:*\]"
}

# NOTE: The catch is so the case with no instvars won't cause trouble
#
proc otFreeClassObj obj {
	otGetSelf
	uplevel #0 "catch {eval unset \[info vars _oIV_*:${self}:*\]}"
}

proc otFreeCV class {
	uplevel #0 "
		foreach _iii  \[info vars [list _oICV_$class:*]\] {
			unset \$_iii
		}
		foreach _iii  \[info vars [list _oDCV_$class:*]\] {
			unset \$_iii
		}
		catch {unset _iii}
	"
}
