Commit | Line | Data |
d4567ecb |
1 | #-------------------------------------------------------------------------- |
2 | # TITLE: |
3 | # snit_tcl83_utils.tcl |
4 | # |
5 | # AUTHOR: |
6 | # Kenneth Green, 28 Aug 2004 |
7 | # |
8 | # DESCRIPTION: |
9 | # Utilities to support the back-port of snit from Tcl 8.4 to 8.3 |
10 | # |
11 | #-------------------------------------------------------------------------- |
12 | # Copyright |
13 | # |
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 | #-------------------------------------------------------------------------- |
21 | # Acknowledgements |
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 | #----------------------------------------------------------------------- |
26 | |
27 | #----------------------------------------------------------------------- |
28 | # Namespace |
29 | |
30 | namespace eval ::snit83 {} |
31 | |
32 | #----------------------------------------------------------------------- |
33 | # Some Snit83 variables |
34 | |
35 | namespace eval ::snit83 { |
36 | variable cmdTraceTable |
37 | array set cmdTraceTable {} |
38 | |
39 | namespace eval private {} |
40 | } |
41 | |
42 | |
43 | #----------------------------------------------------------------------- |
44 | # Initialisation |
45 | |
46 | # |
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. |
50 | # |
51 | |
52 | if [info exists tk_version] { |
53 | if { |
54 | ![llength [info procs destroy]] || |
55 | ![regexp snit83 [info body destroy]] |
56 | } { |
57 | rename destroy __destroy__ |
58 | } |
59 | } |
60 | if { |
61 | ![llength [info procs namespace]] || |
62 | ![regexp snit83 [info body namespace]] |
63 | } { |
64 | rename namespace __namespace__ |
65 | rename rename __rename__ ;# must be last one renamed! |
66 | } |
67 | |
68 | #----------------------------------------------------------------------- |
69 | # Global namespace functions |
70 | |
71 | |
72 | # destroy - |
73 | # |
74 | # Perform delete tracing and then invoke the actual Tk destroy command |
75 | |
76 | if [info exists tk_version] { |
77 | proc destroy { w } { |
78 | variable ::snit83::cmdTraceTable |
79 | |
80 | set index "delete,$w" |
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] { ; # " |
85 | error $err |
86 | } |
87 | } |
88 | |
89 | return [__destroy__ $w] |
90 | } |
91 | } |
92 | |
93 | # namespace - |
94 | # |
95 | # Add limited support for 'namespace exists'. Must be a fully |
96 | # qualified namespace name (pattern match support not provided). |
97 | |
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}]] |
105 | } |
106 | } else { |
107 | return [uplevel 1 [subst {__namespace__ $cmd $args}]] |
108 | } |
109 | } |
110 | |
111 | # rename - |
112 | # |
113 | # Perform rename tracing and then invoke the actual Tcl rename command |
114 | |
115 | proc rename { oldName newName } { |
116 | variable ::snit83::cmdTraceTable |
117 | |
118 | # Get caller's namespace since rename must be performed |
119 | # in the context of the caller's namespace |
120 | set callerNs "::" |
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] |
126 | } |
127 | |
128 | #puts "rename: callerNs: $callerNs" |
129 | #puts "rename: '$oldName' -> '$newName'" |
130 | #puts "rename: rcds - [join [array names cmdTraceTable] "\nrename: rcds - "]" |
131 | |
132 | set result [namespace eval $callerNs [concat __rename__ [list $oldName $newName]]] |
133 | |
134 | set index1 "rename,$oldName" |
135 | set index2 "rename,::$oldName" |
136 | |
137 | foreach index [list $index1 $index2] { |
138 | if [info exists cmdTraceTable($index)] { |
139 | set cmd $cmdTraceTable($index) |
140 | |
141 | #puts "rename: '$cmd' { $oldName -> $newName }" |
142 | |
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 |
147 | } |
148 | if [catch {eval $cmd $oldName \"$newName\" rename} err] { |
149 | error $err |
150 | } |
151 | break |
152 | } |
153 | } |
154 | |
155 | return $result |
156 | } |
157 | |
158 | |
159 | #----------------------------------------------------------------------- |
160 | # Private functions |
161 | |
162 | proc ::snit83::private::NamespaceIsDescendantOf { parent child } { |
163 | set result 0 |
164 | |
165 | foreach ns [__namespace__ children $parent] { |
166 | if [string match $ns $child] { |
167 | set result 1 |
168 | break; |
169 | } else { |
170 | if [set result [NamespaceIsDescendantOf $ns $child]] { |
171 | break |
172 | } |
173 | } |
174 | } |
175 | return $result |
176 | } |
177 | |
178 | |
179 | #----------------------------------------------------------------------- |
180 | # Utility functions |
181 | |
182 | proc ::snit83::traceAddCommand {name ops command} { |
183 | variable cmdTraceTable |
184 | |
185 | #puts "::snit83::traceAddCommand n/$name/ o/$ops/ c/$command/" |
186 | #puts "XX [join [array names cmdTraceTable] "\nXX "]" |
187 | |
188 | foreach op $ops { |
189 | set index "$op,$name" |
190 | #puts "::snit83::traceAddCommand: index = $index cmd = $command" |
191 | |
192 | set cmdTraceTable($index) $command |
193 | } |
194 | } |
195 | |
196 | proc ::snit83::traceRemoveCommand {name ops command} { |
197 | variable cmdTraceTable |
198 | |
199 | #puts "::snit83::traceRemoveCommand n/$name/ o/$ops/ c/$command/" |
200 | #puts "YY [join [array names cmdTraceTable] "\nYY "]" |
201 | |
202 | foreach op $ops { |
203 | set index "$op,$name" |
204 | #puts "::snit83::traceRemoveCommand: index = $index cmd = $command" |
205 | |
206 | catch { ::unset cmdTraceTable($index) } |
207 | } |
208 | } |
209 | |
210 | # Add support for 'unset -nocomplain' |
211 | proc ::snit83::unset { args } { |
212 | |
213 | #puts "::snit83::unset - args: '$args'" |
214 | |
215 | set noComplain 0 |
216 | if {[string equal [lindex $args 0] "-nocomplain"]} { |
217 | set noComplain 1 |
218 | set args [lrange $args 1 end] |
219 | } |
220 | if {[string equal [lindex $args 0] "--"]} { |
221 | set args [lrange $args 1 end] |
222 | } |
223 | |
224 | if [catch { |
225 | uplevel 1 [linsert $args 0 ::unset] |
226 | } err] { |
227 | if { !$noComplain } { |
228 | error $err |
229 | } |
230 | } |
231 | } |