#
# $Source: /home/nlfm/Working/Zircon/Released/lib/RCS/Object.tcl,v $
# $Date: 2001/07/12 15:35:50 $
# $Revision: 1.18.1.20 $
#
# ----------------------------------------------------------------------
#   AUTHOR:  Lindsay Marshall <lindsay.marshall@newcastle.ac.uk>
# ----------------------------------------------------------------------
# Copyright 2000 The University of Newcastle upon Tyne (see COPYRIGHT)
# ======================================================================
#
package provide zircon 1.18
#
proc objName {class} {
    global OType
    set n [newName $class]
    set OType($n) $class
    return $n
}
#
proc newName {thing} {
    global zircon
    return [string tolower $thing][incr zircon(nameCount)]
}
#
proc class {name vars args} {
    # FRINK: nocheck
    global $name Private.$name Configure.$name
    # FRINK: nocheck
    set $name {}
    foreach {x y z} $vars {
	# FRINK: nocheck
	lappend $name $x $y
	# FRINK: nocheck
	set Configure.${name}($x) $z
    }
    if {$args != {}} {
	# FRINK: nocheck
        set Private.$name [lindex $args 0]
    }
}
#
proc initObj {name args} {
    foreach x $args {
	uplevel #0 "array set $name \[set $x\]"
	catch {uplevel #0 "array set $name \[set Private.$x\]"}
    }
}
#
proc makeObj {types pars} {
    set mt [lindex $types end]
    set this [objName $mt]
    eval initObj $this $types
    uplevel #0 set ${this}(name) $this
    set mt [string tolower $mt]
    switch {} [info procs ${mt}_call] {
	proc $this {unusedop args} "objCall $mt $this \$unusedop \$args"
    } default {
        proc $this {unusedop args}  "${mt}_call $this \$unusedop \$args"
    }
    eval $this configure $pars
    return $this
}
#
proc makeNObj {name net types pars} {
    set mt [lindex $types end]
    set this [objName $mt]
    eval initObj $this $types
    upvar #0 $this odata
    switch {} $name { array set odata [list name $this net $net] } default {
	array set odata [list name $name net $net]
    }
    set mt [string tolower $mt]
    $net register ${mt}s $this
    switch {} [info procs ${mt}_call] {
	proc $this {unusedop args} "objCall $mt $this \$unusedop \$args"
    } default {
        proc $this {unusedop args}  "${mt}_call $this \$unusedop \$args"
    }
    eval $this configure $pars
    return $this
}
#
proc objCall {kind this op pars} {
    upvar #0 $this odata
    if {[info exists odata($op)]} {return $odata($op)}
    return [eval ${kind}_$op $this $pars]
}
#
proc confObj {this pars} {
    upvar #0 $this odata
    foreach {x y} $pars { set odata([string range $x 1 end]) $y}
}
#
proc clone {obj} {
    global OType Clone
    upvar #0 $obj data
    set nn [newName $OType($obj)]
    upvar #0 $nn cdata
    array set cdata [array get data]
    proc $nn {unusedop args} "objCall [string tolower $OType($obj)] $nn \$unusedop \$args"
    set OType($nn) $OType($obj)
    set Clone($nn) $obj
    return $nn
}
#
proc unclone {this} {
    global OType Clone
    upvar #0 $this cdata
    if {![info exists Clone($this)]} { return 0 }
    set mt $Clone($this)
    set typ $OType($this)
    # FRINK: nocheck
    global Configure.$typ
    # FRINK: nocheck
    foreach x [array names Configure.$typ] {
        if {[$mt $x] != $cdata($x)} { $mt configure -$x $cdata($x) }
    }
    # FRINK: nocheck
    unset cdata $OType($this) Clone($this)
    rename $this {}
    return 1
}