#----------------------------------------------------------------------
#				-- obTcl --
#
# `obTcl' is a Tcl-only object- and Megawidget-extension.
#
# The system supports multiple inheritance, three new storage classes,
# and fully transparent Tk-megawidgets.
#
# Efficiency is obtained through method-resolution caching.
# obTcl provides real instance variables and class variables
# (they may be arrays).  Two types of class variables are provided:
# definition-class scoped, and instance-class scoped.
#
# The mega-widget support allows creation of mega-widgets which handle
# like ordinary Tk-widgets; i.e can be "packed", "deleted", "placed" etc,
# intermixed with ordinary Tk-widgets.
# The transparency of the mega-widget extension has been tested by
# wrapping all normal Tk-widgets into objects and running the standard
# "widget" demo provided with Tk4.0.
# 
# To try out obTcl, just start `wish' (Tk4.0 or later) and do "source demo".
# Alternatively run "demo" directly (requires that wish can be located
# by demo).
#
# If you run `wish' interactively and source `obtcl', you will be able to
# type "help" to access a simple help system.
#
# Pronunciation: `obTcl' sounds like "optical".
#
# See COPYRIGHT for copyright information.
#
# Please direct comments, ideas, complaints, etc. to:
#
#	patrik@dynas.se
# 
#   Patrik Floding
#   DynaSoft AB
#
#----------------------------------------------------------------------

if { [info exists env(OBTCL_LIBRARY)] } {
	set OBTCL_LIBRARY $env(OBTCL_LIBRARY)
}
if { ![info exists OBTCL_LIBRARY] || "$OBTCL_LIBRARY" == "" } {
	set OBTCL_LIBRARY "."
}

set obtcl_version "0.5"

# Get generic utility stuff
#
source ${OBTCL_LIBRARY}/utils.tcl

proc instvar2global { name } {
	upvar 1 class class self self
	return _oIV_${class}:${self}:$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
	}"
}

# Instance variables. Specific to instances.
proc instvar_of_class { class args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oIV_${class}:\${self}:\$_obTcl_i \$_obTcl_i
	}"
}
# Instance variables. Specific to instances.
proc instvar { args } {
	uplevel 1 "foreach _obTcl_i [list $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" vaiables (as opposed to "instvars").
#
proc import { class args } {
	uplevel 1 "foreach _obTcl_i [list $args] {
		upvar #0 _oIV_${class}:\${self}:\$_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"
}

# Check if an object exists
#
proc is_object { name } {
	global _obTcl_Objects
	if [info exists _obTcl_Objects($name)] {
		return 1
	} else {
		return 0
	}
}
# Check if a class exists
#
proc is_class { name } {
	global _obTcl_Classes
	if [info exists _obTcl_Classes($name)] {
		return 1
	} else {
		return 0
	}
}

#----------------------------------------------------------------------
# new	Creates a new object.  Creation involves creating a proc with
#	the name of the object, initializing some house-keeping data,
#	call `initialize' to set init any option-variables,
#	and finally calling the `init' method for the newly created object.
#
# 951024. Added rename of any existing command to facilitate wrapping
# of existing widgets/commands. Only one-level wrapping is supported.

proc new { iclass obj args } {
	global _obTcl_Objclass _obTcl_Objects
	set _obTcl_Objclass($iclass,$obj) $obj

	if ![info exists _obTcl_Objects($obj)] {
		catch {rename $obj ${obj}-cmd}
	}

	set _obTcl_Objects($obj) 1
	proc $obj { cmd args } "
		set self $obj
		set iclass $iclass

		if \[catch {eval {$iclass::\$cmd} \$args} val\] {
			return -code error \
			  -errorinfo \"$obj: \$val\" \"$obj: \$val\"
		} else {
			return \$val
		}
	"
	set self $obj
	eval {$iclass::initialize}
	eval {$iclass::init} $args
}

#----------------------------------------------------------------------
# freeObj
#	Unset all instance variables.
#
proc freeObj { obj } {
	global _obTcl_Objclass _obTcl_Objects
	getSelf
	catch {uplevel #0 "eval unset _obTcl_Objclass($iclass,$obj) \
			_obTcl_Objects($obj) \
			\[info vars _oIV_*:${self}:*\]"}
	catch {rename $obj {}}
}

setIfNew _obTcl_Classes() ""
setIfNew _obTcl_NoClasses 0

proc class { class } {
	global _obTcl_NoClasses _obTcl_Classes _obTcl_Inherits

	if [info exists _obTcl_Classes($class)] {
		dbputs "Redefined existing class: $class"
		set self $class
		classDestroy $class
	}
	if [string match "*:*" $class] {
		puts stderr "class: Fatal Error:"
		puts stderr "       class name `$class'\
				contains reserved character `:'"
		return
	}
	incr _obTcl_NoClasses 1
	set _obTcl_Classes($class) 1

	set iclass $class; set obj $class;

	proc $class { cmd args } "
		set self $obj
		set iclass $iclass

		switch -glob \$cmd {
		{.*}		{ eval {new $class \$cmd} \$args }
		{new}		{ eval {new $class} \$args }
		{method}	{ eval {mkMethod N $class} \$args}
		{sys_method}	{ eval {mkMethod S $class} \$args}
		{del_method}	{ eval {rmMethod $class} \$args}
		{inherit}	{ eval {inherit $class} \$args}
		{destroy}	{ eval {classDestroy $class} \$args }
		{init}		{ return -code error \
		     -errorinfo \"$obj: Error: classes may not be init'ed!\" \
				\"$obj: Error: classes may not be init'ed!\"
		}
 		default		{
			if \[catch {eval {$iclass::\$cmd} \$args} val\] {
				return -code error \
				  -errorinfo \"$obj: \$val\" \"$obj: \$val\"
			} else {
				return \$val
			}
		 }
		}
	"

	if { "$class" != "Base" } {
		$class inherit "Base"
	} else {
		set _obTcl_Inherits($class) {}
	}
	return $class
}
proc classDestroy { class } {
	global _obTcl_NoClasses _obTcl_Classes ;# _obTcl_CacheStop
	getSelf

	if ![info exists _obTcl_Classes($class)] { return }
	InvalidateCaches 0 $class [classInfoMethods $class]
	delAllMethods $class
	rename $class {}
	incr _obTcl_NoClasses -1
	unset _obTcl_Classes($class)

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

# getSelf -
#   Bring caller's ID into scope.  For performance reasons
#   an "inlined" (copied) version is used in many places.  Theses places
#   are located by searching for the word 'getSelf', which should occur
#   in a comment near the "inlining".
#
proc getSelf {} {
	uplevel 1 {upvar 1 self self iclass iclass Umethod method}
}

# getSelf inlined
proc mkMethod { mode class name params body } {
	InvalidateCaches 0 $class $name

	if { "$name" == "unknown" } {
		set method ""
	} else {
		set method "set method $name"
	}
	proc $class::$name $params \
		"upvar 1 self self iclass iclass Umethod method
set class $class
$method

$body"
	if { $mode == "S" } {
		global _obTcl_SysMethod
		set _obTcl_SysMethod($class::$name) 1
	}
}

# getSelf inlined
proc Old_mkMethod { class args } {
	set name [lindex $args 0]
	set params [lindex $args 1]
	set body [lindex $args 2]

	InvalidateCaches 0 $class $name

	if { "$name" == "unknown" } {
		set method ""
	} else {
		set method "set method $name"
	}
	proc $class::$name $params \
		"upvar 1 self self iclass iclass Umethod method
set class $class
$method

$body"
}

proc rmMethod { class name } {
	global _obTcl_SysMethod

	if { "$name" == "unknown" } {
		InvalidateCaches 0 $class *
	} else {
		InvalidateCaches 0 $class $name
	}
	rename $class::$name {}
	catch {unset _obTcl_SysMethod($class::$name)}
}

proc delAllMethods { class } {
	global _obTcl_Cached
	foreach i [info procs $class::*] {
		if [info exists _obTcl_SysMethod($i)] {
			continue
		}
		if [info exists _obTcl_Cached($i)] {
			unset _obTcl_Cached($i)
		}
		rename $i {}
	}
}
proc objinfoVars { glob base { match "" } } {
	if { "$match" == "" } { set match "*" }
	set l [info globals ${glob}$match]
	set all {}
	foreach i $l {
		regsub "${base}(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc objinfoObjects { class } {
	global _obTcl_Objclass
	set l [array names _obTcl_Objclass $class,*]
	set all {}
	foreach i $l {
		regsub "${class},(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc classInfoBody { class method } {
	global _obTcl_Objclass _obTcl_Cached
	if [info exists _obTcl_Cached(${class}::$method)] { return }
	if [catch {set b [info body ${class}::$method]} ret] {
		return -code error \
		  -errorinfo "info body: Method '$method' not defined in class $class" \
			"info body: Method '$method' not defined in class $class"
	} else {
		return $b
	}
}
proc classInfoArgs { class method } {
	global _obTcl_Objclass _obTcl_Cached
	if [info exists _obTcl_Cached(${class}::$method)] { return }
	if [catch {set b [info args ${class}::$method]} ret] {
		return -code error \
		  -errorinfo "info args: Method '$method' not defined in class $class" \
			"info args: Method '$method' not defined in class $class"
	} else {
		return $b
	}
}
proc classInfoMethods+Cached { class } {
	global _obTcl_Objclass _obTcl_SysMethod
	set l [info procs ${class}::*]
	set all {}
	foreach i $l {
		regsub "${class}::(.*)" $i {\1} tmp
		if [info exists _obTcl_SysMethod($i)] { continue }
		lappend all $tmp
	}
	return $all
}
proc classInfoMethods { class } {
	global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
	set l [info procs ${class}::*]
	set all {}
	foreach i $l {
		if [info exists _obTcl_Cached($i)] { continue }
		if [info exists _obTcl_SysMethod($i)] { continue }
		regsub "${class}::(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc classInfoSysMethods { class } {
	global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
	set l [info procs ${class}::*]
	set all {}
	foreach i $l {
		if [info exists _obTcl_Cached($i)] { continue }
		if ![info exists _obTcl_SysMethod($i)] { continue }
		regsub "${class}::(.*)" $i {\1} tmp
		lappend all $tmp
	}
	return $all
}
proc classInfoCached { class } {
	global _obTcl_Objclass _obTcl_Cached _obTcl_SysMethod
	if ![array exists _obTcl_Cached] {
		return
	}
	set l [array names _obTcl_Cached $class::*]
	set all {}
	foreach i $l {
		regsub "${class}::(.*)" $i {\1} tmp
		if [info exists _obTcl_SysMethod($i)] { continue }
		lappend all $tmp
	}
	return $all
}

# Get inheritance functionality
#
source ${OBTCL_LIBRARY}/inherit.tcl

# Get the Base and Widget classes
#
source ${OBTCL_LIBRARY}/base.tcl

