diff options
Diffstat (limited to 'contrib/bluegnu2.0.3/lib/Types.itcl')
| -rw-r--r-- | contrib/bluegnu2.0.3/lib/Types.itcl | 216 |
1 files changed, 216 insertions, 0 deletions
diff --git a/contrib/bluegnu2.0.3/lib/Types.itcl b/contrib/bluegnu2.0.3/lib/Types.itcl new file mode 100644 index 0000000..e2ef2b4 --- /dev/null +++ b/contrib/bluegnu2.0.3/lib/Types.itcl @@ -0,0 +1,216 @@ +# -*-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 + } + } + } +} + |