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