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
30namespace eval ::snit83 {}
31
32#-----------------------------------------------------------------------
33# Some Snit83 variables
34
35namespace 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
52if [info exists tk_version] {
53    if {
54	![llength [info procs destroy]] ||
55	![regexp snit83 [info body destroy]]
56    } {
57	rename destroy __destroy__
58    }
59}
60if {
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
76if [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
98proc 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
115proc 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
162proc ::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
182proc ::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
196proc ::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'
211proc ::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}
232