Types.itcl   [plain text]

# -*-Tcl-*-
#
# This [incr Tcl] library script contains type definitions
#
#
# Type super class
#

if {[string length [info commands debug]] == 0} {
    proc debug {args} {}
}

class Type {
    variable _value
    variable _valueSaved
    variable _voidPtr
    variable _bVoid
    protected variable _currentNamespace
    protected variable _lProc
    protected variable _upLevel

    constructor args {
	debug {======= Constructor: [info class] $this $args} 3
	# Go up in the inheritance tree
	debug {        Go up inheritance tree} 4
	set level 1
	if {[string compare [info class] ::Type] != 0} {
	    debug {        level set to >1<} 5
	    while {[string compare [info class] \
		    [uplevel $level {namespace current}]] != 0} {
		debug {>[info class]< != >[uplevel $level\
			{namespace current}]<} 5
		incr level
		debug {        level incrmented to >$level<} 5
	    }
	    debug {>[info class]< == >[uplevel $level\
		    {namespace current}]<} 5
	    incr level
	    regsub {^::} [uplevel $level {namespace current}] "" currentNamespace
	} else {
	    regsub {^::} [uplevel {namespace current}] "" currentNamespace
	}
	set upLevel [expr [info level] - $level]
	set lProc [info level $upLevel]
	debug {    Called from level: >$upLevel<} 4
	debug {    Called from      : >$lProc<} 4
	debug {    Current namespace: >$currentNamespace<} 4
	#catch {puts "     [uplevel "info body [lindex $lProc 0]"]"}
	set _bVoid 0
	set _voidPtr 0
	if {[llength $args] > 0} {
	    set _value [lindex $args 0]
	} else {
	    set  _value ""
	}
	if {$upLevel == 0} {
	    debug {Called from global} 4
	    set $this $_value
	    debug {this variable: [set $this]} 4
	    trace variable $this rwu traceType
	} elseif {[string length $currentNamespace] && \
		[string length $lProc]} {
	    debug {Called from procedure in namespace} 4
	    debug {   this: >$this<} 4
	    debug {set $this >$_value<}
	    catch {
		uplevel #$upLevel set [namespace tail $this] \"$_value\"
		uplevel #$upLevel trace variable [namespace tail $this] \
			rwu traceType
	    } szErrMsg; debug {    szErrMsg: >$szErrMsg<} 4
	} elseif {[string length $currentNamespace]} {
	    debug {Called from namespace} 4
	    debug {set $this >$_value<}
	    catch {
		namespace eval ${currentNamespace} "set $this \"$_value\"\n\
			trace variable $this rwu traceType"
	    } szErrMsg
	    debug {    TRACE set} 4
		debug {    szErrMsg: >$szErrMsg<} 4
	} else {
	    debug {Called from procedure} 4
	    set var [namespace tail $this]
	    uplevel "set $var $_value"
	    debug {this variable: [uplevel "set $var"]} 4
	    uplevel "trace variable $var rwu traceType"
	}
    }

    destructor {
	debug {======= destructor $this} 3
	set calledFrom [lindex [split [info level [expr [info level] - 1]]] 0]
	debug {        calledFrom: >$calledFrom<} 4
	debug {        >[info level [expr [info level] - 1]]<} 4
	# just return when called from traceType
	if {[string compare $calledFrom "traceType"] != 0} {
	    set var [namespace tail $this]
	    debug {   var: >$var<} 4
	    debug {        >[join [trace vinfo $var]]<} 4
	    debug {        >[uplevel [join [trace vinfo $var]]]<} 4
	    debug {        >[join [uplevel "trace vinfo $var"]]<} 4
	    catch {
		debug {eval uplevel \"trace vdelete $var [join [uplevel "trace vinfo $var"]]\"} 4
		eval uplevel "trace vdelete $var [join [uplevel "trace vinfo $var"]]"
		uplevel unset $var
	    } szErrMsg; debug {   #### szErrMsg: >$szErrMsg<} 4
	}
    }

    public method value {args} {
	if {[llength $args] > 0} {
	    set _value [lindex $args 0]
	}
	return $_value
    }

    public method setNull {{ptr 0}} {
	set _voidPtr $ptr
	set _bVoid 1
    }

    public method unsetNull {} {
	set _bVoid 0
    }

    public method isNull {} {
	return $_bVoid
    }

    public method getNull {} {
	return $_voidPtr
    }
}

proc traceType {name1 name2 ops} {
    debug {======= traceType >$name1< >$name2< >$ops<} 3
    upvar $name1 var
    set upLevel [expr [info level] - 1]
    set lProc [info level $upLevel]
    regsub {^::} [uplevel {namespace current}] "" currentNamespace
    debug {    Called from level: >$upLevel<} 4
    debug {    level namespace  : >[uplevel #$upLevel namespace current]<} 4
    debug {    Called from      : >$lProc<} 4
    debug {    Current namespace: >$currentNamespace<} 4
    if {$upLevel == 0} {
	debug {Called from global} 4
	switch $ops {
	    r {
		set var [uplevel $name1 value]
	    }
	    w {
		if [catch {$name1 value [set var]}] {
		    uplevel "$name1 value [set var]"
		}
	    }
	    u {
		uplevel delete object $name1
	    }
	}
    } elseif {[string length $currentNamespace] && \
		[string length $lProc]} {
	debug {Called from procedure in namespace} 4
	set var [uplevel ::itcl::find objects $name1]
	debug {    $name1 ->$var< = ><} 4
	switch $ops {
	    r {
		uplevel set $name1 [uplevel $var value]
	    }
	    w {
		if [catch {uplevel $var value [uplevel set $name1]} szErrMsg] {
		    debug {####### Error: $szErrMsg} 4
		    
		}  
	    }
	    u {
		uplevel delete object $name1
	    }
	}
    } elseif {[string length $currentNamespace]} {
	debug {Called from namespace} 4
	set var [uplevel "namespace which -variable $name1"]
	debug {    $name1 ->$var< = ><} 4
	switch $ops {
	    r {
		set $var [$var value]
	    }
	    w {
		if [catch {$var value [set $var]} szErrMsg] {
		    debug {####### Error: $szErrMsg} 4
		    
		}  
	    }
	    u {
		debug {Deleting >$name1<} 4
		debug {          [namespace current]} 4
		catch {delete object $name1}
		debug {          DONE!} 4
	    }
	}
    } else {
	debug {Called from procedure} 4
	switch $ops {
	    r {
		set $name1 [$name1 value]
	    }
	    w {
		if [catch {$name1 value [uplevel set $name1]}] {
		    uplevel "$name1 value [set $name1]"
		}
	    }
	    u {
		delete object $name1
	    }
	}
    }
}