# 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
#----------------------------------------------------------------------
# - EXPERIMENTAL - EXPERIMENTAL - EXPERIMENTAL - EXPERIMENTAL - EXPERIM
#
# 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 upvars into one global array for all
# instvars.  iclassvars and classvars are still implemented as in
# vars1_tcl.
#
# This implementation is intended to be used with the DLL module.
# The DLL module implements the command `uv_unset' which is used
# to remove global-level upvars (which are created by `instvar2global'.
# Using it without the DLL will result in dangling global upvars
# (if you use `instvar2global').
#----------------------------------------------------------------------
# - EXPERIMENTAL - EXPERIMENTAL - EXPERIMENTAL - EXPERIMENTAL - EXPERIM
#
# NOTE: This implementation is unlikely to be completed, as using upvars
#	in this way is currently not supported by the SUN team!
#----------------------------------------------------------------------

proc initVars {} {}

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

procIfNew 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
procIfNew 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
	}"
}

proc instvar2global name {
	upvar 1 class class self self
	set nm [list $class:$name]
	set fname [list _oIV_$class:$self:$name]
	uplevel #0 upvar 0 _oIV($self) _tmp
	uplevel #0 upvar 0 _tmp($nm) $fname
	uplevel #0 upvar 0 _oIVg($self) _i2g
	uplevel #0 set _i2g($fname) 1
	return $fname
}
#	uplevel 1 global $fname

# Instance variables. Specific to instances.
# instvar: Has twin in obtcl.c!
#
procIfNew instvar args {
	uplevel 1 "upvar #0 _oIV(\$self) _iv
	foreach _ii [list $args] {
		upvar 0 _iv(\$class:\$_ii) \$_ii
	}"
}

# 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 } {
	upvar 1 self self
	uplevel 1 "upvar #0 _oIV($self) _iv;
		foreach _ii [list $args] {
		upvar 0 _iv($class:\$_ii) \$_ii
	}"
}

# FIXME
if {"[info commands instvarInspect]" == "" } {
    procIfNew 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 "upvar #0 _oIV($obj) _iv;
		foreach _i [list $args] {
		upvar 0 _iv($class:\$_i) \$_i
	}"
}

# Renamed Instance variable. Specific to instances.
proc renamed_instvar { normal_name new_name } {
	uplevel 1 "upvar #0 _oIV(\$self) _iv;
		upvar 0 _iv(\[list \$class:$normal_name\]) $new_name"
}

#----------------------------------------------------------------------
# otFreeObj
#	Unset all instance variables.
#
proc otFreeObj obj {
	uplevel #0 "unset _obTcl_Owner(\[list $obj\]) _obTcl_Objects(\[list $obj\]); \
		upvar 0 _oIV($obj) _tmp; catch {unset _tmp}"
	uplevel #0 "upvar 0 _oIVg($obj) _tmp;
		eval uv_unset \[array names _tmp\]"
	uplevel #0 "catch {unset _oIVg($obj)}"
}

procIfNew uv_unset args {}

# NOTE: The catch is so the case with no instvars won't cause trouble
#
proc otFreeClassObj obj {
	uplevel #0 "catch {eval unset _oIV($obj)}"
}

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}
	"
}

#----------------------------------------------------------------------
# Get info on vars:
#
proc otInfoIV { class self {match ""} } {
	upvar #0 _oIV($self) _iv
	set all {}
	foreach i [array names _iv] {
		regsub "$class:(.*)" $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
}

# For debugging obTcl:
#
proc obj_instvars {{obj *}} {
	global _oIV
	set all {}
	foreach i [eval array names _oIV $obj] {
		upvar 0 _oIV($i) _tmp
		foreach j [array names _tmp] {
			lappend all [concat $i:$j]
		}
	}
	return $all
}

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]
	}
}
