snit/snit_tcl83_utils.tcl

   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 }