1 #--------------------------------------------------------------------------
6 # Kenneth Green, 28 Aug 2004
9 # Utilities to support the back-port of snit from Tcl 8.4 to 8.3
11 #--------------------------------------------------------------------------
14 # Copyright (c) 2005 Kenneth Green
15 # Modified by Andreas Kupries.
16 # All rights reserved. This code is licensed as described in license.txt.
17 #--------------------------------------------------------------------------
18 # This code is freely distributable, but is provided as-is with
19 # no warranty expressed or implied.
20 #--------------------------------------------------------------------------
22 # The changes described in this file are made to the awesome 'snit'
23 # library as provided by William H. Duquette under the terms
24 # defined in the associated 'license.txt'.
25 #-----------------------------------------------------------------------
27 #-----------------------------------------------------------------------
30 namespace eval ::snit83 {}
32 #-----------------------------------------------------------------------
33 # Some Snit83 variables
35 namespace eval ::snit83 {
36 variable cmdTraceTable
37 array set cmdTraceTable {}
39 namespace eval private {}
43 #-----------------------------------------------------------------------
47 # Override Tcl functions so we can mimic some behaviours. This is
48 # conditional on not having been done already. Otherwise loading snit
49 # twice will fail the second time.
52 if [info exists tk_version] {
54 ![llength [info procs destroy]] ||
55 ![regexp snit83 [info body destroy]]
57 rename destroy __destroy__
61 ![llength [info procs namespace]] ||
62 ![regexp snit83 [info body namespace]]
64 rename namespace __namespace__
65 rename rename __rename__ ;# must be last one renamed!
68 #-----------------------------------------------------------------------
69 # Global namespace functions
74 # Perform delete tracing and then invoke the actual Tk destroy command
76 if [info exists tk_version] {
78 variable ::snit83::cmdTraceTable
81 if [info exists cmdTraceTable($index)] {
82 set cmd $cmdTraceTable($index)
83 ::unset cmdTraceTable($index) ;# prevent recursive tracing
84 if [catch {eval $cmd $oldName \"$newName\" delete} err] { ; # "
89 return [__destroy__ $w]
95 # Add limited support for 'namespace exists'. Must be a fully
96 # qualified namespace name (pattern match support not provided).
98 proc namespace { cmd args } {
99 if {[string equal $cmd "exists"]} {
100 set ptn [lindex $args 0]
101 return [::snit83::private::NamespaceIsDescendantOf :: $ptn]
102 } elseif {[string equal $cmd "delete"]} {
103 if [namespace exists [lindex $args 0]] {
104 return [uplevel 1 [subst {__namespace__ $cmd $args}]]
107 return [uplevel 1 [subst {__namespace__ $cmd $args}]]
113 # Perform rename tracing and then invoke the actual Tcl rename command
115 proc rename { oldName newName } {
116 variable ::snit83::cmdTraceTable
118 # Get caller's namespace since rename must be performed
119 # in the context of the caller's namespace
121 set callerLevel [expr {[info level] - 1}]
122 if { $callerLevel > 0 } {
123 set callerInfo [info level $callerLevel]
124 set procName [lindex $callerInfo 0]
125 set callerNs [namespace qualifiers $procName]
128 #puts "rename: callerNs: $callerNs"
129 #puts "rename: '$oldName' -> '$newName'"
130 #puts "rename: rcds - [join [array names cmdTraceTable] "\nrename: rcds - "]"
132 set result [namespace eval $callerNs [concat __rename__ [list $oldName $newName]]]
134 set index1 "rename,$oldName"
135 set index2 "rename,::$oldName"
137 foreach index [list $index1 $index2] {
138 if [info exists cmdTraceTable($index)] {
139 set cmd $cmdTraceTable($index)
141 #puts "rename: '$cmd' { $oldName -> $newName }"
143 ::unset cmdTraceTable($index) ;# prevent recursive tracing
144 if {![string equal $newName ""]} {
145 # Create a new trace record under the new name
146 set cmdTraceTable(rename,$newName) $cmd
148 if [catch {eval $cmd $oldName \"$newName\" rename} err] {
159 #-----------------------------------------------------------------------
162 proc ::snit83::private::NamespaceIsDescendantOf { parent child } {
165 foreach ns [__namespace__ children $parent] {
166 if [string match $ns $child] {
170 if [set result [NamespaceIsDescendantOf $ns $child]] {
179 #-----------------------------------------------------------------------
182 proc ::snit83::traceAddCommand {name ops command} {
183 variable cmdTraceTable
185 #puts "::snit83::traceAddCommand n/$name/ o/$ops/ c/$command/"
186 #puts "XX [join [array names cmdTraceTable] "\nXX "]"
189 set index "$op,$name"
190 #puts "::snit83::traceAddCommand: index = $index cmd = $command"
192 set cmdTraceTable($index) $command
196 proc ::snit83::traceRemoveCommand {name ops command} {
197 variable cmdTraceTable
199 #puts "::snit83::traceRemoveCommand n/$name/ o/$ops/ c/$command/"
200 #puts "YY [join [array names cmdTraceTable] "\nYY "]"
203 set index "$op,$name"
204 #puts "::snit83::traceRemoveCommand: index = $index cmd = $command"
206 catch { ::unset cmdTraceTable($index) }
210 # Add support for 'unset -nocomplain'
211 proc ::snit83::unset { args } {
213 #puts "::snit83::unset - args: '$args'"
216 if {[string equal [lindex $args 0] "-nocomplain"]} {
218 set args [lrange $args 1 end]
220 if {[string equal [lindex $args 0] "--"]} {
221 set args [lrange $args 1 end]
225 uplevel 1 [linsert $args 0 ::unset]
227 if { !$noComplain } {