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, 0 insertions, 216 deletions
diff --git a/contrib/bluegnu2.0.3/lib/Types.itcl b/contrib/bluegnu2.0.3/lib/Types.itcl deleted file mode 100644 index e2ef2b4..0000000 --- a/contrib/bluegnu2.0.3/lib/Types.itcl +++ /dev/null @@ -1,216 +0,0 @@ -# -*-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 - } - } - } -} - |